add scheme_add_gc_callback() hook for gc notification in a way that lets you describe a foreign function to call without allocating or the call; the allowed protocols are contrained and ad hoc, but it will be enough for GRacket2

collects/scribblings/inside/memory.scrbl

@@ -1,5 +1,6 @@
 #lang scribble/doc
-@(require "utils.ss")
+@(require "utils.ss"
+          (for-label ffi/unsafe))
 
 @title[#:tag "im:memoryalloc"]{Memory Allocation}
 
@@ -1032,3 +1033,47 @@ implementations of the memory manager, the result is the same as
 moved before it is fixed. With other implementations, an object might
 be moved after the fixup process, and the result is the location that
 the object will have after garbage collection finished.}
+
+@function[(Scheme_Object* scheme_add_gc_callback [Scheme_Object* pre_desc]
+                                                 [Scheme_Object* post_desc])]{
+
+Registers descriptions of foreign functions to be called just before
+and just after a garbage collection. The foreign functions must not
+allocate garbage-collected memory, and they are called in a way that
+does not allocate, which is why @var{pre_desc} and @var{post_desc} are
+function descriptions instead of thunks.
+
+A description is a vector of vectors, where each of the inner vectors
+describes a single call, and the calls are performed in sequence. Each
+call vector starts with a symbol that indicates the protocol of the
+foreign function to be called. The following protocols are supported:
+
+@itemlist[
+
+ @item{@racket['ptr_ptr_ptr->void] corresponds to @cpp{void
+ (*)(void*, void*, void*)}.}
+
+ @item{@racket['ptr_ptr_ptr_int->void] corresponds to @cpp{void
+ (*)(void*, void*, void*, int)}.}
+
+ @item{@racket['ptr_ptr_float->void] corresponds to @cpp{void
+ (*)(void*, void*, float)}.}
+
+ @item{@racket['ptr_ptr_double->void] corresponds to @cpp{void
+ (*)(void*, void*, double)}.}
+
+]
+
+After the protocol symbol, the vector should contain a pointer to a
+foreign function and then an element for each of the function's
+arguments. Pointer values are represented as for the @racket[_pointer]
+representation defined by @racketmodname[ffi/unsafe].
+
+The result is a key for use with @cpp{scheme_remove_gc_callback}. If
+the key becomes inaccessible, then the callback will be removed
+automatically (but beware that the pre-callback will have executed and
+the post-callback will not have executed).}
+
+@function[(void scheme_remove_gc_callback [Scheme_Object* key])]{
+
+Removes a garbage-collection callback installed with @cpp{scheme_add_gc_callback}.}

src/foreign/foreign.c

@@ -1243,6 +1243,10 @@ static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *arg
 }
 #undef MYNAME
 
+void *scheme_extract_pointer(Scheme_Object *v) {
+  return SCHEME_FFIANYPTR_VAL(v);
+}
+
 /*****************************************************************************/
 /* Scheme<-->C conversions */
 

src/foreign/foreign.rktc

@@ -1030,6 +1030,10 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
   return scheme_void;
 }
 
+void *scheme_extract_pointer(Scheme_Object *v) {
+  return SCHEME_FFIANYPTR_VAL(v);
+}
+
 /*****************************************************************************/
 /* Scheme<-->C conversions */
 

src/racket/include/mzwin.def

@@ -202,6 +202,8 @@ EXPORTS
  scheme_collect_garbage
  scheme_malloc_immobile_box
  scheme_free_immobile_box
+ scheme_add_gc_callback
+ scheme_remove_gc_callback
  scheme_make_bucket_table
  scheme_add_to_table
  scheme_change_in_table

src/racket/include/mzwin3m.def

@@ -217,6 +217,8 @@ EXPORTS
  GC_fixup_self
  scheme_malloc_immobile_box
  scheme_free_immobile_box
+ scheme_add_gc_callback
+ scheme_remove_gc_callback
  scheme_make_bucket_table
  scheme_add_to_table
  scheme_change_in_table

src/racket/include/racket.exp

@@ -219,6 +219,8 @@ GC_fixup
 GC_fixup_self
 scheme_malloc_immobile_box
 scheme_free_immobile_box
+scheme_add_gc_callback
+scheme_remove_gc_callback
 scheme_make_bucket_table
 scheme_add_to_table
 scheme_change_in_table

