From 5bce9e822f9a3619d131cfa061df5f5f34ce0942 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 23 Oct 2019 06:48:29 -0600 Subject: [PATCH] cs: improve composable continuation 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. --- .../racket/benchmarks/control/compose.rkt | 28 +++ racket/src/cs/demo/control.ss | 3 + racket/src/cs/rumble/control.ss | 207 +++++++++--------- 3 files changed, 136 insertions(+), 102 deletions(-) create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/compose.rkt diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/compose.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/compose.rkt new file mode 100644 index 0000000000..eda4b9be43 --- /dev/null +++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/compose.rkt @@ -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))))))) diff --git a/racket/src/cs/demo/control.ss b/racket/src/cs/demo/control.ss index 26acc619a8..62287e9c88 100644 --- a/racket/src/cs/demo/control.ss +++ b/racket/src/cs/demo/control.ss @@ -48,6 +48,9 @@ tag1) 10) +(check (call-with-composable-continuation (lambda (k) 5)) + 5) + (check (let ([saved #f]) (let ([a (call-with-continuation-prompt (lambda () diff --git a/racket/src/cs/rumble/control.ss b/racket/src/cs/rumble/control.ss index 4899ce240d..960843a7c0 100644 --- a/racket/src/cs/rumble/control.ss +++ b/racket/src/cs/rumble/control.ss @@ -221,8 +221,7 @@ (wrap-handler-for-impersonator tag (or handler (make-default-abort-handler tag))) - #f ; not a tail call - #t ; delimit + empty-mark-frame ; new splice (lambda () (end-uninterrupted 'prompt) ;; Finally, apply the given function: @@ -233,7 +232,7 @@ (check 'default-continuation-prompt-handler (procedure-arity-includes/c 0) abort-thunk) (call-with-continuation-prompt abort-thunk tag #f))) -(define (resume-metacontinuation delimited? results) +(define (resume-metacontinuation results) ;; pop a metacontinuation frame (cond [(null? (current-metacontinuation)) (engine-return)] @@ -242,9 +241,7 @@ (let ([mf (car (current-metacontinuation))]) (pop-metacontinuation-frame) ;; resume - (if delimited? - ((metacontinuation-frame-resume-k mf) results) - results))])) + ((metacontinuation-frame-resume-k mf) results))])) (define (pop-metacontinuation-frame) (let ([mf (car (current-metacontinuation))]) @@ -252,89 +249,67 @@ (current-winders (metacontinuation-frame-winders 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 ;; current metacontinuation as needed (i.e., if non-empty) as a new ;; frame on `*metacontinuations*`; if the tag is #f and the ;; current metacontinuation frame is already empty, don't push more (assert-in-uninterrupted) (assert-not-in-system-wind) - (call-getting-continuation-attachment - 'none - (lambda (at) - (cond - [(and (eq? tag the-compose-prompt-tag) - (eq? at 'empty)) - ;; empty continuation in the current frame; don't push a new - ;; 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 ; <- could use `call/1cc` if not `delimit?` - (lambda (resume-k) - (when delimit? - ;; 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 - ;; mark the "empty" continuation frame - ;; that just continues the metacontinuation: - (call-setting-continuation-attachment - 'empty - (lambda () - (let ([mf (make-metacontinuation-frame tag - resume-k - (current-winders) - (current-mark-splice) - #f - #f - #f - #f)]) - (current-winders '()) - (current-mark-splice new-splice) - ;; push the metacontinuation: - (current-metacontinuation (cons mf (current-metacontinuation))) - ;; ready: - (proc))))]) - ;; Prepare to use cc-guard, if one was enabled: - (let ([cc-guard (metacontinuation-frame-cc-guard (car (current-metacontinuation)))]) - ;; Continue normally; the metacontinuation could be different - ;; than when we captured this metafunction frame, though: - (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)))])))))])))) + (let ([r ; a list of results, or a non-list for special handling + (call/cc + (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 + ;; mark the "empty" continuation frame + ;; that just continues the metacontinuation: + (call-setting-continuation-attachment + 'empty + (lambda () + (let ([mf (make-metacontinuation-frame tag + resume-k + (current-winders) + (current-mark-splice) + #f + #f + #f + #f)]) + (current-winders '()) + (current-mark-splice new-splice) + ;; push the metacontinuation: + (current-metacontinuation (cons mf (current-metacontinuation))) + ;; ready: + (proc))))]) + ;; Prepare to use cc-guard, if one was enabled: + (let ([cc-guard (metacontinuation-frame-cc-guard (car (current-metacontinuation)))]) + ;; Continue normally; the metacontinuation could be different + ;; than when we captured this metafunction frame, though: + (resume-metacontinuation + ;; 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: (define (call-with-empty-metacontinuation-frame-for-swap proc) @@ -360,6 +335,30 @@ (pop-metacontinuation-frame) ((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) (make-metacontinuation-frame (metacontinuation-frame-tag current-mf) (metacontinuation-frame-resume-k current-mf) @@ -448,8 +447,7 @@ (call-in-empty-metacontinuation-frame the-barrier-prompt-tag ; <- recognized as a barrier by continuation capture or call #f - #f ; not a tail call - #f ; no need to delimit + empty-mark-frame ; new splice (lambda () (end-uninterrupted 'barrier) (|#%app| p)))) @@ -459,8 +457,7 @@ (define-record continuation ()) (define-record full-continuation continuation (k winders mark-stack mark-splice mc tag)) -(define-record composable-continuation full-continuation ()) -(define-record composable-continuation/no-wind composable-continuation ()) +(define-record composable-continuation full-continuation (wind?)) (define-record non-composable-continuation full-continuation ()) (define-record escape-continuation continuation (tag)) @@ -498,15 +495,14 @@ (lambda (k) (|#%app| p - ((if wind? - make-composable-continuation - make-composable-continuation/no-wind) + (make-composable-continuation k (current-winders) (current-mark-stack) (current-mark-splice) (extract-metacontinuation 'call-with-composable-continuation (strip-impersonator tag) #f) - tag))))) + tag + wind?))))) (define (unsafe-call-with-composable-continuation/no-wind p tag) (call-with-composable-continuation* p tag #f)) @@ -527,18 +523,26 @@ [(composable-continuation? c) ;; To compose the metacontinuation, first make sure the current ;; continuation is reified in `(current-metacontinuation)`: - (call-in-empty-metacontinuation-frame - the-compose-prompt-tag - fail-abort-to-delimit-continuation - #t ; a tail call - #f ; no need to delimit + (call-in-empty-metacontinuation-frame-for-compose (lambda () ;; The current metacontinuation frame has an ;; empty continuation, so we can "replace" that ;; with the composable one: - (if (composable-continuation/no-wind? c) - (apply-immediate-continuation/no-wind c args) - (apply-immediate-continuation c (reverse (full-continuation-mc c)) args))))] + (cond + [(and (null? (full-continuation-mc c)) + (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) (apply-non-composable-continuation c args)] [(escape-continuation? c) @@ -567,7 +571,7 @@ ;; changes or changes to marks (so no break-enabled changes), ;; and no tag impersonators to deal with (end-uninterrupted 'cc) - (apply (full-continuation-k c) args)] + (#%apply (full-continuation-k c) args)] [else (let-values ([(common-mc ; shared part of the current metacontinuation rmc-append) ; non-shared part of the destination metacontinuation @@ -713,7 +717,6 @@ (lambda (c . args) (apply-continuation c args))))]) (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 escape-continuation)))) @@ -1907,7 +1910,7 @@ ;; 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)) + (#%apply k args)) ;; ---------------------------------------- ;; Metacontinuation swapping for engines