From 152084d5ce6ef49df3ec25c18e40069950146041 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Sun, 31 Oct 2010 17:13:06 -0500
Subject: [PATCH] Adds an experiment in using a trie in
 `apply-reduction-relation*'

---
 collects/redex/trie-experiment/main.rkt      | 139 +++++++++++++++++++
 collects/redex/trie-experiment/run-trace.rkt |  29 ++++
 collects/redex/trie-experiment/sexp-trie.rkt | 127 +++++++++++++++++
 3 files changed, 295 insertions(+)
 create mode 100644 collects/redex/trie-experiment/main.rkt
 create mode 100644 collects/redex/trie-experiment/run-trace.rkt
 create mode 100644 collects/redex/trie-experiment/sexp-trie.rkt

diff --git a/collects/redex/trie-experiment/main.rkt b/collects/redex/trie-experiment/main.rkt
new file mode 100644
index 0000000000..f098b57aed
--- /dev/null
+++ b/collects/redex/trie-experiment/main.rkt
@@ -0,0 +1,139 @@
+#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)))
diff --git a/collects/redex/trie-experiment/run-trace.rkt b/collects/redex/trie-experiment/run-trace.rkt
new file mode 100644
index 0000000000..008984b8d8
--- /dev/null
+++ b/collects/redex/trie-experiment/run-trace.rkt
@@ -0,0 +1,29 @@
+#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)
\ No newline at end of file
diff --git a/collects/redex/trie-experiment/sexp-trie.rkt b/collects/redex/trie-experiment/sexp-trie.rkt
new file mode 100644
index 0000000000..b8e8e02d4c
--- /dev/null
+++ b/collects/redex/trie-experiment/sexp-trie.rkt
@@ -0,0 +1,127 @@
+#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)))
\ No newline at end of file