src/racket/include/racket3m.exp

@@ -225,6 +225,8 @@ GC_fixup
 GC_fixup_self
 scheme_malloc_immobile_box
 scheme_free_immobile_box
+scheme_add_gc_callback
+scheme_remove_gc_callback
 scheme_make_bucket_table
 scheme_add_to_table
 scheme_change_in_table

src/racket/include/schthread.h

@@ -293,7 +293,7 @@ typedef struct Thread_Local_Variables {
   struct Scheme_Hash_Table *place_local_keyword_table_;
   struct Scheme_Hash_Table *place_local_parallel_symbol_table_;
   struct FFI_Sync_Queue *ffi_sync_queue_;
-/*KPLAKE1*/
+  struct Scheme_GC_Pre_Post_Callback_Desc *gc_prepost_callback_descs_;
 } Thread_Local_Variables;
 
 #if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS)
@@ -588,7 +588,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
 #define place_local_keyword_table XOA (scheme_get_thread_local_variables()->place_local_keyword_table_)
 #define place_local_parallel_symbol_table XOA (scheme_get_thread_local_variables()->place_local_parallel_symbol_table_)
 #define ffi_sync_queue XOA (scheme_get_thread_local_variables()->ffi_sync_queue_)
-/*KPLAKE2*/
+#define gc_prepost_callback_descs XOA (scheme_get_thread_local_variables()->gc_prepost_callback_descs_)
 
 /* **************************************** */
 

src/racket/src/schemef.h

@@ -435,6 +435,9 @@ MZ_EXTERN void *GC_fixup_self(void *p);
 MZ_EXTERN void **scheme_malloc_immobile_box(void *p);
 MZ_EXTERN void scheme_free_immobile_box(void **b);
 
+MZ_EXTERN Scheme_Object *scheme_add_gc_callback(Scheme_Object *pre, Scheme_Object *post);
+MZ_EXTERN void scheme_remove_gc_callback(Scheme_Object *key);
+
 /*========================================================================*/
 /*                             hash tables                                */
 /*========================================================================*/

src/racket/src/schemex.h

@@ -351,6 +351,8 @@ void *(*GC_fixup_self)(void *p);
 #endif
 void **(*scheme_malloc_immobile_box)(void *p);
 void (*scheme_free_immobile_box)(void **b);
+Scheme_Object *(*scheme_add_gc_callback)(Scheme_Object *pre, Scheme_Object *post);
+void (*scheme_remove_gc_callback)(Scheme_Object *key);
 /*========================================================================*/
 /*                             hash tables                                */
 /*========================================================================*/

src/racket/src/schemex.inc

@@ -250,6 +250,8 @@
 #endif
   scheme_extension_table->scheme_malloc_immobile_box = scheme_malloc_immobile_box;
   scheme_extension_table->scheme_free_immobile_box = scheme_free_immobile_box;
+  scheme_extension_table->scheme_add_gc_callback = scheme_add_gc_callback;
+  scheme_extension_table->scheme_remove_gc_callback = scheme_remove_gc_callback;
   scheme_extension_table->scheme_make_bucket_table = scheme_make_bucket_table;
   scheme_extension_table->scheme_add_to_table = scheme_add_to_table;
   scheme_extension_table->scheme_change_in_table = scheme_change_in_table;

src/racket/src/schemexm.h

@@ -250,6 +250,8 @@
 #endif
 #define scheme_malloc_immobile_box (scheme_extension_table->scheme_malloc_immobile_box)
 #define scheme_free_immobile_box (scheme_extension_table->scheme_free_immobile_box)
+#define scheme_add_gc_callback (scheme_extension_table->scheme_add_gc_callback)
+#define scheme_remove_gc_callback (scheme_extension_table->scheme_remove_gc_callback)
 #define scheme_make_bucket_table (scheme_extension_table->scheme_make_bucket_table)
 #define scheme_add_to_table (scheme_extension_table->scheme_add_to_table)
 #define scheme_change_in_table (scheme_extension_table->scheme_change_in_table)

src/racket/src/schpriv.h

@@ -464,6 +464,10 @@ void scheme_resume_remembered_threads(void);
 extern void scheme_check_foreign_work(void);
 #endif
 
