Removes `apply-reduction-relation*' trie experiment
This commit is contained in:
Casey Klein
parent
152084d5ce
commit
f9b64fa2b8
|
|
@ -2058,6 +2058,12 @@
|
|||
[cycle? #f]
|
||||
[cutoff? #f])
|
||||
(let loop ([term start]
|
||||
;; It would be better to record all visited terms, to avoid traversing
|
||||
;; any part of the graph multiple times. Results from
|
||||
;; collects/redex/trie-experiment
|
||||
;; in commit
|
||||
;; 152084d5ce6ef49df3ec25c18e40069950146041
|
||||
;; suggest that a hash works better than a trie.
|
||||
[path (make-immutable-hash '())]
|
||||
[more-steps steps])
|
||||
(if (and goal? (goal? term))
|
||||
|
|
|
|||
|
|
@ -1,139 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(require (only-in redex/examples/racket-machine/reduction -> load)
|
||||
(only-in redex/examples/racket-machine/model-impl compile-bytecode impl->model)
|
||||
"sexp-trie.rkt"
|
||||
redex/reduction-semantics
|
||||
rackunit)
|
||||
|
||||
(define capture-trace #f)
|
||||
(define program-size 2)
|
||||
(command-line
|
||||
#:once-each
|
||||
["--capture-trace" trace-path
|
||||
"Writes the terms inserted and looked up to the given path"
|
||||
(set! capture-trace trace-path)]
|
||||
["--program-size" n "The length of the list processed by the bytecode program"
|
||||
(set! program-size (string->number n))]
|
||||
#:args () (void))
|
||||
|
||||
(define ((make-eval normal-forms) expr [cycles '()])
|
||||
(map (match-lambda
|
||||
[`((clos ,_) ,_ ,_ ,_ ()) (closure)]
|
||||
[`(,v ,_ ,_ ,_ ()) v]
|
||||
[`(,_ ,_ ,_ ,_ (,_ ,_ ...)) (stuck)]
|
||||
['error (error)])
|
||||
(normal-forms (program expr cycles))))
|
||||
|
||||
(define (show-memory)
|
||||
(collect-garbage)
|
||||
(collect-garbage)
|
||||
(printf "~s MB\n" (exact->inexact (/ (current-memory-use) (expt 2 20)))))
|
||||
|
||||
(define eval-hash
|
||||
(make-eval
|
||||
(λ (p)
|
||||
(let* ([seen (make-hash)]
|
||||
[finals '()]
|
||||
[go (λ (trace)
|
||||
(time
|
||||
(let loop ([state p])
|
||||
(when trace (write (cons 'lookup state) trace))
|
||||
(unless (hash-ref seen state #f)
|
||||
(when trace (write (cons 'insert state) trace))
|
||||
(hash-set! seen state #t)
|
||||
(let ([succs (apply-reduction-relation -> state)])
|
||||
(if (null? succs)
|
||||
(set! finals (cons state finals))
|
||||
(map loop succs)))))))])
|
||||
(if capture-trace
|
||||
(call-with-output-file #:exists 'truncate capture-trace go)
|
||||
(go #f))
|
||||
(show-memory)
|
||||
(fprintf (open-output-nowhere) "~s" seen)
|
||||
finals))))
|
||||
|
||||
(define trie-friendly
|
||||
(match-lambda
|
||||
[(list V S H T C)
|
||||
(list T (reverse H) (reverse C) (reverse S) V)]
|
||||
[x x]))
|
||||
|
||||
(define eval-trie
|
||||
(make-eval
|
||||
(λ (p)
|
||||
(let ([seen empty-sexp-trie]
|
||||
[finals '()])
|
||||
(time
|
||||
(let loop ([state p])
|
||||
(define swapped (trie-friendly state))
|
||||
(unless (lookup swapped seen)
|
||||
(set! seen (insert swapped #t seen))
|
||||
(let ([succs (apply-reduction-relation -> state)])
|
||||
(if (null? succs)
|
||||
(set! finals (cons state finals))
|
||||
(map loop succs))))))
|
||||
(show-memory)
|
||||
(fprintf (open-output-nowhere) "~s" seen)
|
||||
finals))))
|
||||
|
||||
;; eval: e ((x e) ...) -> (listof result)
|
||||
;; Evaluates a bytecode program.
|
||||
;; result ::= v | closure | stuck
|
||||
(define eval eval-hash)
|
||||
|
||||
(define (program expr cycles)
|
||||
(term (load ,expr ,cycles)))
|
||||
|
||||
(struct closure () #:transparent)
|
||||
(struct stuck () #:transparent)
|
||||
(struct error () #:transparent)
|
||||
|
||||
;; racket->bytecode: syntax -> (e ((x e) ...))
|
||||
;; Compiles a Racket expression into bytecode.
|
||||
(define racket->bytecode
|
||||
;; make sure compilation doesn't insert unhandled debugging stuff
|
||||
(compose impl->model compile-bytecode))
|
||||
|
||||
(define a-racket-program
|
||||
#`(let ([cons (λ (x y) (λ (s) (s x y)))]
|
||||
[car (λ (p) (p (λ (x y) x)))]
|
||||
[cdr (λ (p) (p (λ (x y) y)))]
|
||||
[null #f]
|
||||
[null? (λ (x) (if x #f #t))])
|
||||
(letrec ([find (lambda (it? xs)
|
||||
(if (null? xs)
|
||||
#f
|
||||
(let ([x (car xs)])
|
||||
(if (it? x)
|
||||
x
|
||||
(find it? (cdr xs))))))])
|
||||
(find (λ (x) x) #,(let loop ([n program-size] [tail #'(cons 1 (cons 2 null))])
|
||||
(if (zero? n)
|
||||
tail
|
||||
(loop (sub1 n) #`(cons #f #,tail))))))))
|
||||
|
||||
(match-let ([(cons expr cycles) (racket->bytecode a-racket-program)])
|
||||
;; Warm Redex's caches
|
||||
(parameterize ([current-output-port (open-output-nowhere)])
|
||||
(eval-hash expr cycles))
|
||||
|
||||
(unless capture-trace
|
||||
(printf "Begin: ")
|
||||
(show-memory)
|
||||
(newline)
|
||||
|
||||
(printf "Hash: ")
|
||||
(eval-hash expr cycles)
|
||||
(newline)
|
||||
|
||||
(printf "Between: ")
|
||||
(show-memory)
|
||||
(newline)
|
||||
|
||||
(printf "Trie: ")
|
||||
(eval-trie expr cycles)
|
||||
(newline)
|
||||
|
||||
(printf "End: ")
|
||||
(show-memory)))
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(require "sexp-trie.rkt")
|
||||
|
||||
(define trace-path
|
||||
(command-line #:args (path) path))
|
||||
|
||||
(define (time-trace insert lookup empty)
|
||||
(call-with-input-file trace-path
|
||||
(λ (trace)
|
||||
(time
|
||||
(let loop ([set empty])
|
||||
(match (read trace)
|
||||
[(? eof-object?)
|
||||
(void)]
|
||||
[(cons 'lookup t)
|
||||
(begin
|
||||
(lookup t set)
|
||||
(loop set))]
|
||||
[(cons 'insert t)
|
||||
(loop (insert t set))]))))))
|
||||
|
||||
(printf "Hash\n")
|
||||
(time-trace (λ (t s) (hash-set! s t #t) s)
|
||||
(λ (t s) (hash-ref s t #f))
|
||||
(make-hash))
|
||||
|
||||
(printf "Trie\n")
|
||||
(time-trace (λ (t s) (insert t #t s)) lookup empty-sexp-trie)
|
||||
|
|
@ -1,127 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(require rackunit)
|
||||
|
||||
(provide empty-sexp-trie
|
||||
lookup
|
||||
insert
|
||||
atom-map-histo)
|
||||
|
||||
(struct sexp-trie (atoms ; (dict/c any α)
|
||||
lists) #:transparent) ; (or/c (sexp-list-trie α) #f)
|
||||
|
||||
(struct sexp-list-trie (empty ; (or/c #f α)
|
||||
non-empty) #:transparent) ; (sexp-trie (sexp-list-trie α))
|
||||
|
||||
;; empty-sexp-trie: sexp-trie α
|
||||
(define empty-sexp-trie (sexp-trie '() #f))
|
||||
|
||||
;; lookup: sexp (sexp-trie α) -> (or/c #f α)
|
||||
(define (lookup s t)
|
||||
(if (list? s)
|
||||
(and (sexp-trie-lists t)
|
||||
(lookup-list s (sexp-trie-lists t)))
|
||||
(dict-ref (sexp-trie-atoms t) s #f)))
|
||||
|
||||
;; lookup-list: (listof sexp) (sexp-list-trie α) -> (or/c #f α)
|
||||
(define (lookup-list ss t)
|
||||
(match ss
|
||||
['() (sexp-list-trie-empty t)]
|
||||
[(cons s ss’)
|
||||
(match (lookup s (sexp-list-trie-non-empty t))
|
||||
[#f #f]
|
||||
[t’ (lookup-list ss’ t’)])]))
|
||||
|
||||
;; replace: sexp (α -> α) (sexp-trie α) -> (sexp-trie α)
|
||||
(define (replace s f t)
|
||||
(let ([t (or t empty-sexp-trie)])
|
||||
(if (list? s)
|
||||
(let ([t’ (or (sexp-trie-lists t)
|
||||
(sexp-list-trie #f empty-sexp-trie))])
|
||||
(sexp-trie (sexp-trie-atoms t)
|
||||
(replace-list s f t’)))
|
||||
(sexp-trie (dict-set (sexp-trie-atoms t) s
|
||||
(f (dict-ref (sexp-trie-atoms t) s #f)))
|
||||
(sexp-trie-lists t)))))
|
||||
|
||||
;; replace-list: (listof sexp) (α -> α) (sexp-list-trie α) -> (sexp-list-trie α)
|
||||
(define (replace-list ss f t)
|
||||
(match ss
|
||||
['()
|
||||
(sexp-list-trie
|
||||
(f (sexp-list-trie-empty t))
|
||||
(sexp-list-trie-non-empty t))]
|
||||
[(cons s ss’)
|
||||
(sexp-list-trie
|
||||
(sexp-list-trie-empty t)
|
||||
(replace
|
||||
s
|
||||
(λ (t’) (replace-list ss’ f (or t’ (sexp-list-trie #f empty-sexp-trie))))
|
||||
(sexp-list-trie-non-empty t)))]))
|
||||
|
||||
;; insert: sexp α (sexp-trie α) -> (sexp-trie α)
|
||||
(define (insert s v t) (replace s (λ (_) v) t))
|
||||
|
||||
(define-syntax (test-insert-lookup stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (insertions ...) (lookups ...))
|
||||
(with-syntax ([(checks ...)
|
||||
(for/list ([lookup-stx (syntax->list #'(lookups ...))])
|
||||
(with-syntax ([(k . v) lookup-stx])
|
||||
(syntax/loc lookup-stx
|
||||
(check-equal? (lookup 'k t) 'v))))])
|
||||
#'(let ([t (for/fold ([t empty-sexp-trie]) ([i '(insertions ...)])
|
||||
(insert (car i) (cdr i) t))])
|
||||
checks ...))]))
|
||||
|
||||
(define-syntax-rule (test-inserted insertions)
|
||||
(test-insert-lookup insertions insertions))
|
||||
|
||||
(test-insert-lookup () ((a . #f)))
|
||||
(test-insert-lookup ((a . 1))
|
||||
((a . 1) (b . #f)))
|
||||
(test-inserted ((a . 1) (b . 2)))
|
||||
(test-insert-lookup ((a . 1) ((b) . 2))
|
||||
((a . 1) ((b) . 2)))
|
||||
(test-insert-lookup (((b) . 2) (a . 1))
|
||||
((a . 1) ((b) . 2)))
|
||||
(test-inserted (((a b c) . 1)
|
||||
((a b d) . 2)
|
||||
((a b c d) . 3)))
|
||||
(test-insert-lookup (((a b c) . 1))
|
||||
(((a b) . #f)))
|
||||
(test-inserted (((((a))) . 1)))
|
||||
(test-inserted (((a) . 1) ((b) . 1)))
|
||||
(test-insert-lookup () ((() . #f)))
|
||||
(test-inserted ((a . 1) (() . 2) ((a) . 3)))
|
||||
(test-inserted ((() . 2) ((a) . 3)))
|
||||
(test-inserted ((a . 1) ((a) . 3) (() . 2)))
|
||||
(test-inserted (((a) . 3) (() . 2)))
|
||||
(test-inserted (((a) . 1) ((b) . 2)))
|
||||
(test-inserted (((a b) . 1) ((a c) . 2)))
|
||||
|
||||
; atom-map-histo: (sexp-trie α) -> (listof (cons/c nat/c nat/c))
|
||||
(define (atom-map-histo t)
|
||||
(define h (make-hash))
|
||||
(for ([c (let counts ([t t])
|
||||
(match t
|
||||
[(sexp-trie as l)
|
||||
(for/fold ([cs (cons (length as) (counts l))]) ([a as])
|
||||
(match-let ([(cons _ x) a])
|
||||
(cond [(sexp-list-trie? x)
|
||||
(append (counts x) cs)]
|
||||
[else cs])))]
|
||||
[(sexp-list-trie e n)
|
||||
(append (counts e) (counts n))]
|
||||
[_ '()]))])
|
||||
(hash-update! h c add1 0))
|
||||
(sort (hash-map h cons) <= #:key car))
|
||||
|
||||
(check-equal?
|
||||
(atom-map-histo
|
||||
(insert '(c d) #t (insert '(b) #t (insert 'a #t empty-sexp-trie))))
|
||||
'((0 . 2) (1 . 2) (2 . 1)))
|
||||
|
||||
(check-equal?
|
||||
(atom-map-histo (insert '(() a) 1 empty-sexp-trie))
|
||||
'((0 . 4) (1 . 1)))
|
||||
Loading…
Reference in New Issue
Block a user