fix lack of space-safety in delimited continuations (related to recently fixed crashing bug)

svn: r9544

collects/tests/mzscheme/prompt-sfs.ss

@@ -0,0 +1,63 @@
+#lang scheme
+
+#|
+
+This test is designed to to check whether meta-continuations are
+correctly split when a continuation is delimited in the middle of
+a meta-continuation other than the current one. In aprticular,
+the `x' binding is part of the deeper meta-continuation when `ak'
+is captured, but it is delimited inside the binding, so `x'
+should not be reated in `ak'.
+
+|#
+
+(define (make-big-thing) (cons (make-string 100000) (make-will-executor)))
+(define (show-big-thing say x) (say (string-length (car x))))
+
+(collect-garbage)
+(collect-garbage)
+(define orig (current-memory-use))
+
+(define single (make-will-executor))
+
+(let loop ([n 10][accums null])
+  (if (zero? n)
+      (begin
+        (collect-garbage)
+        (collect-garbage)
+        (dump-memory-stats) ; look for just one <will-executor>
+        (printf "~s\n" (- (current-memory-use) orig))
+        accums)
+      (let* ([says null]
+             [say (lambda (s)
+                    (set! says (cons s says)))]
+             [a (make-continuation-prompt-tag 'a)]
+             [b (make-continuation-prompt-tag 'b)])
+        (let ([ak
+               (let ([x (make-big-thing)])
+                 (begin0
+                  (call-with-continuation-prompt
+                   (lambda ()
+                     (with-continuation-mark 'y "y0"
+                       (let ([bk (call-with-continuation-prompt
+                                  (lambda ()
+                                    (let ([f (call-with-composable-continuation
+                                              (lambda (k)
+                                                (lambda () k))
+                                              b)])
+                                      (say "bcall")
+                                      (begin0
+                                       (f)
+                                       (say "breturn"))))
+                                  b)])
+                         (call-with-continuation-prompt
+                          (lambda ()
+                            ((bk (lambda ()
+                                   (let ([f (call/cc (lambda (k) (lambda () (lambda () k))) a)])
+                                     (begin0
+                                      (f)
+                                      (say "areturn")))))))
+                          b))))
+                   a)
+                  (show-big-thing say x)))])
+          (loop (sub1 n) (cons ak accums))))))

src/mzscheme/include/scheme.h

@@ -924,7 +924,7 @@ typedef struct Scheme_Thread {
 
   mz_jmp_buf *error_buf;
   Scheme_Continuation_Jump_State cjs;
-  struct Scheme_Cont *decompose;
+  struct Scheme_Meta_Continuation *decompose_mc; /* set during a jump */
 
   Scheme_Thread_Cell_Table *cell_values;
   Scheme_Config *init_config;

src/mzscheme/src/eval.c

@@ -7123,7 +7123,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
         }
         p->meta_continuation = prompt_mc->next;
         p->stack_start = prompt_mc->overflow->stack_start;
-        p->decompose = prompt_mc->cont;
+        p->decompose_mc = prompt_mc;
         scheme_longjmpup(&prompt_mc->overflow->jmp->cont);
       } else if ((!prompt->boundary_overflow_id && !p->overflow)
                  || (prompt->boundary_overflow_id

src/mzscheme/src/fun.c

@@ -194,7 +194,10 @@ typedef struct Scheme_Dynamic_Wind_List {
 } Scheme_Dynamic_Wind_List;
 
 static Scheme_Object *cached_beg_stx, *cached_dv_stx, *cached_ds_stx;
-int cached_stx_phase;
+static int cached_stx_phase;
+
+static Scheme_Cont *offstack_cont;
+static Scheme_Overflow *offstack_overflow;
 
 /*========================================================================*/
 /*                             initialization                             */
@@ -222,6 +225,9 @@ scheme_init_fun (Scheme_Env *env)
   REGISTER_SO(cached_ds_stx);
   REGISTER_SO(scheme_procedure_p_proc);
 
+  REGISTER_SO(offstack_cont);
+  REGISTER_SO(offstack_overflow);
+
   o = scheme_make_folding_prim(procedure_p, "procedure?", 1, 1, 1);
   SCHEME_PRIM_PROC_FLAGS(o) |= SCHEME_PRIM_IS_UNARY_INLINED;
   scheme_add_global_constant("procedure?", o, env);
@@ -4050,6 +4056,7 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
   start = MALLOC_N(Scheme_Object*, size);
   saved->runstack_start = start;
   memcpy(saved->runstack_start, runstack, size * sizeof(Scheme_Object *));
+  saved->runstack_offset = (runstack XFORM_OK_MINUS runstack_start);
 
   if (!effective_prompt || (effective_prompt->runstack_boundary_start != runstack_start)) {
 
@@ -4349,6 +4356,87 @@ static void clear_cm_copy_caches(Scheme_Cont_Mark *cp, int cnt)
   }
 }
 
+static Scheme_Saved_Stack *clone_runstack_saved(Scheme_Saved_Stack *saved, Scheme_Object **boundary_start,
+                                                Scheme_Saved_Stack *last)
+{
+  Scheme_Saved_Stack *naya, *first = last, *prev = NULL;
+
+  while (saved) {
+    naya = MALLOC_ONE_RT(Scheme_Saved_Stack);
+    memcpy(naya, saved, sizeof(Scheme_Saved_Stack));
+    if (prev)
+      prev->prev = naya;
+    else
+      first = naya;
+    prev = naya;
+    if (saved->runstack_start == boundary_start)
+      break;
+    saved = saved->prev;
+  }
+  if (prev)
+    prev->prev = last;
+  
+  return first;
+}
+
+static Scheme_Saved_Stack *clone_runstack_copied(Scheme_Saved_Stack *copied, 
+                                                 Scheme_Object **copied_start,
+                                                 Scheme_Saved_Stack *saved, 
+                                                 Scheme_Object **boundary_start,
+                                                 long boundary_offset)
+{
+  Scheme_Saved_Stack *naya, *first = NULL, *prev = NULL, *s;
+
+  if (copied_start == boundary_start) {
+    naya = copied;
+  } else {
+    for (naya = copied->prev, s = saved; 
+         s->runstack_start != boundary_start; 
+         naya = naya->prev, s = s->prev) {
+    }
+  }
+  if ((naya->runstack_offset + naya->runstack_size == boundary_offset)
+      && !naya->prev) {
+    /* no need to prune anything */
+    return copied;
+  }
+
+  s = NULL;
+  while (copied) {
+    naya = MALLOC_ONE_RT(Scheme_Saved_Stack);
+    memcpy(naya, copied, sizeof(Scheme_Saved_Stack));
+    naya->prev = NULL;
+    if (prev)
+      prev->prev = naya;
+    else
+      first = naya;
+    prev = naya;
+    if ((!s && copied_start == boundary_start)
+        || (s && (s->runstack_start == boundary_start))) {
+      long size;
+      Scheme_Object **a;
+      size = boundary_offset - naya->runstack_offset;
+      if (size < 0)
+        scheme_signal_error("negative stack-copy size while pruning");
+      if (size > naya->runstack_size)
+        scheme_signal_error("bigger stack-copy size while pruning: %d vs. %d", size, naya->runstack_size);
+      a = MALLOC_N(Scheme_Object *, size);
+      memcpy(a, naya->runstack_start, size * sizeof(Scheme_Object *));
+      naya->runstack_start = a;
+      naya->runstack_size = size;
+      break;
+    }
+
+    copied = copied->prev;
+    if (!s)
+      s = saved;
+    else
+      s = s->prev;
+  }
+  
+  return first;
+}
+
 static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc,
                                                  Scheme_Object *limit_tag, int limit_depth,
                                                  Scheme_Meta_Continuation *prompt_cont,
@@ -4378,6 +4466,8 @@ static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc,
     if (SAME_OBJ(mc, prompt_cont)) {
       /* Need only part of this meta-continuation's marks. */
       long delta;
+      void *stack_boundary;
+
       delta = prompt->mark_boundary - naya->cont_mark_offset;
       if (delta) {
         naya->cont_mark_total -= delta;
@@ -4396,8 +4486,18 @@ static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc,
           naya->cont_mark_stack_copied = NULL;
       }
       naya->cont_mark_pos_bottom = prompt->boundary_mark_pos;
-      {
+
+      if ((prompt->boundary_overflow_id && (prompt->boundary_overflow_id == naya->overflow->id))
+          || (!prompt->boundary_overflow_id && !naya->overflow->prev)) {
+        stack_boundary = prompt->stack_boundary;
+      } else {
+        stack_boundary = naya->overflow->stack_start;
+      }
+
+      if (naya->cont) {
         Scheme_Cont *cnaya;
+        Scheme_Saved_Stack *saved;
+
         cnaya = MALLOC_ONE_TAGGED(Scheme_Cont);
         memcpy(cnaya, naya->cont, sizeof(Scheme_Cont));
 
@@ -4408,10 +4508,40 @@ static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc,
         cnaya->cont_mark_pos_bottom = naya->cont_mark_pos_bottom;
         cnaya->cont_mark_stack_copied = naya->cont_mark_stack_copied;
 
-        cnaya->prompt_stack_start = prompt->stack_boundary;
+        cnaya->prompt_stack_start = stack_boundary;
+
+        /* Prune unneeded runstack data */
+        saved = clone_runstack_copied(cnaya->runstack_copied, 
+                                      cnaya->runstack_start,
+                                      cnaya->runstack_saved, 
+                                      prompt->runstack_boundary_start,
+                                      prompt->runstack_boundary_offset);
+        cnaya->runstack_copied = saved;
+
+        /* Prune unneeded buffers */
+        if (prompt->runstack_boundary_start == cnaya->runstack_start)
+          saved = NULL;
+        else
+          saved = clone_runstack_saved(cnaya->runstack_saved, 
+                                       prompt->runstack_boundary_start,
+                                       NULL);
+        cnaya->runstack_saved = saved;
 
         cnaya->need_meta_prompt = 1;
       }
+      if (naya->overflow && !naya->overflow->eot) {
+        /* Prune unneeded C-stack data */
+        Scheme_Overflow *onaya;
+        Scheme_Overflow_Jmp *jmp;
+        jmp = scheme_prune_jmpup(naya->overflow->jmp, stack_boundary);
+        if (jmp) {
+          onaya = MALLOC_ONE_RT(Scheme_Overflow);
+          memcpy(onaya, naya->overflow, sizeof(Scheme_Overflow));
+          naya->overflow = onaya;
+          onaya->jmp = jmp;
+          onaya->stack_start = stack_boundary;
+        }
+      }
     } else {
       if (!mc->cm_caches) {
         mc->cm_shared = 1;
@@ -4549,29 +4679,6 @@ void prune_cont_marks(Scheme_Meta_Continuation *resume_mc, Scheme_Cont *cont, Sc
   sync_meta_cont(resume_mc);
 }
 
-Scheme_Saved_Stack *clone_runstack_saved(Scheme_Saved_Stack *saved, Scheme_Object **boundary_start,
-                                         Scheme_Saved_Stack *last)
-{
-  Scheme_Saved_Stack *naya, *first = last, *prev = NULL;
-
-  while (saved) {
-    naya = MALLOC_ONE_RT(Scheme_Saved_Stack);
-    memcpy(naya, saved, sizeof(Scheme_Saved_Stack));
-    if (prev)
-      prev->prev = naya;
-    else
-      first = naya;
-    prev = naya;
-    if (saved->runstack_start == boundary_start)
-      break;
-    saved = saved->prev;
-  }
-  if (prev)
-    prev->prev = last;
-  
-  return first;
-}
-
 static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
                                              int dwl_len,
                                              Scheme_Cont *cont,
@@ -4751,7 +4858,10 @@ static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int comp
                               (for_prompt ? p->meta_prompt : prompt));
     cont->runstack_copied = saved;
     if (!for_prompt && prompt) {
-      /* Prune cont->runstack_saved to drop unneeded saves. */
+      /* Prune cont->runstack_saved to drop unneeded saves.
+         (Note that this is different than runstack_copied; 
+          runstack_saved keeps the shared runstack buffers, 
+          not the content.) */
       if (SAME_OBJ(prompt->runstack_boundary_start, MZ_RUNSTACK_START))
         saved = NULL;
       else
@@ -5626,7 +5736,7 @@ Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Obje
         p->cjs.val = val;
       }
       p->stack_start = resume->stack_start;
-      p->decompose = resume_mc->cont;
+      p->decompose_mc = resume_mc;
       scheme_longjmpup(&resume->jmp->cont);
       return NULL;
     }
@@ -5689,11 +5799,17 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain,
   overflow->jmp = jmp;
 
   saved->resume_to = overflow; /* used by eval to jump to current meta-continuation */
-  cont->use_next_cont = saved;
+  offstack_cont = saved;
   saved = NULL;
-  
+
   scheme_init_jmpup_buf(&overflow->jmp->cont);
-  if (scheme_setjmpup(&overflow->jmp->cont, overflow->jmp, ADJUST_STACK_START(p->stack_start))) {
+
+  offstack_overflow = overflow;
+  overflow = NULL; /* so it's not saved in the continuation */
+
+  if (scheme_setjmpup(&offstack_overflow->jmp->cont, 
+                      offstack_overflow->jmp, 
+                      ADJUST_STACK_START(p->stack_start))) {
     /* Returning. (Jumped here from finish_apply_for_prompt,
        scheme_compose_continuation, scheme_eval, or start_child.)
        
@@ -5709,12 +5825,14 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain,
            scheme_finish_apply_for_prompt() for those possibilities.
     */
     Scheme_Object *v;
-    Scheme_Meta_Continuation *mc;
+    Scheme_Meta_Continuation *mc, *dmc;
 
     p = scheme_current_thread;
 
-    saved = p->decompose;
+    dmc = p->decompose_mc;
-    p->decompose = NULL;
+    p->decompose_mc = NULL;
+    saved = dmc->cont;
+    overflow = dmc->overflow;
 
     if (!p->cjs.jumping_to_continuation) {
       /* Got a result: */
@@ -5765,16 +5883,21 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain,
       reset_cjs(&p->cjs);
       /* The current meta-continuation may have changed since capture: */
       saved->meta_continuation = p->meta_continuation;
-      cont->use_next_cont = saved;
       /* Fall though to continuation application below. */
     } else {
       return v;
     }
+  } else {
+    saved = offstack_cont;
+    overflow = offstack_overflow;
+    offstack_cont = NULL;
+    offstack_overflow = NULL;
   }
 
   scheme_current_thread->suspend_break++;
   
   /* Here's where we jump to the target: */
+  cont->use_next_cont = saved;
   cont->resume_to = overflow;
   cont->empty_to_next_mc = (char)empty_to_next_mc;
   scheme_current_thread->stack_start = cont->prompt_stack_start;
@@ -6228,7 +6351,7 @@ Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Sch
     p->cjs.is_escape = 1;
 
     p->stack_start = mc->overflow->stack_start;
-    p->decompose = mc->cont;
+    p->decompose_mc = mc;
 
     scheme_longjmpup(&mc->overflow->jmp->cont);
     return NULL;

src/mzscheme/src/mzmark.c

@@ -929,8 +929,6 @@ static int cont_proc_MARK(void *p) {
   gcMARK(c->prompt_id);
   gcMARK(c->prompt_buf);
 
-  /* These shouldn't actually persist across a GC, but
-     just in case... */
   gcMARK(c->value);
   gcMARK(c->resume_to);
   gcMARK(c->use_next_cont);
@@ -969,8 +967,6 @@ static int cont_proc_FIXUP(void *p) {
   gcFIXUP(c->prompt_id);
   gcFIXUP(c->prompt_buf);
 
-  /* These shouldn't actually persist across a GC, but
-     just in case... */
   gcFIXUP(c->value);
   gcFIXUP(c->resume_to);
   gcFIXUP(c->use_next_cont);
@@ -1598,7 +1594,7 @@ static int thread_val_MARK(void *p) {
   gcMARK(pr->t_set_prev);
 
   MARK_cjs(&pr->cjs);
-  gcMARK(pr->decompose);
+  gcMARK(pr->decompose_mc);
 
   gcMARK(pr->cell_values);
   gcMARK(pr->init_config);
@@ -1699,7 +1695,7 @@ static int thread_val_FIXUP(void *p) {
   gcFIXUP(pr->t_set_prev);
 
   FIXUP_cjs(&pr->cjs);
-  gcFIXUP(pr->decompose);
+  gcFIXUP(pr->decompose_mc);
 
   gcFIXUP(pr->cell_values);
   gcFIXUP(pr->init_config);

src/mzscheme/src/mzmarksrc.c

@@ -361,8 +361,6 @@ cont_proc {
   gcMARK(c->prompt_id);
   gcMARK(c->prompt_buf);
 
-  /* These shouldn't actually persist across a GC, but
-     just in case... */
   gcMARK(c->value);
   gcMARK(c->resume_to);
   gcMARK(c->use_next_cont);
@@ -611,7 +609,7 @@ thread_val {
   gcMARK(pr->t_set_prev);
 
   MARK_cjs(&pr->cjs);
-  gcMARK(pr->decompose);
+  gcMARK(pr->decompose_mc);
 
   gcMARK(pr->cell_values);
   gcMARK(pr->init_config);

src/mzscheme/src/schpriv.h

@@ -978,6 +978,8 @@ extern void *scheme_deepest_stack_start;
 # define ADJUST_STACK_START(start) (start ? start : scheme_deepest_stack_start)
 #endif
 
+struct Scheme_Overflow_Jmp *scheme_prune_jmpup(struct Scheme_Overflow_Jmp *jmp, void *stack_boundary);
+
 void scheme_jmpup_free(Scheme_Jumpup_Buf *);
 void *scheme_enlarge_runstack(long size, void *(*k)());
 int scheme_check_runstack(long size);

src/mzscheme/src/setjmpup.c

@@ -466,24 +466,26 @@ static void *align_var_stack(void **vs, void *s)
 }
 #define ALIGN_VAR_STACK(vs, s) s = align_var_stack(vs, s)
 
-static void *shift_var_stack(void *s)
+static void *shift_var_stack(void *s, long delta)
 {
 #ifdef STACK_GROWS_UP
   return s;
 #else
-  void **vs = (void **)s;
+  void **vs = (void **)(s + delta);
   long cnt;
   
   /* Set s past end of vs: */
   cnt = ((long *)vs)[1];
-  return (void *)(vs + cnt + 2);
+  return (void *)((void **)s + cnt + 2);
 #endif
 }
-#define PAST_VAR_STACK(s) s = shift_var_stack(s);
+#define PAST_VAR_STACK(s) s = shift_var_stack(s, 0);
+#define PAST_VAR_STACK_DELTA(s, d) s = shift_var_stack(s, d);
 END_XFORM_SKIP;
 #else
 # define ALIGN_VAR_STACK(vs, s) /* empty */
 # define PAST_VAR_STACK(s) /* empty */
+# define PAST_VAR_STACK_DELTA(s, d) /* empty */
 #endif
 
 int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base,
@@ -550,6 +552,62 @@ int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base,
   return local;
 }
 
+struct Scheme_Overflow_Jmp *scheme_prune_jmpup(struct Scheme_Overflow_Jmp *jmp, void *stack_boundary)
+{
+  void *cur_end;
+
+  PAST_VAR_STACK_DELTA(stack_boundary,  (void *)get_copy(jmp->cont.stack_copy) - (void *)jmp->cont.stack_from);
+
+#ifdef STACK_GROWS_UP
+  cur_end = (void *)jmp->cont.stack_from;
+#else
+  cur_end = (void *)((char *)jmp->cont.stack_from + jmp->cont.stack_size);
+#endif
+
+  if (stack_boundary != cur_end) {
+    long new_size, delta;
+    Scheme_Overflow_Jmp *naya;
+    void *copy, *base;
+
+# ifdef STACK_GROWS_UP
+    delta = (char *)stack_boundary - (char *)jmp->cont.stack_from;
+    new_size = jmp->cont.stack_size - delta;
+    base = (char *)stack_boundary;
+# else
+    delta = 0;
+    new_size = (long)stack_boundary - (long)jmp->cont.stack_from;
+    base = jmp->cont.stack_from;
+# endif
+
+    if ((new_size < 0) || (new_size > jmp->cont.stack_size))
+      scheme_signal_error("bad C-stack pruigin size: %ld vs. %ld", new_size, jmp->cont.stack_size);
+
+    naya = MALLOC_ONE_RT(Scheme_Overflow_Jmp);
+    memcpy(naya, jmp, sizeof(Scheme_Overflow_Jmp));
+    scheme_init_jmpup_buf(&naya->cont);
+    
+#ifndef MZ_PRECISE_GC
+    copy = make_stack_copy_rec(new_size);
+    naya->cont.stack_copy = copy;
+    set_copy(naya->cont.stack_copy, MALLOC_STACK(new_size));
+#else
+    copy = MALLOC_STACK(new_size);
+    set_copy(naya->cont.stack_copy, copy);
+#endif
+    
+    memcpy(get_copy(copy), 
+           get_copy(jmp->cont.stack_copy) XFORM_OK_PLUS delta,
+           new_size);
+
+    naya->cont.stack_size = naya->cont.stack_max_size = new_size;
+    naya->cont.stack_from = base;
+
+    return naya;
+  }
+
+  return NULL;
+}
+
 void scheme_longjmpup(Scheme_Jumpup_Buf *b)
 {
   long z;

src/mzscheme/src/thread.c

@@ -2790,7 +2790,7 @@ static void start_child(Scheme_Thread * volatile child,
         p->meta_continuation = mc->next;
         if (!oflow->eot) {
           p->stack_start = oflow->stack_start;
-          p->decompose = mc->cont;
+          p->decompose_mc = mc;
           scheme_longjmpup(&oflow->jmp->cont);
         }
       }