From 0a179481a5312d7d9f31cd59febcdbec476a126a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 8 Nov 2010 17:44:10 -0700 Subject: [PATCH] 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 | 52 +++++++++++++++++++++++ src/racket/include/scheme.h | 1 + src/racket/src/eval.c | 1 + src/racket/src/fun.c | 55 ++++++++++++++++++++----- src/racket/src/mzmark.c | 2 + src/racket/src/mzmarksrc.c | 1 + 6 files changed, 102 insertions(+), 10 deletions(-) diff --git a/collects/tests/racket/prompt-tests.rktl b/collects/tests/racket/prompt-tests.rktl index 67bc988b32..3fea812086 100644 --- a/collects/tests/racket/prompt-tests.rktl +++ b/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)) + + + + + + + diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index 96b0fa63d0..45986e784f 100644 --- a/src/racket/include/scheme.h +++ b/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; diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index d03957a60a..0b01dae837 100644 --- a/src/racket/src/eval.c +++ b/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; diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 76105958e2..b812d5b540 100644 --- a/src/racket/src/fun.c +++ b/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, diff --git a/src/racket/src/mzmark.c b/src/racket/src/mzmark.c index 15b3802ed4..835c6d69f7 100644 --- a/src/racket/src/mzmark.c +++ b/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); diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index cfd9d10e45..561c9e2440 100644 --- a/src/racket/src/mzmarksrc.c +++ b/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);