From 73a137d84c857722a02a7a1c0d3fe04ac0d8294d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 8 Mar 2008 15:46:50 +0000 Subject: [PATCH] added scheme_add_swap_out_callback svn: r8932 --- collects/scribblings/inside/threads.scrbl | 19 +++++++++++++++++++ src/mzscheme/include/mzscheme.exp | 1 + src/mzscheme/include/mzscheme3m.exp | 1 + src/mzscheme/include/mzwin.def | 1 + src/mzscheme/include/mzwin3m.def | 1 + src/mzscheme/src/schemef.h | 1 + src/mzscheme/src/schemex.h | 1 + src/mzscheme/src/schemex.inc | 1 + src/mzscheme/src/schemexm.h | 1 + src/mzscheme/src/thread.c | 23 ++++++++++++++++++++++- 10 files changed, 49 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/inside/threads.scrbl b/collects/scribblings/inside/threads.scrbl index e55595722a..1f30790161 100644 --- a/collects/scribblings/inside/threads.scrbl +++ b/collects/scribblings/inside/threads.scrbl @@ -727,3 +727,22 @@ Ends an atomic region with respect to Scheme threads. The current Ends an atomic region with respect to Scheme threads, and also prevents an immediate thread swap. (In other words, no Scheme thread swaps will occur until a future safe point.)} + +@function[(void scheme_add_swap_callback + [Scheme_Closure_Func f] + [Scheme_Object* data])]{ + +Registers a callback to be invoked just after a Scheme thread is +swapped in. The @var{data} is provided back to @var{f} when it is +called, where @cpp{Closure_Func} is defined as follows: + +@verbatim[#:indent 2]{ + typedef Scheme_Object *(*Scheme_Closure_Func)(Scheme_Object *); +}} + +@function[(void scheme_add_swap_out_callback + [Scheme_Closure_Func f] + [Scheme_Object* data])]{ + +Like @cpp{scheme_add_swap_callback}, but registers a callback to be +invoked just before a Scheme thread is swapped out.} diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp index 3d818ebd4d..72262feab4 100644 --- a/src/mzscheme/include/mzscheme.exp +++ b/src/mzscheme/include/mzscheme.exp @@ -61,6 +61,7 @@ scheme_sync_enable_break scheme_sync_timeout scheme_make_evt_set scheme_add_swap_callback +scheme_add_swap_out_callback scheme_call_enable_break scheme_close_should_force_port_closed scheme_push_kill_action diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index 0e765ddf95..54dc68f284 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/src/mzscheme/include/mzscheme3m.exp @@ -61,6 +61,7 @@ scheme_sync_enable_break scheme_sync_timeout scheme_make_evt_set scheme_add_swap_callback +scheme_add_swap_out_callback scheme_call_enable_break scheme_close_should_force_port_closed scheme_push_kill_action diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def index 4e9c41cd81..b2afb08f34 100644 --- a/src/mzscheme/include/mzwin.def +++ b/src/mzscheme/include/mzwin.def @@ -63,6 +63,7 @@ EXPORTS scheme_sync_timeout scheme_make_evt_set scheme_add_swap_callback + scheme_add_swap_out_callback scheme_call_enable_break scheme_close_should_force_port_closed scheme_push_kill_action diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def index 80d06b7a94..e709d3be0d 100644 --- a/src/mzscheme/include/mzwin3m.def +++ b/src/mzscheme/include/mzwin3m.def @@ -63,6 +63,7 @@ EXPORTS scheme_sync_timeout scheme_make_evt_set scheme_add_swap_callback + scheme_add_swap_out_callback scheme_call_enable_break scheme_close_should_force_port_closed scheme_push_kill_action diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index 448d336be7..25a09fd6e9 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -152,6 +152,7 @@ MZ_EXTERN Scheme_Object *scheme_sync_timeout(int argc, Scheme_Object *argv[]); MZ_EXTERN Scheme_Object *scheme_make_evt_set(int argc, Scheme_Object **argv); MZ_EXTERN void scheme_add_swap_callback(Scheme_Closure_Func f, Scheme_Object *data); +MZ_EXTERN void scheme_add_swap_out_callback(Scheme_Closure_Func f, Scheme_Object *data); MZ_EXTERN Scheme_Object *scheme_call_enable_break(Scheme_Prim *prim, int argc, Scheme_Object *argv[]); MZ_EXTERN int scheme_close_should_force_port_closed(); diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 98902cd301..4354299d40 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -121,6 +121,7 @@ Scheme_Object *(*scheme_sync_enable_break)(int argc, Scheme_Object *argv[]); Scheme_Object *(*scheme_sync_timeout)(int argc, Scheme_Object *argv[]); Scheme_Object *(*scheme_make_evt_set)(int argc, Scheme_Object **argv); void (*scheme_add_swap_callback)(Scheme_Closure_Func f, Scheme_Object *data); +void (*scheme_add_swap_out_callback)(Scheme_Closure_Func f, Scheme_Object *data); Scheme_Object *(*scheme_call_enable_break)(Scheme_Prim *prim, int argc, Scheme_Object *argv[]); int (*scheme_close_should_force_port_closed)(); void (*scheme_push_kill_action)(Scheme_Kill_Action_Func f, void *d); diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index 18d973d7ad..dc520ceeb8 100644 --- a/src/mzscheme/src/schemex.inc +++ b/src/mzscheme/src/schemex.inc @@ -69,6 +69,7 @@ scheme_extension_table->scheme_sync_timeout = scheme_sync_timeout; scheme_extension_table->scheme_make_evt_set = scheme_make_evt_set; scheme_extension_table->scheme_add_swap_callback = scheme_add_swap_callback; + scheme_extension_table->scheme_add_swap_out_callback = scheme_add_swap_out_callback; scheme_extension_table->scheme_call_enable_break = scheme_call_enable_break; scheme_extension_table->scheme_close_should_force_port_closed = scheme_close_should_force_port_closed; scheme_extension_table->scheme_push_kill_action = scheme_push_kill_action; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index 3f618c0b4f..4a98c162c6 100644 --- a/src/mzscheme/src/schemexm.h +++ b/src/mzscheme/src/schemexm.h @@ -69,6 +69,7 @@ #define scheme_sync_timeout (scheme_extension_table->scheme_sync_timeout) #define scheme_make_evt_set (scheme_extension_table->scheme_make_evt_set) #define scheme_add_swap_callback (scheme_extension_table->scheme_add_swap_callback) +#define scheme_add_swap_out_callback (scheme_extension_table->scheme_add_swap_out_callback) #define scheme_call_enable_break (scheme_extension_table->scheme_call_enable_break) #define scheme_close_should_force_port_closed (scheme_extension_table->scheme_close_should_force_port_closed) #define scheme_push_kill_action (scheme_extension_table->scheme_push_kill_action) diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 98ac9be748..516a5d58f1 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -253,7 +253,7 @@ static Scheme_Object *nested_exn_handler; static Scheme_Object *closers; -static Scheme_Object *thread_swap_callbacks; +static Scheme_Object *thread_swap_callbacks, *thread_swap_out_callbacks; static Scheme_Object *recycle_cell; static Scheme_Object *maybe_recycle_cell; @@ -2078,6 +2078,7 @@ static Scheme_Thread *make_thread(Scheme_Config *config, REGISTER_SO(scheme_main_thread); REGISTER_SO(scheme_first_thread); REGISTER_SO(thread_swap_callbacks); + REGISTER_SO(thread_swap_out_callbacks); REGISTER_SO(swap_target); scheme_current_thread = process; @@ -2088,6 +2089,7 @@ static Scheme_Thread *make_thread(Scheme_Config *config, process->error_buf = &main_init_error_buf; thread_swap_callbacks = scheme_null; + thread_swap_out_callbacks = scheme_null; GC_collect_start_callback = get_ready_for_GC; GC_collect_end_callback = done_with_GC; @@ -2438,6 +2440,17 @@ static void do_swap_thread() /* We're leaving... */ + { + Scheme_Object *l, *o; + Scheme_Closure_Func f; + for (l = thread_swap_out_callbacks; SCHEME_RPAIRP(l); l = SCHEME_CDR(l)) { + o = SCHEME_CAR(l); + f = SCHEME_CLOS_FUNC(o); + o = SCHEME_CLOS_DATA(o); + f(o); + } + } + if (scheme_current_thread->init_break_cell) { int cb; cb = can_break_param(scheme_current_thread); @@ -2946,6 +2959,14 @@ void scheme_add_swap_callback(Scheme_Closure_Func f, Scheme_Object *data) thread_swap_callbacks = scheme_make_pair(p, thread_swap_callbacks); } +void scheme_add_swap_out_callback(Scheme_Closure_Func f, Scheme_Object *data) +{ + Scheme_Object *p; + + p = scheme_make_raw_pair((Scheme_Object *)f, data); + thread_swap_out_callbacks = scheme_make_pair(p, thread_swap_out_callbacks); +} + /**************************************************************************/ /* Ensure that a new thread has a reasonable starting stack */