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

cs: improve composable continuation

Browse Source 
Refactor to move some composable-continuation support out of the
way of prompts, and add a shortcut for simple composition cases.

Also, fix stack traces with continuation barriers and composable
composition, which could show sections of a trace duplicated.
This commit is contained in:
Matthew Flatt 2019-10-23 06:48:29 -06:00
parent f01a561c47
commit 5bce9e822f
3 changed files with 136 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
pkgs/racket-benchmarks/tests/racket/benchmarks/control/compose.rkt Normal file
View File

@ -0,0 +1,28 @@
#lang racket/base
(require racket/include)
(include "config.rktl")
;; ----------------------------------------
'capture
(times
(call-with-continuation-prompt
(lambda ()
(let loop ([i M] [k #f])
(unless (zero? i)
(loop (- i 1)
(call-with-composable-continuation
(lambda (k) k))))))))
'compose
(times
(let ([one #f])
(call-with-continuation-prompt
(lambda ()
(call-with-composable-continuation
(lambda (k) (set! one k)))
1))
(let loop ([i M])
(unless (zero? i)
(loop (- i (one)))))))

3
racket/src/cs/demo/control.ss
View File

@ -48,6 +48,9 @@
tag1) tag1)
10) 10)
(check (call-with-composable-continuation (lambda (k) 5))
5)
(check (let ([saved #f]) (check (let ([saved #f])
(let ([a (call-with-continuation-prompt (let ([a (call-with-continuation-prompt
(lambda () (lambda ()

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

@ -221,8 +221,7 @@
(wrap-handler-for-impersonator (wrap-handler-for-impersonator
tag tag
(or handler (make-default-abort-handler tag))) (or handler (make-default-abort-handler tag)))
#f ; not a tail call empty-mark-frame ; new splice
#t ; delimit
(lambda () (lambda ()
(end-uninterrupted 'prompt) (end-uninterrupted 'prompt)
;; Finally, apply the given function: ;; Finally, apply the given function:
@ -233,7 +232,7 @@
(check 'default-continuation-prompt-handler (procedure-arity-includes/c 0) abort-thunk) (check 'default-continuation-prompt-handler (procedure-arity-includes/c 0) abort-thunk)
(call-with-continuation-prompt abort-thunk tag #f))) (call-with-continuation-prompt abort-thunk tag #f)))
(define (resume-metacontinuation delimited? results) (define (resume-metacontinuation results)
;; pop a metacontinuation frame ;; pop a metacontinuation frame
(cond (cond
[(null? (current-metacontinuation)) (engine-return)] [(null? (current-metacontinuation)) (engine-return)]
@ -242,9 +241,7 @@
(let ([mf (car (current-metacontinuation))]) (let ([mf (car (current-metacontinuation))])
(pop-metacontinuation-frame) (pop-metacontinuation-frame)
;; resume ;; resume
(if delimited? ((metacontinuation-frame-resume-k mf) results))]))
((metacontinuation-frame-resume-k mf) results)
results))]))
(define (pop-metacontinuation-frame) (define (pop-metacontinuation-frame)
(let ([mf (car (current-metacontinuation))]) (let ([mf (car (current-metacontinuation))])
@ -252,89 +249,67 @@
(current-winders (metacontinuation-frame-winders mf)) (current-winders (metacontinuation-frame-winders mf))
(current-mark-splice (metacontinuation-frame-mark-splice mf)))) (current-mark-splice (metacontinuation-frame-mark-splice mf))))
(define (call-in-empty-metacontinuation-frame tag handler tail? delimit? proc) (define (call-in-empty-metacontinuation-frame tag handler new-splice proc)
;; Call `proc` in an empty metacontinuation frame, reifying the ;; Call `proc` in an empty metacontinuation frame, reifying the
;; current metacontinuation as needed (i.e., if non-empty) as a new ;; current metacontinuation as needed (i.e., if non-empty) as a new
;; frame on `*metacontinuations*`; if the tag is #f and the ;; frame on `*metacontinuations*`; if the tag is #f and the
;; current metacontinuation frame is already empty, don't push more ;; current metacontinuation frame is already empty, don't push more
(assert-in-uninterrupted) (assert-in-uninterrupted)
(assert-not-in-system-wind) (assert-not-in-system-wind)
(call-getting-continuation-attachment (let ([r ; a list of results, or a non-list for special handling
'none (call/cc
(lambda (at) (lambda (resume-k)
(cond ;; the `call/cc` to get `k` created a new stack
[(and (eq? tag the-compose-prompt-tag) ;; segment; by dropping the link from the current
(eq? at 'empty)) ;; segment to the return context referenced by `k`,
;; empty continuation in the current frame; don't push a new ;; we actually delimit the current continuation:
;; metacontinuation frame (#%$current-stack-link #%$null-continuation)
(proc)] (current-mark-stack '())
[else (let-values ([results
((if tail? call/cc (lambda (proc) (proc #f))) ;; mark the "empty" continuation frame
(lambda (from-k) ;; that just continues the metacontinuation:
(let ([new-splice (if tail? (call-setting-continuation-attachment
(keep-immediate-attachment (current-mark-stack) 'empty
(continuation-next-attachments from-k)) (lambda ()
empty-mark-frame)]) (let ([mf (make-metacontinuation-frame tag
(when tail? resume-k
;; Prune splicing marks from `resume-k` by dropping the difference (current-winders)
;; between `from-k` and `resume-k`: (current-mark-splice)
(current-mark-stack (continuation-next-attachments from-k))) #f
(let ([r ; a list of results, or a non-list for special handling #f
(call/cc ; <- could use `call/1cc` if not `delimit?` #f
(lambda (resume-k) #f)])
(when delimit? (current-winders '())
;; the `call/cc` to get `k` created a new stack (current-mark-splice new-splice)
;; segment; by dropping the link from the current ;; push the metacontinuation:
;; segment to the return context referenced by `k`, (current-metacontinuation (cons mf (current-metacontinuation)))
;; we actually delimit the current continuation: ;; ready:
(#%$current-stack-link #%$null-continuation)) (proc))))])
(current-mark-stack '()) ;; Prepare to use cc-guard, if one was enabled:
(let-values ([results (let ([cc-guard (metacontinuation-frame-cc-guard (car (current-metacontinuation)))])
;; mark the "empty" continuation frame ;; Continue normally; the metacontinuation could be different
;; that just continues the metacontinuation: ;; than when we captured this metafunction frame, though:
(call-setting-continuation-attachment (resume-metacontinuation
'empty ;; Apply the cc-guard, if any, outside of the prompt:
(lambda () (if cc-guard
(let ([mf (make-metacontinuation-frame tag (lambda () (apply cc-guard results))
resume-k results))))))])
(current-winders) (cond
(current-mark-splice) [(aborting? r)
#f ;; Remove the prompt as we call the handler:
#f (pop-metacontinuation-frame)
#f (end-uninterrupted/call-hook 'handle)
#f)]) (apply handler
(current-winders '()) (aborting-args r))]
(current-mark-splice new-splice) [else
;; push the metacontinuation: ;; We're returning normally; the metacontinuation frame has
(current-metacontinuation (cons mf (current-metacontinuation))) ;; been popped already by `resume-metacontinuation`
;; ready: (end-uninterrupted 'resume)
(proc))))]) (if (#%procedure? r)
;; Prepare to use cc-guard, if one was enabled: (r)
(let ([cc-guard (metacontinuation-frame-cc-guard (car (current-metacontinuation)))]) (if (and (pair? r) (null? (cdr r)))
;; Continue normally; the metacontinuation could be different (car r)
;; than when we captured this metafunction frame, though: (#%apply values r)))])))
(resume-metacontinuation
delimit?
;; 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)))])))))]))))
;; Simplified `call-in-empty-metacontinuation-frame` suitable for swapping engines: ;; Simplified `call-in-empty-metacontinuation-frame` suitable for swapping engines:
(define (call-with-empty-metacontinuation-frame-for-swap proc) (define (call-with-empty-metacontinuation-frame-for-swap proc)
@ -360,6 +335,30 @@
(pop-metacontinuation-frame) (pop-metacontinuation-frame)
((metacontinuation-frame-resume-k mf) r))))))) ((metacontinuation-frame-resume-k mf) r)))))))
(define (call-in-empty-metacontinuation-frame-for-compose proc)
(call-getting-continuation-attachment
'none
(lambda (at)
(cond
[(eq? at 'empty)
;; empty continuation in the current frame; don't push a new
;; 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))))]))))
(define (metacontinuation-frame-update-mark-splice current-mf mark-splice) (define (metacontinuation-frame-update-mark-splice current-mf mark-splice)
(make-metacontinuation-frame (metacontinuation-frame-tag current-mf) (make-metacontinuation-frame (metacontinuation-frame-tag current-mf)
(metacontinuation-frame-resume-k current-mf) (metacontinuation-frame-resume-k current-mf)
@ -448,8 +447,7 @@
(call-in-empty-metacontinuation-frame (call-in-empty-metacontinuation-frame
the-barrier-prompt-tag ; <- recognized as a barrier by continuation capture or call the-barrier-prompt-tag ; <- recognized as a barrier by continuation capture or call
#f #f
#f ; not a tail call empty-mark-frame ; new splice
#f ; no need to delimit
(lambda () (lambda ()
(end-uninterrupted 'barrier) (end-uninterrupted 'barrier)
(|#%app| p)))) (|#%app| p))))
@ -459,8 +457,7 @@
(define-record continuation ()) (define-record continuation ())
(define-record full-continuation continuation (k winders mark-stack mark-splice mc tag)) (define-record full-continuation continuation (k winders mark-stack mark-splice mc tag))
(define-record composable-continuation full-continuation ()) (define-record composable-continuation full-continuation (wind?))
(define-record composable-continuation/no-wind composable-continuation ())
(define-record non-composable-continuation full-continuation ()) (define-record non-composable-continuation full-continuation ())
(define-record escape-continuation continuation (tag)) (define-record escape-continuation continuation (tag))
@ -498,15 +495,14 @@
(lambda (k) (lambda (k)
(|#%app| (|#%app|
p p
((if wind? (make-composable-continuation
make-composable-continuation
make-composable-continuation/no-wind)
k k
(current-winders) (current-winders)
(current-mark-stack) (current-mark-stack)
(current-mark-splice) (current-mark-splice)
(extract-metacontinuation 'call-with-composable-continuation (strip-impersonator tag) #f) (extract-metacontinuation 'call-with-composable-continuation (strip-impersonator tag) #f)
tag))))) tag
wind?)))))
(define (unsafe-call-with-composable-continuation/no-wind p tag) (define (unsafe-call-with-composable-continuation/no-wind p tag)
(call-with-composable-continuation* p tag #f)) (call-with-composable-continuation* p tag #f))
@ -527,18 +523,26 @@
[(composable-continuation? c) [(composable-continuation? c)
;; To compose the metacontinuation, first make sure the current ;; To compose the metacontinuation, first make sure the current
;; continuation is reified in `(current-metacontinuation)`: ;; continuation is reified in `(current-metacontinuation)`:
(call-in-empty-metacontinuation-frame (call-in-empty-metacontinuation-frame-for-compose
the-compose-prompt-tag
fail-abort-to-delimit-continuation
#t ; a tail call
#f ; no need to delimit
(lambda () (lambda ()
;; The current metacontinuation frame has an ;; The current metacontinuation frame has an
;; empty continuation, so we can "replace" that ;; empty continuation, so we can "replace" that
;; with the composable one: ;; with the composable one:
(if (composable-continuation/no-wind? c) (cond
(apply-immediate-continuation/no-wind c args) [(and (null? (full-continuation-mc c))
(apply-immediate-continuation c (reverse (full-continuation-mc c)) args))))] (null? (full-continuation-winders c))
(eq? (current-mark-splice) (full-continuation-mark-splice c))
(let ([marks (continuation-next-attachments (full-continuation-k c))])
(or (null? marks)
(and (null? (cdr marks))
(eq? (car marks) 'empty)))))
;; Shortcut for no winds and no change to break status:
(end-uninterrupted 'cc)
(#%apply (full-continuation-k c) args)]
[(not (composable-continuation-wind? c))
(apply-immediate-continuation/no-wind c args)]
[else
(apply-immediate-continuation c (reverse (full-continuation-mc c)) args)])))]
[(non-composable-continuation? c) [(non-composable-continuation? c)
(apply-non-composable-continuation c args)] (apply-non-composable-continuation c args)]
[(escape-continuation? c) [(escape-continuation? c)
@ -567,7 +571,7 @@
;; changes or changes to marks (so no break-enabled changes), ;; changes or changes to marks (so no break-enabled changes),
;; and no tag impersonators to deal with ;; and no tag impersonators to deal with
(end-uninterrupted 'cc) (end-uninterrupted 'cc)
(apply (full-continuation-k c) args)] (#%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
@ -713,7 +717,6 @@
(lambda (c . args) (lambda (c . args)
(apply-continuation c args))))]) (apply-continuation c args))))])
(add (record-type-descriptor composable-continuation)) (add (record-type-descriptor composable-continuation))
(add (record-type-descriptor composable-continuation/no-wind))
(add (record-type-descriptor non-composable-continuation)) (add (record-type-descriptor non-composable-continuation))
(add (record-type-descriptor escape-continuation)))) (add (record-type-descriptor escape-continuation))))
@ -1907,7 +1910,7 @@
;; the difference, and its only options are to return or escape. ;; the difference, and its only options are to return or escape.
(current-mark-stack (continuation-next-attachments k)) (current-mark-stack (continuation-next-attachments k))
(break-enabled-transition-hook) (break-enabled-transition-hook)
(apply k args)) (#%apply k args))
;; ---------------------------------------- ;; ----------------------------------------
;; Metacontinuation swapping for engines ;; Metacontinuation swapping for engines