[racket-dev] current-load-extension: expects argument of type <procedure (arity 2)>; given #"([^:]*):(.*)"

Hi Everyone,

I'm trying to add support for per-thread allocation accounting to aid
in some performance debugging.  I've already instrumented the GC and
can retrieve the statistics via hacks I added to current-memory-use.

I'm running into trouble reverting current-memory-use and instead
adding a primitive: (thread-memory-allocations thread [allocated #f])

In src/thread.c
===========
static Scheme_Object *thread_memory_allocations(int argc,
Scheme_Object *args[]);
GLOBAL_PRIM_W_ARITY("thread-memory-allocations" ,
thread_memory_allocations   , 1, 2, env);
static Scheme_Object *thread_memory_allocations(int argc, Scheme_Object *args[])
{
  Scheme_Thread *thread = NULL;
  intptr_t retval = 0;

  if (!SCHEME_THREADP(args[0]))
    scheme_wrong_type("thread-memory-allocations", "thread", 0, argc, args);

  thread = (Scheme_Thread*) args[0];
  if(argc == 1 || SCHEME_FALSEP(args[1])) {
    retval = thread->total_memory_requested;
  } else {
    retval = thread->total_memory_allocated;
  }

  return scheme_make_integer_value(retval);
}

In src/schinc.h
===========
#define EXPECTED_PRIM_COUNT 1043

When I build I get:
...
<snip>
...
cd gc2; make all
mkdir xsrc
make xsrc/precomp.h
env XFORM_PRECOMP=yes ../racketcgc -cqu ../../../racket/gc2/xform.rkt
--setup . --cpp "gcc -E -I./.. -I../../../racket/gc2/../include
-I/usr/local/lib/libffi-3.0.9/include   -pthread    -DMZ_NO_ICONV"
--keep-lines -o xsrc/precomp.h ../../../racket/gc2/precomp.c
current-load-extension: expects argument of type <procedure (arity
2)>; given #"([^:]*):(.*)"
*** Signal 11

I've scanned through xform.rkt but I'm not able to track down the
origin of that error.  Any ideas?

Thanks,
Nick

A full patch (based on tag v5.2.1) is attached if that helps.
-------------- next part --------------
diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c
index 7370cde..816cf16 100644
--- a/src/racket/gc2/newgc.c
+++ b/src/racket/gc2/newgc.c
@@ -968,6 +975,14 @@ static void *allocate_big(const size_t request_size_bytes, int type)
   else
     addr = malloc_pages(gc, realpagesize, APAGE_SIZE, MMU_ZEROED, MMU_BIG_MED, MMU_PROTECTABLE, &bpage->mmu_src_block);
 
+  {
+    Scheme_Thread *thread = scheme_get_current_thread();
+    if(thread) {
+      thread->total_memory_requested += request_size_bytes;
+      thread->total_memory_allocated += realpagesize;
+    }
+  }
+
   bpage->addr = addr;
   bpage->size = allocate_size;
   bpage->size_class = 2;
@@ -1100,15 +1115,24 @@ static void *allocate_medium(const size_t request_size_bytes, const int type)
 
   {
     NewGC *gc = GC_get_GC();
+    Scheme_Thread *thread = scheme_get_current_thread();
     void *objptr;
 
     gc_if_needed_account_alloc_size(gc, sz);
 
+    if(thread) {
+      thread->total_memory_requested += request_size_bytes;
+    }
+
     objptr = medium_page_realloc_dead_slot(gc, sz, pos, type);
     if (!objptr) {
       mpage *page;
       objhead *info;
 
+      if(thread) {
+        thread->total_memory_allocated += sz;
+      }
+
       page = create_new_medium_page(gc, sz, pos);
       info = (objhead *)PTR(NUM(page->addr) + MED_NEXT_SEARCH_SLOT(page));
 
@@ -1303,6 +1327,14 @@ inline static void *allocate(const size_t request_size, const int type)
     newptr = allocate_slowpath(gc, allocate_size, newptr);
   }
 
+  {
+    Scheme_Thread *thread = scheme_get_current_thread();
+    if(thread) {
+      thread->total_memory_requested += request_size;
+      thread->total_memory_allocated += allocate_size;
+    }
+  }
+
   /* actual Allocation */
   {
     objhead *info = (objhead *)PTR(GC_gen0_alloc_page_ptr);
@@ -1350,6 +1382,14 @@ inline static void *fast_malloc_one_small_tagged(size_t request_size, int dirty)
     info->size = BYTES_MULTIPLE_OF_WORD_TO_WORDS(allocate_size); /* ALIGN_BYTES_SIZE bumbed us up to the next word boundary */
 
     {
+      Scheme_Thread *thread = scheme_get_current_thread();
+      if(thread) {
+        thread->total_memory_requested += request_size;
+        thread->total_memory_allocated += allocate_size;
+      }
+    }
+
+    {
       void * objptr = OBJHEAD_TO_OBJPTR(info);
       ASSERT_VALID_OBJPTR(objptr);
       return objptr;
diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h
index e90062c..c57bccc 100644
--- a/src/racket/include/scheme.h
+++ b/src/racket/include/scheme.h
@@ -1130,6 +1130,8 @@ typedef struct Scheme_Thread {
 
   intptr_t accum_process_msec;
   intptr_t current_start_process_msec;
+  intptr_t total_memory_allocated;
+  intptr_t total_memory_requested;
 
   struct Scheme_Thread_Custodian_Hop *mr_hop;
   Scheme_Custodian_Reference *mref;
diff --git a/src/racket/src/schminc.h b/src/racket/src/schminc.h
index 4d377b1..1ed428b 100644
--- a/src/racket/src/schminc.h
+++ b/src/racket/src/schminc.h
@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1042
+#define EXPECTED_PRIM_COUNT 1043
 #define EXPECTED_UNSAFE_COUNT 78
 #define EXPECTED_FLFXNUM_COUNT 68
 #define EXPECTED_FUTURES_COUNT 11
diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c
index 78a919c..ca74dab 100644
--- a/src/racket/src/thread.c
+++ b/src/racket/src/thread.c
@@ -321,6 +321,7 @@ static Scheme_Object *union_tracking_val(int argc, Scheme_Object *args[]);
 
 static Scheme_Object *collect_garbage(int argc, Scheme_Object *args[]);
 static Scheme_Object *current_memory_use(int argc, Scheme_Object *args[]);
+static Scheme_Object *thread_memory_allocations(int argc, Scheme_Object *args[]);
 
 static Scheme_Object *sch_thread(int argc, Scheme_Object *args[]);
 static Scheme_Object *sch_thread_nokill(int argc, Scheme_Object *args[]);
@@ -558,8 +559,9 @@ void scheme_init_thread(Scheme_Env *env)
   scheme_add_evt_through_sema(scheme_will_executor_type, will_executor_sema, NULL);
 
 
-  GLOBAL_PRIM_W_ARITY("collect-garbage"                       , collect_garbage      , 0, 0, env);
-  GLOBAL_PRIM_W_ARITY("current-memory-use"                    , current_memory_use   , 0, 1, env);
+  GLOBAL_PRIM_W_ARITY("collect-garbage"           , collect_garbage             , 0, 0, env);
+  GLOBAL_PRIM_W_ARITY("current-memory-use"        , current_memory_use          , 0, 1, env);
+  GLOBAL_PRIM_W_ARITY("thread-memory-allocations" , thread_memory_allocations   , 1, 2, env);
 
   GLOBAL_PRIM_W_ARITY("custodian-require-memory"              , custodian_require_mem, 3, 3, env);
   GLOBAL_PRIM_W_ARITY("custodian-limit-memory"                , custodian_limit_mem  , 2, 3, env);
@@ -698,6 +700,24 @@ static Scheme_Object *current_memory_use(int argc, Scheme_Object *args[])
   return scheme_make_integer_value(retval);
 }
 
+static Scheme_Object *thread_memory_allocations(int argc, Scheme_Object *args[])
+{
+  Scheme_Thread *thread = NULL;
+  intptr_t retval = 0;
+
+  if (!SCHEME_THREADP(args[0]))
+    scheme_wrong_type("thread-memory-allocations", "thread", 0, argc, args);
+
+  thread = (Scheme_Thread*) args[0];
+  if(argc == 1 || SCHEME_FALSEP(args[1])) {
+    retval = thread->total_memory_requested;
+  } else {
+    retval = thread->total_memory_allocated;
+  }
+  
+  return scheme_make_integer_value(retval);
+}
+
 
 /*========================================================================*/
 /*                              custodians                                */
@@ -2219,7 +2239,8 @@ static Scheme_Thread *make_thread(Scheme_Config *config,
   process->mref = NULL;
   process->extra_mrefs = NULL;
 
-    
+  process->total_memory_allocated = 0;
+  process->total_memory_requested = 0;
 
   /* A thread points to a lot of stuff, so it's bad to put a finalization
      on it, which is what registering with a custodian does. Instead, we