cs: use call-in-continuation
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
parent
3ddc1ca367
commit
f98d0a5cc1
|
|
@ -12,7 +12,7 @@
|
|||
|
||||
(define collection 'multi)
|
||||
|
||||
(define version "7.6.0.15")
|
||||
(define version "7.6.0.16")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
;; Check to make we're using a build of Chez Scheme
|
||||
;; that has all the features we need.
|
||||
(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))
|
||||
(error 'compile-file
|
||||
|
|
|
|||
|
|
@ -47,14 +47,13 @@
|
|||
;; continuation. See also `current-mark-splice` below.
|
||||
|
||||
;; A metacontinuation frame's `resume-k` is called when control
|
||||
;; returns or aborts to the frame:
|
||||
;;
|
||||
;; * When returning normally to a metacontinuation frame, the
|
||||
;; `resume-k` continuation receives a function for values returned
|
||||
;; to the frame.
|
||||
;;
|
||||
;; * When aborting to a prompt tag, the `resume-k` continination
|
||||
;; receives a special value that indicates an abort with arguments.
|
||||
;; returns or aborts to the frame. When aborting to a prompt tag,
|
||||
;; metacontinuation frames between the abort and prompt are removed
|
||||
;; one-by-one, running any winders in each frame. Finally, the
|
||||
;; `resume-k` continuation of the target prompt's metacontinuation is
|
||||
;; called; the `resume-k` is called using `call-in-continuation` to
|
||||
;; run a thunk in the restored continuation to apply the prompt's
|
||||
;; handler.
|
||||
;;
|
||||
;; Calling a non-composable continuation is similar to aborting,
|
||||
;; except that the target prompt's abort handler is not called. In
|
||||
|
|
@ -102,7 +101,9 @@
|
|||
(define-virtual-register current-metacontinuation '())
|
||||
|
||||
(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
|
||||
mark-splice ; extra part of mark stack to restore
|
||||
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
|
||||
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?)
|
||||
(fields (mutable name))) ; mutable => constructor generates fresh instances
|
||||
|
||||
|
|
@ -164,7 +162,7 @@
|
|||
(or (and (not mc)
|
||||
(or (eq? tag the-default-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
|
||||
(let ([mc (or mc (current-metacontinuation))])
|
||||
(let loop ([mc mc] [slow-mc mc] [slow-step? #f] [steps 0])
|
||||
|
|
@ -256,84 +254,68 @@
|
|||
"\n in: application of default prompt handler"
|
||||
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)
|
||||
(let ([mf (car (current-metacontinuation))])
|
||||
(current-metacontinuation (cdr (current-metacontinuation)))
|
||||
(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)
|
||||
;; Call `proc` in an empty metacontinuation frame, reifying the
|
||||
;; current metacontinuation as needed (i.e., if non-empty) as a new
|
||||
;; frame on `*metacontinuations*`; if the tag is #f and the
|
||||
;; current metacontinuation frame is already empty, don't push more
|
||||
;; current metacontinuation as a new frame on `current-metacontinuation`
|
||||
(assert-in-uninterrupted)
|
||||
(assert-not-in-system-wind)
|
||||
(let ([r ; a list of results, or a non-list for special handling
|
||||
(call/cc
|
||||
(lambda (resume-k)
|
||||
;; the `call/cc` to get `k` created a new stack
|
||||
;; segment; by dropping the link from the current
|
||||
;; segment to the return context referenced by `k`,
|
||||
;; we actually delimit the current continuation:
|
||||
(#%$current-stack-link #%$null-continuation)
|
||||
(current-mark-stack '())
|
||||
(let-values ([results
|
||||
;; mark the "empty" continuation frame
|
||||
;; that just continues the metacontinuation:
|
||||
(call-setting-continuation-attachment
|
||||
'empty
|
||||
(lambda ()
|
||||
(let ([mf (make-metacontinuation-frame tag
|
||||
resume-k
|
||||
(current-winders)
|
||||
(current-mark-splice)
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
#f)])
|
||||
(current-winders '())
|
||||
(current-mark-splice new-splice)
|
||||
;; push the metacontinuation:
|
||||
(current-metacontinuation (cons mf (current-metacontinuation)))
|
||||
;; ready:
|
||||
(proc))))])
|
||||
;; Prepare to use cc-guard, if one was enabled:
|
||||
(let ([cc-guard (metacontinuation-frame-cc-guard (car (current-metacontinuation)))])
|
||||
;; Continue normally; the metacontinuation could be different
|
||||
;; than when we captured this metafunction frame, though:
|
||||
(resume-metacontinuation
|
||||
;; Apply the cc-guard, if any, outside of the prompt:
|
||||
(if cc-guard
|
||||
(lambda () (apply cc-guard results))
|
||||
results))))))])
|
||||
(cond
|
||||
[(aborting? r)
|
||||
;; Remove the prompt as we call the handler:
|
||||
(pop-metacontinuation-frame)
|
||||
(end-uninterrupted/call-hook 'handle)
|
||||
(apply handler
|
||||
(aborting-args r))]
|
||||
[else
|
||||
;; We're returning normally; the metacontinuation frame has
|
||||
;; been popped already by `resume-metacontinuation`
|
||||
(end-uninterrupted 'resume)
|
||||
(if (#%procedure? r)
|
||||
(r)
|
||||
(if (and (pair? r) (null? (cdr r)))
|
||||
(car r)
|
||||
(#%apply values r)))])))
|
||||
(call/cc
|
||||
(lambda (resume-k)
|
||||
(let ([marks (current-mark-stack)]) ; grab marks before `call-in-continuation`
|
||||
(call-in-continuation
|
||||
#%$null-continuation
|
||||
'()
|
||||
(lambda ()
|
||||
(let-values ([results
|
||||
;; mark the "empty" continuation frame
|
||||
;; that just continues the metacontinuation:
|
||||
(call-setting-continuation-attachment
|
||||
'empty
|
||||
(lambda ()
|
||||
(let ([mf (make-metacontinuation-frame tag
|
||||
resume-k
|
||||
handler
|
||||
marks
|
||||
(current-winders)
|
||||
(current-mark-splice)
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
#f)])
|
||||
(current-winders '())
|
||||
(current-mark-splice new-splice)
|
||||
;; push the metacontinuation:
|
||||
(current-metacontinuation (cons mf (current-metacontinuation)))
|
||||
;; ready:
|
||||
(proc))))])
|
||||
;; Continue normally; the metacontinuation could be different
|
||||
;; than when we captured this metafunction frame, though:
|
||||
(cond
|
||||
[(null? (current-metacontinuation)) (engine-return)]
|
||||
[else
|
||||
(start-uninterrupted 'resume-mc)
|
||||
(let ([mf (pop-metacontinuation-frame)])
|
||||
(call-in-continuation
|
||||
(metacontinuation-frame-resume-k mf)
|
||||
(metacontinuation-frame-marks mf)
|
||||
(lambda ()
|
||||
(end-uninterrupted 'resume)
|
||||
(let ([cc-guard (metacontinuation-frame-cc-guard mf)])
|
||||
;; Apply the cc-guard, if any, outside of the prompt:
|
||||
(cond
|
||||
[cc-guard
|
||||
(apply cc-guard results)]
|
||||
[else
|
||||
(if (and (pair? results) (null? (cdr results)))
|
||||
(car results)
|
||||
(#%apply values results))])))))]))))))))
|
||||
|
||||
;; Simplified `call-in-empty-metacontinuation-frame` suitable for swapping engines:
|
||||
(define (call-with-empty-metacontinuation-frame-for-swap proc)
|
||||
|
|
@ -341,23 +323,30 @@
|
|||
(assert-not-in-system-wind)
|
||||
(call/cc
|
||||
(lambda (resume-k)
|
||||
(#%$current-stack-link #%$null-continuation)
|
||||
(current-mark-stack '())
|
||||
(let ([mf (make-metacontinuation-frame #f
|
||||
resume-k
|
||||
(current-winders)
|
||||
(current-mark-splice)
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
#f)])
|
||||
(current-winders '())
|
||||
(current-mark-splice empty-mark-frame)
|
||||
(current-metacontinuation (cons mf (current-metacontinuation)))
|
||||
(let ([r (proc (current-metacontinuation))])
|
||||
(let ([mf (car (current-metacontinuation))])
|
||||
(pop-metacontinuation-frame)
|
||||
((metacontinuation-frame-resume-k mf) r)))))))
|
||||
(let ([marks (current-mark-stack)])
|
||||
(call-in-continuation
|
||||
#%$null-continuation
|
||||
'()
|
||||
(lambda ()
|
||||
(let ([mf (make-metacontinuation-frame #f
|
||||
resume-k
|
||||
void
|
||||
marks
|
||||
(current-winders)
|
||||
(current-mark-splice)
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
#f)])
|
||||
(current-winders '())
|
||||
(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)
|
||||
(call-getting-continuation-attachment
|
||||
|
|
@ -369,23 +358,22 @@
|
|||
;; metacontinuation frame
|
||||
(proc)]
|
||||
[else
|
||||
(call/cc
|
||||
(lambda (from-k)
|
||||
(let ([new-splice (keep-immediate-attachment (current-mark-stack)
|
||||
(continuation-next-attachments from-k))])
|
||||
;; Prune splicing marks from `resume-k` by dropping the difference
|
||||
;; between `from-k` and `resume-k`:
|
||||
(current-mark-stack (continuation-next-attachments from-k))
|
||||
;; Call
|
||||
(call-in-empty-metacontinuation-frame
|
||||
the-compose-prompt-tag
|
||||
fail-abort-to-delimit-continuation
|
||||
new-splice
|
||||
proc))))]))))
|
||||
;; Consume attachment to move it (if there is one) to the new
|
||||
;; metacontinuation frame's splice:
|
||||
(call-consuming-continuation-attachment
|
||||
empty-mark-frame
|
||||
(lambda (new-splice)
|
||||
(call-in-empty-metacontinuation-frame
|
||||
the-compose-prompt-tag
|
||||
fail-abort-to-delimit-continuation
|
||||
new-splice
|
||||
proc)))]))))
|
||||
|
||||
(define (metacontinuation-frame-update-mark-splice current-mf mark-splice)
|
||||
(make-metacontinuation-frame (metacontinuation-frame-tag current-mf)
|
||||
(metacontinuation-frame-resume-k current-mf)
|
||||
(metacontinuation-frame-handler current-mf)
|
||||
(metacontinuation-frame-marks current-mf)
|
||||
(metacontinuation-frame-winders current-mf)
|
||||
mark-splice
|
||||
#f
|
||||
|
|
@ -397,6 +385,8 @@
|
|||
;; Ok to keep caches, since the cc-guard doesn't affect them
|
||||
(make-metacontinuation-frame (metacontinuation-frame-tag 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-mark-splice current-mf)
|
||||
(metacontinuation-frame-mark-chain current-mf)
|
||||
|
|
@ -432,8 +422,16 @@
|
|||
(let ([mf (car (current-metacontinuation))])
|
||||
(cond
|
||||
[(eq? tag (strip-impersonator (metacontinuation-frame-tag mf)))
|
||||
((metacontinuation-frame-resume-k mf)
|
||||
(make-aborting args))]
|
||||
;; Remove the prompt and resume its continuation
|
||||
;; 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
|
||||
;; Aborting to an enclosing prompt, so keep going:
|
||||
(pop-metacontinuation-frame)
|
||||
|
|
@ -853,8 +851,7 @@
|
|||
(list mark-splice))
|
||||
r)))]
|
||||
;; Get marks shallower than the splice
|
||||
[marks (let ([marks (continuation-next-attachments
|
||||
(metacontinuation-frame-resume-k mf))])
|
||||
[marks (let ([marks (metacontinuation-frame-marks mf)])
|
||||
(if (and (pair? marks)
|
||||
(let ([mark (car marks)])
|
||||
(or (eq? mark 'empty)
|
||||
|
|
@ -1131,13 +1128,6 @@
|
|||
(mark-frame-table (coerce-to-mark-frame mark-splice)))
|
||||
#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
|
||||
|
||||
|
|
@ -1828,7 +1818,7 @@
|
|||
|
||||
(define-virtual-register current-winders '())
|
||||
|
||||
(define-record winder (depth k pre post))
|
||||
(define-record winder (depth k marks pre post))
|
||||
|
||||
;; Jobs for `dynamic-wind`:
|
||||
|
||||
|
|
@ -1847,29 +1837,33 @@
|
|||
;; parameterizations.
|
||||
|
||||
(define (dynamic-wind pre thunk post)
|
||||
((call/cc
|
||||
(lambda (k)
|
||||
(let* ([winders (current-winders)]
|
||||
[winder (make-winder (if (null? winders)
|
||||
0
|
||||
(fx+ 1 (winder-depth (car winders))))
|
||||
k
|
||||
pre
|
||||
post)])
|
||||
(start-uninterrupted 'dw)
|
||||
(begin
|
||||
(call-winder-thunk 'dw-pre pre)
|
||||
(current-winders (cons winder winders))
|
||||
(end-uninterrupted/call-hook 'dw-body)
|
||||
(call-with-values (if (#%procedure? thunk)
|
||||
thunk
|
||||
(lambda () (|#%app| thunk)))
|
||||
(lambda args
|
||||
(start-uninterrupted 'dw-body)
|
||||
(current-winders winders)
|
||||
(call-winder-thunk 'dw-post post)
|
||||
(end-uninterrupted/call-hook 'dw)
|
||||
(lambda () (#%apply values args))))))))))
|
||||
(call/cc
|
||||
(lambda (k) ; continuation to restore while running pre/post thunk to unwind/rewind
|
||||
(let* ([winders (current-winders)]
|
||||
[winder (make-winder (if (null? winders)
|
||||
0
|
||||
(fx+ 1 (winder-depth (car winders))))
|
||||
k
|
||||
(current-mark-stack)
|
||||
pre
|
||||
post)])
|
||||
(start-uninterrupted 'dw)
|
||||
(begin
|
||||
(call-winder-thunk 'dw-pre pre)
|
||||
(current-winders (cons winder winders))
|
||||
(end-uninterrupted/call-hook 'dw-body)
|
||||
(call-with-values (if (#%procedure? thunk)
|
||||
thunk
|
||||
(lambda () (|#%app| thunk)))
|
||||
(lambda args
|
||||
(start-uninterrupted 'dw-body)
|
||||
(current-winders winders)
|
||||
(call-winder-thunk 'dw-post post)
|
||||
(end-uninterrupted/call-hook 'dw)
|
||||
(if (and (pair? args)
|
||||
(null? (cdr args)))
|
||||
(car args)
|
||||
(#%apply values args)))))))))
|
||||
|
||||
(define (call-winder-thunk who thunk)
|
||||
(with-continuation-mark
|
||||
|
|
@ -1891,7 +1885,9 @@
|
|||
[winders (cdr winders)])
|
||||
(current-winders winders)
|
||||
(let ([thunk (winder-thunk winder)])
|
||||
((winder-k winder)
|
||||
(call-in-continuation
|
||||
(winder-k winder)
|
||||
(winder-marks winder)
|
||||
(lambda ()
|
||||
(call-winder-thunk who thunk)
|
||||
(k))))))
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
#define MZSCHEME_VERSION_X 7
|
||||
#define MZSCHEME_VERSION_Y 6
|
||||
#define MZSCHEME_VERSION_Z 0
|
||||
#define MZSCHEME_VERSION_W 15
|
||||
#define MZSCHEME_VERSION_W 16
|
||||
|
||||
/* A level of indirection makes `#` work as needed: */
|
||||
#define AS_a_STR_HELPER(x) #x
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user