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

cs: streamline continuation application slightly

Browse Source 
Avoid some allocation and indirect calls, and add a shortcut for the
case where there are no winder changes, no mark changes, etc.
This commit is contained in:
Matthew Flatt 2019-10-10 09:22:46 -06:00
parent d49b182cf4
commit 67a7a5c869
1 changed files with 75 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -420,11 +420,11 @@
'() '()
;; No winders left: ;; No winders left:
(lambda () (lambda ()
(do-abort-current-continuation who tag args wind?)) (do-abort-current-continuation who tag args #t))
;; If the metacontinuation changes, check target before retrying: ;; If the metacontinuation changes, check target before retrying:
(lambda () (lambda ()
(check-prompt-still-available who tag) (check-prompt-still-available who tag)
(do-abort-current-continuation who tag args wind?)))])) (do-abort-current-continuation who tag args #t)))]))
(define (check-prompt-still-available who tag) (define (check-prompt-still-available who tag)
(unless (continuation-prompt-available? tag) (unless (continuation-prompt-available? tag)
@ -551,63 +551,76 @@
(define (apply-non-composable-continuation c args) (define (apply-non-composable-continuation c args)
(assert-in-uninterrupted) (assert-in-uninterrupted)
(let* ([tag (full-continuation-tag c)]) (let ([mc (current-metacontinuation)]
(let-values ([(common-mc ; shared part of the current metacontinuation [c-mc (full-continuation-mc c)]
rmc-append) ; non-shared part of the destination metacontinuation [tag (full-continuation-tag c)])
;; We check every time, just in case control operations (cond
;; change the current continuation out from under us. [(and (null? c-mc)
(find-common-metacontinuation (full-continuation-mc c) (pair? mc)
(current-metacontinuation) (not (impersonator? tag))
(strip-impersonator tag))]) (eq? tag (metacontinuation-frame-tag (car mc)))
(let loop () (same-winders? (current-winders) (full-continuation-winders c))
(cond (eq? (current-mark-splice) (full-continuation-mark-splice c))
[(eq? common-mc (current-metacontinuation)) (eq? (continuation-next-attachments (full-continuation-k c))
;; Replace the current metacontinuation frame's continuation (current-mark-stack)))
;; with the saved one; this replacement will take care of any ;; Short cut: jump within the same metacontinuation, no winder
;; shared winders within the frame. ;; changes or changes to marks, and no tag impersonators to deal with
(apply-immediate-continuation c rmc-append args)] ((full-continuation-k c) (lambda () (end-uninterrupted-with-values/same-marks args)))]
[else [else
;; Unwind this metacontinuation frame: (let-values ([(common-mc ; shared part of the current metacontinuation
(wind-to rmc-append) ; non-shared part of the destination metacontinuation
'() ;; We check every time, just in case control operations
;; If all winders complete simply: ;; change the current continuation out from under us.
(lambda () (find-common-metacontinuation c-mc
(pop-metacontinuation-frame) mc
(loop)) (strip-impersonator tag))])
;; If a winder changes the metacontinuation, then (let loop ()
;; start again: (cond
(lambda () [(eq? common-mc (current-metacontinuation))
(apply-non-composable-continuation c args)))]))))) ;; Replace the current metacontinuation frame's continuation
;; with the saved one; this replacement will take care of any
;; shared winders within the frame.
(apply-immediate-continuation c rmc-append args)]
[else
;; Unwind this metacontinuation frame:
(wind-to
'()
;; If all winders complete simply:
(lambda ()
(pop-metacontinuation-frame)
(loop))
;; If a winder changes the metacontinuation, then
;; start again:
(lambda ()
(apply-non-composable-continuation c args)))])))])))
;; Apply a continuation within the current metacontinuation frame: ;; Apply a continuation within the current metacontinuation frame:
(define (apply-immediate-continuation c rmc args) (define (apply-immediate-continuation c rmc args)
(assert-in-uninterrupted) (assert-in-uninterrupted)
(call-with-appended-metacontinuation (apply-continuation-with-appended-metacontinuation rmc c args))
rmc
c (define (apply-continuation-within-metacontinuation c args)
args (let ([mark-stack (full-continuation-mark-stack c)])
(lambda () (current-mark-splice (let ([mark-splice (full-continuation-mark-splice c)])
(let ([mark-stack (full-continuation-mark-stack c)]) (if (composable-continuation? c)
(current-mark-splice (let ([mark-splice (full-continuation-mark-splice c)]) (merge-mark-splice mark-splice (current-mark-splice))
(if (composable-continuation? c) mark-splice)))
(merge-mark-splice mark-splice (current-mark-splice)) (wind-to
mark-splice))) (full-continuation-winders c)
(wind-to ;; When no winders are left:
(full-continuation-winders c) (lambda ()
;; When no winders are left: (when (non-composable-continuation? c)
(lambda () ;; Activate/add cc-guards in target prompt; any user-level
(when (non-composable-continuation? c) ;; callbacks here are run with a continuation barrier, so
;; Activate/add cc-guards in target prompt; any user-level ;; the metacontinuation won't change (except by escaping):
;; callbacks here are run with a continuation barrier, so (activate-and-wrap-cc-guard-for-impersonator!
;; the metacontinuation won't change (except by escaping): (full-continuation-tag c)))
(activate-and-wrap-cc-guard-for-impersonator! ((full-continuation-k c) (lambda () (end-uninterrupted-with-values args))))
(full-continuation-tag c))) ;; If a winder changed the meta-continuation, try again for a
((full-continuation-k c) (lambda () (end-uninterrupted-with-values args)))) ;; non-composable continuation:
;; If a winder changed the meta-continuation, try again for a (and (non-composable-continuation? c)
;; non-composable continuation: (lambda ()
(and (non-composable-continuation? c) (apply-non-composable-continuation c args))))))
(lambda ()
(apply-non-composable-continuation c args))))))))
;; Like `apply-immediate-continuation`, but don't run winders ;; Like `apply-immediate-continuation`, but don't run winders
(define (apply-immediate-continuation/no-wind c args) (define (apply-immediate-continuation/no-wind c args)
@ -739,7 +752,7 @@
exn:fail:contract:continuation exn:fail:contract:continuation
(list "tag" tag))) (list "tag" tag)))
(define (call-with-appended-metacontinuation rmc dest-c dest-args proc) (define (apply-continuation-with-appended-metacontinuation rmc dest-c dest-args)
;; Assumes that the current metacontinuation frame is ready to be ;; Assumes that the current metacontinuation frame is ready to be
;; replaced with `mc` (reversed as `rmc`) plus `proc`. ;; replaced with `mc` (reversed as `rmc`) plus `proc`.
;; In the simple case of no winders and an empty frame immediate ;; In the simple case of no winders and an empty frame immediate
@ -750,7 +763,7 @@
(assert-in-uninterrupted) (assert-in-uninterrupted)
(let loop ([rmc rmc]) (let loop ([rmc rmc])
(cond (cond
[(null? rmc) (proc)] [(null? rmc) (apply-continuation-within-metacontinuation dest-c dest-args)]
[else [else
(let ([mf (maybe-merge-splice (composable-continuation? dest-c) (let ([mf (maybe-merge-splice (composable-continuation? dest-c)
(metacontinuation-frame-clear-cache (car rmc)))] (metacontinuation-frame-clear-cache (car rmc)))]
@ -1026,6 +1039,11 @@
(end-uninterrupted/call-hook 'cc) (end-uninterrupted/call-hook 'cc)
(#%apply values args)) (#%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)))