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

cs: use call-setting-continuation-attachment

Browse Source
This commit is contained in:
Matthew Flatt 2018-07-24 13:43:23 -06:00
parent 60977b36c7
commit a41f58f9d7
10 changed files with 305 additions and 365 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "7.0.0.7") (define version "7.0.0.8")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

1
racket/src/cs/compile-file.ss
View File

@ -17,6 +17,7 @@
(check-defined 'load-compiled-from-port) (check-defined 'load-compiled-from-port)
(check-defined 'collect-rendezvous) (check-defined 'collect-rendezvous)
(check-defined '(define-ftype T (function __collect_safe () void))) (check-defined '(define-ftype T (function __collect_safe () void)))
(check-defined 'call-setting-continuation-attachment)
;; ---------------------------------------- ;; ----------------------------------------

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

@ -1,13 +1,13 @@
(import (rumble) (import (rumble))
(rename (only (chezscheme) dynamic-wind)
(dynamic-wind chez:dynamic-wind)))
(define-syntax check (define-syntax check
(syntax-rules () (syntax-rules ()
[(_ a b) [(_ a b)
(begin
#;(printf "try ~s\n" 'a)
(let ([v a]) (let ([v a])
(unless (equal? v b) (unless (equal? v b)
(error 'check (format "failed ~s => ~s" 'a v))))])) (error 'check (format "failed ~s => ~s" 'a v)))))]))
(define check-abort-tag (make-continuation-prompt-tag 'check-abort)) (define check-abort-tag (make-continuation-prompt-tag 'check-abort))
@ -406,8 +406,8 @@
(continuation-mark-set->list* (continuation-mark-set->list*
(current-continuation-marks) (current-continuation-marks)
'(x1 x2) '(x1 x2)
(default-continuation-prompt-tag) 'nope
'nope)))))))) (default-continuation-prompt-tag)))))))))
'(#(nope 3) #(2 nope) #(1 1))) '(#(nope 3) #(2 nope) #(1 1)))
;; Make sure caching doesn't ignore the prompt tag ;; Make sure caching doesn't ignore the prompt tag
@ -432,7 +432,7 @@
;; Engines ;; Engines
(define e (make-engine (lambda () 'done) #f #f)) (define e (make-engine (lambda () 'done) #f #f))
(check (cdr (e 20 void list vector)) (check (cdr (e 100 void list vector))
'(done)) '(done))
(define e-forever (make-engine (lambda () (let loop () (loop))) #f #f)) (define e-forever (make-engine (lambda () (let loop () (loop))) #f #f))
@ -608,7 +608,7 @@
(lambda () (lambda ()
(call-with-system-wind (call-with-system-wind
(lambda () (lambda ()
(chez:dynamic-wind (#%dynamic-wind
(lambda () (lambda ()
(set! pre (add1 pre))) (set! pre (add1 pre)))
(lambda () (lambda ()
@ -622,7 +622,7 @@
(check (let ([prefixes 0]) (check (let ([prefixes 0])
(let loop ([e e-sw] [i 0]) (let loop ([e e-sw] [i 0])
(e 100 (e 110
(lambda () (set! prefixes (add1 prefixes))) (lambda () (set! prefixes (add1 prefixes)))
(lambda (remain v) (list (> i 2) (lambda (remain v) (list (> i 2)
(= prefixes (add1 i)) (= prefixes (add1 i))

9
racket/src/cs/expander.sls
View File

@ -134,7 +134,14 @@
(eval '(define-syntax with-continuation-mark (eval '(define-syntax with-continuation-mark
(syntax-rules () (syntax-rules ()
[(_ key val body) [(_ key val body)
(call/cm key val (lambda () body))]))) (call-with-current-continuation-attachment
empty-mark-frame
(lambda (a)
(call-setting-continuation-attachment
(mark-frame-update a key val)
(lambda ()
body))))])))
(eval '(define call-with-immediate-continuation-mark call-with-immediate-continuation-mark/proc))
(eval '(define-syntax begin0 (eval '(define-syntax begin0
(syntax-rules () (syntax-rules ()
[(_ expr0 expr ...) [(_ expr0 expr ...)

1
racket/src/cs/primitive/internal.ss
View File

@ -3,7 +3,6 @@
;; can be used in a linklet: ;; can be used in a linklet:
(define-primitive-table internal-table (define-primitive-table internal-table
[call/cm (known-constant)]
[extract-procedure (known-constant)] [extract-procedure (known-constant)]
[set-ctl-c-handler! (known-constant)] [set-ctl-c-handler! (known-constant)]
[register-linklet-instantiate-continuation! (known-constant)] [register-linklet-instantiate-continuation! (known-constant)]

6
racket/src/cs/rumble.sls
View File

@ -28,8 +28,10 @@
unsafe-call-with-composable-continuation/no-wind unsafe-call-with-composable-continuation/no-wind
with-continuation-mark with-continuation-mark
call/cm ; not exported to Racket (rename [call-with-immediate-continuation-mark/inline
call-with-immediate-continuation-mark call-with-immediate-continuation-mark]
[call-with-immediate-continuation-mark
call-with-immediate-continuation-mark/proc])
continuation-mark-set-first continuation-mark-set-first
continuation-mark-set->list continuation-mark-set->list
continuation-mark-set->list* continuation-mark-set->list*

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

@ -13,18 +13,18 @@
;; A picture where the continuation grows down: ;; A picture where the continuation grows down:
;; [root empty continuation] ;; [root empty continuation]
;; --- empty-k ;; --- empty-k: 'empty attachment
;; metacontinuation | ;; metacontinuation |
;; frame | ;; frame |
;; |--- resume-k ;; |--- resume-k
;; |<-- tag represents this point ;; |<-- tag represents this point
;; --- empty-k ;; --- empty-k: 'empty attachment
;; metacontinuation | ;; metacontinuation |
;; frame | ;; frame |
;; | ;; |
;; |--- resume-k ;; |--- resume-k
;; |<-- tag represents this point ;; |<-- tag represents this point
;; --- empty-k ;; --- empty-k: 'empty attachment
;; current host | ;; current host |
;; continuation | ;; continuation |
;; v ;; v
@ -32,20 +32,19 @@
;; Concretely, the metacontinuation is the current host continuation ;; Concretely, the metacontinuation is the current host continuation
;; plus the frames in the list `(current-metacontinuation)`, where the ;; plus the frames in the list `(current-metacontinuation)`, where the
;; shallowest (= lowest in the picture above) frame is first in the ;; shallowest (= lowest in the picture above) frame is first in the
;; list. The `empty-k` value of the current host continuation is ;; list. The `empty-k` continuation is recognized by having an
;; in `current-empty-k`. ;; 'empty continuation attachment.
;; The shallowest metacontinuation frame's `empty-k` continuation is ;; The conceptual `empty-k` continuation is used to detect when the
;; used to detect when the current host continuation is empty (i.e., ;; current host continuation is empty. When it's empty, then calling a
;; when it matches the `current-empty-k` value). When it's empty, then ;; composable continuation doesn't need to add a new metacontinuation
;; calling a composable continuation doesn't need to add a new ;; frame, and the application gets the right "tail" behavior.
;; metacontinuation frame, and the application gets the right "tail"
;; behavior.
;; The shallowest metacontinuation frame's `empty-k` continuation also ;; Any continuation marks for the `empty-k` continuation are kept
;; indicates which continuation's marks (if any) should be spliced ;; separate in `current-mark-splice`, instead of being kept as an
;; into a new context when captured in a composable continuation. See ;; attachment. That way, the continuation's marks (if any) can be
;; also `current-mark-splice` below. ;; spliced into a new context when captured in a composable
;; continuation. See also `current-mark-splice` below.
;; A metacontinuation frame's `resume-k` is called when control ;; A metacontinuation frame's `resume-k` is called when control
;; returns or aborts to the frame: ;; returns or aborts to the frame:
@ -71,22 +70,25 @@
;; the continuation where the jump starts. ;; the continuation where the jump starts.
;; The continuation marks for the frame represented by the current ;; The continuation marks for the frame represented by the current
;; host continuation are kept in `current-mark-stack`. When a ;; host continuation are implemented by the host's
;; metacontinuation frame is created, it takes the current ;; continuation-attachment support. The `current-mark-stack` function
;; is just an alias for the host's `$current-attachments` function.
;; When a metacontinuation frame is created, it takes the current
;; `current-mark-stack` value and `current-mark-stack` is set back to ;; `current-mark-stack` value and `current-mark-stack` is set back to
;; empty. To keep winders and the mark stack in sync, a `dynamic-wind` ;; empty. To keep winders and the mark stack in sync, a `dynamic-wind`
;; pre or post thunk resets the mark stack on entry. ;; pre or post thunk resets the mark stack on entry.
;; When a composable continuation is applied in a continuation frame ;; When a composable continuation is applied in a continuation frame
;; that has marks, then the marks are moved into `current-mark-splice`, ;; that has marks, then the marks are moved into
;; which is conceptually merged into the tai of `current-mark-stack`. ;; `current-mark-splice`, which is conceptually merged into the tail
;; Having a separate `current-mark-splice` enables `dynamic-wind` ;; of `current-mark-stack`. Having a separate `current-mark-splice`
;; pre and post thunks adapt correctly to the splicing while jumping ;; enables `dynamic-wind` pre and post thunks to adapt correctly to
;; into or out of the continuation. ;; the splicing while jumping into or out of the continuation.
;; A metacontinuation frame has an extra cache slot to contain a list ;; A metacontinuation frame has an extra cache slot to contain a "mark
;; of mark-stack lists down to the root continuation. When a delimited ;; chain", which is a cached/caching list of mark-stack lists down to
;; sequence of metacontinuation frames are copied out of or into the ;; the root continuation. When a delimited sequence of
;; metacontinuation frames are copied out of or into the
;; metacontinuation, the slot is flushed and will be reset on demand. ;; metacontinuation, the slot is flushed and will be reset on demand.
;; Continuations are used to implement engines, but it's important ;; Continuations are used to implement engines, but it's important
@ -99,13 +101,9 @@
(define-virtual-register current-metacontinuation '()) (define-virtual-register current-metacontinuation '())
(define-virtual-register current-empty-k #f)
(define-record metacontinuation-frame (tag ; continuation prompt tag or #f (define-record metacontinuation-frame (tag ; continuation prompt tag or #f
resume-k ; delivers values to the prompt resume-k ; delivers values to the prompt, also keeps mark stack as attachments
empty-k ; deepest end of this frame
winders ; `dynamic-wind` winders winders ; `dynamic-wind` winders
mark-stack ; mark stack to restore
mark-splice ; extra part of mark stack to restore mark-splice ; extra part of mark stack to restore
mark-chain ; #f or a cached list of mark-chain-frame or elem+cache mark-chain ; #f or a cached list of mark-chain-frame or elem+cache
traces ; #f or a cached list of traces traces ; #f or a cached list of traces
@ -224,9 +222,7 @@
(let ([mf (car (current-metacontinuation))]) (let ([mf (car (current-metacontinuation))])
(current-metacontinuation (cdr (current-metacontinuation))) (current-metacontinuation (cdr (current-metacontinuation)))
(current-winders (metacontinuation-frame-winders mf)) (current-winders (metacontinuation-frame-winders mf))
(current-mark-stack (metacontinuation-frame-mark-stack mf)) (current-mark-splice (metacontinuation-frame-mark-splice mf))))
(current-mark-splice (metacontinuation-frame-mark-splice mf))
(current-empty-k (metacontinuation-frame-empty-k mf))))
(define (call-in-empty-metacontinuation-frame tag handler tail? proc) (define (call-in-empty-metacontinuation-frame tag handler tail? proc)
;; Call `proc` in an empty metacontinuation frame, reifying the ;; Call `proc` in an empty metacontinuation frame, reifying the
@ -235,47 +231,50 @@
;; 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/cc (call-with-current-continuation-attachment
(lambda (tail-k) 'none
(lambda (at)
(cond (cond
[(and (eq? tag the-compose-prompt-tag) [(and (eq? tag the-compose-prompt-tag)
(eq? tail-k (current-empty-k))) (eq? at 'empty))
;; empty continuation in the current frame; don't push a new ;; empty continuation in the current frame; don't push a new
;; metacontinuation frame; if the mark stack is non-empty, ;; metacontinuation frame
;; merge it into the mark splice
(current-mark-splice (merge-mark-splice (current-mark-stack) (current-mark-splice)))
(current-mark-stack '())
(proc)] (proc)]
[else [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 (let ([r ; a list of results, or a non-list for special handling
(call/cc (call/cc
(lambda (k) (lambda (resume-k)
;; the `call/cc` to get `k` created a new stack ;; the `call/cc` to get `k` created a new stack
;; segment; By dropping the link from the current ;; segment; By dropping the link from the current
;; segment to the return context referenced by `k`, ;; segment to the return context referenced by `k`,
;; we actually delimit the current continuation: ;; we actually delimit the current continuation:
(#%$current-stack-link #%$null-continuation) (#%$current-stack-link #%$null-continuation)
(current-mark-stack '())
(let-values ([results (let-values ([results
(call/cc ;; mark the "empty" continuation frame
;; remember the "empty" continuation frame
;; that just continues the metacontinuation: ;; that just continues the metacontinuation:
(lambda (empty-k) (call-setting-continuation-attachment
'empty
(lambda ()
(let ([mf (make-metacontinuation-frame tag (let ([mf (make-metacontinuation-frame tag
k resume-k
(current-empty-k)
(current-winders) (current-winders)
(if tail?
(prune-immediate-frame (current-mark-stack) tail-k)
(current-mark-stack))
(current-mark-splice) (current-mark-splice)
#f #f
#f #f
#f)]) #f)])
(current-winders '()) (current-winders '())
(current-empty-k empty-k) (current-mark-splice new-splice)
(current-mark-splice (and tail?
(keep-immediate-frame (current-mark-stack) tail-k empty-k)))
(current-mark-stack #f)
;; push the metacontinuation: ;; push the metacontinuation:
(current-metacontinuation (cons mf (current-metacontinuation))) (current-metacontinuation (cons mf (current-metacontinuation)))
;; ready: ;; ready:
@ -299,14 +298,12 @@
;; We're returning normally; the metacontinuation frame has ;; We're returning normally; the metacontinuation frame has
;; been popped already by `resume-metacontinuation` ;; been popped already by `resume-metacontinuation`
(end-uninterrupted 'resume) (end-uninterrupted 'resume)
(r)]))])))) (r)])))))]))))
(define (metacontinuation-frame-update-mark-stack current-mf mark-stack 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)
(metacontinuation-frame-empty-k current-mf)
(metacontinuation-frame-winders current-mf) (metacontinuation-frame-winders current-mf)
mark-stack
mark-splice mark-splice
#f #f
#f #f
@ -316,9 +313,7 @@
;; Ok to keep caches, since the cc-guard doesn't affect them ;; Ok to keep caches, since the cc-guard doesn't affect them
(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)
(metacontinuation-frame-empty-k current-mf)
(metacontinuation-frame-winders current-mf) (metacontinuation-frame-winders current-mf)
(metacontinuation-frame-mark-stack current-mf)
(metacontinuation-frame-mark-splice current-mf) (metacontinuation-frame-mark-splice current-mf)
(metacontinuation-frame-mark-chain current-mf) (metacontinuation-frame-mark-chain current-mf)
(metacontinuation-frame-traces current-mf) (metacontinuation-frame-traces current-mf)
@ -400,7 +395,7 @@
;; Capturing and applying continuations ;; Capturing and applying continuations
(define-record continuation ()) (define-record continuation ())
(define-record full-continuation continuation (k winders mark-stack mark-splice empty-k mc)) (define-record full-continuation continuation (k winders mark-stack mark-splice mc))
(define-record composable-continuation full-continuation ()) (define-record composable-continuation full-continuation ())
(define-record composable-continuation/no-wind composable-continuation ()) (define-record composable-continuation/no-wind composable-continuation ())
(define-record non-composable-continuation full-continuation (tag)) (define-record non-composable-continuation full-continuation (tag))
@ -425,7 +420,6 @@
(current-winders) (current-winders)
(current-mark-stack) (current-mark-stack)
(current-mark-splice) (current-mark-splice)
(current-empty-k)
(extract-metacontinuation 'call-with-current-continuation (strip-impersonator tag) #t) (extract-metacontinuation 'call-with-current-continuation (strip-impersonator tag) #t)
tag))))))])) tag))))))]))
@ -452,7 +446,6 @@
(current-winders) (current-winders)
(current-mark-stack) (current-mark-stack)
(current-mark-splice) (current-mark-splice)
(current-empty-k)
(extract-metacontinuation 'call-with-composable-continuation (strip-impersonator tag) #f)))))))) (extract-metacontinuation 'call-with-composable-continuation (strip-impersonator tag) #f))))))))
(define (unsafe-call-with-composable-continuation/no-wind p tag) (define (unsafe-call-with-composable-continuation/no-wind p tag)
@ -533,20 +526,15 @@
c c
args args
(lambda () (lambda ()
(let ([mark-stack (full-continuation-mark-stack c)] (let ([mark-stack (full-continuation-mark-stack c)])
[empty-k (full-continuation-empty-k 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)
(prune-mark-splice (merge-mark-splice mark-splice (current-mark-splice)) (merge-mark-splice mark-splice (current-mark-splice))
mark-stack
empty-k)
mark-splice))) mark-splice)))
(current-empty-k empty-k)
(wind-to (wind-to
(full-continuation-winders c) (full-continuation-winders c)
;; When no winders are left: ;; When no winders are left:
(lambda () (lambda ()
(current-mark-stack mark-stack)
(when (non-composable-continuation? c) (when (non-composable-continuation? c)
;; Activate/add cc-guards in target prompt; any user-level ;; Activate/add cc-guards in target prompt; any user-level
;; callbacks here are run with a continuation barrier, so ;; callbacks here are run with a continuation barrier, so
@ -566,9 +554,7 @@
(map metacontinuation-frame-clear-cache (full-continuation-mc c)) (map metacontinuation-frame-clear-cache (full-continuation-mc c))
(current-metacontinuation))) (current-metacontinuation)))
(current-winders (full-continuation-winders c)) (current-winders (full-continuation-winders c))
(current-mark-stack (full-continuation-mark-stack c))
(current-mark-splice (full-continuation-mark-splice c)) (current-mark-splice (full-continuation-mark-splice c))
(current-empty-k (full-continuation-empty-k c))
(apply (full-continuation-k c) args)) (apply (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
@ -642,20 +628,13 @@
(raise-continuation-error '|continuation application| (raise-continuation-error '|continuation application|
"attempt to cross a continuation barrier")) "attempt to cross a continuation barrier"))
(define (call-with-end-uninterrupted thunk) ;; Update `empty-k` for splicing to be the "inside" of a continuation prompt.
;; Using `call/cm` with a key of `none` ensures that we have an
;; `(end-uninterrupted)` in the immediate continuation, but
;; keeping the illusion that `thunk` is called in tail position.
(call/cm none #f thunk))
;; Update `splice-k` to be the "inside" of a continuation prompt.
(define (call-with-splice-k thunk) (define (call-with-splice-k thunk)
(call-with-end-uninterrupted (call-with-end-uninterrupted
(lambda () (lambda ()
(call/cc (call-setting-continuation-attachment
(lambda (k) 'empty
(current-empty-k k) (lambda () (thunk))))))
(thunk))))))
(define (set-continuation-applicables!) (define (set-continuation-applicables!)
(let ([add (lambda (rtd) (let ([add (lambda (rtd)
@ -737,8 +716,7 @@
(apply-non-composable-continuation dest-c dest-args)))))]))) (apply-non-composable-continuation dest-c dest-args)))))])))
(define (metacontinuation-frame-clear-cache mf) (define (metacontinuation-frame-clear-cache mf)
(metacontinuation-frame-update-mark-stack mf (metacontinuation-frame-update-mark-splice mf
(metacontinuation-frame-mark-stack mf)
(metacontinuation-frame-mark-splice mf))) (metacontinuation-frame-mark-splice mf)))
;; Get/cache a converted list of marks for a metacontinuation ;; Get/cache a converted list of marks for a metacontinuation
@ -749,20 +727,17 @@
(or (metacontinuation-frame-mark-chain mf) (or (metacontinuation-frame-mark-chain mf)
(let* ([r (metacontinuation-marks (cdr mc))] (let* ([r (metacontinuation-marks (cdr mc))]
[m (let ([mark-splice (metacontinuation-frame-mark-splice mf)]) [m (let ([mark-splice (metacontinuation-frame-mark-splice mf)])
(if mark-splice (if (empty-mark-frame? mark-splice)
r
(cons (make-mark-chain-frame (cons (make-mark-chain-frame
(strip-impersonator (metacontinuation-frame-tag mf)) (strip-impersonator (metacontinuation-frame-tag mf))
;; maybe splicing: (mark-stack-to-marks (list mark-splice)))
(mark-stack-tail-matches? (metacontinuation-frame-mark-stack mf) r)))]
(mark-stack-frame-k mark-splice))
(mark-stack-to-marks mark-splice))
r)
r))]
[l (cons (make-mark-chain-frame [l (cons (make-mark-chain-frame
(strip-impersonator (metacontinuation-frame-tag mf)) (strip-impersonator (metacontinuation-frame-tag mf))
#t ; not splicing
(mark-stack-to-marks (mark-stack-to-marks
(metacontinuation-frame-mark-stack mf))) (continuation-next-attachments
(metacontinuation-frame-resume-k mf))))
m)]) m)])
(set-metacontinuation-frame-mark-chain! mf l) (set-metacontinuation-frame-mark-chain! mf l)
l)))])) l)))]))
@ -771,9 +746,8 @@
(cond (cond
[(and splice? (current-mark-splice)) [(and splice? (current-mark-splice))
=> (lambda (mark-splice) => (lambda (mark-splice)
(current-mark-splice #f) (current-mark-splice empty-mark-frame)
(metacontinuation-frame-update-mark-stack mf (metacontinuation-frame-update-mark-splice mf
(metacontinuation-frame-mark-stack mf)
(merge-mark-splice (metacontinuation-frame-mark-splice mf) (merge-mark-splice (metacontinuation-frame-mark-splice mf)
mark-splice)))] mark-splice)))]
[else mf])) [else mf]))
@ -786,10 +760,14 @@
;; small. ;; small.
(define empty-mark-table '()) (define empty-mark-table '())
(define empty-mark-table? null?)
(define (mark-table-add mt k v) (define (mark-table-add mt k v)
(cons (cons k v) mt)) (cons (cons k v) mt))
(define (pair->mark-table k+v)
(list k+v))
(define (mark-table-remove mt k) (define (mark-table-remove mt k)
(cond (cond
[(null? mt) mt] [(null? mt) mt]
@ -820,13 +798,6 @@
(loop (mark-table-add/replace b (car p) (cdr p)) (loop (mark-table-add/replace b (car p) (cdr p))
(cdr a)))]))])) (cdr a)))]))]))
(define (mark-table-prune a b)
(cond
[(null? a) '()]
[(null? b) a]
[else (mark-table-prune (mark-table-remove a (caar b))
(cdr b))]))
(define (mark-table->hash mt) (define (mark-table->hash mt)
(let loop ([ht empty-hasheq] [mt mt]) (let loop ([ht empty-hasheq] [mt mt])
(cond (cond
@ -838,84 +809,116 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Continuation marks ;; Continuation marks
;; A "mark frame" in the mark stack is one of
;;
;; - #f = empty-mark-frame = (make-mark-frame empty-mark-table #f #f)
;; - (cons key val) = (make-mark-frame (pair->mark-table (cons key val)) #f #f)
;; - a mark frame
;;
;; The shorthand forms are promoted to `make-mark-frame` as needed to
;; hold mappings for multiple key. The shorthand forms are also promoted
;; on capture by `current-continuation-marks`; in that case, the mark-stack
;; list is mutated to substitute the promoted form.
;;
;; On capture by `current-continuation-marks`, the `flat` field of a
;; mark frame is filled in with a list of mark tables converted to
;; hash tables. That list can be mutated to substitute an `elem+cache`
;; in place of plain hash table; that substitution happens when searching
;; for a mark in the list.
(define-record continuation-mark-set (mark-chain traces)) (define-record continuation-mark-set (mark-chain traces))
(define-record mark-stack-frame (prev ; prev frame (define-record mark-frame (table ; intmap mapping keys to values
k ; continuation for this frame end-uninterupted? ; whether an "in interrupted?" check has been added
table ; intmap mapping keys to values
flat)) ; #f or cached list that contains only tables and elem+caches flat)) ; #f or cached list that contains only tables and elem+caches
;; A mark stack is made of marks-stack frames: (define empty-mark-frame #f)
(define-virtual-register current-mark-stack #f)
(define (empty-mark-frame? mf)
(or (not mf)
(and (mark-frame? mf)
(empty-mark-table? (mark-frame-table mf)))))
(define current-mark-stack
(case-lambda
[() (#%$current-attachments)]
[(l) (#%$current-attachments l)]))
;; An extra mark stack of size 0 or 1 that is conceptually appended to ;; An extra mark stack of size 0 or 1 that is conceptually appended to
;; the end of `current-mark-stack`, mainly to support composable ;; the end of `current-mark-stack`, which supports composable
;; continuations and `dynamic-wind`. If the last frame of ;; continuations.
;; `current-mark-stack` has the same `k` as a frame in (define-virtual-register current-mark-splice empty-mark-frame)
;; `current-mark-stack-splice`, then then frames are conceptually
;; merged, so no key should be inthe mark-splice frame if it's in the (define (mark-frame-update a key val)
;; mark-stack frame. (cond
(define-virtual-register current-mark-splice #f) [(not a) (cons key val)]
[(pair? a)
(if (eq? key (car a))
(cons key val)
(make-mark-frame (mark-table-add/replace (pair->mark-table a) key val)
#f
#f))]
[(eq? a 'empty)
;; The current frame is the mark-splice frame, so update
;; `current-mark-splice`.
(current-mark-splice (mark-frame-update (current-mark-splice) key val))
'empty]
[(mark-frame? a)
(make-mark-frame (mark-table-add/replace (mark-frame-table a) key val)
(mark-frame-end-uninterupted? a)
#f)]))
(define (coerce-to-mark-frame a)
(cond
[(mark-frame? a) a]
[(not a) (make-mark-frame '() #f #f)]
[else (make-mark-frame (list a) #f #f)]))
(define (extract-mark-from-frame a key default-v)
(cond
[(pair? a) (if (eq? key (car a)) (cdr a) default-v)]
[(mark-frame? a) (mark-table-ref (mark-frame-table a) key default-v)]
[else default-v]))
;; See copy in "expander.sls" ;; See copy in "expander.sls"
(define-syntax with-continuation-mark (define-syntax with-continuation-mark
(syntax-rules () (syntax-rules ()
[(_ key val body) [(_ key val body)
(call/cm key val (lambda () body))])) (call-with-current-continuation-attachment
empty-mark-frame
(lambda (a)
(call-setting-continuation-attachment
(mark-frame-update a key val)
(lambda ()
body))))]))
;; Sets a continuation mark. ;; Ensure that we have an `(end-uninterrupted)` in the immediate
;; Using `none` as a key ensures that a ;; continuation, but keep the illusion that `thunk` is called in
;; stack-restoring frame is pushed without ;; tail position.
;; adding a key--value mapping. (define (call-with-end-uninterrupted thunk)
(define (call/cm key val proc) (call-with-current-continuation-attachment
empty-mark-frame
(lambda (a)
(cond
[(or (eq? a 'empty)
(and (mark-frame? a)
(mark-frame-end-uninterupted? a)))
;; an end-uninterupted check is in place
(thunk)]
[else
;; Add an uninteruped check, moving the current continuation
;; marks to the more nested continuation
(call-setting-continuation-attachment
'skip
(lambda ()
(call/cc (call/cc
(lambda (k) (lambda (k)
(when (eq? k (current-empty-k)) (call-setting-continuation-attachment
;; Need to merge the main stack and splice, if both are active (let ([a (coerce-to-mark-frame a)])
(when (current-mark-splice) (make-mark-frame (mark-frame-table a)
(merge-mark-splice!)))
(let ([mark-stack (current-mark-stack)])
(cond
[(and mark-stack
(eq? k (mark-stack-frame-k mark-stack)))
(unless (eq? key none)
(current-mark-stack (make-mark-stack-frame (mark-stack-frame-prev mark-stack)
k
(mark-table-add/replace* (mark-stack-frame-table mark-stack)
key
val)
#f)))
(proc)]
[else
(begin0
(call/cc
(lambda (new-k)
(current-mark-stack
(make-mark-stack-frame mark-stack
new-k
(if (eq? key none)
empty-mark-table
(mark-table-add empty-mark-table key val))
#f))
(proc)))
(current-mark-stack (mark-stack-frame-prev (current-mark-stack)))
;; To support exiting an uninterrupted region on resumption of
;; a continuation (see `call-with-end-uninterrupted`):
(when (current-in-uninterrupted)
(pariah (end-uninterrupted/call-hook 'cm))))])))))
;; For internal use, such as `dynamic-wind` pre thunks:
(define (call/cm/nontail key val proc)
(current-mark-stack
(make-mark-stack-frame (current-mark-stack)
#f #f
(mark-table-add empty-mark-table key val) (mark-frame-flat a)))
#f)) (lambda ()
(proc) (thunk)))))))]))))
;; If we're in an escape process, then `(current-mark-stack)` might not
;; match, and that's ok; it doesn't matter what we set the mark stack to
;; in that case, so we do something that's right for the non-escape case
(when (current-mark-stack)
(current-mark-stack (mark-stack-frame-prev (current-mark-stack)))))
(define (current-mark-chain) (define (current-mark-chain)
(get-current-mark-chain (current-mark-stack) (current-mark-splice) (current-metacontinuation))) (get-current-mark-chain (current-mark-stack) (current-mark-splice) (current-metacontinuation)))
@ -923,38 +926,37 @@
(define (mark-stack-to-marks mark-stack) (define (mark-stack-to-marks mark-stack)
(let loop ([mark-stack mark-stack]) (let loop ([mark-stack mark-stack])
(cond (cond
[(not mark-stack) null] [(null? mark-stack) null]
[(mark-stack-frame-flat mark-stack) => (lambda (l) l)]
[else [else
(let ([l (cons (mark-table->hash (mark-stack-frame-table mark-stack)) (let ([a (car mark-stack)])
(loop (mark-stack-frame-prev mark-stack)))]) (cond
(set-mark-stack-frame-flat! mark-stack l) [(eq? a 'empty) (loop (cdr mark-stack))]
l)]))) [(not (mark-frame? a))
;; Promote to general frame form
(set-car! mark-stack (coerce-to-mark-frame a))
(loop mark-stack)]
[(mark-frame-flat a) => (lambda (l) l)]
[else
(let ([l (cons (mark-table->hash (mark-frame-table a))
(loop (cdr mark-stack)))])
(set-mark-frame-flat! a l)
l)]))])))
(define-record mark-chain-frame (tag splice? marks)) (define-record mark-chain-frame (tag marks))
(define (get-current-mark-chain mark-stack mark-splice mc) (define (get-current-mark-chain mark-stack mark-splice mc)
(let ([hd (make-mark-chain-frame (let ([hd (make-mark-chain-frame
#f ; no tag #f ; no tag
#f ; not a splice
(mark-stack-to-marks mark-stack))] (mark-stack-to-marks mark-stack))]
[mid (and mark-splice [mid (and (not (empty-mark-frame? mark-splice))
(make-mark-chain-frame (make-mark-chain-frame
#f ; no tag #f ; no tag
(mark-stack-tail-matches? mark-stack (mark-stack-frame-k mark-splice)) ; maybe splicing (mark-stack-to-marks (list mark-splice))))]
(mark-stack-to-marks mark-splice)))]
[tl (metacontinuation-marks mc)]) [tl (metacontinuation-marks mc)])
(if mid (if mid
(cons hd (cons mid tl)) (cons hd (cons mid tl))
(cons hd tl)))) (cons hd tl))))
(define (mark-stack-tail-matches? mark-stack k)
(and mark-stack
(let ([prev (mark-stack-frame-prev mark-stack)])
(or (and (not prev)
(eq? (mark-stack-frame-k mark-stack) k))
(mark-stack-tail-matches? prev k)))))
(define (prune-mark-chain-prefix tag mark-chain) (define (prune-mark-chain-prefix tag mark-chain)
(cond (cond
[(eq? tag (mark-chain-frame-tag (elem+cache-strip (car mark-chain)))) [(eq? tag (mark-chain-frame-tag (elem+cache-strip (car mark-chain))))
@ -974,94 +976,26 @@
(cons (car mark-chain) (cons (car mark-chain)
rest-mark-chain)))])) rest-mark-chain)))]))
;; Used by `continuation-mark-set->list*` to determine when to splice
(define (splice-next? mark-chain)
(and (pair? mark-chain)
(pair? (cdr mark-chain))
(mark-chain-frame-splice? (elem+cache-strip (cadr mark-chain)))))
;; Called when the curent continuation is `(current-empty-k)`,
;; merge anything in `(current-mark-splice)` into `(current-mark-stack)`
(define (merge-mark-splice!)
(let ([mark-splice (current-mark-splice)])
(when mark-splice
(current-mark-stack (merge-mark-splice (current-mark-stack)
mark-splice))
(current-mark-splice #f))))
;; Merge immediate frame of `mark-splice` into immediate frame of ;; Merge immediate frame of `mark-splice` into immediate frame of
;; `mark-stack`, where `mark-stack` takes precedence. We expect that ;; `mark-stack`, where `mark-stack` takes precedence. We expect that
;; each argument is a stack of length 0 or 1, since that's when ;; each argument is a stack of length 0 or 1, since that's when
;; merging makes sense. ;; merging makes sense.
(define (merge-mark-splice mark-stack mark-splice) (define (merge-mark-splice mark-stack mark-splice)
(cond (cond
[(not mark-stack) mark-splice] [(empty-mark-frame? mark-stack) mark-splice]
[(not mark-splice) mark-stack] [(empty-mark-frame? mark-splice) mark-stack]
[else [else
(make-mark-stack-frame #f (make-mark-frame (mark-table-merge (mark-frame-table (coerce-to-mark-frame mark-stack))
(mark-stack-frame-k mark-stack) (mark-frame-table (coerce-to-mark-frame mark-splice)))
(mark-table-merge (mark-stack-frame-table mark-stack) #f
(mark-stack-frame-table mark-splice))
#f)])) #f)]))
;; If `mark-stack` ends with a frame that is conceptually (define (keep-immediate-attachment mark-stack next-mark-stack)
;; merged with one in `mark-splice`, then discard any keys
;; in `mark-splice` that are in the `mark-stack` frame.
;; Also, update `mark-splice` to use `empty-k`.
(define (prune-mark-splice mark-splice mark-stack empty-k)
(cond (cond
[(not mark-splice) #f] [(eq? mark-stack next-mark-stack)
empty-mark-frame]
[else [else
(let loop ([mark-stack mark-stack]) (car mark-stack)]))
(cond
[(not mark-stack) (make-mark-stack-frame #f
empty-k
(mark-stack-frame-table mark-splice)
#f)]
[else
(let ([prev (mark-stack-frame-prev mark-stack)])
(cond
[(and (not prev) (eq? (mark-stack-frame-k mark-stack) empty-k))
(make-mark-stack-frame #f
empty-k
(mark-table-prune (mark-stack-frame-table mark-splice)
(mark-stack-frame-table mark-stack))
#f)]
[else (loop prev)]))]))]))
(define (mark-stack-starts-with? mark-stack k)
(and mark-stack
(eq? k (mark-stack-frame-k mark-stack))))
;; Drop any marks on the immediate frame --- used when
;; moving a frame across a metacontinuation boundary
(define (prune-immediate-frame mark-stack k)
(cond
[(mark-stack-starts-with? mark-stack k)
(make-mark-stack-frame (mark-stack-frame-prev mark-stack)
(mark-stack-frame-k mark-stack)
empty-mark-table
#f)]
[else mark-stack]))
(define (keep-immediate-frame mark-stack k empty-k)
(cond
[(mark-stack-starts-with? mark-stack k)
(make-mark-stack-frame #f
empty-k
(mark-stack-frame-table mark-stack)
#f)]
[else #f]))
(define (mark-stack-append a b)
(cond
[(not a) b]
[(not b) a]
[else
(make-mark-stack-frame (mark-stack-append (mark-stack-frame-prev a) b)
(mark-stack-frame-k a)
(mark-stack-frame-table a)
#f)]))
;; ---------------------------------------- ;; ----------------------------------------
;; Continuation-mark caching ;; Continuation-mark caching
@ -1074,25 +1008,32 @@
(define-record elem+cache (elem cache)) (define-record elem+cache (elem cache))
(define (elem+cache-strip t) (if (elem+cache? t) (elem+cache-elem t) t)) (define (elem+cache-strip t) (if (elem+cache? t) (elem+cache-elem t) t))
;; Export this form renamed to `call-with-immediate-continuation-mark`.
;; It's a macro to ensure that the underlying `call-with-current-continuation-attachment`
;; is exposed.
(define-syntax (call-with-immediate-continuation-mark/inline stx)
(syntax-case stx (lambda)
[(_ key-expr proc-expr)
#'(call-with-immediate-continuation-mark/inline key-expr proc-expr #f)]
[(_ key-expr (lambda (arg) body ...) default-v-expr)
#'(call-with-current-continuation-attachment
empty-mark-frame
(lambda (a)
(let* ([key key-expr]
[default-v default-v-expr]
[arg (extract-mark-from-frame a key default-v)])
body ...)))]
[(_ arg ...)
#'(call-with-immediate-continuation-mark arg ...)]
[_
#'call-with-immediate-continuation-mark]))
(define/who call-with-immediate-continuation-mark (define/who call-with-immediate-continuation-mark
(case-lambda (case-lambda
[(key proc) (call-with-immediate-continuation-mark key proc #f)] [(key proc) (call-with-immediate-continuation-mark key proc #f)]
[(key proc default-v) [(key proc default-v)
(check who (procedure-arity-includes/c 1) proc) (check who (procedure-arity-includes/c 1) proc)
(let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'call-with-immediate-continuation-mark key)]) (call-with-immediate-continuation-mark/inline key (lambda (arg) (proc arg)) default-v)]))
(cond
[(not (current-mark-stack)) (|#%app| proc default-v)]
[else
(call/cc (lambda (k)
(when (eq? k (current-empty-k)) (merge-mark-splice!))
(if (eq? k (mark-stack-frame-k (current-mark-stack)))
(|#%app| proc (let ([v (mark-table-ref (mark-stack-frame-table (current-mark-stack))
key
none)])
(if (eq? v none)
default-v
(wrapper v))))
(|#%app| proc default-v))))]))]))
(define/who continuation-mark-set-first (define/who continuation-mark-set-first
(case-lambda (case-lambda
@ -1244,9 +1185,9 @@
(define/who continuation-mark-set->list* (define/who continuation-mark-set->list*
(case-lambda (case-lambda
[(marks keys) (continuation-mark-set->list* marks keys the-default-continuation-prompt-tag #f)] [(marks keys) (continuation-mark-set->list* marks keys #f the-default-continuation-prompt-tag)]
[(marks keys prompt-tag) (continuation-mark-set->list* marks keys prompt-tag #f)] [(marks keys none-v) (continuation-mark-set->list* marks keys none-v the-default-continuation-prompt-tag)]
[(marks keys prompt-tag none-v) [(marks keys none-v prompt-tag)
(check who continuation-mark-set? :or-false marks) (check who continuation-mark-set? :or-false marks)
(check who list? keys) (check who list? keys)
(check who continuation-prompt-tag? prompt-tag) (check who continuation-prompt-tag? prompt-tag)
@ -1270,18 +1211,10 @@
[(eq? (mark-chain-frame-tag mcf) prompt-tag) [(eq? (mark-chain-frame-tag mcf) prompt-tag)
null] null]
[else [else
(let loop ([marks (let ([marks (mark-chain-frame-marks mcf)]) (let loop ([marks (mark-chain-frame-marks mcf)])
(if (splice-next? mark-chain)
;; handle splicing (created by applying a composable
;; continuation to a context that had marks already)
(append marks
(mark-chain-frame-marks (elem+cache-strip (cadr mark-chain))))
marks))])
(cond (cond
[(null? marks) [(null? marks)
(chain-loop (if (splice-next? mark-chain) (chain-loop (cdr mark-chain))]
(cddr mark-chain)
(cdr mark-chain)))]
[else [else
(let ([t (elem+cache-strip (car marks))]) (let ([t (elem+cache-strip (car marks))])
(let key-loop ([keys all-keys] [wrappers all-wrappers] [i 0] [found? #f]) (let key-loop ([keys all-keys] [wrappers all-wrappers] [i 0] [found? #f])
@ -1311,6 +1244,7 @@
[(tag) [(tag)
(check who continuation-prompt-tag? tag) (check who continuation-prompt-tag? tag)
(maybe-future-barricade tag) (maybe-future-barricade tag)
(check-prompt-tag-available who tag)
(call/cc (call/cc
(lambda (k) (lambda (k)
(make-continuation-mark-set (prune-mark-chain-suffix (strip-impersonator tag) (current-mark-chain)) (make-continuation-mark-set (prune-mark-chain-suffix (strip-impersonator tag) (current-mark-chain))
@ -1660,7 +1594,7 @@
(define-virtual-register current-winders '()) (define-virtual-register current-winders '())
(define-record winder (depth k pre post mark-stack)) (define-record winder (depth k pre post))
;; Jobs for `dynamic-wind`: ;; Jobs for `dynamic-wind`:
@ -1687,8 +1621,7 @@
(fx+ 1 (winder-depth (car winders)))) (fx+ 1 (winder-depth (car winders))))
k k
pre pre
post post)])
(current-mark-stack))])
(start-uninterrupted 'dw) (start-uninterrupted 'dw)
(begin (begin
(call-winder-thunk 'dw-pre pre) (call-winder-thunk 'dw-pre pre)
@ -1703,9 +1636,9 @@
(lambda () (apply values args)))))))))) (lambda () (apply values args))))))))))
(define (call-winder-thunk who thunk) (define (call-winder-thunk who thunk)
(call/cm/nontail (with-continuation-mark
break-enabled-key (make-thread-cell #f #t) break-enabled-key (make-thread-cell #f #t)
(lambda () (begin
(end-uninterrupted who) (end-uninterrupted who)
(thunk) (thunk)
(start-uninterrupted who)))) (start-uninterrupted who))))
@ -1721,7 +1654,6 @@
(let ([winder (car winders)] (let ([winder (car winders)]
[winders (cdr winders)]) [winders (cdr winders)])
(current-winders winders) (current-winders winders)
(current-mark-stack (winder-mark-stack winder))
(let ([thunk (winder-thunk winder)]) (let ([thunk (winder-thunk winder)])
((winder-k winder) ((winder-k winder)
(lambda () (lambda ()
@ -1782,9 +1714,9 @@
;; Breaks ;; Breaks
(define (call-with-break-disabled thunk) (define (call-with-break-disabled thunk)
(call/cm (with-continuation-mark
break-enabled-key (make-thread-cell #f #t) break-enabled-key (make-thread-cell #f #t)
thunk)) (thunk)))
;; Some points where we jump out of uninterrupted mode are also points ;; Some points where we jump out of uninterrupted mode are also points
;; where we might jump to a context where breaks are allowed. The ;; where we might jump to a context where breaks are allowed. The
@ -1827,7 +1759,6 @@
(current-metacontinuation (saved-metacontinuation-mc saved)) (current-metacontinuation (saved-metacontinuation-mc saved))
(#%$current-winders (saved-metacontinuation-system-winders saved)) (#%$current-winders (saved-metacontinuation-system-winders saved))
(current-exception-state (saved-metacontinuation-exn-state saved)) (current-exception-state (saved-metacontinuation-exn-state saved))
(current-empty-k #f)
(set! saved #f) ; break link for space safety (set! saved #f) ; break link for space safety
(proc now-saved))))])) (proc now-saved))))]))

2
racket/src/cs/rumble/error.ss
View File

@ -738,7 +738,7 @@
(|#%app| exn:fail msg (current-continuation-marks)))))) (|#%app| exn:fail msg (current-continuation-marks))))))
(define (call-with-exception-handler proc thunk) (define (call-with-exception-handler proc thunk)
(call/cm exception-handler-key proc thunk)) (with-continuation-mark exception-handler-key proc (thunk)))
;; ---------------------------------------- ;; ----------------------------------------

4
racket/src/cs/rumble/parameter.ss
View File

@ -34,10 +34,10 @@
(raise-argument-error 'extend-parameterization "parameter?" (car args))]))) (raise-argument-error 'extend-parameterization "parameter?" (car args))])))
(define (call-with-parameterization parameter value thunk) (define (call-with-parameterization parameter value thunk)
(call/cm (with-continuation-mark
parameterization-key parameterization-key
(extend-parameterization (current-parameterization) parameter value) (extend-parameterization (current-parameterization) parameter value)
thunk)) (thunk)))
(define (current-parameterization) (define (current-parameterization)
(continuation-mark-set-first (continuation-mark-set-first

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "7.0.0.7" #define MZSCHEME_VERSION "7.0.0.8"
#define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 7 #define MZSCHEME_VERSION_W 8
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)