extend C API to abort/capture cont skipping dynamic-winds

src/racket/include/mzwin.def

@@ -84,6 +84,9 @@ EXPORTS
  scheme_with_stack_freeze
  scheme_frozen_run_some
  scheme_is_in_frozen_stack
+ scheme_abort_continuation_no_dws
+ scheme_call_with_composable_no_dws
+ scheme_set_on_atomic_timeout
  scheme_signal_error
  scheme_raise_exn
  scheme_warning

src/racket/include/mzwin3m.def

@@ -84,6 +84,9 @@ EXPORTS
  scheme_with_stack_freeze
  scheme_frozen_run_some
  scheme_is_in_frozen_stack
+ scheme_abort_continuation_no_dws
+ scheme_call_with_composable_no_dws
+ scheme_set_on_atomic_timeout
  scheme_signal_error
  scheme_raise_exn
  scheme_warning

src/racket/include/racket.exp

@@ -82,6 +82,9 @@ scheme_pop_break_enable
 scheme_with_stack_freeze
 scheme_frozen_run_some
 scheme_is_in_frozen_stack
+scheme_abort_continuation_no_dws
+scheme_call_with_composable_no_dws
+scheme_set_on_atomic_timeout
 scheme_signal_error
 scheme_raise_exn
 scheme_warning

src/racket/include/racket3m.exp

@@ -82,6 +82,9 @@ scheme_pop_break_enable
 scheme_with_stack_freeze
 scheme_frozen_run_some
 scheme_is_in_frozen_stack
+scheme_abort_continuation_no_dws
+scheme_call_with_composable_no_dws
+scheme_set_on_atomic_timeout
 scheme_signal_error
 scheme_raise_exn
 scheme_warning

src/racket/include/scheme.h

@@ -882,7 +882,7 @@ typedef struct Scheme_Continuation_Jump_State {
   struct Scheme_Object *alt_full_continuation;
   Scheme_Object *val; /* or **vals */
   mzshort num_vals;
-  short is_kill, is_escape;
+  char is_kill, is_escape, skip_dws;
 } Scheme_Continuation_Jump_State;
 
 /* A mark position is in odd number, so that it can be
@@ -1684,6 +1684,8 @@ extern void *scheme_malloc_envunbox(size_t);
 /*                   embedding configuration and hooks                    */
 /*========================================================================*/
 
+typedef void (*Scheme_On_Atomic_Timeout_Proc)(void);
+
 #if SCHEME_DIRECT_EMBEDDED
 
 #if defined(_IBMR2)
@@ -1810,7 +1812,7 @@ MZ_EXTERN void scheme_register_static(void *ptr, long size);
 # define MZ_REGISTER_STATIC(x) /* empty */
 #endif
 
-MZ_EXTERN void (*scheme_on_atomic_timeout)(void);
+MZ_EXTERN Scheme_On_Atomic_Timeout_Proc scheme_on_atomic_timeout;
 
 MZ_EXTERN void scheme_immediate_exit(int status);
 

src/racket/src/eval.c

@@ -8906,6 +8906,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
         p->cjs.alt_full_continuation = NULL;
         p->overflow = overflow;
         p->stack_start = overflow->stack_start;
