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

cs: faster continuation-mark-set-first

Browse Source 
Avoid allocating mark-chain elements, and change search function so
that it's more recognizable as a loop.
This commit is contained in:
Matthew Flatt 2018-08-27 19:09:46 -06:00
parent f9e6a8b61b
commit 1d65a89f53
1 changed files with 53 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -892,7 +892,7 @@
(apply values args)) (apply values args))
(define (current-mark-chain) (define (current-mark-chain)
(get-current-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) (define (mark-stack-to-marks mark-stack)
(let loop ([mark-stack mark-stack]) (let loop ([mark-stack mark-stack])
@ -915,18 +915,21 @@
(define-record mark-chain-frame (tag marks)) (define-record mark-chain-frame (tag marks))
(define (get-current-mark-chain mark-stack mark-splice mc) (define (get-rest-mark-chain mark-splice mc)
(let ([hd (make-mark-chain-frame (let ([mid (and (not (empty-mark-frame? mark-splice))
#f ; no tag
(mark-stack-to-marks mark-stack))]
[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))))] (mark-stack-to-marks (list mark-splice))))]
[tl (metacontinuation-marks mc)]) [tl (metacontinuation-marks mc)])
(if mid (if mid
(cons hd (cons mid tl)) (cons mid tl)
(cons hd tl)))) tl)))
(define (get-mark-chain mark-stack mark-splice mc)
(cons (make-mark-chain-frame
#f ; no tag
(mark-stack-to-marks mark-stack))
(get-rest-mark-chain mark-splice mc)))
(define (prune-mark-chain-prefix tag mark-chain) (define (prune-mark-chain-prefix tag mark-chain)
(cond (cond
@ -1024,12 +1027,22 @@
(maybe-future-barricade prompt-tag) (maybe-future-barricade prompt-tag)
(let ([prompt-tag (strip-impersonator prompt-tag)]) (let ([prompt-tag (strip-impersonator prompt-tag)])
(let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'continuation-mark-set-first key)]) (let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'continuation-mark-set-first key)])
(let ([v (marks-search (or (and marks (let* ([v0 (if marks
(continuation-mark-set-mark-chain marks)) none
(current-mark-chain)) ;; Avoid allocating a frame for the immediate marks:
key (marks-search (mark-stack-to-marks (current-mark-stack))
#t ; at-outer? key
prompt-tag)]) #f ; at-outer?
prompt-tag))]
[v (if (eq? v0 none)
(marks-search (or (and marks
(continuation-mark-set-mark-chain marks))
;; We've already checked `(current-mark-stack)`, so get the rest
(get-rest-mark-chain (current-mark-splice) (current-metacontinuation)))
key
#t ; at-outer?
prompt-tag)
v0)])
(cond (cond
[(eq? v none) [(eq? v none)
;; More special treatment of built-in keys ;; More special treatment of built-in keys
@ -1054,33 +1067,14 @@
(cache-result! elems elems/cache-pos depth key none at-outer? prompt-tag) (cache-result! elems elems/cache-pos depth key none at-outer? prompt-tag)
none] none]
[else [else
(let ([t (car elems)] (let t-loop ([t (car elems)])
[check-elem
(lambda (t)
(let ([v (if at-outer?
;; Search within the metacontinuation frame:
(let ([marks (mark-chain-frame-marks t)])
(marks-search marks key #f #f))
;; We're looking at just one frame:
(intmap-ref t key none))])
(cond
[(eq? v none)
;; Not found at this point; keep looking
(loop (cdr elems)
(if cache-step? (cdr elems/cache-pos) elems/cache-pos)
(not cache-step?)
(fx+ 1 depth))]
[else
;; Found it
(cache-result! elems elems/cache-pos depth key v at-outer? prompt-tag)
v])))])
(cond (cond
[(elem+cache? t) [(elem+cache? t)
(let ([v (intmap-ref (elem+cache-cache t) key none2)]) (let ([v (intmap-ref (elem+cache-cache t) key none2)])
(cond (cond
[(eq? v none2) [(eq? v none2)
;; No mapping in cache, so try the element and continue: ;; No mapping in cache, so try the element and continue:
(check-elem (elem+cache-elem t))] (t-loop (elem+cache-elem t))]
[else [else
(let ([v (if at-outer? (let ([v (if at-outer?
;; strip & combine --- cache results at the metacontinuation ;; strip & combine --- cache results at the metacontinuation
@ -1091,7 +1085,7 @@
(cond (cond
[(eq? v none2) [(eq? v none2)
;; Strip filtered this cache entry away, so try the element: ;; Strip filtered this cache entry away, so try the element:
(check-elem (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 elems/cache-pos depth key none at-outer? prompt-tag)
@ -1102,7 +1096,25 @@
v]))]))] v]))]))]
[else [else
;; Try the element: ;; Try the element:
(check-elem t)]))]))) (let ([v (if at-outer?
;; Search within the metacontinuation frame:
(let ([marks (mark-chain-frame-marks t)])
(if (null? marks)
none
(marks-search marks key #f #f)))
;; We're looking at just one frame:
(intmap-ref t key none))])
(cond
[(eq? v none)
;; Not found at this point; keep looking
(loop (cdr elems)
(if cache-step? (cdr elems/cache-pos) elems/cache-pos)
(not cache-step?)
(fx+ 1 depth))]
[else
;; Found it
(cache-result! elems elems/cache-pos depth key v at-outer? prompt-tag)
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
@ -1245,15 +1257,15 @@
(make-continuation-mark-set (make-continuation-mark-set
(prune-mark-chain-suffix (prune-mark-chain-suffix
tag tag
(get-current-mark-chain '() #f mc)) (get-mark-chain '() #f mc))
(get-metacontinuation-traces mc)))] (get-metacontinuation-traces mc)))]
[(full-continuation? k) [(full-continuation? k)
(make-continuation-mark-set (make-continuation-mark-set
(prune-mark-chain-suffix (prune-mark-chain-suffix
tag tag
(get-current-mark-chain (full-continuation-mark-stack k) (get-mark-chain (full-continuation-mark-stack k)
(full-continuation-mark-splice k) (full-continuation-mark-splice k)
(full-continuation-mc k))) (full-continuation-mc k)))
(cons (continuation->trace (full-continuation-k k)) (cons (continuation->trace (full-continuation-k k))
(get-metacontinuation-traces (full-continuation-mc k))))] (get-metacontinuation-traces (full-continuation-mc k))))]
[(escape-continuation? k) [(escape-continuation? k)