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

46
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,13 +551,28 @@
(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)]
[c-mc (full-continuation-mc c)]
[tag (full-continuation-tag c)])
(cond
[(and (null? c-mc)
(pair? mc)
(not (impersonator? tag))
(eq? tag (metacontinuation-frame-tag (car mc)))
(same-winders? (current-winders) (full-continuation-winders c))
(eq? (current-mark-splice) (full-continuation-mark-splice c))
(eq? (continuation-next-attachments (full-continuation-k c))
(current-mark-stack)))
;; Short cut: jump within the same metacontinuation, no winder
;; changes or changes to marks, and no tag impersonators to deal with
((full-continuation-k c) (lambda () (end-uninterrupted-with-values/same-marks args)))]
[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
;; We check every time, just in case control operations ;; We check every time, just in case control operations
;; change the current continuation out from under us. ;; change the current continuation out from under us.
(find-common-metacontinuation (full-continuation-mc c) (find-common-metacontinuation c-mc
(current-metacontinuation) mc
(strip-impersonator tag))]) (strip-impersonator tag))])
(let loop () (let loop ()
(cond (cond
@ -577,16 +592,14 @@
;; If a winder changes the metacontinuation, then ;; If a winder changes the metacontinuation, then
;; start again: ;; start again:
(lambda () (lambda ()
(apply-non-composable-continuation c args)))]))))) (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
(lambda ()
(let ([mark-stack (full-continuation-mark-stack c)]) (let ([mark-stack (full-continuation-mark-stack c)])
(current-mark-splice (let ([mark-splice (full-continuation-mark-splice c)]) (current-mark-splice (let ([mark-splice (full-continuation-mark-splice c)])
(if (composable-continuation? c) (if (composable-continuation? c)
@ -607,7 +620,7 @@
;; non-composable continuation: ;; non-composable continuation:
(and (non-composable-continuation? c) (and (non-composable-continuation? c)
(lambda () (lambda ()
(apply-non-composable-continuation c args)))))))) (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)))