fix potential GC problem with continuation copies

Merge to 5.3

src/racket/src/eval.c

@@ -427,7 +427,7 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void))
                  && SCHEME_CONTP(p->cjs.jumping_to_continuation)) {
         Scheme_Cont *c = (Scheme_Cont *)p->cjs.jumping_to_continuation;
         p->cjs.jumping_to_continuation = NULL;
-        scheme_longjmpup(&c->buf);
+        scheme_longjmpup(&c->buf_ptr->buf);
       } else {
         /* Continue normal escape: */
         scheme_longjmp(scheme_error_buf, 1);
@@ -1512,7 +1512,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
     /* This continuation is the same as another, except
        that its mark stack is different. The different part
        of the mark stack won't be visible, so we use the other. */
-    c = c->buf.cont;
+    c = c->buf_ptr->buf.cont;
   }
 
   if (c->composable) {
@@ -1588,7 +1588,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
         c->resume_to = thread_end_oflow;
         p->stack_start = c->prompt_stack_start;
       }
-      scheme_longjmpup(&c->buf);
+      scheme_longjmpup(&c->buf_ptr->buf);
     } else if (prompt->id
                && (prompt->id == c->prompt_id)
                && !prompt_mc) {
@@ -1599,7 +1599,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
       if ((!prompt->boundary_overflow_id && !p->overflow)
           || (prompt->boundary_overflow_id
               && (prompt->boundary_overflow_id == p->overflow->id))) {
-        scheme_longjmpup(&c->buf);
+        scheme_longjmpup(&c->buf_ptr->buf);
       } else {
         /* Need to unwind overflows... */
         Scheme_Overflow *overflow;

src/racket/src/fun.c

@@ -4634,6 +4634,7 @@ static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int comp
                                       )
 {
   Scheme_Cont *cont;
+  Scheme_Cont_Jmp *buf_ptr;
   
   cont = MALLOC_ONE_TAGGED(Scheme_Cont);
   cont->so.type = scheme_cont_type;
@@ -4645,8 +4646,12 @@ static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int comp
 
   if (composable)
     cont->composable = 1;
+  
+  buf_ptr = MALLOC_ONE_RT(Scheme_Cont_Jmp);
+  SET_REQUIRED_TAG(buf_ptr->type = scheme_rt_cont_jmp);
+  cont->buf_ptr = buf_ptr;
 
-  scheme_init_jmpup_buf(&cont->buf);
+  scheme_init_jmpup_buf(&cont->buf_ptr->buf);
   cont->prompt_tag = prompt_tag;
   if (for_prompt)
     cont->dw = NULL;
@@ -4953,10 +4958,10 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
     intptr_t done = cont->runstack_copied->runstack_size, size;
     sub_cont = cont;
     while (sub_cont) {
-      if (sub_cont->buf.cont
+      if (sub_cont->buf_ptr->buf.cont
-          && (sub_cont->runstack_start == sub_cont->buf.cont->runstack_start)) {
+          && (sub_cont->runstack_start == sub_cont->buf_ptr->buf.cont->runstack_start)) {
         /* Copy shared part in: */
-        sub_cont = sub_cont->buf.cont;
+        sub_cont = sub_cont->buf_ptr->buf.cont;
         size = sub_cont->runstack_copied->runstack_size;
         if (size) {
           /* Skip the first item, since that's the call/cc argument,
@@ -5003,7 +5008,7 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
     meta_prompt->boundary_overflow_id = NULL;
     {
       Scheme_Cont *tc;
-      for (tc = cont; tc->buf.cont; tc = tc->buf.cont) {
+      for (tc = cont; tc->buf_ptr->buf.cont; tc = tc->buf_ptr->buf.cont) {
       }
       meta_prompt->mark_boundary = tc->cont_mark_offset;
     }
@@ -5013,9 +5018,9 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
       Scheme_Cont *rs_cont = cont;
       Scheme_Saved_Stack *saved, *actual;
       int delta = 0;
-      while (rs_cont->buf.cont) {
+      while (rs_cont->buf_ptr->buf.cont) {
         delta += rs_cont->runstack_copied->runstack_size;
-        rs_cont = rs_cont->buf.cont;
+        rs_cont = rs_cont->buf_ptr->buf.cont;
         if (rs_cont->runstack_copied->runstack_size) {
           delta -= 1; /* overlap for not-saved call/cc argument */
         }
@@ -5042,14 +5047,14 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr
   /* For copying cont marks back in, we need a list of sub_conts,
      deepest to shallowest: */
   copied_cms = cont->cont_mark_offset;
-  for (sub_cont = cont->buf.cont; sub_cont; sub_cont = sub_cont->buf.cont) {
+  for (sub_cont = cont->buf_ptr->buf.cont; sub_cont; sub_cont = sub_cont->buf_ptr->buf.cont) {
     copied_cms = sub_cont->cont_mark_offset;
     sub_conts = scheme_make_raw_pair((Scheme_Object *)sub_cont, sub_conts);
   }
 
   if (!shortcut_prompt) {    
     Scheme_Cont *tc;
-    for (tc = cont; tc->buf.cont; tc = tc->buf.cont) {
+    for (tc = cont; tc->buf_ptr->buf.cont; tc = tc->buf_ptr->buf.cont) {
     }
     p->cont_mark_stack_bottom = tc->cont_mark_offset;
     p->cont_mark_pos_bottom = tc->cont_mark_pos_bottom;
@@ -5262,10 +5267,10 @@ internal_call_cc (int argc, Scheme_Object *argv[])
 
       cont = MALLOC_ONE_TAGGED(Scheme_Cont);
       cont->so.type = scheme_cont_type;
-      cont->buf.cont = sub_cont;
+      cont->buf_ptr->buf.cont = sub_cont;
       cont->escape_cont = sub_cont->escape_cont;
 
-      sub_cont = sub_cont->buf.cont;
+      sub_cont = sub_cont->buf_ptr->buf.cont;
 
       /* This mark stack won't be restored, but it may be
 	 used by `continuation-marks'. */
@@ -5349,7 +5354,7 @@ internal_call_cc (int argc, Scheme_Object *argv[])
   prompt_cont = NULL;
   barrier_cont = NULL;
 
-  if (scheme_setjmpup_relative(&cont->buf, cont, stack_start, sub_cont)) {
+  if (scheme_setjmpup_relative(&cont->buf_ptr->buf, cont->buf_ptr, stack_start, sub_cont)) {
     /* We arrive here when the continuation is applied */
     Scheme_Object *result, *extra_marks;
     Scheme_Overflow *resume;
@@ -5876,7 +5881,7 @@ static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain,
   cont->resume_to = overflow;
   cont->empty_to_next_mc = (char)empty_to_next_mc;
   scheme_current_thread->stack_start = cont->prompt_stack_start;
-  scheme_longjmpup(&cont->buf);
+  scheme_longjmpup(&cont->buf_ptr->buf);
 
   ESCAPED_BEFORE_HERE;
 }
@@ -6537,9 +6542,9 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p,
           if (!cont->runstack_copied) {
             /* Current cont was just a mark-stack variation of
                next cont, so skip the next cont. */
-            cont = cont->buf.cont;
+            cont = cont->buf_ptr->buf.cont;
           }
-          cont = cont->buf.cont;
+          cont = cont->buf_ptr->buf.cont;
           if (cont)
             cdelta = cont->cont_mark_offset;
           else

src/racket/src/mzmark_type.inc

@@ -927,7 +927,7 @@ static int cont_proc_MARK(void *p, struct NewGC *gc) {
   gcMARK2(c->native_trace, gc);
 #endif
 
-  MARK_jmpup(&c->buf, gc);
+  gcMARK2(c->buf_ptr, gc);
   MARK_cjs(&c->cjs, gc);
   MARK_stack_state(&c->ss, gc);
   gcMARK2(c->barrier_prompt, gc);
@@ -969,7 +969,7 @@ static int cont_proc_FIXUP(void *p, struct NewGC *gc) {
   gcFIXUP2(c->native_trace, gc);
 #endif
 
-  FIXUP_jmpup(&c->buf, gc);
+  gcFIXUP2(c->buf_ptr, gc);
   FIXUP_cjs(&c->cjs, gc);
   FIXUP_stack_state(&c->ss, gc);
   gcFIXUP2(c->barrier_prompt, gc);
@@ -997,6 +997,33 @@ static int cont_proc_FIXUP(void *p, struct NewGC *gc) {
 #define cont_proc_IS_CONST_SIZE 1
 
 
+static int cont_jmp_proc_SIZE(void *p, struct NewGC *gc) {
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Cont_Jmp));
+}
+
+static int cont_jmp_proc_MARK(void *p, struct NewGC *gc) {
+  Scheme_Cont_Jmp *c = (Scheme_Cont_Jmp *)p;
+
+  MARK_jmpup(&c->buf, gc);
+  
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Cont_Jmp));
+}
+
+static int cont_jmp_proc_FIXUP(void *p, struct NewGC *gc) {
+  Scheme_Cont_Jmp *c = (Scheme_Cont_Jmp *)p;
+
+  FIXUP_jmpup(&c->buf, gc);
+  
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Cont_Jmp));
+}
+
+#define cont_jmp_proc_IS_ATOMIC 0
+#define cont_jmp_proc_IS_CONST_SIZE 1
+
+
 static int meta_cont_proc_SIZE(void *p, struct NewGC *gc) {
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Meta_Continuation));

src/racket/src/mzmarksrc.c

@@ -367,7 +367,7 @@ cont_proc {
   gcMARK2(c->native_trace, gc);
 #endif
 
-  MARK_jmpup(&c->buf, gc);
+  gcMARK2(c->buf_ptr, gc);
   MARK_cjs(&c->cjs, gc);
   MARK_stack_state(&c->ss, gc);
   gcMARK2(c->barrier_prompt, gc);
@@ -391,6 +391,16 @@ cont_proc {
   gcBYTES_TO_WORDS(sizeof(Scheme_Cont));
 }
 
+cont_jmp_proc {
+ mark:
+  Scheme_Cont_Jmp *c = (Scheme_Cont_Jmp *)p;
+
+  MARK_jmpup(&c->buf, gc);
+  
+ size:
+  gcBYTES_TO_WORDS(sizeof(Scheme_Cont_Jmp));
+}
+
 meta_cont_proc {
  mark:
   Scheme_Meta_Continuation *c = (Scheme_Meta_Continuation *)p;

src/racket/src/schpriv.h

@@ -1493,11 +1493,16 @@ typedef struct Scheme_Dynamic_Wind {
   struct Scheme_Dynamic_Wind *prev;
 } Scheme_Dynamic_Wind;
 
+typedef struct Scheme_Cont_Jmp {
+  MZTAG_IF_REQUIRED
+  Scheme_Jumpup_Buf buf;
+} Scheme_Cont_Jmp;
+
 typedef struct Scheme_Cont {
   Scheme_Object so;
   char composable, has_prompt_dw, need_meta_prompt, skip_dws;
   struct Scheme_Meta_Continuation *meta_continuation;
-  Scheme_Jumpup_Buf buf;
+  Scheme_Cont_Jmp *buf_ptr; /* indirection allows sharing */
   Scheme_Dynamic_Wind *dw;
   int next_meta;
   Scheme_Continuation_Jump_State cjs;

src/racket/src/setjmpup.c

@@ -354,16 +354,16 @@ void scheme_uncopy_stack(int ok, Scheme_Jumpup_Buf *b, intptr_t *prev)
 
     if (c->cont) {
 #ifdef STACK_GROWS_UP
-      top_delta = (((uintptr_t)c->cont->buf.stack_from
+      top_delta = (((uintptr_t)c->cont->buf_ptr->buf.stack_from
 		    + c->cont->buf.stack_size)
 		   - (uintptr_t)c->stack_from);
 #else
       bottom_delta = ((uintptr_t)c->stack_from 
 		      + c->stack_size
-		      - (uintptr_t)c->cont->buf.stack_from);
+		      - (uintptr_t)c->cont->buf_ptr->buf.stack_from);
       top_delta = bottom_delta;
 #endif
-      c = &c->cont->buf;
+      c = &c->cont->buf_ptr->buf;
     } else
       c = NULL;
   }
@@ -518,12 +518,15 @@ int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base,
          but watch out. */
       intptr_t same_size;
       START_XFORM_SKIP;
-      same_size = find_same(get_copy(c->buf.stack_copy), c->buf.stack_from, c->buf.stack_size);
+      same_size = find_same(get_copy(c->buf_ptr->buf.stack_copy), 
+                            c->buf_ptr->buf.stack_from, 
+                            c->buf_ptr->buf.stack_size);
       b->cont = c;
 #ifdef STACK_GROWS_UP
-      start = (void *)((char *)c->buf.stack_from + same_size);
+      start = (void *)((char *)c->buf_ptr->buf.stack_from + same_size);
 #else
-      start = (void *)((char *)c->buf.stack_from + (c->buf.stack_size - same_size));
+      start = (void *)((char *)c->buf_ptr->buf.stack_from 
+                       + (c->buf_ptr->buf.stack_size - same_size));
 #endif
       /* In 3m-mode, we need `start' on a var-stack boundary: */
       ALIGN_VAR_STACK(__gc_var_stack__, start);

src/racket/src/stypes.h

@@ -274,6 +274,7 @@ enum {
   scheme_rt_rb_node,                    /* 250 */
   scheme_rt_lightweight_cont,           /* 251 */
   scheme_rt_export_info,                /* 252 */
+  scheme_rt_cont_jmp,                   /* 253 */
 #endif
 
   _scheme_last_type_

src/racket/src/type.c

@@ -590,6 +590,7 @@ void scheme_register_traversers(void)
   GC_REG_TRAV(scheme_rt_overflow_jmp, mark_overflow_jmp);
   GC_REG_TRAV(scheme_rt_meta_cont, meta_cont_proc);
   GC_REG_TRAV(scheme_escaping_cont_type, escaping_cont_proc);
+  GC_REG_TRAV(scheme_rt_cont_jmp, cont_jmp_proc);
 
   GC_REG_TRAV(scheme_char_type, char_obj);
   GC_REG_TRAV(scheme_integer_type, bad_trav);