|
|
|
|
@ -13,18 +13,18 @@
|
|
|
|
|
;; A picture where the continuation grows down:
|
|
|
|
|
|
|
|
|
|
;; [root empty continuation]
|
|
|
|
|
;; --- empty-k
|
|
|
|
|
;; --- empty-k: 'empty attachment
|
|
|
|
|
;; metacontinuation |
|
|
|
|
|
;; frame |
|
|
|
|
|
;; |--- resume-k
|
|
|
|
|
;; |<-- tag represents this point
|
|
|
|
|
;; --- empty-k
|
|
|
|
|
;; --- empty-k: 'empty attachment
|
|
|
|
|
;; metacontinuation |
|
|
|
|
|
;; frame |
|
|
|
|
|
;; |
|
|
|
|
|
;; |--- resume-k
|
|
|
|
|
;; |<-- tag represents this point
|
|
|
|
|
;; --- empty-k
|
|
|
|
|
;; --- empty-k: 'empty attachment
|
|
|
|
|
;; current host |
|
|
|
|
|
;; continuation |
|
|
|
|
|
;; v
|
|
|
|
|
@ -32,20 +32,19 @@
|
|
|
|
|
;; Concretely, the metacontinuation is the current host continuation
|
|
|
|
|
;; plus the frames in the list `(current-metacontinuation)`, where the
|
|
|
|
|
;; shallowest (= lowest in the picture above) frame is first in the
|
|
|
|
|
;; list. The `empty-k` value of the current host continuation is
|
|
|
|
|
;; in `current-empty-k`.
|
|
|
|
|
;; list. The `empty-k` continuation is recognized by having an
|
|
|
|
|
;; 'empty continuation attachment.
|
|
|
|
|
|
|
|
|
|
;; The shallowest metacontinuation frame's `empty-k` continuation is
|
|
|
|
|
;; used to detect when the current host continuation is empty (i.e.,
|
|
|
|
|
;; when it matches the `current-empty-k` value). When it's empty, then
|
|
|
|
|
;; calling a composable continuation doesn't need to add a new
|
|
|
|
|
;; metacontinuation frame, and the application gets the right "tail"
|
|
|
|
|
;; behavior.
|
|
|
|
|
;; The conceptual `empty-k` continuation is used to detect when the
|
|
|
|
|
;; current host continuation is empty. When it's empty, then calling a
|
|
|
|
|
;; composable continuation doesn't need to add a new metacontinuation
|
|
|
|
|
;; frame, and the application gets the right "tail" behavior.
|
|
|
|
|
|
|
|
|
|
;; The shallowest metacontinuation frame's `empty-k` continuation also
|
|
|
|
|
;; indicates which continuation's marks (if any) should be spliced
|
|
|
|
|
;; into a new context when captured in a composable continuation. See
|
|
|
|
|
;; also `current-mark-splice` below.
|
|
|
|
|
;; Any continuation marks for the `empty-k` continuation are kept
|
|
|
|
|
;; separate in `current-mark-splice`, instead of being kept as an
|
|
|
|
|
;; attachment. That way, the continuation's marks (if any) can be
|
|
|
|
|
;; spliced into a new context when captured in a composable
|
|
|
|
|
;; continuation. See also `current-mark-splice` below.
|
|
|
|
|
|
|
|
|
|
;; A metacontinuation frame's `resume-k` is called when control
|
|
|
|
|
;; returns or aborts to the frame:
|
|
|
|
|
@ -71,22 +70,25 @@
|
|
|
|
|
;; the continuation where the jump starts.
|
|
|
|
|
|
|
|
|
|
;; The continuation marks for the frame represented by the current
|
|
|
|
|
;; host continuation are kept in `current-mark-stack`. When a
|
|
|
|
|
;; metacontinuation frame is created, it takes the current
|
|
|
|
|
;; host continuation are implemented by the host's
|
|
|
|
|
;; continuation-attachment support. The `current-mark-stack` function
|
|
|
|
|
;; is just an alias for the host's `$current-attachments` function.
|
|
|
|
|
;; When a metacontinuation frame is created, it takes the current
|
|
|
|
|
;; `current-mark-stack` value and `current-mark-stack` is set back to
|
|
|
|
|
;; empty. To keep winders and the mark stack in sync, a `dynamic-wind`
|
|
|
|
|
;; pre or post thunk resets the mark stack on entry.
|
|
|
|
|
|
|
|
|
|
;; When a composable continuation is applied in a continuation frame
|
|
|
|
|
;; that has marks, then the marks are moved into `current-mark-splice`,
|
|
|
|
|
;; which is conceptually merged into the tai of `current-mark-stack`.
|
|
|
|
|
;; Having a separate `current-mark-splice` enables `dynamic-wind`
|
|
|
|
|
;; pre and post thunks adapt correctly to the splicing while jumping
|
|
|
|
|
;; into or out of the continuation.
|
|
|
|
|
;; that has marks, then the marks are moved into
|
|
|
|
|
;; `current-mark-splice`, which is conceptually merged into the tail
|
|
|
|
|
;; of `current-mark-stack`. Having a separate `current-mark-splice`
|
|
|
|
|
;; enables `dynamic-wind` pre and post thunks to adapt correctly to
|
|
|
|
|
;; the splicing while jumping into or out of the continuation.
|
|
|
|
|
|
|
|
|
|
;; A metacontinuation frame has an extra cache slot to contain a list
|
|
|
|
|
;; of mark-stack lists down to the root continuation. When a delimited
|
|
|
|
|
;; sequence of metacontinuation frames are copied out of or into the
|
|
|
|
|
;; A metacontinuation frame has an extra cache slot to contain a "mark
|
|
|
|
|
;; chain", which is a cached/caching list of mark-stack lists down to
|
|
|
|
|
;; the root continuation. When a delimited sequence of
|
|
|
|
|
;; metacontinuation frames are copied out of or into the
|
|
|
|
|
;; metacontinuation, the slot is flushed and will be reset on demand.
|
|
|
|
|
|
|
|
|
|
;; Continuations are used to implement engines, but it's important
|
|
|
|
|
@ -99,13 +101,9 @@
|
|
|
|
|
|
|
|
|
|
(define-virtual-register current-metacontinuation '())
|
|
|
|
|
|
|
|
|
|
(define-virtual-register current-empty-k #f)
|
|
|
|
|
|
|
|
|
|
(define-record metacontinuation-frame (tag ; continuation prompt tag or #f
|
|
|
|
|
resume-k ; delivers values to the prompt
|
|
|
|
|
empty-k ; deepest end of this frame
|
|
|
|
|
resume-k ; delivers values to the prompt, also keeps mark stack as attachments
|
|
|
|
|
winders ; `dynamic-wind` winders
|
|
|
|
|
mark-stack ; 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
|
|
|
|
|
traces ; #f or a cached list of traces
|
|
|
|
|
@ -224,9 +222,7 @@
|
|
|
|
|
(let ([mf (car (current-metacontinuation))])
|
|
|
|
|
(current-metacontinuation (cdr (current-metacontinuation)))
|
|
|
|
|
(current-winders (metacontinuation-frame-winders mf))
|
|
|
|
|
(current-mark-stack (metacontinuation-frame-mark-stack mf))
|
|
|
|
|
(current-mark-splice (metacontinuation-frame-mark-splice mf))
|
|
|
|
|
(current-empty-k (metacontinuation-frame-empty-k mf))))
|
|
|
|
|
(current-mark-splice (metacontinuation-frame-mark-splice mf))))
|
|
|
|
|
|
|
|
|
|
(define (call-in-empty-metacontinuation-frame tag handler tail? proc)
|
|
|
|
|
;; Call `proc` in an empty metacontinuation frame, reifying the
|
|
|
|
|
@ -235,47 +231,50 @@
|
|
|
|
|
;; current metacontinuation frame is already empty, don't push more
|
|
|
|
|
(assert-in-uninterrupted)
|
|
|
|
|
(assert-not-in-system-wind)
|
|
|
|
|
(call/cc
|
|
|
|
|
(lambda (tail-k)
|
|
|
|
|
(call-with-current-continuation-attachment
|
|
|
|
|
'none
|
|
|
|
|
(lambda (at)
|
|
|
|
|
(cond
|
|
|
|
|
[(and (eq? tag the-compose-prompt-tag)
|
|
|
|
|
(eq? tail-k (current-empty-k)))
|
|
|
|
|
(eq? at 'empty))
|
|
|
|
|
;; empty continuation in the current frame; don't push a new
|
|
|
|
|
;; metacontinuation frame; if the mark stack is non-empty,
|
|
|
|
|
;; merge it into the mark splice
|
|
|
|
|
(current-mark-splice (merge-mark-splice (current-mark-stack) (current-mark-splice)))
|
|
|
|
|
(current-mark-stack '())
|
|
|
|
|
;; metacontinuation frame
|
|
|
|
|
(proc)]
|
|
|
|
|
[else
|
|
|
|
|
((if tail? call/cc (lambda (proc) (proc #f)))
|
|
|
|
|
(lambda (from-k)
|
|
|
|
|
(let ([new-splice (if tail?
|
|
|
|
|
(keep-immediate-attachment (current-mark-stack)
|
|
|
|
|
(continuation-next-attachments from-k))
|
|
|
|
|
empty-mark-frame)])
|
|
|
|
|
(when tail?
|
|
|
|
|
;; Prune splicing marks from `resume-k` by dropping the difference
|
|
|
|
|
;; between `from-k` and `resume-k`:
|
|
|
|
|
(current-mark-stack (continuation-next-attachments from-k)))
|
|
|
|
|
(let ([r ; a list of results, or a non-list for special handling
|
|
|
|
|
(call/cc
|
|
|
|
|
(lambda (k)
|
|
|
|
|
(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
|
|
|
|
|
(call/cc
|
|
|
|
|
;; remember the "empty" continuation frame
|
|
|
|
|
;; mark the "empty" continuation frame
|
|
|
|
|
;; that just continues the metacontinuation:
|
|
|
|
|
(lambda (empty-k)
|
|
|
|
|
(call-setting-continuation-attachment
|
|
|
|
|
'empty
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ([mf (make-metacontinuation-frame tag
|
|
|
|
|
k
|
|
|
|
|
(current-empty-k)
|
|
|
|
|
resume-k
|
|
|
|
|
(current-winders)
|
|
|
|
|
(if tail?
|
|
|
|
|
(prune-immediate-frame (current-mark-stack) tail-k)
|
|
|
|
|
(current-mark-stack))
|
|
|
|
|
(current-mark-splice)
|
|
|
|
|
#f
|
|
|
|
|
#f
|
|
|
|
|
#f)])
|
|
|
|
|
(current-winders '())
|
|
|
|
|
(current-empty-k empty-k)
|
|
|
|
|
(current-mark-splice (and tail?
|
|
|
|
|
(keep-immediate-frame (current-mark-stack) tail-k empty-k)))
|
|
|
|
|
(current-mark-stack #f)
|
|
|
|
|
(current-mark-splice new-splice)
|
|
|
|
|
;; push the metacontinuation:
|
|
|
|
|
(current-metacontinuation (cons mf (current-metacontinuation)))
|
|
|
|
|
;; ready:
|
|
|
|
|
@ -299,14 +298,12 @@
|
|
|
|
|
;; We're returning normally; the metacontinuation frame has
|
|
|
|
|
;; been popped already by `resume-metacontinuation`
|
|
|
|
|
(end-uninterrupted 'resume)
|
|
|
|
|
(r)]))]))))
|
|
|
|
|
(r)])))))]))))
|
|
|
|
|
|
|
|
|
|
(define (metacontinuation-frame-update-mark-stack current-mf mark-stack mark-splice)
|
|
|
|
|
(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-empty-k current-mf)
|
|
|
|
|
(metacontinuation-frame-winders current-mf)
|
|
|
|
|
mark-stack
|
|
|
|
|
mark-splice
|
|
|
|
|
#f
|
|
|
|
|
#f
|
|
|
|
|
@ -316,9 +313,7 @@
|
|
|
|
|
;; 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-empty-k current-mf)
|
|
|
|
|
(metacontinuation-frame-winders current-mf)
|
|
|
|
|
(metacontinuation-frame-mark-stack current-mf)
|
|
|
|
|
(metacontinuation-frame-mark-splice current-mf)
|
|
|
|
|
(metacontinuation-frame-mark-chain current-mf)
|
|
|
|
|
(metacontinuation-frame-traces current-mf)
|
|
|
|
|
@ -400,7 +395,7 @@
|
|
|
|
|
;; Capturing and applying continuations
|
|
|
|
|
|
|
|
|
|
(define-record continuation ())
|
|
|
|
|
(define-record full-continuation continuation (k winders mark-stack mark-splice empty-k mc))
|
|
|
|
|
(define-record full-continuation continuation (k winders mark-stack mark-splice mc))
|
|
|
|
|
(define-record composable-continuation full-continuation ())
|
|
|
|
|
(define-record composable-continuation/no-wind composable-continuation ())
|
|
|
|
|
(define-record non-composable-continuation full-continuation (tag))
|
|
|
|
|
@ -425,7 +420,6 @@
|
|
|
|
|
(current-winders)
|
|
|
|
|
(current-mark-stack)
|
|
|
|
|
(current-mark-splice)
|
|
|
|
|
(current-empty-k)
|
|
|
|
|
(extract-metacontinuation 'call-with-current-continuation (strip-impersonator tag) #t)
|
|
|
|
|
tag))))))]))
|
|
|
|
|
|
|
|
|
|
@ -452,7 +446,6 @@
|
|
|
|
|
(current-winders)
|
|
|
|
|
(current-mark-stack)
|
|
|
|
|
(current-mark-splice)
|
|
|
|
|
(current-empty-k)
|
|
|
|
|
(extract-metacontinuation 'call-with-composable-continuation (strip-impersonator tag) #f))))))))
|
|
|
|
|
|
|
|
|
|
(define (unsafe-call-with-composable-continuation/no-wind p tag)
|
|
|
|
|
@ -533,20 +526,15 @@
|
|
|
|
|
c
|
|
|
|
|
args
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ([mark-stack (full-continuation-mark-stack c)]
|
|
|
|
|
[empty-k (full-continuation-empty-k c)])
|
|
|
|
|
(let ([mark-stack (full-continuation-mark-stack c)])
|
|
|
|
|
(current-mark-splice (let ([mark-splice (full-continuation-mark-splice c)])
|
|
|
|
|
(if (composable-continuation? c)
|
|
|
|
|
(prune-mark-splice (merge-mark-splice mark-splice (current-mark-splice))
|
|
|
|
|
mark-stack
|
|
|
|
|
empty-k)
|
|
|
|
|
(merge-mark-splice mark-splice (current-mark-splice))
|
|
|
|
|
mark-splice)))
|
|
|
|
|
(current-empty-k empty-k)
|
|
|
|
|
(wind-to
|
|
|
|
|
(full-continuation-winders c)
|
|
|
|
|
;; When no winders are left:
|
|
|
|
|
(lambda ()
|
|
|
|
|
(current-mark-stack mark-stack)
|
|
|
|
|
(when (non-composable-continuation? c)
|
|
|
|
|
;; Activate/add cc-guards in target prompt; any user-level
|
|
|
|
|
;; callbacks here are run with a continuation barrier, so
|
|
|
|
|
@ -566,9 +554,7 @@
|
|
|
|
|
(map metacontinuation-frame-clear-cache (full-continuation-mc c))
|
|
|
|
|
(current-metacontinuation)))
|
|
|
|
|
(current-winders (full-continuation-winders c))
|
|
|
|
|
(current-mark-stack (full-continuation-mark-stack c))
|
|
|
|
|
(current-mark-splice (full-continuation-mark-splice c))
|
|
|
|
|
(current-empty-k (full-continuation-empty-k c))
|
|
|
|
|
(apply (full-continuation-k c) args))
|
|
|
|
|
|
|
|
|
|
;; Used as a "handler" for a prompt without a tag, which is used for
|
|
|
|
|
@ -642,20 +628,13 @@
|
|
|
|
|
(raise-continuation-error '|continuation application|
|
|
|
|
|
"attempt to cross a continuation barrier"))
|
|
|
|
|
|
|
|
|
|
(define (call-with-end-uninterrupted thunk)
|
|
|
|
|
;; Using `call/cm` with a key of `none` ensures that we have an
|
|
|
|
|
;; `(end-uninterrupted)` in the immediate continuation, but
|
|
|
|
|
;; keeping the illusion that `thunk` is called in tail position.
|
|
|
|
|
(call/cm none #f thunk))
|
|
|
|
|
|
|
|
|
|
;; Update `splice-k` to be the "inside" of a continuation prompt.
|
|
|
|
|
;; Update `empty-k` for splicing to be the "inside" of a continuation prompt.
|
|
|
|
|
(define (call-with-splice-k thunk)
|
|
|
|
|
(call-with-end-uninterrupted
|
|
|
|
|
(lambda ()
|
|
|
|
|
(call/cc
|
|
|
|
|
(lambda (k)
|
|
|
|
|
(current-empty-k k)
|
|
|
|
|
(thunk))))))
|
|
|
|
|
(call-setting-continuation-attachment
|
|
|
|
|
'empty
|
|
|
|
|
(lambda () (thunk))))))
|
|
|
|
|
|
|
|
|
|
(define (set-continuation-applicables!)
|
|
|
|
|
(let ([add (lambda (rtd)
|
|
|
|
|
@ -737,8 +716,7 @@
|
|
|
|
|
(apply-non-composable-continuation dest-c dest-args)))))])))
|
|
|
|
|
|
|
|
|
|
(define (metacontinuation-frame-clear-cache mf)
|
|
|
|
|
(metacontinuation-frame-update-mark-stack mf
|
|
|
|
|
(metacontinuation-frame-mark-stack mf)
|
|
|
|
|
(metacontinuation-frame-update-mark-splice mf
|
|
|
|
|
(metacontinuation-frame-mark-splice mf)))
|
|
|
|
|
|
|
|
|
|
;; Get/cache a converted list of marks for a metacontinuation
|
|
|
|
|
@ -749,20 +727,17 @@
|
|
|
|
|
(or (metacontinuation-frame-mark-chain mf)
|
|
|
|
|
(let* ([r (metacontinuation-marks (cdr mc))]
|
|
|
|
|
[m (let ([mark-splice (metacontinuation-frame-mark-splice mf)])
|
|
|
|
|
(if mark-splice
|
|
|
|
|
(if (empty-mark-frame? mark-splice)
|
|
|
|
|
r
|
|
|
|
|
(cons (make-mark-chain-frame
|
|
|
|
|
(strip-impersonator (metacontinuation-frame-tag mf))
|
|
|
|
|
;; maybe splicing:
|
|
|
|
|
(mark-stack-tail-matches? (metacontinuation-frame-mark-stack mf)
|
|
|
|
|
(mark-stack-frame-k mark-splice))
|
|
|
|
|
(mark-stack-to-marks mark-splice))
|
|
|
|
|
r)
|
|
|
|
|
r))]
|
|
|
|
|
(mark-stack-to-marks (list mark-splice)))
|
|
|
|
|
r)))]
|
|
|
|
|
[l (cons (make-mark-chain-frame
|
|
|
|
|
(strip-impersonator (metacontinuation-frame-tag mf))
|
|
|
|
|
#t ; not splicing
|
|
|
|
|
(mark-stack-to-marks
|
|
|
|
|
(metacontinuation-frame-mark-stack mf)))
|
|
|
|
|
(continuation-next-attachments
|
|
|
|
|
(metacontinuation-frame-resume-k mf))))
|
|
|
|
|
m)])
|
|
|
|
|
(set-metacontinuation-frame-mark-chain! mf l)
|
|
|
|
|
l)))]))
|
|
|
|
|
@ -771,9 +746,8 @@
|
|
|
|
|
(cond
|
|
|
|
|
[(and splice? (current-mark-splice))
|
|
|
|
|
=> (lambda (mark-splice)
|
|
|
|
|
(current-mark-splice #f)
|
|
|
|
|
(metacontinuation-frame-update-mark-stack mf
|
|
|
|
|
(metacontinuation-frame-mark-stack mf)
|
|
|
|
|
(current-mark-splice empty-mark-frame)
|
|
|
|
|
(metacontinuation-frame-update-mark-splice mf
|
|
|
|
|
(merge-mark-splice (metacontinuation-frame-mark-splice mf)
|
|
|
|
|
mark-splice)))]
|
|
|
|
|
[else mf]))
|
|
|
|
|
@ -786,10 +760,14 @@
|
|
|
|
|
;; small.
|
|
|
|
|
|
|
|
|
|
(define empty-mark-table '())
|
|
|
|
|
(define empty-mark-table? null?)
|
|
|
|
|
|
|
|
|
|
(define (mark-table-add mt k v)
|
|
|
|
|
(cons (cons k v) mt))
|
|
|
|
|
|
|
|
|
|
(define (pair->mark-table k+v)
|
|
|
|
|
(list k+v))
|
|
|
|
|
|
|
|
|
|
(define (mark-table-remove mt k)
|
|
|
|
|
(cond
|
|
|
|
|
[(null? mt) mt]
|
|
|
|
|
@ -820,13 +798,6 @@
|
|
|
|
|
(loop (mark-table-add/replace b (car p) (cdr p))
|
|
|
|
|
(cdr a)))]))]))
|
|
|
|
|
|
|
|
|
|
(define (mark-table-prune a b)
|
|
|
|
|
(cond
|
|
|
|
|
[(null? a) '()]
|
|
|
|
|
[(null? b) a]
|
|
|
|
|
[else (mark-table-prune (mark-table-remove a (caar b))
|
|
|
|
|
(cdr b))]))
|
|
|
|
|
|
|
|
|
|
(define (mark-table->hash mt)
|
|
|
|
|
(let loop ([ht empty-hasheq] [mt mt])
|
|
|
|
|
(cond
|
|
|
|
|
@ -838,84 +809,116 @@
|
|
|
|
|
;; ----------------------------------------
|
|
|
|
|
;; Continuation marks
|
|
|
|
|
|
|
|
|
|
;; A "mark frame" in the mark stack is one of
|
|
|
|
|
;;
|
|
|
|
|
;; - #f = empty-mark-frame = (make-mark-frame empty-mark-table #f #f)
|
|
|
|
|
;; - (cons key val) = (make-mark-frame (pair->mark-table (cons key val)) #f #f)
|
|
|
|
|
;; - a mark frame
|
|
|
|
|
;;
|
|
|
|
|
;; The shorthand forms are promoted to `make-mark-frame` as needed to
|
|
|
|
|
;; hold mappings for multiple key. The shorthand forms are also promoted
|
|
|
|
|
;; on capture by `current-continuation-marks`; in that case, the mark-stack
|
|
|
|
|
;; list is mutated to substitute the promoted form.
|
|
|
|
|
;;
|
|
|
|
|
;; On capture by `current-continuation-marks`, the `flat` field of a
|
|
|
|
|
;; mark frame is filled in with a list of mark tables converted to
|
|
|
|
|
;; hash tables. That list can be mutated to substitute an `elem+cache`
|
|
|
|
|
;; in place of plain hash table; that substitution happens when searching
|
|
|
|
|
;; for a mark in the list.
|
|
|
|
|
|
|
|
|
|
(define-record continuation-mark-set (mark-chain traces))
|
|
|
|
|
(define-record mark-stack-frame (prev ; prev frame
|
|
|
|
|
k ; continuation for this frame
|
|
|
|
|
table ; intmap mapping keys to values
|
|
|
|
|
(define-record mark-frame (table ; intmap mapping keys to values
|
|
|
|
|
end-uninterupted? ; whether an "in interrupted?" check has been added
|
|
|
|
|
flat)) ; #f or cached list that contains only tables and elem+caches
|
|
|
|
|
|
|
|
|
|
;; A mark stack is made of marks-stack frames:
|
|
|
|
|
(define-virtual-register current-mark-stack #f)
|
|
|
|
|
(define empty-mark-frame #f)
|
|
|
|
|
|
|
|
|
|
(define (empty-mark-frame? mf)
|
|
|
|
|
(or (not mf)
|
|
|
|
|
(and (mark-frame? mf)
|
|
|
|
|
(empty-mark-table? (mark-frame-table mf)))))
|
|
|
|
|
|
|
|
|
|
(define current-mark-stack
|
|
|
|
|
(case-lambda
|
|
|
|
|
[() (#%$current-attachments)]
|
|
|
|
|
[(l) (#%$current-attachments l)]))
|
|
|
|
|
|
|
|
|
|
;; An extra mark stack of size 0 or 1 that is conceptually appended to
|
|
|
|
|
;; the end of `current-mark-stack`, mainly to support composable
|
|
|
|
|
;; continuations and `dynamic-wind`. If the last frame of
|
|
|
|
|
;; `current-mark-stack` has the same `k` as a frame in
|
|
|
|
|
;; `current-mark-stack-splice`, then then frames are conceptually
|
|
|
|
|
;; merged, so no key should be inthe mark-splice frame if it's in the
|
|
|
|
|
;; mark-stack frame.
|
|
|
|
|
(define-virtual-register current-mark-splice #f)
|
|
|
|
|
;; the end of `current-mark-stack`, which supports composable
|
|
|
|
|
;; continuations.
|
|
|
|
|
(define-virtual-register current-mark-splice empty-mark-frame)
|
|
|
|
|
|
|
|
|
|
(define (mark-frame-update a key val)
|
|
|
|
|
(cond
|
|
|
|
|
[(not a) (cons key val)]
|
|
|
|
|
[(pair? a)
|
|
|
|
|
(if (eq? key (car a))
|
|
|
|
|
(cons key val)
|
|
|
|
|
(make-mark-frame (mark-table-add/replace (pair->mark-table a) key val)
|
|
|
|
|
#f
|
|
|
|
|
#f))]
|
|
|
|
|
[(eq? a 'empty)
|
|
|
|
|
;; The current frame is the mark-splice frame, so update
|
|
|
|
|
;; `current-mark-splice`.
|
|
|
|
|
(current-mark-splice (mark-frame-update (current-mark-splice) key val))
|
|
|
|
|
'empty]
|
|
|
|
|
[(mark-frame? a)
|
|
|
|
|
(make-mark-frame (mark-table-add/replace (mark-frame-table a) key val)
|
|
|
|
|
(mark-frame-end-uninterupted? a)
|
|
|
|
|
#f)]))
|
|
|
|
|
|
|
|
|
|
(define (coerce-to-mark-frame a)
|
|
|
|
|
(cond
|
|
|
|
|
[(mark-frame? a) a]
|
|
|
|
|
[(not a) (make-mark-frame '() #f #f)]
|
|
|
|
|
[else (make-mark-frame (list a) #f #f)]))
|
|
|
|
|
|
|
|
|
|
(define (extract-mark-from-frame a key default-v)
|
|
|
|
|
(cond
|
|
|
|
|
[(pair? a) (if (eq? key (car a)) (cdr a) default-v)]
|
|
|
|
|
[(mark-frame? a) (mark-table-ref (mark-frame-table a) key default-v)]
|
|
|
|
|
[else default-v]))
|
|
|
|
|
|
|
|
|
|
;; See copy in "expander.sls"
|
|
|
|
|
(define-syntax with-continuation-mark
|
|
|
|
|
(syntax-rules ()
|
|
|
|
|
[(_ key val body)
|
|
|
|
|
(call/cm key val (lambda () body))]))
|
|
|
|
|
(call-with-current-continuation-attachment
|
|
|
|
|
empty-mark-frame
|
|
|
|
|
(lambda (a)
|
|
|
|
|
(call-setting-continuation-attachment
|
|
|
|
|
(mark-frame-update a key val)
|
|
|
|
|
(lambda ()
|
|
|
|
|
body))))]))
|
|
|
|
|
|
|
|
|
|
;; Sets a continuation mark.
|
|
|
|
|
;; Using `none` as a key ensures that a
|
|
|
|
|
;; stack-restoring frame is pushed without
|
|
|
|
|
;; adding a key--value mapping.
|
|
|
|
|
(define (call/cm key val proc)
|
|
|
|
|
;; Ensure that we have an `(end-uninterrupted)` in the immediate
|
|
|
|
|
;; continuation, but keep the illusion that `thunk` is called in
|
|
|
|
|
;; tail position.
|
|
|
|
|
(define (call-with-end-uninterrupted thunk)
|
|
|
|
|
(call-with-current-continuation-attachment
|
|
|
|
|
empty-mark-frame
|
|
|
|
|
(lambda (a)
|
|
|
|
|
(cond
|
|
|
|
|
[(or (eq? a 'empty)
|
|
|
|
|
(and (mark-frame? a)
|
|
|
|
|
(mark-frame-end-uninterupted? a)))
|
|
|
|
|
;; an end-uninterupted check is in place
|
|
|
|
|
(thunk)]
|
|
|
|
|
[else
|
|
|
|
|
;; Add an uninteruped check, moving the current continuation
|
|
|
|
|
;; marks to the more nested continuation
|
|
|
|
|
(call-setting-continuation-attachment
|
|
|
|
|
'skip
|
|
|
|
|
(lambda ()
|
|
|
|
|
(call/cc
|
|
|
|
|
(lambda (k)
|
|
|
|
|
(when (eq? k (current-empty-k))
|
|
|
|
|
;; Need to merge the main stack and splice, if both are active
|
|
|
|
|
(when (current-mark-splice)
|
|
|
|
|
(merge-mark-splice!)))
|
|
|
|
|
(let ([mark-stack (current-mark-stack)])
|
|
|
|
|
(cond
|
|
|
|
|
[(and mark-stack
|
|
|
|
|
(eq? k (mark-stack-frame-k mark-stack)))
|
|
|
|
|
(unless (eq? key none)
|
|
|
|
|
(current-mark-stack (make-mark-stack-frame (mark-stack-frame-prev mark-stack)
|
|
|
|
|
k
|
|
|
|
|
(mark-table-add/replace* (mark-stack-frame-table mark-stack)
|
|
|
|
|
key
|
|
|
|
|
val)
|
|
|
|
|
#f)))
|
|
|
|
|
(proc)]
|
|
|
|
|
[else
|
|
|
|
|
(begin0
|
|
|
|
|
(call/cc
|
|
|
|
|
(lambda (new-k)
|
|
|
|
|
(current-mark-stack
|
|
|
|
|
(make-mark-stack-frame mark-stack
|
|
|
|
|
new-k
|
|
|
|
|
(if (eq? key none)
|
|
|
|
|
empty-mark-table
|
|
|
|
|
(mark-table-add empty-mark-table key val))
|
|
|
|
|
#f))
|
|
|
|
|
(proc)))
|
|
|
|
|
(current-mark-stack (mark-stack-frame-prev (current-mark-stack)))
|
|
|
|
|
;; To support exiting an uninterrupted region on resumption of
|
|
|
|
|
;; a continuation (see `call-with-end-uninterrupted`):
|
|
|
|
|
(when (current-in-uninterrupted)
|
|
|
|
|
(pariah (end-uninterrupted/call-hook 'cm))))])))))
|
|
|
|
|
|
|
|
|
|
;; For internal use, such as `dynamic-wind` pre thunks:
|
|
|
|
|
(define (call/cm/nontail key val proc)
|
|
|
|
|
(current-mark-stack
|
|
|
|
|
(make-mark-stack-frame (current-mark-stack)
|
|
|
|
|
(call-setting-continuation-attachment
|
|
|
|
|
(let ([a (coerce-to-mark-frame a)])
|
|
|
|
|
(make-mark-frame (mark-frame-table a)
|
|
|
|
|
#f
|
|
|
|
|
(mark-table-add empty-mark-table key val)
|
|
|
|
|
#f))
|
|
|
|
|
(proc)
|
|
|
|
|
;; If we're in an escape process, then `(current-mark-stack)` might not
|
|
|
|
|
;; match, and that's ok; it doesn't matter what we set the mark stack to
|
|
|
|
|
;; in that case, so we do something that's right for the non-escape case
|
|
|
|
|
(when (current-mark-stack)
|
|
|
|
|
(current-mark-stack (mark-stack-frame-prev (current-mark-stack)))))
|
|
|
|
|
(mark-frame-flat a)))
|
|
|
|
|
(lambda ()
|
|
|
|
|
(thunk)))))))]))))
|
|
|
|
|
|
|
|
|
|
(define (current-mark-chain)
|
|
|
|
|
(get-current-mark-chain (current-mark-stack) (current-mark-splice) (current-metacontinuation)))
|
|
|
|
|
@ -923,38 +926,37 @@
|
|
|
|
|
(define (mark-stack-to-marks mark-stack)
|
|
|
|
|
(let loop ([mark-stack mark-stack])
|
|
|
|
|
(cond
|
|
|
|
|
[(not mark-stack) null]
|
|
|
|
|
[(mark-stack-frame-flat mark-stack) => (lambda (l) l)]
|
|
|
|
|
[(null? mark-stack) null]
|
|
|
|
|
[else
|
|
|
|
|
(let ([l (cons (mark-table->hash (mark-stack-frame-table mark-stack))
|
|
|
|
|
(loop (mark-stack-frame-prev mark-stack)))])
|
|
|
|
|
(set-mark-stack-frame-flat! mark-stack l)
|
|
|
|
|
l)])))
|
|
|
|
|
(let ([a (car mark-stack)])
|
|
|
|
|
(cond
|
|
|
|
|
[(eq? a 'empty) (loop (cdr mark-stack))]
|
|
|
|
|
[(not (mark-frame? a))
|
|
|
|
|
;; Promote to general frame form
|
|
|
|
|
(set-car! mark-stack (coerce-to-mark-frame a))
|
|
|
|
|
(loop mark-stack)]
|
|
|
|
|
[(mark-frame-flat a) => (lambda (l) l)]
|
|
|
|
|
[else
|
|
|
|
|
(let ([l (cons (mark-table->hash (mark-frame-table a))
|
|
|
|
|
(loop (cdr mark-stack)))])
|
|
|
|
|
(set-mark-frame-flat! a l)
|
|
|
|
|
l)]))])))
|
|
|
|
|
|
|
|
|
|
(define-record mark-chain-frame (tag splice? marks))
|
|
|
|
|
(define-record mark-chain-frame (tag marks))
|
|
|
|
|
|
|
|
|
|
(define (get-current-mark-chain mark-stack mark-splice mc)
|
|
|
|
|
(let ([hd (make-mark-chain-frame
|
|
|
|
|
#f ; no tag
|
|
|
|
|
#f ; not a splice
|
|
|
|
|
(mark-stack-to-marks mark-stack))]
|
|
|
|
|
[mid (and mark-splice
|
|
|
|
|
[mid (and (not (empty-mark-frame? mark-splice))
|
|
|
|
|
(make-mark-chain-frame
|
|
|
|
|
#f ; no tag
|
|
|
|
|
(mark-stack-tail-matches? mark-stack (mark-stack-frame-k mark-splice)) ; maybe splicing
|
|
|
|
|
(mark-stack-to-marks mark-splice)))]
|
|
|
|
|
(mark-stack-to-marks (list mark-splice))))]
|
|
|
|
|
[tl (metacontinuation-marks mc)])
|
|
|
|
|
(if mid
|
|
|
|
|
(cons hd (cons mid tl))
|
|
|
|
|
(cons hd tl))))
|
|
|
|
|
|
|
|
|
|
(define (mark-stack-tail-matches? mark-stack k)
|
|
|
|
|
(and mark-stack
|
|
|
|
|
(let ([prev (mark-stack-frame-prev mark-stack)])
|
|
|
|
|
(or (and (not prev)
|
|
|
|
|
(eq? (mark-stack-frame-k mark-stack) k))
|
|
|
|
|
(mark-stack-tail-matches? prev k)))))
|
|
|
|
|
|
|
|
|
|
(define (prune-mark-chain-prefix tag mark-chain)
|
|
|
|
|
(cond
|
|
|
|
|
[(eq? tag (mark-chain-frame-tag (elem+cache-strip (car mark-chain))))
|
|
|
|
|
@ -974,94 +976,26 @@
|
|
|
|
|
(cons (car mark-chain)
|
|
|
|
|
rest-mark-chain)))]))
|
|
|
|
|
|
|
|
|
|
;; Used by `continuation-mark-set->list*` to determine when to splice
|
|
|
|
|
(define (splice-next? mark-chain)
|
|
|
|
|
(and (pair? mark-chain)
|
|
|
|
|
(pair? (cdr mark-chain))
|
|
|
|
|
(mark-chain-frame-splice? (elem+cache-strip (cadr mark-chain)))))
|
|
|
|
|
|
|
|
|
|
;; Called when the curent continuation is `(current-empty-k)`,
|
|
|
|
|
;; merge anything in `(current-mark-splice)` into `(current-mark-stack)`
|
|
|
|
|
(define (merge-mark-splice!)
|
|
|
|
|
(let ([mark-splice (current-mark-splice)])
|
|
|
|
|
(when mark-splice
|
|
|
|
|
(current-mark-stack (merge-mark-splice (current-mark-stack)
|
|
|
|
|
mark-splice))
|
|
|
|
|
(current-mark-splice #f))))
|
|
|
|
|
|
|
|
|
|
;; Merge immediate frame of `mark-splice` into immediate frame of
|
|
|
|
|
;; `mark-stack`, where `mark-stack` takes precedence. We expect that
|
|
|
|
|
;; each argument is a stack of length 0 or 1, since that's when
|
|
|
|
|
;; merging makes sense.
|
|
|
|
|
(define (merge-mark-splice mark-stack mark-splice)
|
|
|
|
|
(cond
|
|
|
|
|
[(not mark-stack) mark-splice]
|
|
|
|
|
[(not mark-splice) mark-stack]
|
|
|
|
|
[(empty-mark-frame? mark-stack) mark-splice]
|
|
|
|
|
[(empty-mark-frame? mark-splice) mark-stack]
|
|
|
|
|
[else
|
|
|
|
|
(make-mark-stack-frame #f
|
|
|
|
|
(mark-stack-frame-k mark-stack)
|
|
|
|
|
(mark-table-merge (mark-stack-frame-table mark-stack)
|
|
|
|
|
(mark-stack-frame-table mark-splice))
|
|
|
|
|
(make-mark-frame (mark-table-merge (mark-frame-table (coerce-to-mark-frame mark-stack))
|
|
|
|
|
(mark-frame-table (coerce-to-mark-frame mark-splice)))
|
|
|
|
|
#f
|
|
|
|
|
#f)]))
|
|
|
|
|
|
|
|
|
|
;; If `mark-stack` ends with a frame that is conceptually
|
|
|
|
|
;; merged with one in `mark-splice`, then discard any keys
|
|
|
|
|
;; in `mark-splice` that are in the `mark-stack` frame.
|
|
|
|
|
;; Also, update `mark-splice` to use `empty-k`.
|
|
|
|
|
(define (prune-mark-splice mark-splice mark-stack empty-k)
|
|
|
|
|
(define (keep-immediate-attachment mark-stack next-mark-stack)
|
|
|
|
|
(cond
|
|
|
|
|
[(not mark-splice) #f]
|
|
|
|
|
[(eq? mark-stack next-mark-stack)
|
|
|
|
|
empty-mark-frame]
|
|
|
|
|
[else
|
|
|
|
|
(let loop ([mark-stack mark-stack])
|
|
|
|
|
(cond
|
|
|
|
|
[(not mark-stack) (make-mark-stack-frame #f
|
|
|
|
|
empty-k
|
|
|
|
|
(mark-stack-frame-table mark-splice)
|
|
|
|
|
#f)]
|
|
|
|
|
[else
|
|
|
|
|
(let ([prev (mark-stack-frame-prev mark-stack)])
|
|
|
|
|
(cond
|
|
|
|
|
[(and (not prev) (eq? (mark-stack-frame-k mark-stack) empty-k))
|
|
|
|
|
(make-mark-stack-frame #f
|
|
|
|
|
empty-k
|
|
|
|
|
(mark-table-prune (mark-stack-frame-table mark-splice)
|
|
|
|
|
(mark-stack-frame-table mark-stack))
|
|
|
|
|
#f)]
|
|
|
|
|
[else (loop prev)]))]))]))
|
|
|
|
|
|
|
|
|
|
(define (mark-stack-starts-with? mark-stack k)
|
|
|
|
|
(and mark-stack
|
|
|
|
|
(eq? k (mark-stack-frame-k mark-stack))))
|
|
|
|
|
|
|
|
|
|
;; Drop any marks on the immediate frame --- used when
|
|
|
|
|
;; moving a frame across a metacontinuation boundary
|
|
|
|
|
(define (prune-immediate-frame mark-stack k)
|
|
|
|
|
(cond
|
|
|
|
|
[(mark-stack-starts-with? mark-stack k)
|
|
|
|
|
(make-mark-stack-frame (mark-stack-frame-prev mark-stack)
|
|
|
|
|
(mark-stack-frame-k mark-stack)
|
|
|
|
|
empty-mark-table
|
|
|
|
|
#f)]
|
|
|
|
|
[else mark-stack]))
|
|
|
|
|
|
|
|
|
|
(define (keep-immediate-frame mark-stack k empty-k)
|
|
|
|
|
(cond
|
|
|
|
|
[(mark-stack-starts-with? mark-stack k)
|
|
|
|
|
(make-mark-stack-frame #f
|
|
|
|
|
empty-k
|
|
|
|
|
(mark-stack-frame-table mark-stack)
|
|
|
|
|
#f)]
|
|
|
|
|
[else #f]))
|
|
|
|
|
|
|
|
|
|
(define (mark-stack-append a b)
|
|
|
|
|
(cond
|
|
|
|
|
[(not a) b]
|
|
|
|
|
[(not b) a]
|
|
|
|
|
[else
|
|
|
|
|
(make-mark-stack-frame (mark-stack-append (mark-stack-frame-prev a) b)
|
|
|
|
|
(mark-stack-frame-k a)
|
|
|
|
|
(mark-stack-frame-table a)
|
|
|
|
|
#f)]))
|
|
|
|
|
(car mark-stack)]))
|
|
|
|
|
|
|
|
|
|
;; ----------------------------------------
|
|
|
|
|
;; Continuation-mark caching
|
|
|
|
|
@ -1074,25 +1008,32 @@
|
|
|
|
|
(define-record elem+cache (elem cache))
|
|
|
|
|
(define (elem+cache-strip t) (if (elem+cache? t) (elem+cache-elem t) t))
|
|
|
|
|
|
|
|
|
|
;; Export this form renamed to `call-with-immediate-continuation-mark`.
|
|
|
|
|
;; It's a macro to ensure that the underlying `call-with-current-continuation-attachment`
|
|
|
|
|
;; is exposed.
|
|
|
|
|
(define-syntax (call-with-immediate-continuation-mark/inline stx)
|
|
|
|
|
(syntax-case stx (lambda)
|
|
|
|
|
[(_ key-expr proc-expr)
|
|
|
|
|
#'(call-with-immediate-continuation-mark/inline key-expr proc-expr #f)]
|
|
|
|
|
[(_ key-expr (lambda (arg) body ...) default-v-expr)
|
|
|
|
|
#'(call-with-current-continuation-attachment
|
|
|
|
|
empty-mark-frame
|
|
|
|
|
(lambda (a)
|
|
|
|
|
(let* ([key key-expr]
|
|
|
|
|
[default-v default-v-expr]
|
|
|
|
|
[arg (extract-mark-from-frame a key default-v)])
|
|
|
|
|
body ...)))]
|
|
|
|
|
[(_ arg ...)
|
|
|
|
|
#'(call-with-immediate-continuation-mark arg ...)]
|
|
|
|
|
[_
|
|
|
|
|
#'call-with-immediate-continuation-mark]))
|
|
|
|
|
|
|
|
|
|
(define/who call-with-immediate-continuation-mark
|
|
|
|
|
(case-lambda
|
|
|
|
|
[(key proc) (call-with-immediate-continuation-mark key proc #f)]
|
|
|
|
|
[(key proc default-v)
|
|
|
|
|
(check who (procedure-arity-includes/c 1) proc)
|
|
|
|
|
(let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'call-with-immediate-continuation-mark key)])
|
|
|
|
|
(cond
|
|
|
|
|
[(not (current-mark-stack)) (|#%app| proc default-v)]
|
|
|
|
|
[else
|
|
|
|
|
(call/cc (lambda (k)
|
|
|
|
|
(when (eq? k (current-empty-k)) (merge-mark-splice!))
|
|
|
|
|
(if (eq? k (mark-stack-frame-k (current-mark-stack)))
|
|
|
|
|
(|#%app| proc (let ([v (mark-table-ref (mark-stack-frame-table (current-mark-stack))
|
|
|
|
|
key
|
|
|
|
|
none)])
|
|
|
|
|
(if (eq? v none)
|
|
|
|
|
default-v
|
|
|
|
|
(wrapper v))))
|
|
|
|
|
(|#%app| proc default-v))))]))]))
|
|
|
|
|
(call-with-immediate-continuation-mark/inline key (lambda (arg) (proc arg)) default-v)]))
|
|
|
|
|
|
|
|
|
|
(define/who continuation-mark-set-first
|
|
|
|
|
(case-lambda
|
|
|
|
|
@ -1244,9 +1185,9 @@
|
|
|
|
|
|
|
|
|
|
(define/who continuation-mark-set->list*
|
|
|
|
|
(case-lambda
|
|
|
|
|
[(marks keys) (continuation-mark-set->list* marks keys the-default-continuation-prompt-tag #f)]
|
|
|
|
|
[(marks keys prompt-tag) (continuation-mark-set->list* marks keys prompt-tag #f)]
|
|
|
|
|
[(marks keys prompt-tag none-v)
|
|
|
|
|
[(marks keys) (continuation-mark-set->list* marks keys #f the-default-continuation-prompt-tag)]
|
|
|
|
|
[(marks keys none-v) (continuation-mark-set->list* marks keys none-v the-default-continuation-prompt-tag)]
|
|
|
|
|
[(marks keys none-v prompt-tag)
|
|
|
|
|
(check who continuation-mark-set? :or-false marks)
|
|
|
|
|
(check who list? keys)
|
|
|
|
|
(check who continuation-prompt-tag? prompt-tag)
|
|
|
|
|
@ -1270,18 +1211,10 @@
|
|
|
|
|
[(eq? (mark-chain-frame-tag mcf) prompt-tag)
|
|
|
|
|
null]
|
|
|
|
|
[else
|
|
|
|
|
(let loop ([marks (let ([marks (mark-chain-frame-marks mcf)])
|
|
|
|
|
(if (splice-next? mark-chain)
|
|
|
|
|
;; handle splicing (created by applying a composable
|
|
|
|
|
;; continuation to a context that had marks already)
|
|
|
|
|
(append marks
|
|
|
|
|
(mark-chain-frame-marks (elem+cache-strip (cadr mark-chain))))
|
|
|
|
|
marks))])
|
|
|
|
|
(let loop ([marks (mark-chain-frame-marks mcf)])
|
|
|
|
|
(cond
|
|
|
|
|
[(null? marks)
|
|
|
|
|
(chain-loop (if (splice-next? mark-chain)
|
|
|
|
|
(cddr mark-chain)
|
|
|
|
|
(cdr mark-chain)))]
|
|
|
|
|
(chain-loop (cdr mark-chain))]
|
|
|
|
|
[else
|
|
|
|
|
(let ([t (elem+cache-strip (car marks))])
|
|
|
|
|
(let key-loop ([keys all-keys] [wrappers all-wrappers] [i 0] [found? #f])
|
|
|
|
|
@ -1311,6 +1244,7 @@
|
|
|
|
|
[(tag)
|
|
|
|
|
(check who continuation-prompt-tag? tag)
|
|
|
|
|
(maybe-future-barricade tag)
|
|
|
|
|
(check-prompt-tag-available who tag)
|
|
|
|
|
(call/cc
|
|
|
|
|
(lambda (k)
|
|
|
|
|
(make-continuation-mark-set (prune-mark-chain-suffix (strip-impersonator tag) (current-mark-chain))
|
|
|
|
|
@ -1660,7 +1594,7 @@
|
|
|
|
|
|
|
|
|
|
(define-virtual-register current-winders '())
|
|
|
|
|
|
|
|
|
|
(define-record winder (depth k pre post mark-stack))
|
|
|
|
|
(define-record winder (depth k pre post))
|
|
|
|
|
|
|
|
|
|
;; Jobs for `dynamic-wind`:
|
|
|
|
|
|
|
|
|
|
@ -1687,8 +1621,7 @@
|
|
|
|
|
(fx+ 1 (winder-depth (car winders))))
|
|
|
|
|
k
|
|
|
|
|
pre
|
|
|
|
|
post
|
|
|
|
|
(current-mark-stack))])
|
|
|
|
|
post)])
|
|
|
|
|
(start-uninterrupted 'dw)
|
|
|
|
|
(begin
|
|
|
|
|
(call-winder-thunk 'dw-pre pre)
|
|
|
|
|
@ -1703,9 +1636,9 @@
|
|
|
|
|
(lambda () (apply values args))))))))))
|
|
|
|
|
|
|
|
|
|
(define (call-winder-thunk who thunk)
|
|
|
|
|
(call/cm/nontail
|
|
|
|
|
(with-continuation-mark
|
|
|
|
|
break-enabled-key (make-thread-cell #f #t)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(begin
|
|
|
|
|
(end-uninterrupted who)
|
|
|
|
|
(thunk)
|
|
|
|
|
(start-uninterrupted who))))
|
|
|
|
|
@ -1721,7 +1654,6 @@
|
|
|
|
|
(let ([winder (car winders)]
|
|
|
|
|
[winders (cdr winders)])
|
|
|
|
|
(current-winders winders)
|
|
|
|
|
(current-mark-stack (winder-mark-stack winder))
|
|
|
|
|
(let ([thunk (winder-thunk winder)])
|
|
|
|
|
((winder-k winder)
|
|
|
|
|
(lambda ()
|
|
|
|
|
@ -1782,9 +1714,9 @@
|
|
|
|
|
;; Breaks
|
|
|
|
|
|
|
|
|
|
(define (call-with-break-disabled thunk)
|
|
|
|
|
(call/cm
|
|
|
|
|
(with-continuation-mark
|
|
|
|
|
break-enabled-key (make-thread-cell #f #t)
|
|
|
|
|
thunk))
|
|
|
|
|
(thunk)))
|
|
|
|
|
|
|
|
|
|
;; Some points where we jump out of uninterrupted mode are also points
|
|
|
|
|
;; where we might jump to a context where breaks are allowed. The
|
|
|
|
|
@ -1827,7 +1759,6 @@
|
|
|
|
|
(current-metacontinuation (saved-metacontinuation-mc saved))
|
|
|
|
|
(#%$current-winders (saved-metacontinuation-system-winders saved))
|
|
|
|
|
(current-exception-state (saved-metacontinuation-exn-state saved))
|
|
|
|
|
(current-empty-k #f)
|
|
|
|
|
(set! saved #f) ; break link for space safety
|
|
|
|
|
(proc now-saved))))]))
|
|
|
|
|
|
|
|
|
|
|
Matthew Flatt