fix continuation capture in continuation transferred to a thread

where the prompt is the implicit one at the thread's creation
 Closes PR 11382

collects/tests/racket/prompt-tests.rktl

@@ -1965,3 +1965,55 @@
             (k (lambda () (abort-current-continuation
                            (default-continuation-prompt-tag)
                            (lambda () 45))))))))
+
+;; ----------------------------------------
+;; Check continuations captured in continuations applied in
+;;  a thread:
+
+(test (void)
+      'simple-thread-transfer
+      (let ([k (call-with-continuation-prompt
+                (lambda ()
+                  (call/cc values)))])
+        (sync (thread (lambda () (k 6))))
+        (void)))
+
+(test (void)
+      'capture-in-transferred-thread
+      (let ([k (call-with-continuation-prompt
+                (lambda ()
+                  (let/ec esc
+                    (call/cc esc)
+                    (call/cc values))))])
+        (sync (thread (lambda () (k 6))))
+        (void)))
+
+(let ()
+  (define sema (make-semaphore 1))
+  (define l null)
+  (define (push v) (semaphore-wait sema) (set! l (cons v l)) (semaphore-post sema))
+  (define (count n)
+    (let loop ([l l])
+      (cond
+       [(null? l) 0]
+       [(equal? (car l) n) (add1 (loop (cdr l)))]
+       [else (loop (cdr l))])))
+  (define (f)
+    (push 1)
+    (call/cc thread)
+    (push 2)
+    (call/cc thread)
+    (push 3))
+  
+  (call-with-continuation-prompt f)
+  (sync (system-idle-evt))
+  (test 1 count 1)
+  (test 2 count 2)
+  (test 4 count 3))
+
+
+
+      
+
+
+

src/racket/include/scheme.h

@@ -991,6 +991,7 @@ typedef struct Scheme_Thread {
   struct Scheme_Prompt *meta_prompt; /* a pseudo-prompt */
   
   struct Scheme_Meta_Continuation *meta_continuation;
+  struct Scheme_Prompt *acting_barrier_prompt;
 
   long engine_weight;
 

src/racket/src/eval.c

@@ -8882,6 +8882,7 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
          created with a new thread or a barrier prompt. */
       p->meta_continuation = NULL; /* since prompt wasn't in any meta-continuation */
       p->meta_prompt = NULL;
+      p->acting_barrier_prompt = NULL;
       if ((c->barrier_prompt == barrier_prompt) && barrier_prompt) {
         /* Barrier determines continuation end. */
         c->resume_to = NULL;

src/racket/src/fun.c

@@ -6276,23 +6276,25 @@ internal_call_cc (int argc, Scheme_Object *argv[])
          Must be inside overflow, or the ids wouldn't match. */
       stack_start = prompt->stack_boundary;
     } else {
-      Scheme_Prompt *meta_prompt;
+      Scheme_Prompt *meta_prompt, *stack_barrier_prompt;
 
-      if (!barrier_prompt->is_barrier)
-        barrier_prompt = NULL;
-      else if (barrier_prompt->boundary_overflow_id != overflow_id)
-        barrier_prompt = NULL;
+      stack_barrier_prompt = barrier_prompt;
+
+      if (!stack_barrier_prompt->is_barrier)
+        stack_barrier_prompt = NULL;
+      else if (stack_barrier_prompt->boundary_overflow_id != overflow_id)
+        stack_barrier_prompt = NULL;
       meta_prompt = p->meta_prompt;
       if (meta_prompt)
         if (meta_prompt->boundary_overflow_id != overflow_id)
           meta_prompt = NULL;
 
-      if (barrier_prompt && meta_prompt) {
-        barrier_prompt = NULL;
+      if (stack_barrier_prompt && meta_prompt) {
+        stack_barrier_prompt = NULL;
       }
 
-      if (barrier_prompt)
-        stack_start = barrier_prompt->stack_boundary;
+      if (stack_barrier_prompt)
+        stack_start = stack_barrier_prompt->stack_boundary;
       else if (meta_prompt)
         stack_start = meta_prompt->stack_boundary;
       else
@@ -6357,6 +6359,23 @@ internal_call_cc (int argc, Scheme_Object *argv[])
 
     /* We may have just re-activated breaking: */
     scheme_check_break_now();
+
+    if (!scheme_get_barrier_prompt(NULL, NULL)) {
+      /* The continuation was applied in a thread where the barrier prompt
+         was supposed to be the pseduo-prompt for a thread, but we've lost
+         that prompt. The barrier prompt from capturing the continuation
+         has the right info, but we need to claim that it's not a barrier
+         from the perspective of changing continuations. */
+      Scheme_Prompt *acting_barrier_prompt;
+      if (!barrier_prompt->is_barrier)
+        acting_barrier_prompt = barrier_prompt;
+      else {
+        acting_barrier_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
+        memcpy(acting_barrier_prompt, barrier_prompt, sizeof(Scheme_Prompt));
+        acting_barrier_prompt->is_barrier = 0;
+      }
+      p->acting_barrier_prompt = acting_barrier_prompt;
+    }
     
     return result;
   } else if (composable || cont->escape_cont) {
@@ -6437,7 +6456,23 @@ call_with_continuation_barrier (int argc, Scheme_Object *argv[])
 Scheme_Prompt *scheme_get_barrier_prompt(Scheme_Meta_Continuation **_meta_cont,
                                          MZ_MARK_POS_TYPE *_pos)
 {
-  return (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, barrier_prompt_key, NULL, _meta_cont, _pos);
+  Scheme_Prompt *p;
+  
+  p = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, barrier_prompt_key, NULL, _meta_cont, _pos);
+  if (!p) {
+    p = scheme_current_thread->acting_barrier_prompt;
+    if (_meta_cont) {
+      /* acting barrier prompt is deepest: */
+      Scheme_Meta_Continuation *mc = scheme_current_thread->meta_continuation;
+      while (mc && mc->next) {
+        mc = mc->next;
+      }
+      *_meta_cont = mc;
+      *_pos = -1;
+    }
+  }
+
+  return p;
 }
 
 Scheme_Prompt *scheme_get_prompt(Scheme_Object *prompt_tag,

src/racket/src/mzmark.c

@@ -1667,6 +1667,7 @@ static int thread_val_MARK(void *p, struct NewGC *gc) {
 
   gcMARK2(pr->meta_prompt, gc);
   gcMARK2(pr->meta_continuation, gc);
+  gcMARK2(pr->acting_barrier_prompt, gc);
   
   gcMARK2(pr->cont_mark_stack_segments, gc);
   gcMARK2(pr->cont_mark_stack_owner, gc);
@@ -1781,6 +1782,7 @@ static int thread_val_FIXUP(void *p, struct NewGC *gc) {
 
   gcFIXUP2(pr->meta_prompt, gc);
   gcFIXUP2(pr->meta_continuation, gc);
+  gcFIXUP2(pr->acting_barrier_prompt, gc);
   
   gcFIXUP2(pr->cont_mark_stack_segments, gc);
   gcFIXUP2(pr->cont_mark_stack_owner, gc);

src/racket/src/mzmarksrc.c

@@ -650,6 +650,7 @@ thread_val {
 
   gcMARK2(pr->meta_prompt, gc);
   gcMARK2(pr->meta_continuation, gc);
+  gcMARK2(pr->acting_barrier_prompt, gc);
   
   gcMARK2(pr->cont_mark_stack_segments, gc);
   gcMARK2(pr->cont_mark_stack_owner, gc);