added scheme_add_swap_out_callback

svn: r8932

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.}

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

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

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

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

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();

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);

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;

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)

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 */