GC backtrace: add limited support for distinguishing new and old objects

racket/src/racket/gc2/backtrace.c

@@ -95,7 +95,8 @@ static void *print_out_pointer(const char *prefix, void *p,
 
 static void print_traced_objects(int path_length_limit,
 				 GC_get_type_name_proc get_type_name,
-				 GC_print_tagged_value_proc print_tagged_value)
+				 GC_print_tagged_value_proc print_tagged_value,
+                                 GC_print_traced_filter_proc print_traced_filter)
 {
   int i, j, k, dp = 0, counter, each;
 # define DITTO_BUFFER_SIZE 16
@@ -110,33 +111,35 @@ static void print_traced_objects(int path_length_limit,
     int limit = path_length_limit;
     int kind = 0;
     p = found_objects[i];
-    p = print_out_pointer("==* ", p, get_type_name, print_tagged_value, &kind);
+    if (print_traced_filter(p)) {
+      p = print_out_pointer("==* ", p, get_type_name, print_tagged_value, &kind);
 
-    j = 0; counter = 0; each = 1;
+      j = 0; counter = 0; each = 1;
-    while (p && limit) {
+      while (p && limit) {
-      for (k = 0; k < DITTO_BUFFER_SIZE; k++) {
+        for (k = 0; k < DITTO_BUFFER_SIZE; k++) {
-        if (ditto[k] == p) {
+          if (ditto[k] == p) {
-          GCPRINT(GCOUTF, " <- %p: DITTO\n", p);
+            GCPRINT(GCOUTF, " <- %p: DITTO\n", p);
-          p = NULL;
+            p = NULL;
-          break;
+            break;
-        }
-      }
-      if (p) {
-        if (j < DITTO_BUFFER_SIZE) {
-          /* Rememebr the 1st 2nd, 4th, 8th, etc. */
-          counter++;
-          if (counter == each) {
-            ditto[(j + dp) % DITTO_BUFFER_SIZE] = p;
-            j++;
-            each *= 2;
-            counter = 0;
           }
         }
-        p = print_out_pointer(" <- ", p, get_type_name, print_tagged_value, &kind);
+        if (p) {
-        limit--;
+          if (j < DITTO_BUFFER_SIZE) {
+            /* Rememebr the 1st 2nd, 4th, 8th, etc. */
+            counter++;
+            if (counter == each) {
+              ditto[(j + dp) % DITTO_BUFFER_SIZE] = p;
+              j++;
+              each *= 2;
+              counter = 0;
+            }
+          }
+          p = print_out_pointer(" <- ", p, get_type_name, print_tagged_value, &kind);
+          limit--;
+        }
       }
+      dp = (j % DITTO_BUFFER_SIZE);
     }
-    dp = (j % DITTO_BUFFER_SIZE);
   }
   GCPRINT(GCOUTF, "End Trace\n");
   --GC_instance->avoid_collection;

racket/src/racket/gc2/gc2_dump.h

@@ -11,11 +11,13 @@ typedef void (*GC_for_each_struct_proc)(void *p);
 typedef void (*GC_print_tagged_value_proc)(const char *prefix, 
 					   void *v, uintptr_t diff, int max_w,
 					   const char *suffix);
+typedef int (*GC_print_traced_filter_proc)(void *p);
 
 GC2_EXTERN void GC_dump_with_traces(int flags,
 				    GC_get_type_name_proc get_type_name,
 				    GC_for_each_found_proc for_each_found,
 				    short min_trace_for_tag, short max_trace_for_tag,
+                                    GC_print_traced_filter_proc print_traced_filter,
 				    GC_print_tagged_value_proc print_tagged_value,
 				    int path_length_limit,
                                     GC_for_each_struct_proc for_each_struct);

racket/src/racket/gc2/newgc.c

@@ -3690,7 +3690,7 @@ const char *trace_source_kind(int kind)
 # define reset_object_traces() /* */
 # define clear_object_traces() /* */
 # define register_traced_object(p) /* */
-# define print_traced_objects(x, q, z) /* */
+# define print_traced_objects(x, q, z, w) /* */
 #endif
 
 #define MAX_DUMP_TAG 256
@@ -3699,6 +3699,7 @@ void GC_dump_with_traces(int flags,
                          GC_get_type_name_proc get_type_name,
                          GC_for_each_found_proc for_each_found,
                          short min_trace_for_tag, short max_trace_for_tag,
+                         GC_print_traced_filter_proc print_traced_filter,
                          GC_print_tagged_value_proc print_tagged_value,
                          int path_length_limit,
                          GC_for_each_struct_proc for_each_struct)
@@ -3876,7 +3877,7 @@ void GC_dump_with_traces(int flags,
   }
 
   if (flags & GC_DUMP_SHOW_TRACE) {
-    print_traced_objects(path_length_limit, get_type_name, print_tagged_value);
+    print_traced_objects(path_length_limit, get_type_name, print_tagged_value, print_traced_filter);
   }
 
   clear_object_traces();
@@ -3887,7 +3888,7 @@ void GC_dump_with_traces(int flags,
 
 void GC_dump(void)
 {
-  GC_dump_with_traces(0, NULL, NULL, 0, -1, NULL, 0, NULL);
+  GC_dump_with_traces(0, NULL, NULL, 0, -1, NULL, NULL, 0, NULL);
 }
 
 #ifdef MZ_GC_BACKTRACE

racket/src/racket/src/print.c

@@ -2907,7 +2907,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
 		       notdisplay, 1, ht, mt, pp);
       } else if (pp->print_unreadable) {
 	Scheme_Stx *stx = (Scheme_Stx *)obj;
-	if ((stx->srcloc->line >= 0) || (stx->srcloc->pos >= 0)) {
+	if (stx->srcloc && ((stx->srcloc->line >= 0) || (stx->srcloc->pos >= 0))) {
 	  print_utf8_string(pp, "#<syntax:", 0, 9);
 	  if (stx->srcloc->src && SCHEME_PATHP(stx->srcloc->src)) {
 	    print_utf8_string(pp, SCHEME_BYTE_STR_VAL(stx->srcloc->src), 0, SCHEME_BYTE_STRLEN_VAL(stx->srcloc->src));

racket/src/racket/src/salloc.c

@@ -1906,6 +1906,42 @@ static void cons_onto_list(void *p)
 {
   cons_accum_result = scheme_make_pair((Scheme_Object *)p, cons_accum_result);
 }
+
+static int print_all_traced(void *p) { return 1; }
+
+static int traced_buffer_counter, traced_buffer_size;
+static void **traced_buffer;
+
+static int record_traced(void *p)
+{
+  if (traced_buffer_counter == traced_buffer_size) {
+    void **b2;
+    int new_size = (traced_buffer_size
+                    ? (2 * traced_buffer_size)
+                    : 512);
+    if (!traced_buffer) REGISTER_SO(traced_buffer);
+    b2 = scheme_malloc(sizeof(void*) * new_size);
+    memcpy(b2, traced_buffer, sizeof(void*)*traced_buffer_size);
+    traced_buffer = b2;
+    traced_buffer_size = new_size;
+  }
+
+  traced_buffer[traced_buffer_counter++] = p;
+
+  return 1;
+}
+
+static int record_traced_and_print_new(void *p)
+{
+  int i;
+
+  for (i = 0; i < traced_buffer_counter; i++) {
+    if (p == traced_buffer[i])
+      return 0;
+  }
+
+  return record_traced(p);
+}
 #endif
 
 #if MZ_PRECISE_GC
@@ -2173,6 +2209,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
   int trace_for_tag = 0;
   int dump_flags = 0;
   GC_for_each_found_proc for_each_found = NULL;
+  GC_print_traced_filter_proc maybe_print_traced_filter = NULL;
 # else
 #  define skip_summary 0
 #  define dump_flags 0
@@ -2190,6 +2227,10 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
 # endif
 #endif
 
+#if defined(MZ_PRECISE_GC) && MZ_PRECISE_GC_TRACE
+  maybe_print_traced_filter = print_all_traced;
+#endif
+
 #if 0
   /* Syntax-object debugging support: */
   if ((c == 1) && SCHEME_STXP(p[0])) {
@@ -2490,6 +2531,10 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
       if (tn && !strcmp(tn, s)) {
 	trace_for_tag = i;
 	dump_flags |= GC_DUMP_SHOW_TRACE;
+        if ((c > 1)
+            && SCHEME_SYMBOLP(p[1])
+            && !strcmp(SCHEME_SYM_VAL(p[1]), "new"))
+          maybe_print_traced_filter = record_traced_and_print_new;
 	break;
       }
     }
@@ -2581,6 +2626,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
 		      scheme_get_type_name_or_null,
 		      for_each_found,
 		      trace_for_tag, trace_for_tag,
+                      maybe_print_traced_filter,
 		      print_tagged_value,
 		      path_length_limit,
                       for_each_struct);
@@ -2670,8 +2716,9 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
     scheme_console_printf(" (dump-memory-stats 'count sym) - return number of instances of type named by sym.\n");
     scheme_console_printf("   Example: (dump-memory-stats 'count '<pair>)\n");
 # if MZ_PRECISE_GC_TRACE
-    scheme_console_printf(" (dump-memory-stats sym) - prints paths to instances of type named by sym.\n");
+    scheme_console_printf(" (dump-memory-stats sym ['new]) - prints paths to instances of type named by sym.\n");
     scheme_console_printf("   Example: (dump-memory-stats '<pair>)\n");
+    scheme_console_printf("   If 'new, all will be retrined, only new paths will be shown\n");
     scheme_console_printf(" (dump-memory-stats 'struct) - show counts for specific structure types.\n");
     scheme_console_printf(" (dump-memory-stats 'fnl) - prints not-yet-finalized objects.\n");
     scheme_console_printf(" (dump-memory-stats num) - prints paths to objects with tag num.\n");