internal support for measuring allocation counts

racket/src/racket/src/eval.c

@@ -2251,6 +2251,8 @@ scheme_case_lambda_execute(Scheme_Object *expr)
   int i, cnt;
   Scheme_Thread *p = scheme_current_thread;
 
+  DEBUG_COUNT_ALLOCATION(expr);
+
   seqin = (Scheme_Case_Lambda *)expr;
 
 #ifdef MZ_USE_JIT
@@ -2502,6 +2504,8 @@ scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close)
   GC_CAN_IGNORE mzshort *map;
   int i;
 
+  DEBUG_COUNT_ALLOCATION(code);
+
   data = (Scheme_Lambda *)code;
   
 #ifdef MZ_USE_JIT

racket/src/racket/src/hash.c

@@ -246,6 +246,8 @@ Scheme_Hash_Table *scheme_make_hash_table(int type)
 {
   Scheme_Hash_Table *table;
 
+  DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_hash_table_type));
+
   table = MALLOC_ONE_TAGGED(Scheme_Hash_Table);
 
   table->size = 0;
@@ -640,6 +642,8 @@ Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *ht)
   Scheme_Hash_Table *table;
   Scheme_Object **ba;
 
+  DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_hash_table_type));
+
   table = MALLOC_ONE_TAGGED(Scheme_Hash_Table);
   memcpy(table, ht, sizeof(Scheme_Hash_Table));
   MZ_OPT_HASH_KEY(&(table->iso)) = 0;
@@ -723,6 +727,8 @@ scheme_make_bucket_table (intptr_t size, int type)
   Scheme_Bucket_Table *table;
   size_t asize;
 
+  DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_bucket_table_type));
+
   table = MALLOC_ONE_TAGGED(Scheme_Bucket_Table);
 
   table->size = 4;
@@ -1119,6 +1125,8 @@ Scheme_Bucket_Table *scheme_clone_bucket_table(Scheme_Bucket_Table *bt)
   Scheme_Bucket_Table *table;
   size_t asize;
 
+  DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_bucket_table_type));
+
   table = MALLOC_ONE_TAGGED(Scheme_Bucket_Table);
   table->so.type = scheme_bucket_table_type;
   table->size = bt->size;
@@ -2562,6 +2570,7 @@ XFORM_NONGCING static Scheme_Hash_Tree *hamt_assoc(Scheme_Hash_Tree *ht, uintptr
 static Scheme_Hash_Tree *hamt_alloc(int kind, int popcount)
 /* be sure to set `bitmap` field before a GC becomes possible */
 {
+  DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_hash_tree_type));
   return (Scheme_Hash_Tree *)scheme_malloc_small_tagged(HASH_TREE_RECORD_SIZE(kind, popcount));
 }
 

racket/src/racket/src/list.c

@@ -1049,6 +1049,7 @@ scheme_init_unsafe_hash (Scheme_Env *env)
 
 Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
 {
+  DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_pair_type));
 #ifdef MZ_PRECISE_GC
   return GC_malloc_pair(car, cdr);
 #else
@@ -1793,6 +1794,8 @@ Scheme_Object *scheme_box(Scheme_Object *v)
 {
   Scheme_Object *obj;
 
+  DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_box_type));
+
   obj = scheme_alloc_small_object();
   obj->type = scheme_box_type;
   SCHEME_BOX_VAL(obj) = v;
@@ -3645,6 +3648,8 @@ static Scheme_Object *eqv_hash_code(int argc, Scheme_Object *argv[])
 
 Scheme_Object *scheme_make_weak_box(Scheme_Object *v)
 {
+  DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_weak_box_type));
+
 #ifdef MZ_PRECISE_GC
   return (Scheme_Object *)GC_malloc_weak_box(v, NULL, 0, 0);
 #else

racket/src/racket/src/print.c

