fix break checking on continuation applciation

Racket did not check for a break when escaping from a break-disabled
context to a break-enabled context. RacketCS didn't check in other
cases, either. Fix those various cases.
This commit is contained in:
Matthew Flatt 2018-08-18 17:04:51 -06:00
parent 40b5fffb80
commit 27693843ea
5 changed files with 55 additions and 10 deletions

View File

@ -1236,6 +1236,7 @@
should-done-break?) should-done-break?)
;; print the state for this test: ;; print the state for this test:
(test #t list? (list 'go (test #t list? (list 'go
mk-t* break-off?
pre-thunk act-thunk post-thunk pre-thunk act-thunk post-thunk
pre-semaphore-wait act-semaphore-wait post-semaphore-wait pre-semaphore-wait act-semaphore-wait post-semaphore-wait
try-pre-break try-pre-break
@ -1354,8 +1355,8 @@
no-capture no-capture no-capture no-capture no-capture no-capture
args))))]) args))))])
(list plain-mk-t (list plain-mk-t
(mk-capturing 'pre) (procedure-rename (mk-capturing 'pre) 'pre-capturing)
(mk-capturing 'act)))))) (procedure-rename (mk-capturing 'act) 'act-capturing))))))
;; ---------------------------------------- ;; ----------------------------------------
;; Check wrap-evt result superceded by internally ;; Check wrap-evt result superceded by internally

View File

@ -197,6 +197,49 @@
(err/rt-test (break-thread (current-thread) 'hang-up) exn:break:hang-up?) (err/rt-test (break-thread (current-thread) 'hang-up) exn:break:hang-up?)
(err/rt-test (break-thread (current-thread) 'terminate) exn:break:terminate?) (err/rt-test (break-thread (current-thread) 'terminate) exn:break:terminate?)
(let ([bad? #f])
(define t
(thread
(lambda ()
(let/ec k
(parameterize-break #f
(break-thread (current-thread))
(k #f)))
(set! bad? #t))))
(sync t)
(test #f 'escape bad?))
(let ([bad? #f])
(define t
(thread
(lambda ()
(let/cc k
(parameterize-break #f
(break-thread (current-thread))
(k #f)))
(set! bad? #t))))
(sync t)
(test #f 'escape/cc bad?))
(let ([bad? #f])
(define t
(thread
(lambda ()
(define jump-k #f)
(parameterize-break #f
((let/cc k
(set! jump-k k)
void)
#f))
(let/cc k
(parameterize-break #f
(break-thread (current-thread))
(jump-k k)))
(set! bad? #t))))
(sync t)
(test #f 'jump-in bad?))
(let ([ex? #f] (let ([ex? #f]
[s (make-semaphore)]) [s (make-semaphore)])
(define (go) (define (go)

View File

@ -286,7 +286,7 @@
[(aborting? r) [(aborting? r)
;; Remove the prompt as we call the handler: ;; Remove the prompt as we call the handler:
(pop-metacontinuation-frame) (pop-metacontinuation-frame)
(end-uninterrupted 'handle) (end-uninterrupted/call-hook 'handle)
(apply handler (apply handler
(aborting-args r))] (aborting-args r))]
[else [else
@ -888,11 +888,7 @@
;; Called on the arguments to return to a continuation ;; Called on the arguments to return to a continuation
;; captured by `call/cc/end-uninterrupted`: ;; captured by `call/cc/end-uninterrupted`:
(define (end-uninterrupted-with-values args) (define (end-uninterrupted-with-values args)
;; Arguably, we should use `end-uninterrupted/hook` here to check (end-uninterrupted/call-hook 'cc)
;; for breaks, in case a jump enabled breaks and one is pending.
;; The traditional Racket implementation doesn't include that
;; check, and the check imposes a costs, so we leave it out for now.
(end-uninterrupted 'cc)
(apply values args)) (apply values args))
(define (current-mark-chain) (define (current-mark-chain)

View File

@ -4276,6 +4276,7 @@ do_call_ec (int argc, Scheme_Object *argv[], Scheme_Object *_for_cc)
reset_cjs(&p2->cjs); reset_cjs(&p2->cjs);
scheme_restore_env_stack_w_thread(cont->envss, p2); scheme_restore_env_stack_w_thread(cont->envss, p2);
p2->suspend_break = 0; p2->suspend_break = 0;
scheme_check_break_now();
if (n != 1) if (n != 1)
v = scheme_values(n, (Scheme_Object **)v); v = scheme_values(n, (Scheme_Object **)v);
} else { } else {

View File

@ -725,7 +725,11 @@
;; `check-for-break` should be called. ;; `check-for-break` should be called.
(define (check-for-break) (define (check-for-break)
(define t (current-thread)) (define t (current-thread))
(when t ; allow `check-for-break` before threads are running (when (and
;; allow `check-for-break` before threads are running:
t
;; quick pre-test before going atomic:
(thread-pending-break t))
((atomically ((atomically
(cond (cond
[(and (thread-pending-break t) [(and (thread-pending-break t)