diff --git a/collects/scribblings/inside/memory.scrbl b/collects/scribblings/inside/memory.scrbl index 19f61a5dab..5d86f4f73c 100644 --- a/collects/scribblings/inside/memory.scrbl +++ b/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}.} diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index b283a0fd9b..4fb3d1048f 100644 --- a/src/foreign/foreign.c +++ b/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 */ diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index fac59f5397..00a4febeca 100755 --- a/src/foreign/foreign.rktc +++ b/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 */ diff --git a/src/racket/include/mzwin.def b/src/racket/include/mzwin.def index d86769ee9a..3cb7a765b3 100644 --- a/src/racket/include/mzwin.def +++ b/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 diff --git a/src/racket/include/mzwin3m.def b/src/racket/include/mzwin3m.def index f05018f56d..20d3c108c8 100644 --- a/src/racket/include/mzwin3m.def +++ b/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 diff --git a/src/racket/include/racket.exp b/src/racket/include/racket.exp index b561ef33df..824e48413a 100644 --- a/src/racket/include/racket.exp +++ b/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 diff --git a/src/racket/include/racket3m.exp b/src/racket/include/racket3m.exp index 6ead0190cf..7b620836f5 100644 --- a/src/racket/include/racket3m.exp +++ b/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 diff --git a/src/racket/include/schthread.h b/src/racket/include/schthread.h index e456034855..c002ba3d2a 100644 --- a/src/racket/include/schthread.h +++ b/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_) /* **************************************** */ diff --git a/src/racket/src/schemef.h b/src/racket/src/schemef.h index 1ca1e9125d..2621474fbd 100644 --- a/src/racket/src/schemef.h +++ b/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 */ /*========================================================================*/ diff --git a/src/racket/src/schemex.h b/src/racket/src/schemex.h index 12dcf854f2..843d606486 100644 --- a/src/racket/src/schemex.h +++ b/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 */ /*========================================================================*/ diff --git a/src/racket/src/schemex.inc b/src/racket/src/schemex.inc index 9deec63693..c3090a1dea 100644 --- a/src/racket/src/schemex.inc +++ b/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; diff --git a/src/racket/src/schemexm.h b/src/racket/src/schemexm.h index 570510b7db..998743c940 100644 --- a/src/racket/src/schemexm.h +++ b/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) diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 0d2d5b2f92..7100115d92 100644 --- a/src/racket/src/schpriv.h +++ b/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 diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index ff92b61e90..b2e09cc57e 100644 --- a/src/racket/src/thread.c +++ b/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