From 0a945cd5f73009385cc185956498bfef8a82b921 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 3 Feb 2021 07:02:39 -0700 Subject: [PATCH] fix `continuation-marks` on thread without prompt Closes #3675 --- pkgs/racket-test-core/tests/racket/contmark.rktl | 13 ++++++++++++- racket/src/bc/src/fun.c | 16 ++++++++++++++-- racket/src/bc/src/schpriv.h | 1 + racket/src/bc/src/thread.c | 2 +- racket/src/cs/rumble/control.ss | 4 ++++ racket/src/cs/schemified/thread.scm | 2 +- racket/src/thread/continuation-mark.rkt | 2 +- 7 files changed, 34 insertions(+), 6 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/contmark.rktl b/pkgs/racket-test-core/tests/racket/contmark.rktl index edac0e5d6b..7ea3541a87 100644 --- a/pkgs/racket-test-core/tests/racket/contmark.rktl +++ b/pkgs/racket-test-core/tests/racket/contmark.rktl @@ -610,7 +610,18 @@ (c 4 5)))) (test '(1 2 4 5) values l)) - +(err/rt-test (continuation-marks (current-thread) (make-continuation-prompt-tag))) +(let ([t (thread (lambda () (semaphore-wait (make-semaphore))))]) + (err/rt-test (continuation-marks t (make-continuation-prompt-tag))) + (sync (system-idle-evt)) + (err/rt-test (continuation-marks t (make-continuation-prompt-tag)))) + +(let ([t (thread void)]) + (sync (system-idle-evt)) + (define m (continuation-marks t (make-continuation-prompt-tag))) + (test #t continuation-mark-set? m) + (test null continuation-mark-set->list m 'anything)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Try to test internal caching strategies diff --git a/racket/src/bc/src/fun.c b/racket/src/bc/src/fun.c index 38b7061e5c..de4d903a37 100644 --- a/racket/src/bc/src/fun.c +++ b/racket/src/bc/src/fun.c @@ -8003,14 +8003,20 @@ static Scheme_Object *make_empty_marks() return (Scheme_Object *)set; } -Scheme_Object *scheme_current_continuation_marks(Scheme_Object *prompt_tag) +Scheme_Object *scheme_current_continuation_marks_as(const char *who, Scheme_Object *prompt_tag) +/* if who is NULL, the result can be NULL instead of a prompt-tag error */ { return continuation_marks(scheme_current_thread, NULL, NULL, NULL, prompt_tag ? prompt_tag : scheme_default_prompt_tag, - "continuation-marks", + who, 0, 1); } +Scheme_Object *scheme_current_continuation_marks(Scheme_Object *prompt_tag) +{ + return scheme_current_continuation_marks_as("continuation-marks", prompt_tag); +} + Scheme_Object *scheme_all_current_continuation_marks() { return continuation_marks(scheme_current_thread, NULL, NULL, NULL, @@ -8123,6 +8129,12 @@ cont_marks(int argc, Scheme_Object *argv[]) scheme_end_atomic_no_swap(); + if (!m) + scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, + "%s: no corresponding prompt in the continuation\n" + " tag: %V", + "continuation-marks", prompt_tag); + return m; } } else { diff --git a/racket/src/bc/src/schpriv.h b/racket/src/bc/src/schpriv.h index cf4f47f786..562731e5e8 100644 --- a/racket/src/bc/src/schpriv.h +++ b/racket/src/bc/src/schpriv.h @@ -2035,6 +2035,7 @@ int scheme_is_cm_deeper(struct Scheme_Meta_Continuation *m1, MZ_MARK_POS_TYPE p1 void scheme_recheck_prompt_and_barrier(struct Scheme_Cont *c); Scheme_Object *scheme_all_current_continuation_marks(void); +Scheme_Object *scheme_current_continuation_marks_as(const char *who, Scheme_Object *prompt_tag); void scheme_about_to_move_C_stack(void); diff --git a/racket/src/bc/src/thread.c b/racket/src/bc/src/thread.c index 9e7eb501ef..c74834bc35 100644 --- a/racket/src/bc/src/thread.c +++ b/racket/src/bc/src/thread.c @@ -2959,7 +2959,7 @@ int scheme_in_main_thread(void) static void stash_current_marks() { Scheme_Object *m; - m = scheme_current_continuation_marks(scheme_current_thread->returned_marks); + m = scheme_current_continuation_marks_as(NULL, scheme_current_thread->returned_marks); scheme_current_thread->returned_marks = m; swap_target = scheme_current_thread->return_marks_to; scheme_current_thread->return_marks_to = NULL; diff --git a/racket/src/cs/rumble/control.ss b/racket/src/cs/rumble/control.ss index ac2a4e6e7a..2fe83b286e 100644 --- a/racket/src/cs/rumble/control.ss +++ b/racket/src/cs/rumble/control.ss @@ -1540,6 +1540,10 @@ (prune-mark-chain-prefix (escape-continuation-tag k) (current-mark-chain))) null)] [else + ;; A `#f` is used to get the marks for a completed thread. + ;; It would make sense to raise an error for any prompt, + ;; since the continuaiton is empty, but `continuation-marks` + ;; is defined to return empty marks in this case. (make-continuation-mark-set null null)]))])) (define (get-metacontinuation-traces mc) diff --git a/racket/src/cs/schemified/thread.scm b/racket/src/cs/schemified/thread.scm index ffb382bb1e..d61dfd9e8d 100644 --- a/racket/src/cs/schemified/thread.scm +++ b/racket/src/cs/schemified/thread.scm @@ -12981,7 +12981,7 @@ (if (eq? e_0 'done) (|#%app| host:continuation-marks #f prompt-tag_0) (if (eq? e_0 'running) - (current-continuation-marks) + (current-continuation-marks prompt-tag_0) (|#%app| host:continuation-marks e_0 prompt-tag_0)))) (|#%app| host:continuation-marks k2_0 prompt-tag_0))))))))) (|#%name| diff --git a/racket/src/thread/continuation-mark.rkt b/racket/src/thread/continuation-mark.rkt index e277a8921a..508f9ed059 100644 --- a/racket/src/thread/continuation-mark.rkt +++ b/racket/src/thread/continuation-mark.rkt @@ -15,7 +15,7 @@ (define e (thread-engine k)) (cond [(eq? e 'done) (host:continuation-marks #f prompt-tag)] - [(eq? e 'running) (current-continuation-marks)] + [(eq? e 'running) (current-continuation-marks prompt-tag)] [else (host:continuation-marks e prompt-tag)])] [else (host:continuation-marks k prompt-tag)]))