GC with backtraces: add structure-type listing

src/racket/gc2/gc2_dump.h

@@ -7,6 +7,7 @@
 typedef char *(*GC_get_type_name_proc)(short t);
 typedef char *(*GC_get_xtagged_name_proc)(void *p);
 typedef void (*GC_for_each_found_proc)(void *p);
+typedef void (*GC_for_each_struct_proc)(void *p);
 
 typedef void (*GC_print_tagged_value_proc)(const char *prefix, 
 					   void *v, int xtagged, uintptr_t diff, int max_w,
@@ -16,9 +17,10 @@ GC2_EXTERN void GC_dump_with_traces(int flags,
 				    GC_get_type_name_proc get_type_name,
 				    GC_get_xtagged_name_proc get_xtagged_name,
 				    GC_for_each_found_proc for_each_found,
-				    short trace_for_tag,
+				    short min_trace_for_tag, short max_trace_for_tag,
 				    GC_print_tagged_value_proc print_tagged_value,
-				    int path_length_limit);
+				    int path_length_limit,
+                                    GC_for_each_struct_proc for_each_struct);
 
 GC2_EXTERN void GC_dump_variable_stack(void **var_stack,
                                        intptr_t delta,

src/racket/gc2/newgc.c

@@ -3402,9 +3402,10 @@ void GC_dump_with_traces(int flags,
                          GC_get_type_name_proc get_type_name,
                          GC_get_xtagged_name_proc get_xtagged_name,
                          GC_for_each_found_proc for_each_found,
-                         short trace_for_tag,
+                         short min_trace_for_tag, short max_trace_for_tag,
                          GC_print_tagged_value_proc print_tagged_value,
-                         int path_length_limit)
+                         int path_length_limit,
+                         GC_for_each_struct_proc for_each_struct)
 {
   NewGC *gc = GC_get_GC();
   mpage *page;
@@ -3434,7 +3435,10 @@ void GC_dump_with_traces(int flags,
           counts[tag]++;
           sizes[tag] += info->size;
         }
-        if (tag == trace_for_tag) {
+        if ((tag == scheme_proc_struct_type) || (tag == scheme_structure_type)) {
+          if (for_each_struct) for_each_struct(obj_start);
+        }
+        if ((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag)) {
           register_traced_object(obj_start);
           if (for_each_found)
             for_each_found(obj_start);
@@ -3453,8 +3457,11 @@ void GC_dump_with_traces(int flags,
         counts[tag]++;
         sizes[tag] += gcBYTES_TO_WORDS(page->size);
       }
-      if ((tag == trace_for_tag)
+      if ((tag == scheme_proc_struct_type) || (tag == scheme_structure_type)) {
-          || (tag == -trace_for_tag)) {
+        if (for_each_struct) for_each_struct(obj_start);
+      }
+      if (((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag))
+          || ((-tag >= min_trace_for_tag) && (-tag <= max_trace_for_tag))) {
         register_traced_object(obj_start);
         if (for_each_found)
           for_each_found(obj_start);
@@ -3477,7 +3484,10 @@ void GC_dump_with_traces(int flags,
               counts[tag]++;
               sizes[tag] += info->size;
             }
-            if (tag == trace_for_tag) {
+            if ((tag == scheme_proc_struct_type) || (tag == scheme_structure_type)) {
+              if (for_each_struct) for_each_struct(obj_start);
+            }
+            if ((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag)) {
               register_traced_object(obj_start);
               if (for_each_found)
                 for_each_found(obj_start);
@@ -3569,7 +3579,7 @@ void GC_dump_with_traces(int flags,
 
 void GC_dump(void)
 {
-  GC_dump_with_traces(0, NULL, NULL, NULL, 0, NULL, 0);
+  GC_dump_with_traces(0, NULL, NULL, NULL, 0, -1, NULL, 0, NULL);
 }
 
 #ifdef MZ_GC_BACKTRACE

src/racket/src/salloc.c

@@ -1916,6 +1916,13 @@ static void cons_onto_list(void *p)
 }
 #endif
 
+#if MZ_PRECISE_GC_TRACE
+static void count_struct_instance(void *p) {
+  Scheme_Structure *s = (Scheme_Structure *)p;
+  s->stype->instance_count++;
+}
+#endif
+
 #if defined(USE_TAGGED_ALLOCATION) || MZ_PRECISE_GC_TRACE
 
 # ifdef MZ_PRECISE_GC
@@ -2171,12 +2178,14 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
   int flags = 0;
   int path_length_limit = 10000;
   GC_for_each_found_proc for_each_found = NULL;
+  GC_for_each_struct_proc for_each_struct = NULL;
 #else
 # ifndef USE_TAGGED_ALLOCATION
 #  define flags 0
 #  define trace_for_tag 0
 #  define path_length_limit 10000
 #  define for_each_found NULL
+#  define for_each_struct NULL
 #  define GC_get_xtagged_name NULL
 #  define print_tagged_value NULL
 # endif
@@ -2242,8 +2251,6 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
   if (scheme_external_dump_arg)
     scheme_external_dump_arg(c ? p[0] : NULL);
 
-  scheme_console_printf("Begin Dump\n");
-
 #ifdef USE_TAGGED_ALLOCATION
   trace_path_type = -1;
   obj_type = -1;
@@ -2468,6 +2475,13 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
     if (!strcmp("fnl", s))
       flags |= GC_DUMP_SHOW_FINALS;
 
+    if (!strcmp("struct", s)) {
+      for_each_struct = count_struct_instance;
+      trace_for_tag = scheme_struct_type_type;
+      for_each_found = cons_onto_list;
+      cons_accum_result = scheme_null;
+    }
+
     if (!strcmp("peek", s) && (c == 3)) {
       intptr_t n;
       scheme_end_atomic();
@@ -2537,6 +2551,8 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
     flags -= (flags & GC_DUMP_SHOW_TRACE);
   }
   scheme_console_printf("Begin Dump\n");
+#else
+  scheme_console_printf("Begin Dump\n");
 #endif
 
 # ifdef MZ_PRECISE_GC
@@ -2544,14 +2560,30 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
 		      scheme_get_type_name_or_null,
 		      GC_get_xtagged_name,
 		      for_each_found,
-		      trace_for_tag,
+		      trace_for_tag, trace_for_tag,
 		      print_tagged_value,
-		      path_length_limit);
+		      path_length_limit,
+                      for_each_struct);
 # else
   GC_dump();
 # endif
 #endif
 
+#if MZ_PRECISE_GC_TRACE
+  if (for_each_struct) {
+    scheme_console_printf("Begin Struct\n");
+    while (SCHEME_PAIRP(cons_accum_result)) {
+      Scheme_Struct_Type *stype = (Scheme_Struct_Type *)SCHEME_CAR(cons_accum_result);
+      if (stype->instance_count) {
+        scheme_console_printf(" %32.32s: %10" PRIdPTR "\n", SCHEME_SYM_VAL(stype->name), stype->instance_count);
+        stype->instance_count = 0;
+      }
+      cons_accum_result = SCHEME_CDR(cons_accum_result);
+    }
+    scheme_console_printf("End Struct\n");
+  }
+#endif
+
   if (scheme_external_dump_info)
     scheme_external_dump_info();
 
@@ -2623,6 +2655,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
   scheme_console_printf("Begin Help\n");
   scheme_console_printf(" (dump-memory-stats sym) - prints paths to instances of type named by sym.\n");
   scheme_console_printf("   Example: (dump-memory-stats '<pair>)\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");
   scheme_console_printf(" (dump-memory-stats -num) - prints paths to objects of size num.\n");

src/racket/src/schpriv.h

@@ -737,7 +737,7 @@ typedef struct Scheme_Struct_Property {
 int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos);
 
 typedef struct Scheme_Struct_Type {
-  Scheme_Inclhash_Object iso; /* scheme_structure_type or scheme_proc_struct_type */
+  Scheme_Inclhash_Object iso; /* scheme_struct_type_type */
   mzshort num_slots;   /* initialized + auto + parent-initialized + parent-auto */
   mzshort num_islots; /* initialized + parent-initialized */
   mzshort name_pos;
@@ -758,6 +758,10 @@ typedef struct Scheme_Struct_Type {
 
   Scheme_Object *guard;
 
+#if defined(MZ_GC_BACKTRACE) && defined(MZ_PRECISE_GC)
+  intptr_t instance_count;
+#endif
+
   struct Scheme_Struct_Type *parent_types[mzFLEX_ARRAY_DECL];
 } Scheme_Struct_Type;