@@ -2808,9 +2808,13 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
 	cannot_print(pp, notdisplay, obj, ht, compact);
       } else {
 	print_utf8_string(pp, "#<", 0, 2);
-	print_string_in_angle(pp, scheme_symbol_val(((Scheme_Struct_Type *)obj)->name),
+        if (((Scheme_Struct_Type *)obj)->name) {
-			      "struct-type:",
+          print_string_in_angle(pp, scheme_symbol_val(((Scheme_Struct_Type *)obj)->name),
-			      SCHEME_SYM_LEN(((Scheme_Struct_Type *)obj)->name));
+                                "struct-type:",
+                                SCHEME_SYM_LEN(((Scheme_Struct_Type *)obj)->name));
+        } else {
+          print_utf8_string(pp, "struct-type", 0, 11);
+        }
 	PRINTADDRESS(pp, obj);
 	print_utf8_string(pp, ">", 0, 1);
       }
@@ -2821,9 +2825,13 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
 	cannot_print(pp, notdisplay, obj, ht, compact);
       } else {
 	print_utf8_string(pp, "#<", 0, 2);
-	print_string_in_angle(pp, scheme_symbol_val(((Scheme_Struct_Property *)obj)->name),
+        if (((Scheme_Struct_Property *)obj)->name) {
-			      "struct-type-property:", 
+          print_string_in_angle(pp, scheme_symbol_val(((Scheme_Struct_Property *)obj)->name),
-			      SCHEME_SYM_LEN(((Scheme_Struct_Property *)obj)->name));
+                                "struct-type-property:", 
+                                SCHEME_SYM_LEN(((Scheme_Struct_Property *)obj)->name));
+        } else {
+          print_utf8_string(pp, "struct-type-property", 0, 21);
+        }
 	PRINTADDRESS(pp, obj);
 	print_utf8_string(pp, ">", 0, 1);
       }

racket/src/racket/src/salloc.c

@@ -3288,3 +3288,92 @@ intptr_t scheme_count_envbox(Scheme_Object *root, Scheme_Hash_Table *ht)
 }
 
 #endif
+
+/**********************************************************************/
+
+#if RECORD_ALLOCATION_COUNTS
+ 
+/* Allocation profiling --- prints allocated counts (not necessarily
+   still live) after every `NUM_ALLOCS_BEFORE_REPORT` structure and
+   closure allocations. Adjust that constant to match a test program.
+   Also, run with `racket -j` so that structure allocation is not
+   inlined, and don't use places. */
+
+#define NUM_ALLOCS_BEFORE_REPORT 100000
+
+static Scheme_Hash_Table *allocs;
+static int alloc_count;
+static int reporting;
+
+#include "../gc2/my_qsort.c"
+typedef struct alloc_count_result { int pos; int count; } alloc_count_result;
+
+static int smaller_alloc_count(const void *a, const void *b) {
+  return ((alloc_count_result*)a)->count - ((alloc_count_result*)b)->count;
+}
+
+void scheme_record_allocation(Scheme_Object *tag)
+{
+  Scheme_Object *c;
+  
+  if (reporting)
+    return;
+
+  alloc_count++;
+
+  if (!allocs) {
+    REGISTER_SO(allocs);
+    reporting++;
+    allocs = scheme_make_hash_table(SCHEME_hash_ptr);
+    --reporting;
+  }
+
+  c = scheme_hash_get(allocs, tag);
+  if (!c) c = scheme_make_integer(0);
+  scheme_hash_set(allocs, tag, scheme_make_integer(SCHEME_INT_VAL(c)+1));
+    
+  if (alloc_count == NUM_ALLOCS_BEFORE_REPORT) {
+    alloc_count_result *a;
+    int count = allocs->count;
+    int k = 0;
+    int i;
+    char *s;
+
+    reporting++;
+    
+    a = MALLOC_N_ATOMIC(alloc_count_result, count);
+    printf("\n");
+    for (i = allocs->size; i--; ) {
+      if (allocs->vals[i]) {
+        a[k].pos = i;
+        a[k].count = SCHEME_INT_VAL(allocs->vals[i]);
+        k++;
+      }
+    }
+    my_qsort(a, allocs->count, sizeof(alloc_count_result), smaller_alloc_count);
+    
+    for (i = 0; i < count; i++) {
+      tag = allocs->keys[a[i].pos];
+
+      if (SCHEME_INTP(tag)) {
+        s = scheme_get_type_name(SCHEME_INT_VAL(tag));
+      } else {
+        if (SAME_TYPE(SCHEME_TYPE(tag), scheme_lambda_type)
+            && ((Scheme_Lambda *)tag)->name)
+          tag = ((Scheme_Lambda*)tag)->name;
+        else if (SAME_TYPE(SCHEME_TYPE(tag), scheme_case_lambda_sequence_type)
+                 && ((Scheme_Case_Lambda *)tag)->name)
+          tag = ((Scheme_Case_Lambda*)tag)->name;
+      
+        s = scheme_write_to_string(tag, NULL);
+      }
+      
+      printf("%d %s\n", a[i].count, s);
+    }
+    
+    alloc_count = 0;
+    --reporting;
+  }
+}
+
+#endif

