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

cs: tune parameterization lookup

Browse Source
This commit is contained in:
Matthew Flatt 2019-09-22 13:50:31 -06:00
parent e147a96843
commit 5fea629cea
2 changed files with 12 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1194,12 +1194,13 @@
(cond (cond
[(or (null? elems) [(or (null? elems)
(and at-outer? (and at-outer?
(not (eq? prompt-tag the-root-continuation-prompt-tag))
(eq? (mark-chain-frame-tag (elem+cache-strip (car elems))) prompt-tag))) (eq? (mark-chain-frame-tag (elem+cache-strip (car elems))) prompt-tag)))
;; Not found ;; Not found
(cond (cond
[(and need-tag? (null? elems)) none2] [(and need-tag? (null? elems)) none2]
[else [else
(cache-result! elems elems/cache-pos depth key none at-outer? prompt-tag) (cache-result! elems/cache-pos depth key none at-outer? prompt-tag)
none])] none])]
[else [else
(let t-loop ([t (car elems)]) (let t-loop ([t (car elems)])
@ -1223,11 +1224,11 @@
(t-loop (elem+cache-elem t))] (t-loop (elem+cache-elem t))]
[(eq? v none) [(eq? v none)
;; The cache records that it's not in the rest: ;; The cache records that it's not in the rest:
(cache-result! elems elems/cache-pos depth key none at-outer? prompt-tag) (cache-result! elems/cache-pos depth key none at-outer? prompt-tag)
none] none]
[else [else
;; The cache provides a value from the rest: ;; The cache provides a value from the rest:
(cache-result! elems elems/cache-pos depth key v at-outer? prompt-tag) (cache-result! elems/cache-pos depth key v at-outer? prompt-tag)
v]))]))] v]))]))]
[else [else
;; Try the element: ;; Try the element:
@ -1239,11 +1240,12 @@
(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:
(cond (cond
;; Inline common case: ;; Inline common cases:
[(pair? t) [(pair? t)
(if (eq? (car t) key) (if (eq? (car t) key)
(cdr t) (cdr t)
none)] none)]
[(eq? t 'empty) none]
[else [else
(extract-mark-from-frame* t key none #f)]))]) (extract-mark-from-frame* t key none #f)]))])
(cond (cond
@ -1254,12 +1256,12 @@
(fx+ 1 depth))] (fx+ 1 depth))]
[else [else
;; Found it ;; Found it
(cache-result! elems elems/cache-pos depth key v at-outer? prompt-tag) (cache-result! elems/cache-pos depth key v at-outer? prompt-tag)
v]))]))]))) v]))]))])))
;; To make `continuation-mark-set-first` constant-time, cache ;; To make `continuation-mark-set-first` constant-time, cache
;; a key--value mapping at a point that's half-way in ;; a key--value mapping at a point that's half-way in
(define (cache-result! marks marks/cache-pos depth key v at-outer? prompt-tag) (define (cache-result! marks/cache-pos depth key v at-outer? prompt-tag)
(unless (< depth 8) (unless (< depth 8)
(let* ([t (car marks/cache-pos)] (let* ([t (car marks/cache-pos)]
[new-t (if (elem+cache? t) [new-t (if (elem+cache? t)
@ -1272,8 +1274,8 @@
(if at-outer? (if at-outer?
;; At the metacontinuation level, cache depends on the ;; At the metacontinuation level, cache depends on the
;; prompt tag: ;; prompt tag:
(let ([old (intmap-ref (elem+cache-cache new-t) key none2)]) (let ([old (intmap-ref (elem+cache-cache new-t) key empty-hasheq)])
(intmap-set (if (eq? old none2) empty-hasheq old) prompt-tag v)) (intmap-set old prompt-tag v))
v)))))) v))))))
(define/who continuation-mark-set->list (define/who continuation-mark-set->list

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

@ -39,12 +39,12 @@
(extend-parameterization (current-parameterization) parameter value) (extend-parameterization (current-parameterization) parameter value)
(thunk))) (thunk)))
;; Not exported; the one for `racket/base` is in `racket/private/more-scheme`
(define (current-parameterization) (define (current-parameterization)
(continuation-mark-set-first (continuation-mark-set-first
#f #f
parameterization-key parameterization-key
empty-parameterization empty-parameterization))
the-root-continuation-prompt-tag))
(define (parameter-cell key) (define (parameter-cell key)
(intmap-ref (parameterization-ht (intmap-ref (parameterization-ht