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

cs: avoid cont-mark conversion on capture

Browse Source 
A conversion from assoc list to hash table is a leftover of a previous
stretegy, and it does not seem useful anymore.
This commit is contained in:
Matthew Flatt 2019-02-04 08:23:53 -08:00
parent 2abe2a48b4
commit 2754d4e5a0
1 changed files with 52 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -718,13 +718,12 @@
r r
(cons (make-mark-chain-frame (cons (make-mark-chain-frame
(strip-impersonator (metacontinuation-frame-tag mf)) (strip-impersonator (metacontinuation-frame-tag mf))
(mark-stack-to-marks (list mark-splice))) (list 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))
(mark-stack-to-marks (continuation-next-attachments
(continuation-next-attachments (metacontinuation-frame-resume-k mf)))
(metacontinuation-frame-resume-k mf))))
m)]) m)])
(set-metacontinuation-frame-mark-chain! mf l) (set-metacontinuation-frame-mark-chain! mf l)
l)))])) l)))]))
@ -770,7 +769,9 @@
(define (mark-table-ref mt k default wrapper) (define (mark-table-ref mt k default wrapper)
(let ([a (#%assq k mt)]) (let ([a (#%assq k mt)])
(if a (if a
(wrapper (cdr a)) (if wrapper
(wrapper (cdr a))
(cdr a))
default))) default)))
(define (mark-table-merge a b) (define (mark-table-merge a b)
@ -785,14 +786,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->hash mt)
(let loop ([ht empty-hasheq] [mt mt])
(cond
[(null? mt) ht]
[else (let ([p (car mt)])
(loop (intmap-set ht (car p) (cdr p))
(cdr mt)))])))
;; ---------------------------------------- ;; ----------------------------------------
;; Continuation marks ;; Continuation marks
@ -801,22 +794,20 @@
;; - #f = empty-mark-frame = (make-mark-frame empty-mark-table #f #f) ;; - #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) ;; - (cons key val) = (make-mark-frame (pair->mark-table (cons key val)) #f #f)
;; - a mark frame ;; - a mark frame
;; - a elem+cache containing one of the others
;; ;;
;; The shorthand forms are promoted to `make-mark-frame` as needed to ;; The shorthand forms are promoted to `make-mark-frame` as needed to
;; hold mappings for multiple key. The shorthand forms are also promoted ;; hold mappings for multiple key. The shorthand forms are also promoted
;; on capture by `current-continuation-marks`; in that case, the mark-stack ;; on capture by `current-continuation-marks`; in that case, the mark-stack
;; list is mutated to substitute the promoted form. ;; list is mutated to substitute the promoted form.
;; ;;
;; On capture by `current-continuation-marks`, the `flat` field of a ;; The list can also be mutated to substitute an `elem+cache` in place
;; mark frame is filled in with a list of mark tables converted to ;; of other elements; that substitution happens when searching for a
;; hash tables. That list can be mutated to substitute an `elem+cache` ;; mark in the list.
;; 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-frame (table ; intmap mapping keys to values (define-record mark-frame (table ; maps keys to values; use `mark-hash-ref`
end-uninterupted? ; whether an "in interrupted?" check has been added end-uninterupted?)) ; whether an "in interrupted?" check has been added
flat)) ; #f or cached list that contains only tables and elem+caches
(define empty-mark-frame #f) (define empty-mark-frame #f)
@ -838,13 +829,12 @@
(define (mark-frame-update a key val) (define (mark-frame-update a key val)
(cond (cond
[(not a) (if (impersonator? key) [(not a) (if (impersonator? key)
(mark-frame-update (make-mark-frame '() #f #f) key val) (mark-frame-update (make-mark-frame '() #f) key val)
(cons key val))] (cons key val))]
[(pair? a) [(pair? a)
(if (eq? key (car a)) (if (eq? key (car a))
(cons key val) (cons key val)
(make-mark-frame (mark-table-add/replace* (pair->mark-table a) key val) (make-mark-frame (mark-table-add/replace* (pair->mark-table a) key val)
#f
#f))] #f))]
[(eq? a 'empty) [(eq? a 'empty)
;; The current frame is the mark-splice frame, so update ;; The current frame is the mark-splice frame, so update
@ -853,26 +843,36 @@
'empty] 'empty]
[(mark-frame? a) [(mark-frame? a)
(make-mark-frame (mark-table-add/replace* (mark-frame-table a) key val) (make-mark-frame (mark-table-add/replace* (mark-frame-table a) key val)
(mark-frame-end-uninterupted? a) (mark-frame-end-uninterupted? a))]
#f)])) [else
;; assert: (elem+cache? a)
(mark-frame-update (elem+cache-elem a) key val)]))
(define (coerce-to-mark-frame a) (define (coerce-to-mark-frame a)
(cond (cond
[(mark-frame? a) a] [(mark-frame? a) a]
[(not a) (make-mark-frame '() #f #f)] [(not a) (make-mark-frame '() #f)]
[else (make-mark-frame (list a) #f #f)])) [else (make-mark-frame (list a) #f)]))
(define (extract-mark-from-frame a key default-v) (define (extract-mark-from-frame a key default-v)
(let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'call-with-immediate-continuation-mark key)]) (let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'call-with-immediate-continuation-mark key)])
(cond (cond
[(pair? a) (if (eq? key (car a)) (wrapper (cdr a)) default-v)] [(eq? a 'empty)
[(mark-frame? a) (mark-table-ref (mark-frame-table a) key default-v wrapper)] (let ([a (current-mark-splice)])
[(eq? a 'empty) (let ([a (current-mark-splice)]) ;; `a` is never 'empty or an `elem+cache`
(cond (cond
[(pair? a) (if (eq? key (car a)) (wrapper (cdr a)) default-v)] [(pair? a) (if (eq? key (car a)) (if wrapper (wrapper (cdr a)) (cdr a)) default-v)]
[(mark-frame? a) (mark-table-ref (mark-frame-table a) key default-v wrapper)] [(mark-frame? a) (mark-table-ref (mark-frame-table a) key default-v wrapper)]
[else default-v]))] [else default-v]))]
[else default-v]))) [else
(extract-mark-from-frame* a key default-v wrapper)])))
(define (extract-mark-from-frame* a key default-v wrapper)
(cond
[(pair? a) (if (eq? key (car a)) (if wrapper (wrapper (cdr a)) (cdr a)) default-v)]
[(mark-frame? a) (mark-table-ref (mark-frame-table a) key default-v wrapper)]
[(elem+cache? a) (extract-mark-from-frame* (elem+cache-elem a) key default-v wrapper)]
[else default-v]))
;; See copy in "expander.sls" ;; See copy in "expander.sls"
(define-syntax with-continuation-mark (define-syntax with-continuation-mark
@ -904,32 +904,13 @@
(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)))
(define (mark-stack-to-marks mark-stack)
(let loop ([mark-stack mark-stack])
(cond
[(null? mark-stack) null]
[else
(let ([a (car mark-stack)])
(cond
[(eq? a 'empty) (loop (cdr mark-stack))]
[(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 marks)) (define-record mark-chain-frame (tag marks))
(define (get-rest-mark-chain mark-splice mc) (define (get-rest-mark-chain mark-splice mc)
(let ([mid (and (not (empty-mark-frame? mark-splice)) (let ([mid (and (not (empty-mark-frame? mark-splice))
(make-mark-chain-frame (make-mark-chain-frame
#f ; no tag #f ; no tag
(mark-stack-to-marks (list mark-splice))))] (list mark-splice)))]
[tl (metacontinuation-marks mc)]) [tl (metacontinuation-marks mc)])
(if mid (if mid
(cons mid tl) (cons mid tl)
@ -938,7 +919,7 @@
(define (get-mark-chain mark-stack mark-splice mc) (define (get-mark-chain mark-stack mark-splice mc)
(cons (make-mark-chain-frame (cons (make-mark-chain-frame
#f ; no tag #f ; no tag
(mark-stack-to-marks mark-stack)) mark-stack)
(get-rest-mark-chain mark-splice mc))) (get-rest-mark-chain mark-splice mc)))
(define (prune-mark-chain-prefix tag mark-chain) (define (prune-mark-chain-prefix tag mark-chain)
@ -976,7 +957,6 @@
[else [else
(make-mark-frame (mark-table-merge (mark-frame-table (coerce-to-mark-frame mark-stack)) (make-mark-frame (mark-table-merge (mark-frame-table (coerce-to-mark-frame mark-stack))
(mark-frame-table (coerce-to-mark-frame mark-splice))) (mark-frame-table (coerce-to-mark-frame mark-splice)))
#f
#f)])) #f)]))
(define (keep-immediate-attachment mark-stack next-mark-stack) (define (keep-immediate-attachment mark-stack next-mark-stack)
@ -989,11 +969,11 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Continuation-mark caching ;; Continuation-mark caching
;; A `elem+cache` can replace a plain table in a "flat" variant of the ;; A `elem+cache` can replace a plain table in a mark stack within a
;; mark stack within a metacontinuation frame, or in a mark-stack ;; metacontinuation frame or in a mark-stack chain for a
;; chain for a metacontinuation. The cache is a table that records ;; metacontinuation. The cache is a table that records results found
;; results found later in the list, which allows ;; later in the list, which allows `continuation-mark-set-first` to
;; `continuation-mark-set-first` to take amortized constant time. ;; take amortized constant time.
(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))
@ -1045,7 +1025,7 @@
(let* ([v0 (if marks (let* ([v0 (if marks
none none
;; Avoid allocating a frame for the immediate marks: ;; Avoid allocating a frame for the immediate marks:
(marks-search (mark-stack-to-marks (current-mark-stack)) (marks-search (current-mark-stack)
key key
#f ; at-outer? #f ; at-outer?
prompt-tag prompt-tag
@ -1075,7 +1055,8 @@
[(eq? v none2) [(eq? v none2)
;; Didn't find prompt tag when searching the current continuation ;; Didn't find prompt tag when searching the current continuation
(raise-no-prompt-tag who orig-prompt-tag)] (raise-no-prompt-tag who orig-prompt-tag)]
[else (wrapper v)]))))])) [wrapper (wrapper v)]
[else v]))))]))
;; To make `continuation-mark-set-first` constant-time, if we traverse ;; To make `continuation-mark-set-first` constant-time, if we traverse
;; N elements to get an answer, then cache the answer at N/2 elements. ;; N elements to get an answer, then cache the answer at N/2 elements.
@ -1130,7 +1111,7 @@
none none
(marks-search marks key #f #f #f))) (marks-search marks key #f #f #f)))
;; We're looking at just one frame: ;; We're looking at just one frame:
(intmap-ref t key none))]) (extract-mark-from-frame* t key none #f))])
(cond (cond
[(eq? v none) [(eq? v none)
;; Not found at this point; keep looking ;; Not found at this point; keep looking
@ -1188,10 +1169,10 @@
[(null? marks) [(null? marks)
(chain-loop (cdr mark-chain))] (chain-loop (cdr mark-chain))]
[else [else
(let* ([v (intmap-ref (elem+cache-strip (car marks)) key none)]) (let* ([v (extract-mark-from-frame* (elem+cache-strip (car marks)) key none wrapper)])
(if (eq? v none) (if (eq? v none)
(loop (cdr marks)) (loop (cdr marks))
(cons (wrapper v) (loop (cdr marks)))))]))]))]))))])) (cons v (loop (cdr marks)))))]))]))]))))]))
(define/who continuation-mark-set->list* (define/who continuation-mark-set->list*
(case-lambda (case-lambda
@ -1235,13 +1216,13 @@
(cons vec (loop (cdr marks)))) (cons vec (loop (cdr marks))))
(loop (cdr marks)))] (loop (cdr marks)))]
[else [else
(let ([v (intmap-ref t (car keys) none)]) (let ([v (extract-mark-from-frame* t (car keys) none (car wrappers))])
(cond (cond
[(eq? v none) [(eq? v none)
(vector-set! tmp i none-v) (vector-set! tmp i none-v)
(key-loop (cdr keys) (cdr wrappers) (add1 i) found?)] (key-loop (cdr keys) (cdr wrappers) (add1 i) found?)]
[else [else
(vector-set! tmp i ((car wrappers) v)) (vector-set! tmp i v)
(key-loop (cdr keys) (cdr wrappers) (add1 i) #t)]))])))]))]))])))))])) (key-loop (cdr keys) (cdr wrappers) (add1 i) #t)]))])))]))]))])))))]))
(define/who (continuation-mark-set->context marks) (define/who (continuation-mark-set->context marks)
@ -1369,7 +1350,7 @@
[else (mark-table-add/replace ht k v)])) [else (mark-table-add/replace ht k v)]))
;; Extracts the key and converts the wrapper functions into ;; Extracts the key and converts the wrapper functions into
;; a single function: ;; a single function or #f:
(define (extract-continuation-mark-key-and-wrapper who k) (define (extract-continuation-mark-key-and-wrapper who k)
(cond (cond
[(and (impersonator? k) [(and (impersonator? k)
@ -1396,7 +1377,7 @@
[else [else
(lambda (v) v)])))] (lambda (v) v)])))]
[else [else
(values k (lambda (v) v))])) (values k #f)]))
(define (map/2-values f l) (define (map/2-values f l)
(cond (cond