+#ifndef DONT_USE_FOREIGN
+extern void *scheme_extract_pointer(Scheme_Object *v);
+#endif
+
 void scheme_kickoff_green_thread_time_slice_timer(long usec);
 
 #ifdef UNIX_PROCESSES

src/racket/src/thread.c

@@ -210,6 +210,8 @@ HOOK_SHARED_OK void (*scheme_on_atomic_timeout)(void);
 HOOK_SHARED_OK static int atomic_timeout_auto_suspend;
 HOOK_SHARED_OK static int atomic_timeout_atomic_level;
 
+THREAD_LOCAL_DECL(struct Scheme_GC_Pre_Post_Callback_Desc *gc_prepost_callback_descs);
+
 ROSYM static Scheme_Object *read_symbol, *write_symbol, *execute_symbol, *delete_symbol, *exists_symbol;
 ROSYM static Scheme_Object *client_symbol, *server_symbol;
 ROSYM static Scheme_Object *froz_key;
@@ -824,6 +826,7 @@ void scheme_init_thread_places(void) {
   buffer_init_size = INIT_TB_SIZE;
   REGISTER_SO(recycle_cell);
   REGISTER_SO(maybe_recycle_cell);
+  REGISTER_SO(gc_prepost_callback_descs);
 }
 
 void scheme_init_memtrace(Scheme_Env *env)
@@ -7375,6 +7378,141 @@ static Scheme_Object *will_executor_sema(Scheme_Object *w, int *repost)
 START_XFORM_SKIP;
 #endif
 
