syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Avoid sets on the hot path (use hashes instead); good speed improvement

This commit is contained in:
Tony Garnock-Jones 2018-04-30 09:32:08 +01:00
parent eb3a93e32b
commit 00121d9710
1 changed files with 34 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
syndicate/skeleton.rkt
View File

@ -14,7 +14,6 @@
(require syndicate/support/struct)
(require racket/match)
(require racket/set)
(require racket/hash)
(require racket/list)
@ -112,25 +111,26 @@
'()))
(define (make-empty-skeleton)
(make-empty-skeleton/cache (mutable-set)))
(make-empty-skeleton/cache (make-hash)))
(define (skcont-add! c i)
(match-define (skeleton-interest _desc cs cv vs h _cleanup) i)
(define (make-matched-constant)
(skeleton-matched-constant (for/mutable-set [(a (in-set (skeleton-continuation-cache c)))
#:when (equal? (apply-projection a cs) cv)]
a)
(make-hash)))
(define assertions (make-hash))
(for [(a (in-hash-keys (skeleton-continuation-cache c)))
#:when (equal? (apply-projection a cs) cv)]
(hash-set! assertions a #t))
(skeleton-matched-constant assertions (make-hash)))
(define cvt (hash-ref! (skeleton-continuation-table c) cs make-hash))
(define sc (hash-ref! cvt cv make-matched-constant))
(define (make-accumulator)
(define cache (make-bag))
(for [(a (in-set (skeleton-matched-constant-cache sc)))]
(for [(a (in-hash-keys (skeleton-matched-constant-cache sc)))]
(define vars (apply-projection a vs))
(bag-change! cache vars 1))
(skeleton-accumulator cache (mutable-seteq)))
(skeleton-accumulator cache (make-hasheq)))
(define acc (hash-ref! (skeleton-matched-constant-table sc) vs make-accumulator))
(set-add! (skeleton-accumulator-handlers acc) h)
(hash-set! (skeleton-accumulator-handlers acc) h #t)
(for [(vars (in-bag (skeleton-accumulator-cache acc)))] (apply h '+ vars)))
(define (skcont-remove! c i)
@ -141,10 +141,10 @@
(when sc
(define acc (hash-ref (skeleton-matched-constant-table sc) vs #f))
(when acc
(when (and cleanup (set-member? (skeleton-accumulator-handlers acc) h))
(when (and cleanup (hash-has-key? (skeleton-accumulator-handlers acc) h))
(cleanup (skeleton-accumulator-cache acc)))
(set-remove! (skeleton-accumulator-handlers acc) h)
(when (set-empty? (skeleton-accumulator-handlers acc))
(hash-remove! (skeleton-accumulator-handlers acc) h)
(when (hash-empty? (skeleton-accumulator-handlers acc))
(hash-remove! (skeleton-matched-constant-table sc) vs)))
(when (hash-empty? (skeleton-matched-constant-table sc))
(hash-remove! cvt cv)))
@ -180,8 +180,10 @@
[(cons _selector table) table]))
(define (make-skeleton-node-with-cache)
(define unfiltered (skeleton-continuation-cache (skeleton-node-continuation sk)))
(make-empty-skeleton/cache
(for/mutable-set [(a (in-set unfiltered)) #:when (subterm-matches-class? a path class)] a)))
(define filtered (make-hash))
(for [(a (in-hash-keys unfiltered)) #:when (subterm-matches-class? a path class)]
(hash-set! filtered a #t))
(make-empty-skeleton/cache filtered))
(define next (hash-ref! table class make-skeleton-node-with-cache))
(walk-edge! (update-path path pop-count 0) next 0 0 pieces)]
[_
@ -237,13 +239,13 @@
(walk-node! sk (list (vector 'list term0))))
(define (add-term-to-skcont! skcont term)
(set-add! (skeleton-continuation-cache skcont) term))
(hash-set! (skeleton-continuation-cache skcont) term #t))
(define (add-term-to-skconst! skconst term)
(set-add! (skeleton-matched-constant-cache skconst) term))
(hash-set! (skeleton-matched-constant-cache skconst) term #t))
(define (add-term-to-skacc! skacc vars _term)
(match (bag-change! (skeleton-accumulator-cache skacc) vars 1)
['absent->present
(for [(handler (in-set (skeleton-accumulator-handlers skacc)))]
(for [(handler (in-hash-keys (skeleton-accumulator-handlers skacc)))]
(apply handler '+ vars))]
;; 'present->absent and 'absent->absent absurd
['present->present
@ -257,15 +259,15 @@
add-term-to-skacc!))
(define (remove-term-from-skcont! skcont term)
(set-remove! (skeleton-continuation-cache skcont) term))
(hash-remove! (skeleton-continuation-cache skcont) term))
(define (remove-term-from-skconst! skconst term)
(set-remove! (skeleton-matched-constant-cache skconst) term))
(hash-remove! (skeleton-matched-constant-cache skconst) term))
(define (remove-term-from-skacc! skacc vars _term)
(define cache (skeleton-accumulator-cache skacc))
(if (bag-member? cache vars)
(match (bag-change! cache vars -1)
['present->absent
(for [(handler (in-set (skeleton-accumulator-handlers skacc)))]
(for [(handler (in-hash-keys (skeleton-accumulator-handlers skacc)))]
(apply handler '- vars))]
;; 'absent->absent and 'absent->present absurd
['present->present
@ -285,7 +287,7 @@
void
void
(lambda (skacc vars _term)
(for [(handler (in-set (skeleton-accumulator-handlers skacc)))]
(for [(handler (in-hash-keys (skeleton-accumulator-handlers skacc)))]
(apply handler '! vars)))))
;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj`
@ -308,15 +310,17 @@
(struct d (x y z) #:transparent)
(define sk
(make-empty-skeleton/cache (mutable-set (a (b 'bee) (b 'cat))
(a (b 'foo) (c 'bar))
(a (b 'foo) (c 'BAR))
(a (c 'bar) (b 'foo))
(a (c 'dog) (c 'fox))
(d (b 'DBX) (b 'DBY) (b 'DBZ))
(d (c 'DCX) (c 'DCY) (c 'DCZ))
(b 'zot)
123)))
(make-empty-skeleton/cache
(make-hash (for/list [(x (list (a (b 'bee) (b 'cat))
(a (b 'foo) (c 'bar))
(a (b 'foo) (c 'BAR))
(a (c 'bar) (b 'foo))
(a (c 'dog) (c 'fox))
(d (b 'DBX) (b 'DBY) (b 'DBZ))
(d (c 'DCX) (c 'DCY) (c 'DCZ))
(b 'zot)
123))]
(cons x #t)))))
(define i1
(skeleton-interest (list struct:a (list struct:b #f) #f)