racket/src/racket/src/schpriv.h

@@ -4414,6 +4414,18 @@ void scheme_count_generic(Scheme_Object *o, intptr_t *s, intptr_t *e, Scheme_Has
 #endif
 #endif
 
+/* See "salloc.c": */
+#ifndef RECORD_ALLOCATION_COUNTS
+# define RECORD_ALLOCATION_COUNTS 0
+#endif
+
+#if RECORD_ALLOCATION_COUNTS
+extern void scheme_record_allocation(Scheme_Object *key);
+# define DEBUG_COUNT_ALLOCATION(x) scheme_record_allocation(x);
+#else 
+# define DEBUG_COUNT_ALLOCATION(x) /* empty */
+#endif
+
 /*========================================================================*/
 /*                           miscellaneous                                */
 /*========================================================================*/

racket/src/racket/src/struct.c

@@ -2543,6 +2543,8 @@ scheme_make_struct_instance(Scheme_Object *_stype, int argc, Scheme_Object **arg
 
   stype = (Scheme_Struct_Type *)_stype;
 
+  DEBUG_COUNT_ALLOCATION((Scheme_Object *)stype);
+
   c = stype->num_slots;
   inst = (Scheme_Structure *)
     scheme_malloc_tagged(sizeof(Scheme_Structure) 
@@ -2591,6 +2593,8 @@ Scheme_Object *scheme_make_blank_prefab_struct_instance(Scheme_Struct_Type *styp
   Scheme_Structure *inst;
   int c;
 
+  DEBUG_COUNT_ALLOCATION((Scheme_Object *)stype);
+
   c = stype->num_slots;
   inst = (Scheme_Structure *)
     scheme_malloc_tagged(sizeof(Scheme_Structure) 
@@ -2625,6 +2629,8 @@ Scheme_Object *scheme_make_prefab_struct_instance(Scheme_Struct_Type *stype,
   Scheme_Structure *inst;
   int i, c;
 
+  DEBUG_COUNT_ALLOCATION((Scheme_Object *)stype);
+
   c = stype->num_slots;
   inst = (Scheme_Structure *)
     scheme_malloc_tagged(sizeof(Scheme_Structure) 
@@ -2682,6 +2688,8 @@ make_simple_struct_instance(int argc, Scheme_Object **args, Scheme_Object *prim)
   Scheme_Struct_Type *stype = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
   int i, c;
 
+  DEBUG_COUNT_ALLOCATION((Scheme_Object *)stype);
+
   c = stype->num_slots;
   inst = (Scheme_Structure *)
     scheme_malloc_tagged(sizeof(Scheme_Structure) 

racket/src/racket/src/syntax.c

@@ -465,6 +465,8 @@ Scheme_Object *scheme_make_stx(Scheme_Object *val,
 {
   Scheme_Stx *stx;
 
+  DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_stx_type));
+
   stx = MALLOC_ONE_TAGGED(Scheme_Stx);
   stx->iso.so.type = scheme_stx_type;
   STX_KEY(stx) = HAS_SUBSTX(val) ? STX_SUBSTX_FLAG : 0;

racket/src/racket/src/vector.c

@@ -287,6 +287,8 @@ scheme_make_vector (intptr_t size, Scheme_Object *fill)
     scheme_wrong_contract("make-vector", "exact-nonnegative-integer?", -1, 0, &vec);
   }
 
+  DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_vector_type));
+
   if (size < 1024) {
     vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
   } else {