+        p->cjs.skip_dws = 0;
         scheme_longjmpup(&overflow->jmp->cont);
       }
     } else {
@@ -8916,6 +8917,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
       p->cjs.num_vals = 1;
       p->cjs.val = (Scheme_Object *)c;
       p->cjs.is_escape = 1;
+      p->cjs.skip_dws = 0;
        
       if (prompt_mc) {
         /* The prompt is from a meta-continuation that's different
@@ -9008,6 +9010,7 @@ void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Obj
   p->cjs.val = value;
   p->cjs.jumping_to_continuation = obj;
   p->cjs.alt_full_continuation = alt_full;
+  p->cjs.skip_dws = 0;
   scheme_longjmp(MZTHREADELEM(p, error_buf), 1);
 }
 

src/racket/src/fun.c

@@ -4481,6 +4481,7 @@ static void reset_cjs(Scheme_Continuation_Jump_State *a)
   a->num_vals = 0;
   a->is_kill = 0;
   a->is_escape = 0;
+  a->skip_dws = 0;
 }
 
 void scheme_clear_escape(void)
@@ -4499,6 +4500,7 @@ static void copy_cjs(Scheme_Continuation_Jump_State *a, Scheme_Continuation_Jump
   a->num_vals = b->num_vals;
   a->is_kill = b->is_kill;
   a->is_escape = b->is_escape;
+  a->skip_dws = b->skip_dws;
 }
 
 Scheme_Object *
@@ -5402,7 +5404,8 @@ static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
                                              Scheme_Cont *cont,
                                              MZ_MARK_STACK_TYPE copied_cms,
                                              int clear_cm_caches,
-                                             Scheme_Object **_sub_conts)
+                                             Scheme_Object **_sub_conts,
+                                             int skip_dws)
 {
   Scheme_Thread *p = scheme_current_thread;
   int old_cac = scheme_continuation_application_count;
@@ -5426,6 +5429,7 @@ static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
                            clear_cm_caches);
         copied_cms = MZ_CONT_MARK_STACK;
 
+        if (!skip_dws)
           pre(dwl->dw->data);
 
         if (scheme_continuation_application_count != old_cac) {
@@ -5954,7 +5958,8 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
 
         meta_depth += dw->next_meta;
       }
-      copied_cms = exec_dyn_wind_pres(dwl, dwl_len, cont, copied_cms, clear_cm_caches, &sub_conts);
+      copied_cms = exec_dyn_wind_pres(dwl, dwl_len, cont, copied_cms, clear_cm_caches, &sub_conts,
+                                      cont->skip_dws);
       p = scheme_current_thread;
       p->dw = all_dw;
       p->next_meta = cont->next_meta;      
@@ -6012,7 +6017,7 @@ internal_call_cc (int argc, Scheme_Object *argv[])
 
   barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);
 
-  if (composable) {
+  if (composable && SCHEME_FALSEP(argv[2])) {
     if (!prompt && !barrier_prompt->is_barrier) {
       /* Pseduo-prompt ok. */
     } else {
@@ -6221,6 +6226,9 @@ internal_call_cc (int argc, Scheme_Object *argv[])
   } else if (composable || cont->escape_cont) {
     Scheme_Object *argv2[1];
 
+    if (SCHEME_TRUEP(argv[2]))
+      cont->skip_dws = 1;
+
     argv2[0] = (Scheme_Object *)cont;
     ret = _scheme_tail_apply(argv[0], 1, argv2);
     return ret;
@@ -7127,6 +7135,7 @@ Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Sch
     p->cjs.val = (Scheme_Object *)cont;
     p->cjs.num_vals = 1;
     p->cjs.is_escape = 1;
+    p->cjs.skip_dws = 0;
 
     p->stack_start = mc->overflow->stack_start;
     p->decompose_mc = mc;
@@ -7159,7 +7168,7 @@ Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Sch
   return value;
 }
 
-static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[])
+static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], int skip_dws)
 {
   Scheme_Object *prompt_tag;
   Scheme_Prompt *prompt;
@@ -7197,13 +7206,31 @@ static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[])
   }
   p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
   p->cjs.alt_full_continuation = NULL;
+  p->cjs.skip_dws = skip_dws;
 
   scheme_longjmp(*p->error_buf, 1);
 
   return NULL;
 }
 
-static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[])
+static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[])
+{
+  return do_abort_continuation(argc, argv, 0);
+}
+
+Scheme_Object *scheme_abort_continuation_no_dws (Scheme_Object *pt, Scheme_Object *v)
+{
+  /* This function is useful for GRacket-like extensions of Racket that need to
+     implement something like subtreads through composable continuations. */
+  Scheme_Object *a[2];
+
+  a[0] = pt;
+  a[1] = v;
+
+  return do_abort_continuation(2, a, 1);
+}
+
+static Scheme_Object *do_call_with_control (int argc, Scheme_Object *argv[], int no_dws)
 {
   Scheme_Object *prompt_tag;
   Scheme_Object *a[3];
@@ -7220,13 +7247,29 @@ static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[])
 
   a[0] = argv[0];
   a[1] = prompt_tag;
-  a[2] = scheme_true;
+  a[2] = (no_dws ? scheme_true : scheme_false);
 
   /* Trampoline to internal_call_cc. This trampoline ensures that
      the runstack is flushed before we try to grab the continuation. */
   return _scheme_tail_apply(internal_call_cc_prim, 3, a);
 }
 
