cs: significantly improve continuation capture and application
Avoid a continuation frame and layer of thunks that was in place for checking for breaks just after applying a continuation. Instead, we install just the continuation marks and check for breaks before actually jumping; the break checker can't tell the difference, since marks are the only way for it to check the continuation. This improvement cust about 40% of the time for simple continuation capture and application.
This commit is contained in:
parent
7f04322531
commit
9ce8713cdc
|
@ -472,7 +472,7 @@
|
||||||
(check who (procedure-arity-includes/c 1) proc)
|
(check who (procedure-arity-includes/c 1) proc)
|
||||||
(check who continuation-prompt-tag? tag)
|
(check who continuation-prompt-tag? tag)
|
||||||
(maybe-future-barricade tag)
|
(maybe-future-barricade tag)
|
||||||
(call/cc/end-uninterrupted
|
(call/cc
|
||||||
(lambda (k)
|
(lambda (k)
|
||||||
(|#%app|
|
(|#%app|
|
||||||
proc
|
proc
|
||||||
|
@ -494,7 +494,7 @@
|
||||||
(call-with-composable-continuation* p tag #t)]))
|
(call-with-composable-continuation* p tag #t)]))
|
||||||
|
|
||||||
(define (call-with-composable-continuation* p tag wind?)
|
(define (call-with-composable-continuation* p tag wind?)
|
||||||
(call/cc/end-uninterrupted
|
(call/cc
|
||||||
(lambda (k)
|
(lambda (k)
|
||||||
(|#%app|
|
(|#%app|
|
||||||
p
|
p
|
||||||
|
@ -564,8 +564,10 @@
|
||||||
(eq? (continuation-next-attachments (full-continuation-k c))
|
(eq? (continuation-next-attachments (full-continuation-k c))
|
||||||
(current-mark-stack)))
|
(current-mark-stack)))
|
||||||
;; Short cut: jump within the same metacontinuation, no winder
|
;; Short cut: jump within the same metacontinuation, no winder
|
||||||
;; changes or changes to marks, and no tag impersonators to deal with
|
;; changes or changes to marks (so no break-enabled changes),
|
||||||
((full-continuation-k c) (lambda () (end-uninterrupted-with-values/same-marks args)))]
|
;; and no tag impersonators to deal with
|
||||||
|
(end-uninterrupted 'cc)
|
||||||
|
(apply (full-continuation-k c) args)]
|
||||||
[else
|
[else
|
||||||
(let-values ([(common-mc ; shared part of the current metacontinuation
|
(let-values ([(common-mc ; shared part of the current metacontinuation
|
||||||
rmc-append) ; non-shared part of the destination metacontinuation
|
rmc-append) ; non-shared part of the destination metacontinuation
|
||||||
|
@ -615,7 +617,8 @@
|
||||||
;; the metacontinuation won't change (except by escaping):
|
;; the metacontinuation won't change (except by escaping):
|
||||||
(activate-and-wrap-cc-guard-for-impersonator!
|
(activate-and-wrap-cc-guard-for-impersonator!
|
||||||
(full-continuation-tag c)))
|
(full-continuation-tag c)))
|
||||||
((full-continuation-k c) (lambda () (end-uninterrupted-with-values args))))
|
(end-uninterrupted 'cc)
|
||||||
|
(apply-with-break-transition (full-continuation-k c) args))
|
||||||
;; If a winder changed the meta-continuation, try again for a
|
;; If a winder changed the meta-continuation, try again for a
|
||||||
;; non-composable continuation:
|
;; non-composable continuation:
|
||||||
(and (non-composable-continuation? c)
|
(and (non-composable-continuation? c)
|
||||||
|
@ -629,7 +632,8 @@
|
||||||
(current-metacontinuation)))
|
(current-metacontinuation)))
|
||||||
(current-winders (full-continuation-winders c))
|
(current-winders (full-continuation-winders c))
|
||||||
(current-mark-splice (full-continuation-mark-splice c))
|
(current-mark-splice (full-continuation-mark-splice c))
|
||||||
((full-continuation-k c) (lambda () (end-uninterrupted-with-values args))))
|
(end-uninterrupted 'cc)
|
||||||
|
(apply-with-break-transition (full-continuation-k c) args))
|
||||||
|
|
||||||
;; Used as a "handler" for a prompt without a tag, which is used for
|
;; Used as a "handler" for a prompt without a tag, which is used for
|
||||||
;; composable continuations
|
;; composable continuations
|
||||||
|
@ -1024,26 +1028,6 @@
|
||||||
[else
|
[else
|
||||||
(#%error 'with-continuation-mark* "unrecognized mode: ~s" #'mode)])])))
|
(#%error 'with-continuation-mark* "unrecognized mode: ~s" #'mode)])])))
|
||||||
|
|
||||||
;; Return a continuation that expects a thunk to resume. That way, we
|
|
||||||
;; can can an `(end-uninterrupted)` and check for breaks in the
|
|
||||||
;; destination continuation
|
|
||||||
(define (call/cc/end-uninterrupted proc)
|
|
||||||
((call/cc
|
|
||||||
(lambda (k)
|
|
||||||
(lambda ()
|
|
||||||
(proc k))))))
|
|
||||||
|
|
||||||
;; Called on the arguments to return to a continuation
|
|
||||||
;; captured by `call/cc/end-uninterrupted`:
|
|
||||||
(define (end-uninterrupted-with-values args)
|
|
||||||
(end-uninterrupted/call-hook 'cc)
|
|
||||||
(#%apply values args))
|
|
||||||
|
|
||||||
;; When marks didn't change, then no need to call the hook:
|
|
||||||
(define (end-uninterrupted-with-values/same-marks args)
|
|
||||||
(end-uninterrupted 'cc)
|
|
||||||
(#%apply values args))
|
|
||||||
|
|
||||||
(define (current-mark-chain)
|
(define (current-mark-chain)
|
||||||
(get-mark-chain (current-mark-stack) (current-mark-splice) (current-metacontinuation)))
|
(get-mark-chain (current-mark-stack) (current-mark-splice) (current-metacontinuation)))
|
||||||
|
|
||||||
|
@ -1915,6 +1899,16 @@
|
||||||
(define (set-break-enabled-transition-hook! proc)
|
(define (set-break-enabled-transition-hook! proc)
|
||||||
(set! break-enabled-transition-hook proc))
|
(set! break-enabled-transition-hook proc))
|
||||||
|
|
||||||
|
(define (apply-with-break-transition k args)
|
||||||
|
;; Install attachments of `k` before calling
|
||||||
|
;; `break-enabled-transition-hook`. Technically, the hook is called
|
||||||
|
;; with the wrong Scheme continuation, which might keep the
|
||||||
|
;; continuation live longer than it should. But the hook can't see
|
||||||
|
;; the difference, and its only options are to return or escape.
|
||||||
|
(current-mark-stack (continuation-next-attachments k))
|
||||||
|
(break-enabled-transition-hook)
|
||||||
|
(apply k args))
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
;; Metacontinuation swapping for engines
|
;; Metacontinuation swapping for engines
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user