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

cs: use call-in-continuation

Browse Source 
Using `call-in-continuation` to apply a thunk within a continuation
slightly simplifies and speeds up parts of the implementation of
delimited continuations.
This commit is contained in:
Matthew Flatt 2020-03-12 04:51:28 -06:00
parent 3ddc1ca367
commit f98d0a5cc1
4 changed files with 147 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "7.6.0.15") (define version "7.6.0.16")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

2
racket/src/cs/compile-file.ss
View File

@ -2,7 +2,7 @@
;; Check to make we're using a build of Chez Scheme ;; Check to make we're using a build of Chez Scheme
;; that has all the features we need. ;; that has all the features we need.
(define-values (need-maj need-min need-sub need-dev) (define-values (need-maj need-min need-sub need-dev)
(values 9 5 3 22)) (values 9 5 3 23))
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number)) (unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
(error 'compile-file (error 'compile-file

292
racket/src/cs/rumble/control.ss
View File

@ -47,14 +47,13 @@
;; continuation. See also `current-mark-splice` below. ;; continuation. See also `current-mark-splice` below.
;; A metacontinuation frame's `resume-k` is called when control ;; A metacontinuation frame's `resume-k` is called when control
;; returns or aborts to the frame: ;; returns or aborts to the frame. When aborting to a prompt tag,
;; ;; metacontinuation frames between the abort and prompt are removed
;; * When returning normally to a metacontinuation frame, the ;; one-by-one, running any winders in each frame. Finally, the
;; `resume-k` continuation receives a function for values returned ;; `resume-k` continuation of the target prompt's metacontinuation is
;; to the frame. ;; called; the `resume-k` is called using `call-in-continuation` to
;; ;; run a thunk in the restored continuation to apply the prompt's
;; * When aborting to a prompt tag, the `resume-k` continination ;; handler.
;; receives a special value that indicates an abort with arguments.
;; ;;
;; Calling a non-composable continuation is similar to aborting, ;; Calling a non-composable continuation is similar to aborting,
;; except that the target prompt's abort handler is not called. In ;; except that the target prompt's abort handler is not called. In
@ -102,7 +101,9 @@
(define-virtual-register current-metacontinuation '()) (define-virtual-register current-metacontinuation '())
(define-record metacontinuation-frame (tag ; continuation prompt tag or #f (define-record metacontinuation-frame (tag ; continuation prompt tag or #f
resume-k ; delivers values to the prompt, also keeps mark stack as attachments resume-k ; delivers values to the prompt
handler ; prompt handler
marks ; marks of `resume-k` plus immediate mark (if any)
winders ; `dynamic-wind` winders winders ; `dynamic-wind` winders
mark-splice ; extra part of mark stack to restore mark-splice ; extra part of mark stack to restore
mark-chain ; #f or a cached list of mark-chain-frame or elem+cache mark-chain ; #f or a cached list of mark-chain-frame or elem+cache
@ -110,9 +111,6 @@
cc-guard ; for impersonated tag, initially #f cc-guard ; for impersonated tag, initially #f
avail-cache)) ; cache for `continuation-prompt-available?` avail-cache)) ; cache for `continuation-prompt-available?`
;; Messages to `resume-k[/no-wind]`:
(define-record aborting (args))
(define-record-type (continuation-prompt-tag create-continuation-prompt-tag authentic-continuation-prompt-tag?) (define-record-type (continuation-prompt-tag create-continuation-prompt-tag authentic-continuation-prompt-tag?)
(fields (mutable name))) ; mutable => constructor generates fresh instances (fields (mutable name))) ; mutable => constructor generates fresh instances
@ -164,7 +162,7 @@
(or (and (not mc) (or (and (not mc)
(or (eq? tag the-default-continuation-prompt-tag) (or (eq? tag the-default-continuation-prompt-tag)
(eq? tag the-root-continuation-prompt-tag))) (eq? tag the-root-continuation-prompt-tag)))
;; Looks through metacontinuation cache, but cache a search result ;; Look through metacontinuation cache, but cache a search result
;; half-way up if the chain is deep enough ;; half-way up if the chain is deep enough
(let ([mc (or mc (current-metacontinuation))]) (let ([mc (or mc (current-metacontinuation))])
(let loop ([mc mc] [slow-mc mc] [slow-step? #f] [steps 0]) (let loop ([mc mc] [slow-mc mc] [slow-step? #f] [steps 0])
@ -256,84 +254,68 @@
"\n in: application of default prompt handler" "\n in: application of default prompt handler"
args)])) args)]))
(define (resume-metacontinuation results)
;; pop a metacontinuation frame
(cond
[(null? (current-metacontinuation)) (engine-return)]
[else
(start-uninterrupted 'resume-mc)
(let ([mf (car (current-metacontinuation))])
(pop-metacontinuation-frame)
;; resume
((metacontinuation-frame-resume-k mf) results))]))
(define (pop-metacontinuation-frame) (define (pop-metacontinuation-frame)
(let ([mf (car (current-metacontinuation))]) (let ([mf (car (current-metacontinuation))])
(current-metacontinuation (cdr (current-metacontinuation))) (current-metacontinuation (cdr (current-metacontinuation)))
(current-winders (metacontinuation-frame-winders mf)) (current-winders (metacontinuation-frame-winders mf))
(current-mark-splice (metacontinuation-frame-mark-splice mf)))) (current-mark-splice (metacontinuation-frame-mark-splice mf))
mf))
(define (call-in-empty-metacontinuation-frame tag handler new-splice proc) (define (call-in-empty-metacontinuation-frame tag handler new-splice proc)
;; Call `proc` in an empty metacontinuation frame, reifying the ;; Call `proc` in an empty metacontinuation frame, reifying the
;; current metacontinuation as needed (i.e., if non-empty) as a new ;; current metacontinuation as a new frame on `current-metacontinuation`
;; frame on `*metacontinuations*`; if the tag is #f and the
;; current metacontinuation frame is already empty, don't push more
(assert-in-uninterrupted) (assert-in-uninterrupted)
(assert-not-in-system-wind) (assert-not-in-system-wind)
(let ([r ; a list of results, or a non-list for special handling (call/cc
(call/cc (lambda (resume-k)
(lambda (resume-k) (let ([marks (current-mark-stack)]) ; grab marks before `call-in-continuation`
;; the `call/cc` to get `k` created a new stack (call-in-continuation
;; segment; by dropping the link from the current #%$null-continuation
;; segment to the return context referenced by `k`, '()
;; we actually delimit the current continuation: (lambda ()
(#%$current-stack-link #%$null-continuation) (let-values ([results
(current-mark-stack '()) ;; mark the "empty" continuation frame
(let-values ([results ;; that just continues the metacontinuation:
;; mark the "empty" continuation frame (call-setting-continuation-attachment
;; that just continues the metacontinuation: 'empty
(call-setting-continuation-attachment (lambda ()
'empty (let ([mf (make-metacontinuation-frame tag
(lambda () resume-k
(let ([mf (make-metacontinuation-frame tag handler
resume-k marks
(current-winders) (current-winders)
(current-mark-splice) (current-mark-splice)
#f #f
#f #f
#f #f
#f)]) #f)])
(current-winders '()) (current-winders '())
(current-mark-splice new-splice) (current-mark-splice new-splice)
;; push the metacontinuation: ;; push the metacontinuation:
(current-metacontinuation (cons mf (current-metacontinuation))) (current-metacontinuation (cons mf (current-metacontinuation)))
;; ready: ;; ready:
(proc))))]) (proc))))])
;; Prepare to use cc-guard, if one was enabled: ;; Continue normally; the metacontinuation could be different
(let ([cc-guard (metacontinuation-frame-cc-guard (car (current-metacontinuation)))]) ;; than when we captured this metafunction frame, though:
;; Continue normally; the metacontinuation could be different (cond
;; than when we captured this metafunction frame, though: [(null? (current-metacontinuation)) (engine-return)]
(resume-metacontinuation [else
;; Apply the cc-guard, if any, outside of the prompt: (start-uninterrupted 'resume-mc)
(if cc-guard (let ([mf (pop-metacontinuation-frame)])
(lambda () (apply cc-guard results)) (call-in-continuation
results))))))]) (metacontinuation-frame-resume-k mf)
(cond (metacontinuation-frame-marks mf)
[(aborting? r) (lambda ()
;; Remove the prompt as we call the handler: (end-uninterrupted 'resume)
(pop-metacontinuation-frame) (let ([cc-guard (metacontinuation-frame-cc-guard mf)])
(end-uninterrupted/call-hook 'handle) ;; Apply the cc-guard, if any, outside of the prompt:
(apply handler (cond
(aborting-args r))] [cc-guard
[else (apply cc-guard results)]
;; We're returning normally; the metacontinuation frame has [else
;; been popped already by `resume-metacontinuation` (if (and (pair? results) (null? (cdr results)))
(end-uninterrupted 'resume) (car results)
(if (#%procedure? r) (#%apply values results))])))))]))))))))
(r)
(if (and (pair? r) (null? (cdr r)))
(car r)
(#%apply values r)))])))
;; Simplified `call-in-empty-metacontinuation-frame` suitable for swapping engines: ;; Simplified `call-in-empty-metacontinuation-frame` suitable for swapping engines:
(define (call-with-empty-metacontinuation-frame-for-swap proc) (define (call-with-empty-metacontinuation-frame-for-swap proc)
@ -341,23 +323,30 @@
(assert-not-in-system-wind) (assert-not-in-system-wind)
(call/cc (call/cc
(lambda (resume-k) (lambda (resume-k)
(#%$current-stack-link #%$null-continuation) (let ([marks (current-mark-stack)])
(current-mark-stack '()) (call-in-continuation
(let ([mf (make-metacontinuation-frame #f #%$null-continuation
resume-k '()
(current-winders) (lambda ()
(current-mark-splice) (let ([mf (make-metacontinuation-frame #f
#f resume-k
#f void
#f marks
#f)]) (current-winders)
(current-winders '()) (current-mark-splice)
(current-mark-splice empty-mark-frame) #f
(current-metacontinuation (cons mf (current-metacontinuation))) #f
(let ([r (proc (current-metacontinuation))]) #f
(let ([mf (car (current-metacontinuation))]) #f)])
(pop-metacontinuation-frame) (current-winders '())
((metacontinuation-frame-resume-k mf) r))))))) (current-mark-splice empty-mark-frame)
(current-metacontinuation (cons mf (current-metacontinuation)))
(let ([r (proc (current-metacontinuation))])
(let ([mf (pop-metacontinuation-frame)])
(call-in-continuation
(metacontinuation-frame-resume-k mf)
(metacontinuation-frame-marks mf)
(lambda () r)))))))))))
(define (call-in-empty-metacontinuation-frame-for-compose proc) (define (call-in-empty-metacontinuation-frame-for-compose proc)
(call-getting-continuation-attachment (call-getting-continuation-attachment
@ -369,23 +358,22 @@
;; metacontinuation frame ;; metacontinuation frame
(proc)] (proc)]
[else [else
(call/cc ;; Consume attachment to move it (if there is one) to the new
(lambda (from-k) ;; metacontinuation frame's splice:
(let ([new-splice (keep-immediate-attachment (current-mark-stack) (call-consuming-continuation-attachment
(continuation-next-attachments from-k))]) empty-mark-frame
;; Prune splicing marks from `resume-k` by dropping the difference (lambda (new-splice)
;; between `from-k` and `resume-k`: (call-in-empty-metacontinuation-frame
(current-mark-stack (continuation-next-attachments from-k)) the-compose-prompt-tag
;; Call fail-abort-to-delimit-continuation
(call-in-empty-metacontinuation-frame new-splice
the-compose-prompt-tag proc)))]))))
fail-abort-to-delimit-continuation
new-splice
proc))))]))))
(define (metacontinuation-frame-update-mark-splice current-mf mark-splice) (define (metacontinuation-frame-update-mark-splice current-mf mark-splice)
(make-metacontinuation-frame (metacontinuation-frame-tag current-mf) (make-metacontinuation-frame (metacontinuation-frame-tag current-mf)
(metacontinuation-frame-resume-k current-mf) (metacontinuation-frame-resume-k current-mf)
(metacontinuation-frame-handler current-mf)
(metacontinuation-frame-marks current-mf)
(metacontinuation-frame-winders current-mf) (metacontinuation-frame-winders current-mf)
mark-splice mark-splice
#f #f
@ -397,6 +385,8 @@
;; Ok to keep caches, since the cc-guard doesn't affect them ;; Ok to keep caches, since the cc-guard doesn't affect them
(make-metacontinuation-frame (metacontinuation-frame-tag current-mf) (make-metacontinuation-frame (metacontinuation-frame-tag current-mf)
(metacontinuation-frame-resume-k current-mf) (metacontinuation-frame-resume-k current-mf)
(metacontinuation-frame-handler current-mf)
(metacontinuation-frame-marks current-mf)
(metacontinuation-frame-winders current-mf) (metacontinuation-frame-winders current-mf)
(metacontinuation-frame-mark-splice current-mf) (metacontinuation-frame-mark-splice current-mf)
(metacontinuation-frame-mark-chain current-mf) (metacontinuation-frame-mark-chain current-mf)
@ -432,8 +422,16 @@
(let ([mf (car (current-metacontinuation))]) (let ([mf (car (current-metacontinuation))])
(cond (cond
[(eq? tag (strip-impersonator (metacontinuation-frame-tag mf))) [(eq? tag (strip-impersonator (metacontinuation-frame-tag mf)))
((metacontinuation-frame-resume-k mf) ;; Remove the prompt and resume its continuation
(make-aborting args))] ;; as we call the handler:
(let ([mf (pop-metacontinuation-frame)])
(call-in-continuation
(metacontinuation-frame-resume-k mf)
(metacontinuation-frame-marks mf)
(lambda ()
(end-uninterrupted/call-hook 'handle)
(apply (metacontinuation-frame-handler mf)
args))))]
[else [else
;; Aborting to an enclosing prompt, so keep going: ;; Aborting to an enclosing prompt, so keep going:
(pop-metacontinuation-frame) (pop-metacontinuation-frame)
@ -853,8 +851,7 @@
(list mark-splice)) (list mark-splice))
r)))] r)))]
;; Get marks shallower than the splice ;; Get marks shallower than the splice
[marks (let ([marks (continuation-next-attachments [marks (let ([marks (metacontinuation-frame-marks mf)])
(metacontinuation-frame-resume-k mf))])
(if (and (pair? marks) (if (and (pair? marks)
(let ([mark (car marks)]) (let ([mark (car marks)])
(or (eq? mark 'empty) (or (eq? mark 'empty)
@ -1131,13 +1128,6 @@
(mark-frame-table (coerce-to-mark-frame mark-splice))) (mark-frame-table (coerce-to-mark-frame mark-splice)))
#f)])) #f)]))
(define (keep-immediate-attachment mark-stack next-mark-stack)
(cond
[(eq? mark-stack next-mark-stack)
empty-mark-frame]
[else
(car mark-stack)]))
;; ---------------------------------------- ;; ----------------------------------------
;; Continuation-mark caching ;; Continuation-mark caching
@ -1828,7 +1818,7 @@
(define-virtual-register current-winders '()) (define-virtual-register current-winders '())
(define-record winder (depth k pre post)) (define-record winder (depth k marks pre post))
;; Jobs for `dynamic-wind`: ;; Jobs for `dynamic-wind`:
@ -1847,29 +1837,33 @@
;; parameterizations. ;; parameterizations.
(define (dynamic-wind pre thunk post) (define (dynamic-wind pre thunk post)
((call/cc (call/cc
(lambda (k) (lambda (k) ; continuation to restore while running pre/post thunk to unwind/rewind
(let* ([winders (current-winders)] (let* ([winders (current-winders)]
[winder (make-winder (if (null? winders) [winder (make-winder (if (null? winders)
0 0
(fx+ 1 (winder-depth (car winders)))) (fx+ 1 (winder-depth (car winders))))
k k
pre (current-mark-stack)
post)]) pre
(start-uninterrupted 'dw) post)])
(begin (start-uninterrupted 'dw)
(call-winder-thunk 'dw-pre pre) (begin
(current-winders (cons winder winders)) (call-winder-thunk 'dw-pre pre)
(end-uninterrupted/call-hook 'dw-body) (current-winders (cons winder winders))
(call-with-values (if (#%procedure? thunk) (end-uninterrupted/call-hook 'dw-body)
thunk (call-with-values (if (#%procedure? thunk)
(lambda () (|#%app| thunk))) thunk
(lambda args (lambda () (|#%app| thunk)))
(start-uninterrupted 'dw-body) (lambda args
(current-winders winders) (start-uninterrupted 'dw-body)
(call-winder-thunk 'dw-post post) (current-winders winders)
(end-uninterrupted/call-hook 'dw) (call-winder-thunk 'dw-post post)
(lambda () (#%apply values args)))))))))) (end-uninterrupted/call-hook 'dw)
(if (and (pair? args)
(null? (cdr args)))
(car args)
(#%apply values args)))))))))
(define (call-winder-thunk who thunk) (define (call-winder-thunk who thunk)
(with-continuation-mark (with-continuation-mark
@ -1891,7 +1885,9 @@
[winders (cdr winders)]) [winders (cdr winders)])
(current-winders winders) (current-winders winders)
(let ([thunk (winder-thunk winder)]) (let ([thunk (winder-thunk winder)])
((winder-k winder) (call-in-continuation
(winder-k winder)
(winder-marks winder)
(lambda () (lambda ()
(call-winder-thunk who thunk) (call-winder-thunk who thunk)
(k)))))) (k))))))

2
racket/src/racket/src/schvers.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 6 #define MZSCHEME_VERSION_Y 6
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 15 #define MZSCHEME_VERSION_W 16
/* A level of indirection makes `#` work as needed: */ /* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x #define AS_a_STR_HELPER(x) #x