+typedef struct Scheme_GC_Pre_Post_Callback_Desc {
+  /* All pointer fields => allocate with GC_malloc() */
+  Scheme_Object *boxed_key;
+  Scheme_Object *pre_desc;
+  Scheme_Object *post_desc;
+  struct Scheme_GC_Pre_Post_Callback_Desc *prev;
+  struct Scheme_GC_Pre_Post_Callback_Desc *next;
+} Scheme_GC_Pre_Post_Callback_Desc;
+
+
+Scheme_Object *scheme_add_gc_callback(Scheme_Object *pre, Scheme_Object *post)
+{
+  Scheme_GC_Pre_Post_Callback_Desc *desc;
+  Scheme_Object *key, *boxed;
+
+  desc = (Scheme_GC_Pre_Post_Callback_Desc *)GC_malloc(sizeof(Scheme_GC_Pre_Post_Callback_Desc));
+  desc->pre_desc = pre;
+  desc->post_desc = post;
+
+  key = scheme_make_vector(1, scheme_false);
+  boxed = scheme_make_weak_box(key);
+  desc->boxed_key = boxed;
+
+  desc->next = gc_prepost_callback_descs;
+  gc_prepost_callback_descs = desc;
+  
+  return key;
+}
+
+void scheme_remove_gc_callback(Scheme_Object *key)
+{
+  Scheme_GC_Pre_Post_Callback_Desc *prev = NULL, *desc;
+
+  desc = gc_prepost_callback_descs; 
+  while (desc) {
+    if (SAME_OBJ(SCHEME_WEAK_BOX_VAL(desc->boxed_key), key)) {
+      if (prev)
+        prev->next = desc->next;
+      else
+        gc_prepost_callback_descs = desc->next;
+      if (desc->next)
+        desc->next->prev = desc->prev;
+    }
+    prev = desc;
+    desc = desc->next;
+  }
+}
+
+typedef void (*gccb_Ptr_Ptr_Ptr_Int_to_Void)(void*, void*, void*, int);
+typedef void (*gccb_Ptr_Ptr_Ptr_to_Void)(void*, void*, void*);
+typedef void (*gccb_Ptr_Ptr_Float_to_Void)(void*, void*, float);
+typedef void (*gccb_Ptr_Ptr_Double_to_Void)(void*, void*, double);
+
+#ifdef DONT_USE_FOREIGN
+# define scheme_extract_pointer(x) NULL
+#endif
+
+static void run_gc_callbacks(int pre) 
+  XFORM_SKIP_PROC
+{
+  Scheme_GC_Pre_Post_Callback_Desc *prev = NULL, *desc;
+  Scheme_Object *acts, *act, *protocol;
+  int j;
+
+  desc = gc_prepost_callback_descs; 
+  while (desc) {
+    if (!SCHEME_WEAK_BOX_VAL(desc->boxed_key)) {
+      if (prev)
+        prev->next = desc->next;
+      else
+        gc_prepost_callback_descs = desc->next;
+      if (desc->next)
+        desc->next->prev = desc->prev;
+    } else {
+      if (pre)
+        acts = desc->pre_desc;
+      else
+        acts = desc->post_desc;
+      for (j = 0; j < SCHEME_VEC_SIZE(acts); j++) {
+        act = SCHEME_VEC_ELS(acts)[j];
+        protocol = SCHEME_VEC_ELS(act)[0];
+        /* The set of suported protocols is arbitary, based on what we've needed
+           so far. */
+        if (!strcmp(SCHEME_SYM_VAL(protocol), "ptr_ptr_ptr_int->void")) {
+          gccb_Ptr_Ptr_Ptr_Int_to_Void proc;
+          void *a, *b, *c;
+          int i;
+
+          proc = (gccb_Ptr_Ptr_Ptr_Int_to_Void)scheme_extract_pointer(SCHEME_VEC_ELS(act)[1]);
+          a = scheme_extract_pointer(SCHEME_VEC_ELS(act)[2]);
+          b = scheme_extract_pointer(SCHEME_VEC_ELS(act)[3]);
+          c = scheme_extract_pointer(SCHEME_VEC_ELS(act)[4]);
+          i = SCHEME_INT_VAL(SCHEME_VEC_ELS(act)[5]);
+
+          proc(a, b, c, i);
+        } else if (!strcmp(SCHEME_SYM_VAL(protocol), "ptr_ptr_ptr->void")) {
+          gccb_Ptr_Ptr_Ptr_to_Void proc;
+          void *a, *b, *c;
+
+          proc = (gccb_Ptr_Ptr_Ptr_to_Void)scheme_extract_pointer(SCHEME_VEC_ELS(act)[1]);
+          a = scheme_extract_pointer(SCHEME_VEC_ELS(act)[2]);
+          b = scheme_extract_pointer(SCHEME_VEC_ELS(act)[3]);
+          c = scheme_extract_pointer(SCHEME_VEC_ELS(act)[4]);
+
+          proc(a, b, c);
+        } else if (!strcmp(SCHEME_SYM_VAL(protocol), "ptr_ptr_float->void")) {
+          gccb_Ptr_Ptr_Float_to_Void proc;
+          void *a, *b;
+          float f;
+
+          proc = (gccb_Ptr_Ptr_Float_to_Void)scheme_extract_pointer(SCHEME_VEC_ELS(act)[1]);
+          a = scheme_extract_pointer(SCHEME_VEC_ELS(act)[2]);
+          b = scheme_extract_pointer(SCHEME_VEC_ELS(act)[3]);
+          f = SCHEME_DBL_VAL(SCHEME_VEC_ELS(act)[4]);
+
+          proc(a, b, f);
+        } else if (!strcmp(SCHEME_SYM_VAL(protocol), "ptr_ptr_double->void")) {
+          gccb_Ptr_Ptr_Double_to_Void proc;
+          void *a, *b;
+          double d;
+
+          proc = (gccb_Ptr_Ptr_Double_to_Void)scheme_extract_pointer(SCHEME_VEC_ELS(act)[1]);
+          a = scheme_extract_pointer(SCHEME_VEC_ELS(act)[2]);
+          b = scheme_extract_pointer(SCHEME_VEC_ELS(act)[3]);
+          d = SCHEME_DBL_VAL(SCHEME_VEC_ELS(act)[4]);
+
+          proc(a, b, d);
+        }
+        prev = desc;
+      }
+    }
+    desc = desc->next;
+  }
+}
+
 void scheme_zero_unneeded_rands(Scheme_Thread *p)
 {
   /* Call this procedure before GC or before copying out
@@ -7533,6 +7671,8 @@ static void get_ready_for_GC()
   scheme_future_block_until_gc();
 #endif
 
+  run_gc_callbacks(1);
+
   scheme_zero_unneeded_rands(scheme_current_thread);
 
   scheme_clear_modidx_cache();
@@ -7601,6 +7741,8 @@ static void done_with_GC()
   end_this_gc_time = scheme_get_process_milliseconds();
   scheme_total_gc_time += (end_this_gc_time - start_this_gc_time);
 
+  run_gc_callbacks(0);
+
 #ifdef MZ_USE_FUTURES
   scheme_future_continue_after_gc();
 #endif