diff --git a/racket/src/cs/demo/control.ss b/racket/src/cs/demo/control.ss index 69dc2e2653..bdf0c737c5 100644 --- a/racket/src/cs/demo/control.ss +++ b/racket/src/cs/demo/control.ss @@ -431,11 +431,13 @@ ;; ---------------------------------------- ;; Engines -(define e (make-engine (lambda () 'done) #f #f)) +(define engine-tag (default-continuation-prompt-tag)) + +(define e (make-engine (lambda () 'done) engine-tag #f #f)) (check (cdr (e 100 void list vector)) '(done)) -(define e-forever (make-engine (lambda () (let loop () (loop))) #f #f)) +(define e-forever (make-engine (lambda () (let loop () (loop))) engine-tag #f #f)) (check (vector? (e-forever 10 void list vector)) #t) @@ -448,6 +450,7 @@ [else (engine-block) (loop (sub1 n))]))) + engine-tag #f #f)) (check (let ([started 0]) (let loop ([e e-10] [n 0]) @@ -472,6 +475,7 @@ (lambda () (set! pre (add1 pre))) (lambda () (loop (sub1 n))) (lambda () (set! post (add1 post))))]))) + engine-tag #f #f)]) (check (let loop ([e e-10/dw] [n 0]) (e 200 @@ -493,10 +497,10 @@ (thread-cell-set! pt (add1 p-old)) (list u-old p-old - (make-engine gen #f #f) + (make-engine gen engine-tag #f #f) (thread-cell-ref ut) (thread-cell-ref pt))) - (define l1 ((make-engine gen #f #f) + (define l1 ((make-engine gen engine-tag #f #f) 100 void (lambda (remain l) l) @@ -522,7 +526,7 @@ (check (procedure? my-param) #t) (let ([e (with-continuation-mark parameterization-key (extend-parameterization (continuation-mark-set-first #f parameterization-key) my-param 'set) - (make-engine (lambda () (|#%app| my-param)) #f #f))]) + (make-engine (lambda () (|#%app| my-param)) engine-tag #f #f))]) (check (|#%app| my-param) 'init) (check (e 1000 void (lambda (remain v) v) (lambda (e) (error 'engine "oops"))) 'set)) @@ -618,6 +622,7 @@ (loop (sub1 n))))) (lambda () (set! post (add1 post)))))))) + engine-tag #f #f)) (check (let ([prefixes 0]) diff --git a/racket/src/cs/rumble/engine.ss b/racket/src/cs/rumble/engine.ss index a57eb8b59b..905f5e7142 100644 --- a/racket/src/cs/rumble/engine.ss +++ b/racket/src/cs/rumble/engine.ss @@ -24,17 +24,20 @@ (define (set-engine-exit-handler! proc) (set! engine-exit proc)) -(define (make-engine thunk init-break-enabled-cell empty-config?) +(define (make-engine thunk prompt-tag init-break-enabled-cell empty-config?) (let ([paramz (if empty-config? empty-parameterization (current-parameterization))]) (create-engine empty-metacontinuation (lambda (prefix) - (with-continuation-mark - parameterization-key paramz - (begin - (prefix) - (call-with-values (lambda () (|#%app| thunk)) engine-return)))) + (call-with-continuation-prompt + (lambda () + (with-continuation-mark + parameterization-key paramz + (begin + (prefix) + (call-with-values (lambda () (|#%app| thunk)) engine-return)))) + prompt-tag)) (if empty-config? (make-empty-thread-cell-values) (new-engine-thread-cell-values)) diff --git a/racket/src/thread/future.rkt b/racket/src/thread/future.rkt index 2e9c807972..ab24f1210d 100644 --- a/racket/src/thread/future.rkt +++ b/racket/src/thread/future.rkt @@ -90,14 +90,11 @@ (define (thunk-wrapper f thunk) (lambda () - (call-with-continuation-prompt - (lambda () - (let ([result (thunk)]) - (with-lock ((future*-lock f) (current-future)) - (set-future*-result! f result) - (set-future*-done?! f #t) - (future:condition-broadcast (future*-cond f))))) - (future*-prompt f)))) + (let ([result (thunk)]) + (with-lock ((future*-lock f) (current-future)) + (set-future*-result! f result) + (set-future*-done?! f #t) + (future:condition-broadcast (future*-cond f)))))) (define/who (future thunk) (check who (procedure-arity-includes/c 0) thunk) @@ -106,7 +103,7 @@ (would-be-future thunk)] [else (let ([f (create-future #f)]) - (set-future*-engine! f (make-engine (thunk-wrapper f thunk) #f #t)) + (set-future*-engine! f (make-engine (thunk-wrapper f thunk) (future*-prompt f) #f #t)) (schedule-future f) f)])) diff --git a/racket/src/thread/thread.rkt b/racket/src/thread/thread.rkt index 325085a73e..8a5a91dcc4 100644 --- a/racket/src/thread/thread.rkt +++ b/racket/src/thread/thread.rkt @@ -150,8 +150,8 @@ (define p (if (or at-root? initial?) root-thread-group (current-thread-group))) - (define e (make-engine (lambda () - (call-with-continuation-prompt proc)) + (define e (make-engine proc + (default-continuation-prompt-tag) (if (or initial? at-root?) break-enabled-default-cell (current-break-enabled-cell))