suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix continuation-barrier checking

Browse Source 
Continuation-barrier checking was sometimes too strict,
disallowing jumps out past a barrier (as opposed to
into a barrier) that should be allowed.
This commit is contained in:
Matthew Flatt 2017-12-12 08:52:26 -07:00
parent fc77c91102
commit 544b7a3d53
2 changed files with 72 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
pkgs/racket-test-core/tests/racket/prompt-tests.rktl
View File

@ -1475,10 +1475,12 @@
[exit-k #f]) [exit-k #f])
(let ([go (let ([go
(lambda (launch) (lambda (launch)
(let ([k (let/cc esc (let ([k (call-with-continuation-barrier
(call-with-continuation-prompt (lambda ()
(lambda () (let/cc esc
(dynamic-wind (call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (void)) (lambda () (void))
(lambda () (lambda ()
(with-handlers ([void (lambda (exn) (with-handlers ([void (lambda (exn)
@ -1491,13 +1493,11 @@
(lambda () 10)) (lambda () 10))
p1)) p1))
(set! output (cons 'post output))))) (set! output (cons 'post output)))))
p1))]) p1))))])
(call-with-continuation-barrier (call-with-continuation-prompt
(lambda () (lambda ()
(call-with-continuation-prompt (exit-k (lambda () 'hi)))
(lambda () p1)))])
(exit-k (lambda () 'hi)))
p1)))))])
(err/rt-test (err/rt-test
(go (lambda (esc) (esc 'middle))) (go (lambda (esc) (esc 'middle)))
exn:fail:contract:continuation?) exn:fail:contract:continuation?)
@ -1513,48 +1513,53 @@
exn:fail:contract:continuation?)) exn:fail:contract:continuation?))
(test '(post post post post) values output))) (test '(post post post post) values output)))
;; Similar, but more checking of dropped d-ws: ;; Similar, but not a barrier error, because the jump
;; just escapes past a barrier instead of jumping into
;; one
(let ([p1 (make-continuation-prompt-tag 'p1)] (let ([p1 (make-continuation-prompt-tag 'p1)]
[output null] [output null]
[exit-k #f] [exit-k #f]
[done? #f]) [count 3])
;; Capture a continuation w.r.t. the default prompt tag: (let ([go
(call/cc (lambda (launch)
(lambda (esc) (let ([k (let/cc esc
(dynamic-wind (call-with-continuation-prompt
(lambda () (void)) (lambda ()
(lambda () (dynamic-wind
;; Set a prompt for tag p1: (lambda () (void))
(call-with-continuation-prompt (lambda ()
(lambda () (with-handlers ([void (lambda (exn)
(dynamic-wind (test #f "should not be used!" #t))])
(lambda () (void)) (launch esc)))
;; inside d-w, jump out: (lambda ()
(lambda () (esc 'done)) ((call/cc
(lambda () (lambda (k)
;; As we jump out, capture a continuation (set! exit-k k)
;; w.r.t. p1: (lambda () 10))
((call/cc p1))
(lambda (k) (set! output (cons 'post output)))))
(set! exit-k k) p1))])
(lambda () 10)) (cond
p1)) [(zero? count) 'three]
(set! output (cons 'inner output))))) [else
p1)) (set! count (sub1 count))
(lambda () (call-with-continuation-barrier
;; This post thunk is not in the (lambda ()
;; delimited continuation captured (call-with-continuation-prompt
;; via tag p1: (lambda ()
(set! output (cons 'outer output)))))) (exit-k (lambda () 'hi)))
(unless done? p1)))])))])
(set! done? #t) (test 'three go (lambda (esc) (esc 'middle)))
;; Now invoke the delimited continuation, which must (test '(post post post post) values output)
;; somehow continue the jump to `esc': (let ([meta (call-with-continuation-prompt
(call-with-continuation-prompt (lambda ()
(lambda () ((call-with-composable-continuation
(exit-k (lambda () 10))) (lambda (k) (lambda () k))))))])
p1)) (test 'three
(test '(inner outer inner) values output)) go (lambda (esc)
(meta
(lambda () (esc 'ok))))))
(test '(post post post post post) values output)))
;; Again, more checking of output ;; Again, more checking of output
(let ([p1 (make-continuation-prompt-tag 'p1)] (let ([p1 (make-continuation-prompt-tag 'p1)]
@ -2014,14 +2019,24 @@
(k (lambda () 17))) (k (lambda () 17)))
(test #t procedure? once-k) (test #t procedure? once-k)
(test k values 17) (test k values 17)
(err/rt-test (call-with-continuation-barrier (err/rt-test (call-with-continuation-prompt
(lambda () (lambda ()
(once-k 18))) (call-with-continuation-barrier
exn:fail:contract:continuation?)) (lambda ()
(once-k 18)))))
(lambda (x)
(and (exn:fail:contract? x)
(not (exn:fail:contract:continuation? x))))))
(printf "Trying long chain under barrier...\n")
(let ([k (call-with-continuation-barrier
(lambda ()
(long-loop (lambda ()
((let/cc k (lambda () k)))))))])
(err/rt-test (k 18) exn:fail:contract:continuation?))
(printf "Trying long chain again...\n") (printf "Trying long chain again...\n")
(let ([k (call-with-continuation-prompt (let ([k (call-with-continuation-prompt
(lambda () (lambda ()
(long-loop (lambda () (long-loop (lambda ()
((call-with-composable-continuation ((call-with-composable-continuation
(lambda (k) (lambda (k)
(lambda () k))))))))]) (lambda () k))))))))])

6
racket/src/racket/src/eval.c
View File

@ -1544,7 +1544,7 @@ static Scheme_Prompt *check_barrier(Scheme_Prompt *prompt,
Scheme_Meta_Continuation *prompt_cont, MZ_MARK_POS_TYPE prompt_pos, Scheme_Meta_Continuation *prompt_cont, MZ_MARK_POS_TYPE prompt_pos,
Scheme_Cont *c) Scheme_Cont *c)
/* A continuation barrier is analogous to a dynamic-wind. A jump is /* A continuation barrier is analogous to a dynamic-wind. A jump is
allowed if no dynamic-wind-like barriers would be executed for allowed if no dynamic-wind-like pre-thunks would be executed for
the jump. */ the jump. */
{ {
Scheme_Prompt *barrier_prompt, *b1, *b2; Scheme_Prompt *barrier_prompt, *b1, *b2;
@ -1566,8 +1566,8 @@ static Scheme_Prompt *check_barrier(Scheme_Prompt *prompt,
if (!b2->is_barrier) if (!b2->is_barrier)
b2 = NULL; b2 = NULL;
} }
if (b1 != b2) { if (b2 && (b1 != b2)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"continuation application: attempt to cross a continuation barrier"); "continuation application: attempt to cross a continuation barrier");
} }