+static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[])
+{
+  return do_call_with_control(argc, argv, 0);
+}
+
+Scheme_Object *scheme_call_with_composable_no_dws (Scheme_Object *proc, Scheme_Object *pt)
+{
+  /* Works with scheme_abort_continuation_no_dws() above. */
+  Scheme_Object *a[2];
+
+  a[0] = proc;
+  a[1] = pt;
+
+  return do_call_with_control(2, a, 1);
+}
+
 static Scheme_Object *continuation_marks(Scheme_Thread *p,
 					 Scheme_Object *_cont,
 					 Scheme_Object *econt,
@@ -8373,6 +8416,7 @@ Scheme_Object *scheme_dynamic_wind(void (*pre)(void *),
     } else {
       Scheme_Continuation_Jump_State cjs;
       p = scheme_current_thread;
+      if (!p->cjs.skip_dws) {
         ASSERT_SUSPEND_BREAK_ZERO();
         p->suspend_break++;
         copy_cjs(&cjs, &p->cjs);
@@ -8383,6 +8427,7 @@ Scheme_Object *scheme_dynamic_wind(void (*pre)(void *),
         --p->suspend_break;
       }
     }
+  }
 
   if (err) {
     /* If we're escaping to a prompt or escape continuation,
@@ -8558,6 +8603,7 @@ static Scheme_Object *jump_to_alt_continuation()
   p->cjs.jumping_to_continuation = NULL;
   p->cjs.alt_full_continuation = NULL;
   p->cjs.val = NULL;
+  p->cjs.skip_dws = 0;
 
   return scheme_jump_to_continuation(fc, p->cjs.num_vals, args, NULL, 0);
 }

src/racket/src/schemef.h

@@ -180,6 +180,11 @@ MZ_EXTERN int scheme_with_stack_freeze(Scheme_Frozen_Stack_Proc wha_f, void *wha
 MZ_EXTERN int scheme_frozen_run_some(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs);
 MZ_EXTERN int scheme_is_in_frozen_stack();
 
+MZ_EXTERN Scheme_Object *scheme_abort_continuation_no_dws (Scheme_Object *pt, Scheme_Object *v);
+MZ_EXTERN Scheme_Object *scheme_call_with_composable_no_dws (Scheme_Object *proc, Scheme_Object *pt);
+
+MZ_EXTERN Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p);
+
 /*========================================================================*/
 /*                              error handling                            */
 /*========================================================================*/

src/racket/src/schemex.h

@@ -142,6 +142,9 @@ void (*scheme_pop_break_enable)(Scheme_Cont_Frame_Data *cframe, int post_check);
 int (*scheme_with_stack_freeze)(Scheme_Frozen_Stack_Proc wha_f, void *wha_data);
 int (*scheme_frozen_run_some)(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs);
 int (*scheme_is_in_frozen_stack)();
+Scheme_Object *scheme_abort_continuation_no_dws;
+Scheme_Object *scheme_call_with_composable_no_dws;
+Scheme_On_Atomic_Timeout_Proc (*scheme_set_on_atomic_timeout)(Scheme_On_Atomic_Timeout_Proc p);
 /*========================================================================*/
 /*                              error handling                            */
 /*========================================================================*/

src/racket/src/schemex.inc

@@ -90,6 +90,9 @@
   scheme_extension_table->scheme_with_stack_freeze = scheme_with_stack_freeze;
   scheme_extension_table->scheme_frozen_run_some = scheme_frozen_run_some;
   scheme_extension_table->scheme_is_in_frozen_stack = scheme_is_in_frozen_stack;
+  scheme_extension_table->scheme_abort_continuation_no_dws = scheme_abort_continuation_no_dws;
+  scheme_extension_table->scheme_call_with_composable_no_dws = scheme_call_with_composable_no_dws;
+  scheme_extension_table->scheme_set_on_atomic_timeout = scheme_set_on_atomic_timeout;
   scheme_extension_table->scheme_signal_error = scheme_signal_error;
   scheme_extension_table->scheme_raise_exn = scheme_raise_exn;
   scheme_extension_table->scheme_warning = scheme_warning;

src/racket/src/schemexm.h

@@ -90,6 +90,9 @@
 #define scheme_with_stack_freeze (scheme_extension_table->scheme_with_stack_freeze)
 #define scheme_frozen_run_some (scheme_extension_table->scheme_frozen_run_some)
 #define scheme_is_in_frozen_stack (scheme_extension_table->scheme_is_in_frozen_stack)
+#define scheme_abort_continuation_no_dws (scheme_extension_table->scheme_abort_continuation_no_dws)
+#define scheme_call_with_composable_no_dws (scheme_extension_table->scheme_call_with_composable_no_dws)
+#define scheme_set_on_atomic_timeout (scheme_extension_table->scheme_set_on_atomic_timeout)
 #define scheme_signal_error (scheme_extension_table->scheme_signal_error)
 #define scheme_raise_exn (scheme_extension_table->scheme_raise_exn)
 #define scheme_warning (scheme_extension_table->scheme_warning)

src/racket/src/schpriv.h

@@ -1312,7 +1312,7 @@ typedef struct Scheme_Dynamic_Wind {
 
 typedef struct Scheme_Cont {
   Scheme_Object so;
-  char composable, has_prompt_dw, need_meta_prompt;
+  char composable, has_prompt_dw, need_meta_prompt, skip_dws;
   struct Scheme_Meta_Continuation *meta_continuation;
   Scheme_Jumpup_Buf buf;
   Scheme_Dynamic_Wind *dw;

src/racket/src/thread.c

@@ -207,6 +207,7 @@ HOOK_SHARED_OK void (*scheme_notify_multithread)(int on);
 HOOK_SHARED_OK void (*scheme_wakeup_on_input)(void *fds);
 HOOK_SHARED_OK int (*scheme_check_for_break)(void);
 HOOK_SHARED_OK void (*scheme_on_atomic_timeout)(void);
+HOOK_SHARED_OK static int atomic_timeout_auto_suspend;
 
 ROSYM static Scheme_Object *read_symbol, *write_symbol, *execute_symbol, *delete_symbol, *exists_symbol;
 ROSYM static Scheme_Object *client_symbol, *server_symbol;
@@ -3272,6 +3273,7 @@ static Scheme_Object *def_nested_exn_handler(int argc, Scheme_Object *argv[])
     p->cjs.alt_full_continuation = NULL;
     p->cjs.val = argv[0];
     p->cjs.is_kill = 0;
+    p->cjs.skip_dws = 0;
     scheme_longjmp(*p->error_buf, 1);
   }
 
@@ -3875,6 +3877,7 @@ static void exit_or_escape(Scheme_Thread *p)
     p->cjs.jumping_to_continuation = (Scheme_Object *)p;
     p->cjs.alt_full_continuation = NULL;
     p->cjs.is_kill = 1;
+    p->cjs.skip_dws = 0;
     scheme_longjmp(*p->error_buf, 1);
   }
 
@@ -4216,8 +4219,16 @@ void scheme_thread_block(float sleep_time)
     swap_target = next;
     next = NULL;
     do_swap_thread();
-  } else if (do_atomic && scheme_on_atomic_timeout) {
+  } else if (do_atomic && scheme_on_atomic_timeout
+             && (atomic_timeout_auto_suspend < 2)) {
+    if (atomic_timeout_auto_suspend) {
+      atomic_timeout_auto_suspend++;
+      scheme_fuel_counter = p->engine_weight;
+      scheme_jit_stack_boundary = scheme_stack_boundary;
+    }
     scheme_on_atomic_timeout();
+    if (atomic_timeout_auto_suspend > 1)
+      --atomic_timeout_auto_suspend;
   } else {
     /* If all processes are blocked, check for total process sleeping: */
     if (p->block_descriptor != NOT_BLOCKED) {
@@ -4470,6 +4481,18 @@ static void wait_until_suspend_ok()
   }
 }
 
+Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p)
+{
+  Scheme_On_Atomic_Timeout_Proc old;
+
+  old = scheme_on_atomic_timeout;
+  scheme_on_atomic_timeout = p;
+  if (p)
+    atomic_timeout_auto_suspend = 1;
+
+  return old;
+}
+
 void scheme_weak_suspend_thread(Scheme_Thread *r)
 {
   if (r->running & MZTHREAD_SUSPENDED)