├── README.md ├── benchmarks ├── .gitignore ├── CM.sch ├── church.sch ├── earley.sch ├── fact.sch ├── flatten.sch ├── introspective.sch ├── matt-gc.sch ├── mbrotZ.sch ├── progs.rkt ├── sergey │ ├── TODO │ ├── blur.sch │ ├── eta.sch │ ├── kcfa2.sch │ ├── kcfa3.sch │ ├── loop2.sch │ ├── mj09.sch │ └── sat.sch ├── toplas98 │ ├── boyer.sch │ ├── dynamic.sch │ ├── graphs.sch │ ├── handle.scm │ ├── lattice.scm │ ├── matrix.scm │ ├── maze.sch │ ├── nbody.sch │ ├── nucleic.sch │ ├── nucleic2.sch │ └── splay.scm └── vanhorn-mairson08.sch ├── code ├── .gitignore ├── LK-instantiations.rkt ├── LK.rkt ├── add-lib.rkt ├── ast.rkt ├── bench │ └── out.sh ├── btests.rkt ├── const-prop-fold.rkt ├── context.rkt ├── data.rkt ├── deltas.rkt ├── do.rkt ├── drive-benchmarks.rkt ├── env.rkt ├── fix.rkt ├── generators.rkt ├── graph.rkt ├── handle-limits.rkt ├── imperative.rkt ├── iswim │ ├── 0cfa-compile.rkt │ ├── 0cfa-delta.rkt │ ├── 0cfa-imperative.rkt │ ├── 0cfa-lazy-compile.rkt │ ├── 0cfa-lazy.rkt │ ├── 0cfa-prealloc-generators.rkt │ ├── 0cfa-prealloc.rkt │ ├── 0cfa-specialize-lazy-compile.rkt │ ├── README │ ├── ast.rkt │ ├── data.rkt │ ├── env.rkt │ ├── fix.rkt │ ├── generators.rkt │ ├── macro-all.rkt │ ├── macro-instantiations.rkt │ └── progs.rkt ├── kcfa-instantiations.rkt ├── kcfa.rkt ├── lazy-strict.rkt ├── macros.rkt ├── mk-graph.rkt ├── nonsparse.rkt ├── notation.rkt ├── op-struct.rkt ├── parse.rkt ├── prealloc.rkt ├── primitive-maker.rkt ├── primitives.rkt ├── racket-to-sexp.rkt ├── run-benchmark.rkt └── store-passing.rkt ├── paper ├── .gitignore ├── Makefile ├── all-relative-memory.ps ├── all-relative-space.ps ├── all-relative-speed.ps ├── all-relative-time.ps ├── appendix.tex ├── bench-overview.rkt ├── bench-overview.tex ├── benchmark ├── church-relative-space.ps ├── church-relative-speed.ps ├── church-relative-time.ps ├── data.rkt ├── fanout.pdf ├── fanoutdot2.pdf ├── icfp105-johnson.pdf ├── icfp105-johnson.tex ├── introspective-base.dot ├── introspective-lazy.dot ├── introspective-lazyc.dot ├── lazy.pdf ├── lazydot.pdf ├── local.bib ├── mathpartir.sty ├── onecol.cls ├── paper.bbl ├── pfsteps │ ├── Makefile │ ├── listproc.sty │ ├── pfsteps.dtx │ └── pfsteps.ins ├── plot.rkt ├── preamble.tex ├── precision.tex ├── proctime.rkt ├── proofs.tex ├── response-pldi13.out ├── reviews-icfp13.out ├── reviews-pldi13.out ├── sigplanconf.cls ├── vardoulakis-shivers-numbers.rkt └── vis-bench.rkt └── tests ├── .gitignore ├── parse.rkt └── run.rkt /README.md: -------------------------------------------------------------------------------- 1 | Optimizing Abstract Abstract Machines 2 | ===================================== 3 | 4 | Authors: [J. Ian Johnson](http://www.ccs.neu.edu/home/ianj/), 5 | [Nicholas Labich](http://www.ccs.neu.edu/home/labichn/), 6 | [Matthew Might](http://matt.might.net/), 7 | [David Van Horn](http://www.ccs.neu.edu/home/dvanhorn/) 8 | 9 | Overview 10 | -------- 11 | 12 | Abstracting abstract machines is a lightweight approach to designing 13 | sound and computable program analyses. Although sound analyzers are 14 | straightforward to build under this approach, they are also 15 | prohibitively inefficient. 16 | 17 | This repository contributes a step-by-step process for going from a 18 | naive analyzer derived under the abstracting abstract machine approach 19 | to an efficient program analyzer. The end result of the process is a 20 | two to three order-of-magnitude improvement over the systematically 21 | derived analyzer, making it competitive with hand-optimized 22 | implementations that compute fundamentally less precise results. 23 | 24 | The repository contains a paper describing the approach and 25 | summarizing the results of an empirical evalution; an implementation 26 | of a framework of analyses that can be instantiated to each step of 27 | the optimizations; and a benchmark suite and harness that evaluates 28 | each optimization. 29 | 30 | Paper 31 | ----- 32 | 33 | The paper _Optimizing Abstract Abstract Machines_ is available as a 34 | PDF from [arXiv.org](http://arxiv.org/abs/1211.3722). 35 | 36 | Building 37 | -------- 38 | 39 | Requires [Racket](http://www.racket-lang.org/) version 5.2 or higher 40 | (maybe the nightly) 41 | 42 | ### Running benchmarks 43 | 44 | To make the benchmark harness and all instantiations of 45 | the algorithms/abstractions, run 46 | 47 | raco make code/run-benchmark.rkt 48 | 49 | (This may take several minutes due to the substantial compile-time 50 | computation involved.) 51 | 52 | To run benchmarks, 53 | 54 | racket code/drive-benchmarks.rkt 55 | 56 | (This may take several hours.) 57 | 58 | Instructions for modification (times to run, how many threads, etc) 59 | are inline. 60 | 61 | ### Building the paper 62 | 63 | After benchmarks produce their output, run [code/bench/out.sh] to 64 | produce [paper/benchmark]. Then, in [paper/], run 65 | 66 | make getbib ; make bibtex ; make ; make 67 | 68 | This will fetch the bibliography info, compile the bibliography, build 69 | the paper and the charts using the produced numbers, then rebuild the 70 | paper to correct references. 71 | 72 | [paper/proctime.rkt] is the module that parses [paper/benchmark] and 73 | builds a hash table of raw numbers called timings, if you want to 74 | inspect more. -------------------------------------------------------------------------------- /benchmarks/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | compiled/ 3 | -------------------------------------------------------------------------------- /benchmarks/CM.sch: -------------------------------------------------------------------------------- 1 | #;#; 2 | (define (UserFn sys) (sys UserFn)) 3 | (define (SystemFn user) (user SystemFn)) 4 | (define (RAUserFn sys) 5 | (frame (A) (sys RAUserFn))) 6 | (define (RSSystemFn user) 7 | (frame (S) (user RSSystemFn))) 8 | 9 | (RAUserFn RSSystemFn) -------------------------------------------------------------------------------- /benchmarks/church.sch: -------------------------------------------------------------------------------- 1 | (define plus 2 | (lambda (p1) 3 | (lambda (p2) 4 | (lambda (pf) 5 | (lambda (x) ((p1 pf) ((p2 pf) x))))))) 6 | 7 | (define mult 8 | (lambda (m1) 9 | (lambda (m2) 10 | (lambda (mf) (m2 (m1 mf)))))) 11 | 12 | (define pred 13 | (lambda (n) 14 | (lambda (rf) 15 | (lambda (rx) 16 | (((n (lambda (g) (lambda (h) (h (g rf))))) 17 | (lambda (ignored) rx)) 18 | (lambda (id) id)))))) 19 | 20 | (define sub 21 | (lambda (s1) 22 | (lambda (s2) 23 | ((s2 pred) s1)))) 24 | 25 | 26 | (define church0 (lambda (f0) (lambda (x0) x0))) 27 | (define church1 (lambda (f1) (lambda (x1) (f1 x1)))) 28 | (define church2 (lambda (f2) (lambda (x2) (f2 (f2 x2))))) 29 | (define church3 (lambda (f3) (lambda (x3) (f3 (f3 (f3 x3)))))) 30 | (define church0? (lambda (z) ((z (lambda (zx) #f)) #t))) 31 | (define church=? 32 | (lambda (e1) 33 | (lambda (e2) 34 | (if (church0? e1) 35 | (church0? e2) 36 | (if (church0? e2) 37 | #f 38 | ((church=? ((sub e1) church1)) ((sub e2) church1))))))) 39 | 40 | ;; multiplication distributes over addition 41 | ((church=? ((mult church2) ((plus church1) church3))) 42 | ((plus ((mult church2) church1)) ((mult church2) church3))) -------------------------------------------------------------------------------- /benchmarks/fact.sch: -------------------------------------------------------------------------------- 1 | (letrec ([fact (lambda (n) 2 | (if (zero? n) 1 (* n (fact (sub1 n)))))]) 3 | (fact 3)) 4 | -------------------------------------------------------------------------------- /benchmarks/flatten.sch: -------------------------------------------------------------------------------- 1 | (define (flatten x) 2 | (cond 3 | ((pair? x) 4 | (append (flatten (car x)) (flatten (cdr x)))) 5 | ((null? x) x) 6 | (else (list x)))) 7 | 8 | (flatten '((1 2) (((3 4 5))))) -------------------------------------------------------------------------------- /benchmarks/introspective.sch: -------------------------------------------------------------------------------- 1 | (define (id x) x) 2 | 3 | (define (f n) 4 | (cond [(<= n 1) 1] 5 | [else (* n (f (sub1 n)))])) 6 | 7 | (define (g n) 8 | (cond [(<= n 1) 1] 9 | [else (+ (* n n) (g (sub1 n)))])) 10 | 11 | (+ ((id f) 3) ((id g) 4)) -------------------------------------------------------------------------------- /benchmarks/matt-gc.sch: -------------------------------------------------------------------------------- 1 | 2 | (let lp1 ([i 10] [x 0]) 3 | (if (zero? i) 4 | x 5 | (let lp2 ([j 10] [f (λ (n) (+ n i))] [y x]) 6 | (if (zero? j) 7 | (lp1 (sub1 i) y) 8 | (lp2 (sub1 j) f (f y)))))) 9 | -------------------------------------------------------------------------------- /benchmarks/mbrotZ.sch: -------------------------------------------------------------------------------- 1 | ;;; MBROT -- Generation of Mandelbrot set fractal 2 | ;;; using Scheme's complex numbers. 3 | 4 | (define (count z0 step z) 5 | 6 | (let* ((max-count 64) 7 | (radius 4.0) 8 | (radius^2 (fl* radius radius))) 9 | 10 | (let ((z0 (+ z0 (* z step)))) 11 | 12 | (let loop ((z z0) 13 | (c 0)) 14 | (if (= c max-count) 15 | c 16 | (let* ((zr (real-part z)) 17 | (zi (imag-part z)) 18 | (zr^2 (fl* zr zr)) 19 | (zi^2 (fl* zi zi))) 20 | (if (fl> (fl+ zr^2 zi^2) radius^2) 21 | c 22 | (loop (+ (* z z) z0) (+ c 1))))))))) 23 | 24 | (define (mbrot matrix z0 step n) 25 | (let loop1 ((y (- n 1))) 26 | (if (>= y 0) 27 | (let loop2 ((x (- n 1))) 28 | (if (>= x 0) 29 | (begin 30 | (vector-set! (vector-ref matrix x) 31 | y 32 | (count z0 33 | step 34 | (make-rectangular (->fl x) 35 | (->fl y)))) 36 | (loop2 (- x 1))) 37 | (loop1 (- y 1))))))) 38 | 39 | (define (test n) 40 | (let ((matrix (make-vector n))) 41 | (let loop ((i (- n 1))) 42 | (if (>= i 0) 43 | (begin 44 | (vector-set! matrix i (make-vector n)) 45 | (loop (- i 1))))) 46 | (mbrot matrix -1.0-0.5i 0.005 n) 47 | (vector-ref (vector-ref matrix 0) 0))) 48 | 49 | (define (main) 50 | (let* ((count (read)) 51 | (input1 (read)) 52 | (output (read)) 53 | (s2 (number->string count)) 54 | (s1 (number->string input1)) 55 | (name "mbrot")) 56 | (let ([ok? 57 | (lambda (result) (= result output))] 58 | [thunk (lambda () (test input1))]) 59 | (let loop ([i 0] 60 | [result (void)]) 61 | (cond [(< i count) 62 | (loop (+ i 1) (thunk))] 63 | [(ok? result) result] 64 | [else 65 | (display "ERROR: returned incorrect result: ") 66 | (write result) 67 | (newline) 68 | result]))))) 69 | (main) -------------------------------------------------------------------------------- /benchmarks/progs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (all-defined-out)) 3 | (require racket/runtime-path) 4 | 5 | (define (read-all) 6 | (define o (read)) 7 | (if (eof-object? o) 8 | '() 9 | (cons o (read-all)))) 10 | 11 | (define-runtime-path |.| ".") 12 | (define (read-prog f) 13 | (with-input-from-file (build-path |.| f) 14 | read-all)) 15 | 16 | (define church 17 | (read-prog "church.sch")) 18 | 19 | (define vhm08 20 | (read-prog "vanhorn-mairson08.sch")) 21 | 22 | (define mj09 23 | (read-prog "sergey/mj09.sch")) 24 | 25 | (define eta 26 | (read-prog "sergey/eta.sch")) 27 | 28 | (define kcfa2 29 | (read-prog "sergey/kcfa2.sch")) 30 | 31 | (define kcfa3 32 | (read-prog "sergey/kcfa3.sch")) 33 | 34 | (define blur 35 | (read-prog "sergey/blur.sch")) 36 | 37 | (define loop2 38 | (read-prog "sergey/loop2.sch")) 39 | 40 | (define sat 41 | (read-prog "sergey/sat.sch")) 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /benchmarks/sergey/TODO: -------------------------------------------------------------------------------- 1 | Some of the benchmarks have been rewritten (e.g. curried) in order 2 | to be acceptable to the analysis. Revert to Ilya's original benchmarks 3 | once analyzer is up to snuff. -------------------------------------------------------------------------------- /benchmarks/sergey/blur.sch: -------------------------------------------------------------------------------- 1 | (define id (lambda (x) x)) 2 | (define blur (lambda (y) y)) 3 | (define lp 4 | (lambda (a) 5 | (lambda (n) 6 | (if (zero? n) 7 | (id a) 8 | (let* ((r ((blur id) #t)) 9 | (s ((blur id) #f))) 10 | (not (((blur lp) s) (sub1 n)))))))) 11 | 12 | ((lp #f) 2) 13 | -------------------------------------------------------------------------------- /benchmarks/sergey/eta.sch: -------------------------------------------------------------------------------- 1 | ;; https://github.com/ilyasergey/reachability/blob/master/benchmarks/gcfa2/eta.scm 2 | (define (do-something) 3 | 10) 4 | 5 | (define (id y) 6 | (do-something) 7 | y) 8 | 9 | ((id (lambda (a) a)) #t) 10 | ((id (lambda (b) b)) #f) 11 | -------------------------------------------------------------------------------- /benchmarks/sergey/kcfa2.sch: -------------------------------------------------------------------------------- 1 | ((lambda (f1) 2 | (let ((a (f1 #t))) 3 | (f1 #f))) 4 | (lambda (x1) 5 | ((lambda (f2) 6 | (let ((b (f2 #t))) 7 | (let ((c (f2 #f))) 8 | (f2 #t)))) 9 | (lambda (x2) ((lambda (z) (z x1 x2)) (lambda (y1 y2) y1)))))) -------------------------------------------------------------------------------- /benchmarks/sergey/kcfa3.sch: -------------------------------------------------------------------------------- 1 | ((lambda (f1) 2 | (let ((a (f1 #t))) 3 | (f1 #f))) 4 | (lambda (x1) 5 | ((lambda (f2) 6 | (let ((b (f2 #t))) 7 | (f2 #f))) 8 | (lambda (x2) 9 | ((lambda (f3) 10 | (let ((c (f3 #t))) 11 | (f3 #f))) 12 | (lambda (x3) 13 | ((lambda (z) (z x1 x2 x3)) 14 | (lambda (y1 y2 y3) y1)))))))) 15 | 16 | 17 | -------------------------------------------------------------------------------- /benchmarks/sergey/loop2.sch: -------------------------------------------------------------------------------- 1 | (let ((lp1 2000 #;'(unspecified))) ;; FIXME should '(unspecified) 2 | (let ((a 3 | (set! lp1 (lambda (i x) (let ((a (= 0 i ))) (if 4 | a 5 | x 6 | (let ((lp2 1000 #;'(unspecified))) ;; FIXME should '(unspecified) 7 | (let ((b 8 | (set! lp2 (lambda (j f y) (let ((b (= 0 j ))) 9 | (if b (lp1 (- i 1 ) y ) (let (($tmp$3 (f y ))) (lp2 (- j 1 ) f $tmp$3 )))))))) 10 | (lp2 10 (lambda (n) (+ n i )) x ))))))))) 11 | (lp1 10 0 ))) -------------------------------------------------------------------------------- /benchmarks/sergey/mj09.sch: -------------------------------------------------------------------------------- 1 | 2 | (let ((h (lambda (b) 3 | (let ((g (lambda (z) z))) 4 | (let ((f (lambda (k) 5 | (if b 6 | (k 1) 7 | (k 2))))) 8 | (let ((y (f (lambda (x) x)))) 9 | (g y))))))) 10 | (let* ((x (h #t)) 11 | (y (h #f))) 12 | y)) 13 | -------------------------------------------------------------------------------- /benchmarks/sergey/sat.sch: -------------------------------------------------------------------------------- 1 | ;; https://github.com/ilyasergey/reachability/blob/master/benchmarks/kcfa/sat-brute.scm 2 | (define phi 3 | (lambda (x1) 4 | (lambda (x2) 5 | (lambda (x3) 6 | (lambda (x4) 7 | (lambda (x5) 8 | (lambda (x6) 9 | (lambda (x7) 10 | (and (or x1 x2) 11 | (or x1 (not x2) (not x3)) 12 | (or x3 x4) 13 | (or (not x4) x1) 14 | (or (not x2) (not x3)) 15 | (or x4 x2)))))))))) 16 | 17 | (define try 18 | (lambda (f) (or (f #t) (f #f)))) 19 | 20 | (define sat-solve-7 21 | (lambda (p) 22 | (try (lambda (n1) 23 | (try (lambda (n2) 24 | (try (lambda (n3) 25 | (try (lambda (n4) 26 | (try (lambda (n5) 27 | (try (lambda (n6) 28 | (try (lambda (n7) 29 | (((((((p n1) n2) n3) n4) n5) n6) n7))))))))))))))))) 30 | 31 | (sat-solve-7 phi) 32 | -------------------------------------------------------------------------------- /benchmarks/toplas98/handle.scm: -------------------------------------------------------------------------------- 1 | (define-data handle owner ref) 2 | (define-data Aspace name) 3 | 4 | (defmacro def-macro args 5 | (match args 6 | [((name . pat) . body) 7 | `(defmacro ,name args2 8 | (match args2 9 | [,pat (let () ,@body)]))])) 10 | 11 | (def-macro (with-aspace aspace exp) 12 | `(let ((current-aspace (lambda () ,aspace))) 13 | ,exp)) 14 | 15 | (let* ((a (make-Aspace "foo")) 16 | (b (make-handle a 0)) 17 | (c (make-Aspace "bar")) 18 | (d (make-handle b 0))) 19 | (handle-ref d) 20 | (handle-ref b)) 21 | 22 | -------------------------------------------------------------------------------- /benchmarks/toplas98/lattice.scm: -------------------------------------------------------------------------------- 1 | ; Given a comparison routine that returns one of 2 | ; less 3 | ; more 4 | ; equal 5 | ; uncomparable 6 | ; return a new comparison routine that applies to sequences. 7 | (define lexico 8 | (lambda (base) 9 | (define lex-fixed 10 | (lambda (fixed lhs rhs) 11 | (define check 12 | (lambda (lhs rhs) 13 | (if (null? lhs) 14 | fixed 15 | (let ((probe 16 | (base (car lhs) 17 | (car rhs)))) 18 | (if (or (eq? probe 'equal) 19 | (eq? probe fixed)) 20 | (check (cdr lhs) 21 | (cdr rhs)) 22 | 'uncomparable))))) 23 | (check lhs rhs))) 24 | (define lex-first 25 | (lambda (lhs rhs) 26 | (if (null? lhs) 27 | 'equal 28 | (let ((probe 29 | (base (car lhs) 30 | (car rhs)))) 31 | (case probe 32 | ((less more) 33 | (lex-fixed probe 34 | (cdr lhs) 35 | (cdr rhs))) 36 | ((equal) 37 | (lex-first (cdr lhs) 38 | (cdr rhs))) 39 | ((uncomparable) 40 | 'uncomparable)))))) 41 | lex-first)) 42 | 43 | (define (make-lattice elem-list cmp-func) 44 | (cons elem-list cmp-func)) 45 | 46 | (define lattice->elements (lambda (l) (car l))) 47 | 48 | (define lattice->cmp (lambda (l) (cdr l))) 49 | 50 | ; Select elements of a list which pass some test. 51 | (define zulu-select 52 | (lambda (test lst) 53 | (define select-a 54 | (lambda (ac lst) 55 | (if (null? lst) 56 | (lattice-reverse! ac) 57 | (select-a 58 | (let ((head (car lst))) 59 | (if (test head) 60 | (cons head ac) 61 | ac)) 62 | (cdr lst))))) 63 | (select-a '() lst))) 64 | 65 | (define lattice-reverse! 66 | (letrec ((rotate 67 | (lambda (fo fum) 68 | (let ((next (cdr fo))) 69 | (set-cdr! fo fum) 70 | (if (null? next) 71 | fo 72 | (rotate next fo)))))) 73 | (lambda (lst) 74 | (if (null? lst) 75 | '() 76 | (rotate lst '()))))) 77 | 78 | ; Select elements of a list which pass some test and map a function 79 | ; over the result. Note, only efficiency prevents this from being the 80 | ; composition of select and map. 81 | (define select-map 82 | (lambda (test func lst) 83 | (define select-a 84 | (lambda (ac lst) 85 | (if (null? lst) 86 | (lattice-reverse! ac) 87 | (select-a 88 | (let ((head (car lst))) 89 | (if (test head) 90 | (cons (func head) 91 | ac) 92 | ac)) 93 | (cdr lst))))) 94 | (select-a '() lst))) 95 | 96 | 97 | 98 | ; This version of map-and tail-recurses on the last test. 99 | (define map-and 100 | (lambda (proc lst) 101 | (if (null? lst) 102 | #T 103 | (letrec ((drudge 104 | (lambda (lst) 105 | (let ((rest (cdr lst))) 106 | (if (null? rest) 107 | (proc (car lst)) 108 | (and (proc (car lst)) 109 | (drudge rest))))))) 110 | (drudge lst))))) 111 | 112 | (define (maps-1 source target pas new) 113 | (let ((scmp (lattice->cmp source)) 114 | (tcmp (lattice->cmp target))) 115 | (let ((less 116 | (select-map 117 | (lambda (p) 118 | (eq? 'less 119 | (scmp (car p) new))) 120 | (lambda (l) (cdr l)) 121 | pas)) 122 | (more 123 | (select-map 124 | (lambda (p) 125 | (eq? 'more 126 | (scmp (car p) new))) 127 | (lambda (l) (cdr l)) 128 | pas))) 129 | (zulu-select 130 | (lambda (t) 131 | (and 132 | (map-and 133 | (lambda (t2) 134 | (memq (tcmp t2 t) '(less equal))) 135 | less) 136 | (map-and 137 | (lambda (t2) 138 | (memq (tcmp t2 t) '(more equal))) 139 | more))) 140 | (lattice->elements target))))) 141 | 142 | (define (maps-rest source target pas rest to-1 to-collect) 143 | (if (null? rest) 144 | (to-1 pas) 145 | (let ((next (car rest)) 146 | (rest (cdr rest))) 147 | (to-collect 148 | (map 149 | (lambda (x) 150 | (maps-rest source target 151 | (cons 152 | (cons next x) 153 | pas) 154 | rest 155 | to-1 156 | to-collect)) 157 | (maps-1 source target pas next)))))) 158 | 159 | (define (maps source target) 160 | (make-lattice 161 | (maps-rest source 162 | target 163 | '() 164 | (lattice->elements source) 165 | (lambda (x) (list (map (lambda (l) (cdr l)) x))) 166 | (lambda (x) (apply append x))) 167 | (lexico (lattice->cmp target)))) 168 | 169 | (define print-frequency 10000) 170 | 171 | (define (count-maps source target) 172 | (let ((count 0)) 173 | (maps-rest source 174 | target 175 | '() 176 | (lattice->elements source) 177 | (lambda (x) 178 | (set! count (+ count 1)) 179 | (if (= 0 (remainder count print-frequency)) 180 | (begin 181 | (display count) 182 | (display "...") 183 | (newline)) 184 | (void)) 185 | 1) 186 | (lambda (x) (let loop ((i 0) 187 | (l x)) 188 | (cond ((null? l) i) 189 | (else (loop (+ i (car l)) 190 | (cdr l))))))))) 191 | 192 | (let* ((l2 193 | (make-lattice '(low high) 194 | (lambda (lhs rhs) 195 | (case lhs 196 | ((low) 197 | (case rhs 198 | ((low) 199 | 'equal) 200 | ((high) 201 | 'less) 202 | (else 203 | (error 'make-lattice "base" rhs)))) 204 | ((high) 205 | (case rhs 206 | ((low) 207 | 'more) 208 | ((high) 209 | 'equal) 210 | (else 211 | (error 'make-lattice "base" rhs)))) 212 | (else 213 | (error 'make-lattice "base" lhs))))))) 214 | (display (count-maps l2 l2))) 215 | -------------------------------------------------------------------------------- /benchmarks/vanhorn-mairson08.sch: -------------------------------------------------------------------------------- 1 | (((lambda (f1) (f1 #t) (f1 #f)) 2 | (lambda (x1) 3 | ((lambda (f2) (f2 #t) (f2 #f)) 4 | (lambda (x2) 5 | ((lambda (f3) (f3 #t) (f3 #f)) 6 | (lambda (x3) 7 | (lambda (z) (((z x1) x2) x3)))))))) 8 | (lambda (y1) 9 | (lambda (y2) 10 | (lambda (y3) 11 | y3)))) -------------------------------------------------------------------------------- /code/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | compiled/ 3 | bench/*.0 4 | bench/*.1 5 | bench/*.2 6 | bench/*.3 7 | bench/*.4 8 | bench/*.5 9 | bench/*.6 10 | bench/*.7 11 | bench/*.8 12 | bench/*.9 13 | bench/*.10 14 | bench/*.11 15 | bench/*.12 16 | bench/*.13 17 | bench/*.14 18 | bench/*.15 19 | bench/*.16 20 | bench/*.17 21 | bench/*.18 22 | bench/*.19 23 | bench/*.20 24 | -------------------------------------------------------------------------------- /code/LK-instantiations.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require (rename-in racket/generator [yield real-yield])) 3 | (require "LK.rkt" "data.rkt" "parse.rkt" 4 | "primitives.rkt" "fix.rkt" 5 | ;; different components of instantiantiations 6 | "lazy-strict.rkt" 7 | "context.rkt" 8 | "deltas.rkt" 9 | "generators.rkt" 10 | "store-passing.rkt" 11 | "imperative.rkt" 12 | "prealloc.rkt" 13 | "nonsparse.rkt" 14 | racket/splicing) 15 | 16 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | ;; Concrete semantics 18 | 19 | (define (eval-widen b) 20 | (cond [(atomic? b) b] 21 | [else (error "Unknown base value" b)])) 22 | 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | ;; Potpourris of common parameterizations 25 | 26 | (define-syntax-rule (with-concrete body) 27 | (splicing-syntax-parameterize 28 | ([widen (make-rename-transformer #'eval-widen)]) 29 | body)) 30 | 31 | (define-syntax-rule (with-abstract body) 32 | (splicing-syntax-parameterize 33 | ([widen (make-rename-transformer #'flatten-value)]) 34 | body)) 35 | 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | ;; Potpourris of evaluators 38 | ;; "bl" 39 | (mk-set-fixpoint^ fix baseline-fixpoint baseline-ans?) 40 | (with-nonsparse 41 | (with-strict 42 | (with-0-ctx 43 | (with-whole-σ 44 | (with-σ-passing-set-monad 45 | (with-abstract 46 | (mk-analysis #:aval LK-baseline #:ans baseline-ans 47 | #:fixpoint baseline-fixpoint 48 | #:σ-passing #:wide #:set-monad))))))) 49 | (provide LK-baseline) 50 | 51 | ;; "pd" 52 | #;#; 53 | (mk-prealloc/∆s^-fixpoint prealloc/∆s-fixpoint/c prealloc/∆s-ans/c? 54 | prealloc/∆s-ans/c-v prealloc/∆s-touches-0/c) 55 | (with-nonsparse 56 | (with-lazy 57 | (with-0-ctx/prealloc 58 | (with-σ-∆s/prealloc! 59 | (with-abstract 60 | (mk-analysis #:aval LK-lazy-0cfa^/c/∆s/prealloc! 61 | #:prepare (λ (sexp) (prepare-prealloc parse-prog sexp)) 62 | #:ans prealloc/∆s-ans/c 63 | #:touches prealloc/∆s-touches-0/c 64 | #:fixpoint prealloc/∆s-fixpoint/c 65 | #:global-σ #:compiled #:wide)))))) 66 | (define LK-lazy-0cfa^/c/∆s/prealloc! values) 67 | (provide LK-lazy-0cfa^/c/∆s/prealloc!) 68 | -------------------------------------------------------------------------------- /code/ast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "notation.rkt") 3 | (provide (all-defined-out)) 4 | 5 | ;; An Exp is one of: 6 | ;; (var Lab Exp) 7 | ;; (lam Lab Sym Exp) 8 | ;; (app Lab Exp Exp) 9 | ;; (if Lab Exp Exp Exp) 10 | ;; (st! Lab Var Exp) 11 | ;; (lcc Lab Var Exp) 12 | ;; (primr Lab Sym) 13 | ;; (datum Lab Atom) 14 | (struct exp (lab) #:transparent) 15 | (struct var exp (name) #:transparent) 16 | (struct lrc exp (xs es e) #:transparent) 17 | (struct lam exp (xs exp) #:transparent) 18 | (struct rlm exp (xs rest exp) #:transparent) 19 | (struct app exp (rator rand) #:transparent) 20 | (struct ife exp (t c a) #:transparent) 21 | (struct st! exp (x e) #:transparent) 22 | (struct lcc exp (x e) #:transparent) 23 | ;; Stack inspection forms 24 | (struct grt exp (r e) #:transparent) ;; Grant 25 | (struct fal exp () #:transparent) ;; Fail 26 | (struct frm exp (r e) #:transparent) ;; Frame 27 | (struct tst exp (r t e) #:transparent) ;; Test 28 | 29 | (struct primr exp (which) #:transparent) 30 | ;; (dst Lab Sym List[Pair[Sym Boolean]] Exp) 31 | ;; Define struct form that should die after we go to real Racket. 32 | (struct dst exp (name fields e) #:transparent) 33 | 34 | 35 | ;; Unmerged data. 36 | (struct datum exp (val) #:transparent) 37 | ;; Merged versions of data that must be evaluated specially. 38 | (struct mk-list^ exp (vals) #:transparent) 39 | (struct mk-improper^ exp (vals last) #:transparent) 40 | (struct mk-vector^ exp (vals) #:transparent) 41 | (struct mk-hash^ exp (keys vals) #:transparent) 42 | 43 | (define (free e) 44 | (let loop* ([e e] 45 | [bound (set)]) 46 | (define (loop e) (loop* e bound)) 47 | (match e 48 | [(var _ name) (if (name . ∈ . bound) ∅ (set name))] 49 | [(lrc _ xs es e) 50 | (define bound* (∪/l bound xs)) 51 | (for/union #:initial (loop* e bound*) 52 | ([e (in-list es)]) 53 | (loop* e bound*))] 54 | [(lam _ vars body) (loop* body (∪/l bound vars))] 55 | [(rlm _ vars rest body) (loop* body (∪1 (∪/l bound vars) rest))] 56 | [(app _ rator rands) (for/union #:initial (loop rator) 57 | ([rand (in-list rands)]) 58 | (loop rand))] 59 | [(ife _ t c a) (∪ (loop t) (loop c) (loop a))] 60 | [(st! _ x e) 61 | (define efs (loop e)) 62 | (if (x . ∈ . bound) efs (∪1 efs x))] 63 | [(lcc _ x e) (loop* e (∪1 bound x))] 64 | [(primr _ _) ∅] 65 | [(datum _ _) ∅] 66 | ;; Continuation mark forms 67 | [(grt _ _ e) (loop e)] 68 | [(frm _ _ e) (loop e)] 69 | [(fal _) ∅] 70 | [(tst _ _ t e) (∪ (loop t) (loop e))] 71 | [_ (error 'free "Bad expr ~a" e)]))) -------------------------------------------------------------------------------- /code/bench/out.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | benchmark="../../paper/benchmark" 3 | echo " " > $benchmark 4 | # Make sure this is ((i = base-num; i < (base-num + run-num); i+=1)) 5 | # from ../drive-benchmarks.rkt 6 | for ((i = 0; i < 5; i+=1)) 7 | do 8 | grep cpu `find . -name "*.time.$i" -print` >> $benchmark 9 | grep "State count" `find . -name "*.time.$i" -print` >> $benchmark 10 | grep "Point count" `find . -name "*.time.$i" -print` >> $benchmark 11 | grep "States/second" `find . -name "*.time.$i" -print` >> $benchmark 12 | grep Timeout `find . -name "*.time.$i" -print` >> $benchmark 13 | grep Exhaust `find . -name "*.time.$i" -print` >> $benchmark 14 | grep Peak `find . -name "*.mem.$i" -print` >> $benchmark 15 | grep Current `find . -name "*.mem.$i" -print` >> $benchmark 16 | done 17 | 18 | -------------------------------------------------------------------------------- /code/btests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "parse.rkt" "kcfa-instantiations.rkt" 4 | racket/sandbox) 5 | 6 | (define (sch->sexp file) 7 | (with-input-from-file file 8 | (λ () (for/list ([form (in-port read)]) form)))) 9 | 10 | (define (prep file) (sch->sexp file)) 11 | 12 | (define-syntax-rule (log-thread kind) 13 | (let ([lr (make-log-receiver (current-logger) kind)]) 14 | (thread (λ () (let loop () (define vs (sync lr)) (write vs) (newline) (loop)))))) 15 | 16 | (define (print-values . vs) (for ([v vs]) (display v) (newline))) 17 | 18 | (define-syntax-rule (test aval e) 19 | (parameterize ([current-logger (make-logger 'stuck-states)]) 20 | #;#; 21 | (log-thread 'info) 22 | (log-thread 'debug) 23 | (with-handlers ([exn:fail:resource? 24 | (λ (e) (case (exn:fail:resource-resource e) 25 | [(time) (dump-memory-stats) (printf "Timeout~%")] 26 | [(memory) (printf "Exhausted memory~%")]))]) 27 | (with-limits 3600 10240 28 | (call-with-values 29 | (λ () (begin0 (time (aval e)) 30 | (void)#; 31 | (dump-memory-stats))) 32 | print-values))))) 33 | 34 | (define to-test 35 | (list "../benchmarks/church.sch" 36 | "../benchmarks/mbrotZ.sch" 37 | "../benchmarks/earley.sch" 38 | "../benchmarks/toplas98/boyer.sch" 39 | "../benchmarks/toplas98/graphs.sch" 40 | "../benchmarks/toplas98/lattice.scm" 41 | "../benchmarks/toplas98/matrix.scm" 42 | "../benchmarks/toplas98/maze.sch" ;; call/cc 43 | "../benchmarks/toplas98/nbody.sch" 44 | "../benchmarks/toplas98/nucleic.sch" 45 | ;;"../benchmarks/toplas98/splay.scm" ;; old match 46 | ;;"../benchmarks/toplas98/nucleic2.sch" ;; define-syntax 47 | ;;"../benchmarks/toplas98/handle.scm" ;; old match and defmacro 48 | )) 49 | 50 | (for ([t to-test]) (test lazy-0cfa^/c! (prep t))) 51 | (printf "~%~%==============BASELINE=============~%~%") 52 | (for ([t to-test]) (test 0cfa^ (prep t))) 53 | 54 | -------------------------------------------------------------------------------- /code/context.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "do.rkt" "env.rkt" "notation.rkt" "primitives.rkt" racket/splicing racket/stxparam 3 | (for-syntax syntax/parse) "data.rkt") 4 | (provide bind-0 bind-1 bind-∞ 5 | bind-rest-0 bind-rest-1 bind-rest-∞ 6 | with-0-ctx with-1-ctx with-∞-ctx 7 | make-var-contour-0 make-var-contour-k) 8 | 9 | (define-for-syntax ((mk-bind-rest K) stx) 10 | (syntax-parse stx 11 | [(_ (ρ* σ* δ*) (ρ iσ l δ xs r v-addrs) body) 12 | (define (bind-args wrap as r-meaning) 13 | (wrap 14 | (quasisyntax/loc stx 15 | (let-syntax ([add-r (syntax-rules () 16 | [(_ (νσ νρ sσ sρ sr sδ* vrest) body*) 17 | #,r-meaning])]) 18 | (define-values (vfirst vrest) 19 | (let loop ([xs* xs] [axs '()] [vs v-addrs]) 20 | (match* (xs* vs) 21 | [('() vs) (values (reverse axs) vs)] 22 | [((cons x xrest) (cons a arest)) 23 | (loop xrest (cons a axs) arest)]))) 24 | (add-r (σ* ρ* iσ ρ r δ* vrest) 25 | (bind-alias* (σ* σ* #,as vfirst) body)))))) 26 | ;; Abstractly, rest-arg is an infinite list. 27 | (define abs-r 28 | #`(let* ([ra sr] 29 | [rA (make-var-contour `(A . ,sr) sδ*)] 30 | [rvs (if (null? vrest) snull (⊓1 snull (consv rA ra)))] 31 | #,@(if (zero? K) #'() #'([νρ (extend sρ r rA)]))) 32 | (bind-join (νσ sσ ra rvs) 33 | (bind-big-alias (νσ νσ rA vrest) body*)))) 34 | ;; Concretely, rest-arg is a finite list. 35 | (define conc-r 36 | #'(let*-values ([(ra) (cons sr sδ*)] 37 | [(νρ) (extend sρ r ra)]) 38 | (do (sσ) loop ([as vrest] [last ra] [count 0]) 39 | (match as 40 | ['() 41 | (do (sσ) ([νσ #:join sσ last snull]) 42 | body*)] 43 | [(cons a as) 44 | (define rnextA `((,sr A . ,count) . ,sδ*)) 45 | (define rnextD `((,sr D . ,count) . ,sδ*)) 46 | (do (sσ) ([νσ #:alias sσ rnextA a] 47 | [νσ #:join νσ last (singleton (consv rnextA rnextD))]) 48 | (loop νσ as rnextD (add1 count)))])))) 49 | (cond [(zero? K) 50 | (bind-args values #'xs abs-r)] 51 | [(< K +inf.0) 52 | (bind-args (λ (body) 53 | #`(let* ([δ* (truncate (cons l δ) #,K)] 54 | [as (map (λ (x) (cons x δ*)) xs)] 55 | [ρ* (extend* ρ xs as)]) 56 | #,body)) 57 | #'as abs-r)] 58 | [else 59 | (bind-args (λ (body) #`(let* ([δ* (cons l δ)] 60 | [as (map (λ (x) (cons x δ*)) xs)] 61 | [ρ* (extend* ρ xs as)]) 62 | #,body)) 63 | #'as conc-r)])])) 64 | 65 | (define-for-syntax ((mk-bind K) stx) 66 | (syntax-parse stx 67 | [(_ (ρ* σ* δ*) (ρ bσ l δ xs v-addrs) body) 68 | (define vs 69 | (λ (addrs) 70 | (quasisyntax/loc stx 71 | (bind-alias* (σ* bσ #,addrs v-addrs) body)))) 72 | (if (zero? K) 73 | (vs #'xs) 74 | #`(let* ([δ* (truncate (cons l δ) #,K)] 75 | [as (map (λ (x) (cons x δ*)) xs)] 76 | [ρ* (extend* ρ xs as)]) 77 | #,(vs #'as)))])) 78 | (define-syntax-rule (make-var-contour-0 x δ) x) 79 | (define-syntax-rule (make-var-contour-k x δ) (cons x δ)) 80 | 81 | (define-syntax bind-0 (mk-bind 0)) 82 | (define-syntax bind-1 (mk-bind 1)) 83 | (define-syntax bind-∞ (mk-bind +inf.0)) 84 | (define-syntax bind-rest-0 (mk-bind-rest 0)) 85 | (define-syntax bind-rest-1 (mk-bind-rest 1)) 86 | (define-syntax bind-rest-∞ (mk-bind-rest +inf.0)) 87 | 88 | (define ε '()) 89 | (define (truncate δ k) 90 | (cond [(zero? k) '()] 91 | [(empty? δ) '()] 92 | [else 93 | (cons (first δ) (truncate (rest δ) (sub1 k)))])) 94 | 95 | (define-syntax-rule (with-0-ctx body) 96 | (splicing-syntax-parameterize 97 | ([bind (make-rename-transformer #'bind-0)] 98 | [bind-rest (make-rename-transformer #'bind-rest-0)] 99 | [make-var-contour (make-rename-transformer #'make-var-contour-0)]) 100 | body)) 101 | 102 | (define-syntax-rule (with-1-ctx body) 103 | (splicing-syntax-parameterize 104 | ([bind (make-rename-transformer #'bind-1)] 105 | [bind-rest (make-rename-transformer #'bind-rest-1)] 106 | [make-var-contour (make-rename-transformer #'make-var-contour-k)]) 107 | body)) 108 | 109 | (define-syntax-rule (with-∞-ctx body) 110 | (splicing-syntax-parameterize 111 | ([bind (make-rename-transformer #'bind-∞)] 112 | [bind-rest (make-rename-transformer #'bind-rest-∞)] 113 | [make-var-contour (make-rename-transformer #'make-var-contour-k)]) 114 | body)) 115 | -------------------------------------------------------------------------------- /code/data.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "ast.rkt" "notation.rkt" (for-syntax syntax/parse racket/syntax) 3 | racket/stxparam) 4 | (provide define-nonce mk-touches mk-flatten-value cons-limit 5 | ;; abstract values 6 | number^;;integer^ rational^ 7 | number^? 8 | string^ string^? 9 | symbol^ symbol^? 10 | char^ char^? 11 | cons^ cons^? 12 | vector^ vector^? vec0 13 | vector-immutable^ vector-immutable^? 14 | qdata^ qcons^ qvector^ qcons^? qvector^? 15 | ● ⊥ 16 | open@ closed@ 17 | fail ;; for continuation marks 18 | flatten-value 19 | (struct-out vectorv^) 20 | (struct-out vectorv-immutable^) 21 | (struct-out input-port^) 22 | (struct-out output-port^) 23 | ;; concrete/abstract values 24 | (struct-out primop) 25 | (struct-out consv) 26 | (struct-out vectorv) 27 | (struct-out vectorv-immutable) 28 | (struct-out addr) 29 | atomic? 30 | nothing singleton 31 | ≡ ⊑? big⊓ ⊓ ⊓1) 32 | 33 | (define-syntax (define-nonce stx) 34 | (syntax-case stx () [(_ name) (identifier? #'name) 35 | (with-syntax ([-name (format-id #'name "-~a" #'name)]) 36 | #'(begin (struct -name ()) 37 | (define name (-name))))])) 38 | 39 | ;; An AbstractVal is one of: 40 | ;; - number^ 41 | ;; - string^ 42 | ;; - symbol^ 43 | ;; - cons^ 44 | ;; - vector^ 45 | ;; - ● 46 | ;; - (vectorv^ Number Addr) ;; collapsed into one addr 47 | ;; - (input-port^ Addr) 48 | ;; - (output-port^ Addr) 49 | ;; Some concrete values: 50 | ;; - Number 51 | ;; - String 52 | ;; - Symbol 53 | ;; - eof 54 | ;; - '() 55 | ;; - (void) 56 | ;; - (primop Sym) 57 | ;; - (consv Addr Addr) 58 | ;; - (vectorv Number (listof Addr)) 59 | ;; - (clos List[Var] Exp Env) ;; or without Env. Constructed by mk-analysis. 60 | (define-nonce number^) (define (number^? v) (or (eq? v number^) (and (or (eq? v ●) (eq? v qdata^)) ●))) 61 | (define-nonce string^) (define (string^? v) (or (eq? v string^) (and (or (eq? v ●) (eq? v qdata^)) ●))) 62 | (define-nonce symbol^) (define (symbol^? v) (or (eq? v symbol^) (and (or (eq? v ●) (eq? v qdata^)) ●))) 63 | (define-nonce char^) (define (char^? v) (or (eq? v char^) (and (or (eq? v ●) (eq? v qdata^)) ●))) 64 | (define-nonce cons^) (define (cons^? v) (or (eq? v cons^) (and (eq? v ●) ●))) 65 | (define-nonce vector^) (define (vector^? v) (or (eq? v vector^) (and (eq? v ●) ●))) 66 | (define-nonce vector-immutable^) (define (vector-immutable^? v) (or (eq? v vector-immutable^) (and (eq? v ●) ●))) 67 | (define-nonce qvector^) (define (qvector^? v) (or (eq? v qvector^) (and (eq? v qdata^) ●))) 68 | (define-nonce qcons^) (define (qcons^? v) (or (eq? v qcons^) (and (eq? v qdata^) ●))) 69 | (define-nonce vec0) ;; 0-length vector. 70 | (struct input-port^ (status) #:prefab) 71 | (struct output-port^ (status) #:prefab) 72 | (define-nonce qdata^) 73 | ;; Status tokens for ports. Not values! 74 | (define-nonce open@) 75 | (define-nonce closed@) 76 | ;; Olin's black hole 77 | (define-nonce ●) 78 | (define-nonce ⊥) 79 | 80 | ;; Continutation marks fail token 81 | (define-nonce fail) 82 | 83 | (define-syntax-parameter flatten-value #f) 84 | (define-simple-macro* (mk-flatten-value name clos rlos kont?) 85 | (define (name v) 86 | (match v 87 | [(? number?) number^] 88 | [(? string?) string^] 89 | [(? symbol?) symbol^] 90 | [(? char?) char^] 91 | [(or (? boolean?) '() (? void?) (? eof-object?)) v] 92 | [(or (? number^?) (== string^) (== symbol^) (== char^) 93 | (? vector^?) (== vector-immutable^)) v] 94 | [(? consv?) cons^] 95 | [(? vectorv?) vector^] 96 | [(or (? vectorv-immutable^?) (? vector?)) vector-immutable^] 97 | [(or (? input-port^?) (? input-port?)) 'input-port] 98 | [(or (? output-port^?) (? output-port?)) 'output-port] 99 | [(or (clos _ _ _ _) 100 | (rlos _ _ _ _ _)) 'function] 101 | [(? kont?) 'continuation] 102 | [else (error "Unknown base value" v)]))) 103 | 104 | ;; Everything is all heterogeneous 105 | (define nothing ∅) 106 | (define singleton set) 107 | (define ⊓ set-union) 108 | (define ⊓1 set-add) 109 | 110 | (define ⊑? subset?) 111 | (define (≡ vs0 vs1) (= (set-count vs0) (set-count vs1))) 112 | 113 | (define-syntax-rule (big⊓ vs0 V) 114 | (let () 115 | (unless (= (set-count vs0) 1) 116 | (error 'big⊓ "Expected singleton values for big⊓: ~a ~a" vs0 V)) 117 | (define v0 (for/first ([v (in-set vs0)]) v)) 118 | (cond [(eq? ⊥ V) v0] 119 | [else (if (equal? v0 V) 120 | V 121 | (let ([v0f (flatten-value v0)]) 122 | (if (equal? v0f V) 123 | V 124 | qdata^)))]))) 125 | 126 | (define cons-limit (make-parameter 8)) 127 | 128 | (struct vectorv^ (length addr) #:prefab) 129 | (struct vectorv-immutable^ (length addr) #:prefab) 130 | 131 | ;; A Val is one of: 132 | ;; - Number 133 | ;; - Boolean 134 | ;; - (void) 135 | ;; - String 136 | ;; - Symbol 137 | ;; - '() 138 | ;; - eof 139 | ;; - Input-Port 140 | ;; - Output-Port 141 | ;; - (addr Addr) ;; for delayed lookup. 142 | ;; - (primop Sym) 143 | ;; - (consv Addr Addr) 144 | ;; - (vectorv Number (listof Addr)) 145 | ;; - (immutable-vector Val ...) 146 | ;; - (clos List[Var] Exp Env) ;; or without Env. Constructed by mk-analysis. 147 | (struct primop (which) #:prefab) 148 | (struct consv (car cdr) #:prefab) 149 | (struct vectorv (length addrs) #:prefab) 150 | (struct vectorv-immutable (length addrs) #:prefab) 151 | (struct addr (a) #:prefab) 152 | 153 | ;; For the lazy Krivine machine, a lazy cons (lazy in both arguments) 154 | (struct lconsv (car cdr) #:prefab) 155 | 156 | ;; What are the supported primitives for a datum form? 157 | ;; REMARK: no list literals. 158 | (define (atomic? x) 159 | (or (number? x) 160 | (boolean? x) 161 | (void? x) 162 | (char? x) 163 | (string? x) 164 | (symbol? x) 165 | (null? x) 166 | (eof-object? x))) 167 | 168 | (define-simple-macro* (mk-touches touches:id clos:id rlos:id promise:id 0cfa?:boolean) 169 | (define (touches v) 170 | (match v 171 | [(clos xs e ρ fvs) 172 | #,(if (syntax-e #'0cfa?) 173 | #'fvs 174 | #'(for/hash ([x (in-set fvs)]) 175 | (hash-ref ρ x 176 | (λ () (error 'touches "Free identifier (~a) not in env ~a" x ρ)))))] 177 | [(rlos xs rest e ρ fvs) 178 | #,(if (syntax-e #'0cfa?) 179 | #'fvs 180 | #'(for/hash ([x (in-set fvs)]) 181 | (hash-ref ρ x 182 | (λ () (error 'touches "Free identifier (~a) not in env ~a" x ρ)))))] 183 | [(consv a d) (set a d)] 184 | [(or (vectorv _ l) 185 | (vectorv-immutable _ l)) (list->set l)] 186 | [(or (vectorv^ _ a) 187 | (vectorv-immutable^ _ a)) (set a)] 188 | [(? set? s) (for/union ([v (in-set s)]) (touches v))] 189 | [(promise e ρ) 190 | #,(if (syntax-e #'0cfa?) 191 | #'(free e) 192 | #'(for/hash ([x (in-set (free e))]) 193 | (hash-ref ρ x 194 | (λ () (error 'touches "Free identifier (~a) not in env ~a" x ρ)))))] 195 | [_ (set)]))) 196 | 197 | -------------------------------------------------------------------------------- /code/deltas.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "do.rkt" "env.rkt" "notation.rkt" "primitives.rkt" racket/splicing racket/stxparam 3 | "store-passing.rkt" "context.rkt" "fix.rkt" 4 | "handle-limits.rkt" 5 | "graph.rkt" racket/stxparam) 6 | (provide bind-join-∆s bind-join*-∆s mk-∆-fix^ mk-∆-fix2^ mk-timestamp-∆-fix^ with-σ-∆s) 7 | 8 | ;; Utility function for combining multiple σ-∆s 9 | (define (map2-append f acc ls0 ls1) 10 | (let loop ([ls0 ls0] [ls1 ls1]) 11 | (match* (ls0 ls1) 12 | [((cons h0 t0) (cons h1 t1)) 13 | (cons (f h0 h1) (loop t0 t1))] 14 | [('() '()) acc] 15 | [(_ _) 16 | (error 'map2-append "Expected same length lists. Finished at ~a ~a" 17 | ls0 ls1)]))) 18 | 19 | (define-simple-macro* (bind-join-∆s (∆s* ∆s a vs) body) 20 | (let ([∆s* (cons (cons a vs) ∆s)]) #,(bind-rest #'∆s* #'body))) 21 | (define-simple-macro* (bind-join*-∆s (∆s* ∆s as vss) body) 22 | (let ([∆s* (map2-append cons ∆s as vss)]) #,(bind-rest #'∆s* #'body))) 23 | 24 | (define-syntax-rule (top-hash-getter thgσ a) 25 | (hash-ref top-σ a (λ () (error 'top-hash-getter "Unbound address ~a in store ~a" a top-σ)))) 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | ;; Wide fixpoint for σ-∆s 29 | 30 | (define-syntax-rule (∆-step step) 31 | (λ (state-count) 32 | (λ (σ cs) 33 | (set-box! state-count (+ (unbox state-count) (set-count cs))) 34 | (define-values (∆ cs*) 35 | (for/fold ([∆ '()] [cs* ∅]) ([c (in-set cs)]) 36 | (define-values (∆* cs**) (step (cons σ c))) 37 | (values (append ∆* ∆) (∪ cs** cs*)))) 38 | (define-values (σ* same?) (update/change ∆ σ)) 39 | (values σ* (not same?) cs*)))) 40 | 41 | (define-syntax-rule (∆-step2 step) 42 | (λ (state-count) 43 | (λ (state) 44 | (match state 45 | [(cons σ cs) 46 | (set-box! state-count (+ (unbox state-count) (set-count cs))) 47 | (define-values (∆ cs*) 48 | (for/fold ([∆ '()] [cs* ∅]) ([c (in-set cs)]) 49 | (define-values (∆* cs**) (step (cons σ c))) 50 | (values (append ∆* ∆) (∪ cs** cs*)))) 51 | (set (cons (update ∆ σ) cs*))])))) 52 | 53 | (define-syntax-rule (mk-∆-fix^ name ans^?) 54 | (define-syntax-rule (name step fst) 55 | (let-values ([(∆ cs) fst]) 56 | (define state-count* (state-count)) 57 | (set-box! state-count* 0) 58 | (define step^ ((∆-step step) state-count*)) 59 | (set-box! (start-time) (current-milliseconds)) 60 | (define-values (Σ ss) (fix-t2 step^ (update ∆ (hash)) cs)) 61 | (state-rate) 62 | (define final-cs 63 | (for/fold ([final-cs ∅]) ([s ss]) 64 | (match s 65 | [(cons fsσ c) 66 | (∪ final-cs (if (ans^? c) (set c) ∅))] 67 | [_ (error 'name "bad output ~a~%" s)]))) 68 | (values (format "State count: ~a" (unbox state-count*)) 69 | (format "Point count: ~a" (set-count (for/set ([p (in-set ss)]) (cdr p)))) 70 | (car Σ) final-cs)))) 71 | 72 | 73 | (define-syntax-rule (mk-∆-fix2^ name ans^?) 74 | (define-syntax-rule (name step fst) 75 | (let-values ([(∆ cs) fst]) 76 | (define state-count* (state-count)) 77 | (set-box! state-count* 0) 78 | (define step^ ((∆-step2 step) state-count*)) 79 | (set-box! (start-time) (current-milliseconds)) 80 | (define ss (fix step^ (set (cons (update ∆ (hash)) cs)))) 81 | (state-rate) 82 | (define-values (last-σ final-cs) 83 | (for/fold ([last-σ #hash()] [final-cs ∅]) ([s ss]) 84 | (match s 85 | [(cons fsσ cs) 86 | (values (join-store last-σ fsσ) 87 | (for/fold ([final-cs final-cs]) ([c (in-set cs)] 88 | #:when (ans^? c)) 89 | (∪1 final-cs c)))] 90 | [_ (error 'name "bad output ~a~%" s)]))) 91 | (values (format "State count: ~a" (unbox state-count*)) 92 | (format "Point count: ~a" (set-count (for/union ([p (in-set ss)]) (cdr p)))) 93 | last-σ final-cs)))) 94 | 95 | ;; Uses counting and merges stores between stepping all states. 96 | (define-simple-macro* (mk-timestamp-∆-fix^ name ans^?) 97 | (define-syntax-rule (name step fst) 98 | (let () 99 | (set-box! (start-time) (current-milliseconds)) 100 | (define state-count* (state-count)) 101 | (set-box! state-count* 0) 102 | (define-values (∆ cs) fst) 103 | #,@(if (syntax-parameter-value #'generate-graph?) #'((define graph (make-hash))) #'()) 104 | (define-values (last-σ final-cs) 105 | (let loop ([accum (hash)] [front cs] [σ (update ∆ (hash))] [σ-count 0]) 106 | (cond [(∅? front) 107 | (state-rate) 108 | #,@(if (syntax-parameter-value #'generate-graph?) #'((dump-dot graph)) #'()) 109 | (values σ (for/set ([(c _) (in-hash accum)]) c))] 110 | [else 111 | ;; If a state is revisited with a different store, that counts as 112 | ;; a different state. 113 | (set-box! state-count* (+ (unbox state-count*) (set-count front))) 114 | (let step/join ([accum accum] [todo front] [front ∅] [∆ '()]) 115 | (match (for/first ([c (in-set todo)]) c) 116 | [#f (define σ* (update ∆ σ)) 117 | (define count* (if (null? ∆) σ-count (add1 σ-count))) 118 | (loop accum front σ* count*)] 119 | [c (define-values (∆* cs*) (step (cons σ c))) 120 | (define change? (would-update? ∆* σ)) 121 | (define ∆** (if change? (append ∆* ∆) ∆)) 122 | (define todo* (todo . ∖1 . c)) 123 | (define-values (accum* front*) 124 | (for/fold ([accum* accum] [front* front]) 125 | ([c* (in-set cs*)] 126 | #:when (or change? 127 | (not (= σ-count (hash-ref accum c* -1))))) 128 | #,@(if (syntax-parameter-value #'generate-graph?) #'((add-edge! graph c c*)) #'()) 129 | (values (hash-set accum* c* σ-count) (∪1 front* c*)))) 130 | (step/join accum* todo* front* ∆**)]))]))) 131 | ;; filter the final results 132 | (values (format "State count: ~a" (unbox state-count*)) 133 | (format "Point count: ~a" (set-count final-cs)) 134 | last-σ 135 | (for/set ([c (in-set final-cs)] 136 | #:when (ans^? c)) 137 | c))))) 138 | 139 | (define-syntax-rule (with-σ-∆s body) 140 | (splicing-syntax-parameterize 141 | ([bind-join (make-rename-transformer #'bind-join-∆s)] 142 | [bind-join* (make-rename-transformer #'bind-join*-∆s)] 143 | [getter (make-rename-transformer #'top-hash-getter)]) 144 | body)) 145 | -------------------------------------------------------------------------------- /code/drive-benchmarks.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; This module drives [run-benchmark.rkt] with several algorithms/benchmarks 4 | ;; to run in parallel. Since we want the output of each run of each algorithm/benchmark, 5 | ;; we label the run numbers in the interval [base-num, base-num + run-num). 6 | 7 | ;; The parallelism is determined by num-threads. There is no work-stealing, 8 | ;; so some threads will finish far sooner than others. This has not been a problem, 9 | ;; and we could do better with minimal effort by randomly shuffling the worklist 10 | ;; before distributing it to the threads (see the main submodule below). 11 | 12 | ;; NOTE: if base-num or run-num change, you must manually change [code/bench/out.sh] 13 | ;; and [paper/proctime.rkt] to be consistent with the number range. 14 | (define base-num 0) 15 | (define run-num 5) 16 | (define num-threads 11) 17 | 18 | ;; In order to get consistent benchmarking numbers, each run is in a /fresh/ 19 | ;; Racket VM, which we spin up with a shell command. The analysis statistics are 20 | ;; printed to stdout, and the memory statistics to stderr. 21 | ;; 22 | ;; See [code/bench/out.sh] for the script we used to distill the output info 23 | ;; that is processed by [paper/proctime.rkt] 24 | (define (construct-cmd which n file) 25 | (define path (string->path file)) 26 | (define-values (base filename dir?) (split-path path)) 27 | (define outtime (path-replace-suffix filename (format ".~a.time.~a" which (+ n base-num)))) 28 | (define outmem (path-replace-suffix filename (format ".~a.mem.~a" which (+ n base-num)))) 29 | (format "racket run-benchmark.rkt --~a ~a > bench/~a 2> bench/~a" which file outtime outmem)) 30 | 31 | ;; We identify benchmarks so that we can collect stats easier in [proctime.rkt] (LOC, etc.) 32 | (define church "../benchmarks/church.sch") 33 | (define mbrotZ "../benchmarks/mbrotZ.sch") 34 | (define earley "../benchmarks/earley.sch") 35 | (define boyer "../benchmarks/toplas98/boyer.sch") 36 | (define graphs "../benchmarks/toplas98/graphs.sch") 37 | (define lattice "../benchmarks/toplas98/lattice.scm") 38 | (define matrix "../benchmarks/toplas98/matrix.scm") 39 | (define maze "../benchmarks/toplas98/maze.sch") 40 | (define nbody "../benchmarks/toplas98/nbody.sch") 41 | (define nucleic "../benchmarks/toplas98/nucleic.sch") 42 | (define to-test 43 | (list church mbrotZ earley lattice graphs boyer matrix maze nbody nucleic)) 44 | 45 | (module+ data (provide church mbrotZ earley boyer graphs lattice matrix maze nbody nucleic to-test)) 46 | 47 | ;; Algorithm tags used to drive [run-benchmark.rkt] 48 | (define baseline "sp") 49 | (define timestamped "spt") 50 | (define deltat "sdt") 51 | (define lazy "ls") 52 | (define lazyt "lst") 53 | (define compiled "lc") 54 | (define compiledt "lct") 55 | (define deltas "ld") 56 | (define deltasid "id") 57 | (define deltasis "is") 58 | (define deltaspd "pd") 59 | (define deltasps "ps") 60 | ;; Not in paper since insignificant or worse performance+precision 61 | (define deltasfd "fd") 62 | (define imperative "it") 63 | (define preallocated "pt") 64 | (define deltasia "ia") 65 | (define deltaspa "pa") 66 | 67 | (define which-analyses 68 | (list 69 | ;; deltasfd ;; like deltaspd, only purely functional. Unfortunately slow. 70 | ;; baseline 71 | timestamped 72 | deltat 73 | lazyt 74 | ;; imperative ;; timestamp approximation, not in paper. 75 | ;; preallocated ;; timestamp approximation, not in paper. 76 | #| 77 | deltasid 78 | deltaspd 79 | |# 80 | compiledt 81 | deltasps)) 82 | 83 | (define (run which file) 84 | (for ([n (in-range run-num)]) 85 | (printf "Running ~a (count ~a): ~a~%" which n file) 86 | (system (construct-cmd which n file)))) 87 | 88 | ;; Split work "evenly" by number of threads. 89 | ;; The last thread gets the remainder of integer division in addition to 90 | ;; its "even" allotment. 91 | (define (distribute-threads work) 92 | (define num (length work)) 93 | (define even (quotient num num-threads)) 94 | (let loop ([w work] [per-thread '()] [thread-num 1]) 95 | (cond [(= thread-num num-threads) 96 | (cons w per-thread)] 97 | [else 98 | (define-values (this rest) (split-at w even)) 99 | (loop rest (cons this per-thread) (add1 thread-num))]))) 100 | 101 | (module+ main 102 | ;; Spin up threads 103 | (define running-threads 104 | (let ([distributed (distribute-threads 105 | (for*/list ([file (in-list to-test)] 106 | [which (reverse which-analyses)]) 107 | (cons which file)))]) 108 | (for/list ([work-for-thread distributed]) 109 | (thread (λ () (for ([work (in-list work-for-thread)]) 110 | (run (car work) (cdr work)))))))) 111 | ;; Join all threads 112 | (for ([w running-threads]) (thread-wait w))) 113 | -------------------------------------------------------------------------------- /code/env.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide extend extend* join join* join-store 3 | update update/change would-update? restrict-to-reachable restrict-to-reachable/vector) 4 | (require "data.rkt" "ast.rkt" "notation.rkt") 5 | 6 | (define (extend ρ x v) 7 | (hash-set ρ x v)) 8 | (define (extend* ρ xs vs) 9 | (for/fold ([ρ ρ]) ([x (in-list xs)] [v (in-list vs)]) 10 | (hash-set ρ x v))) 11 | (define (join eσ a s) 12 | (hash-set eσ a (⊓ s (hash-ref eσ a ∅)))) 13 | (define (join* eσ as ss) 14 | (for/fold ([eσ eσ]) ([a as] [s ss]) (join eσ a s))) 15 | 16 | ;; Perform join and return if the join was idempotent 17 | (define (join/change eσ a s) 18 | (define prev (hash-ref eσ a ∅)) 19 | (define s* (⊓ s prev)) 20 | (values (hash-set eσ a s*) (≡ prev s*))) 21 | 22 | (define (no-change? eσ a s) 23 | (⊑? s (hash-ref eσ a nothing))) 24 | 25 | ;; Store Store -> Store 26 | (define (join-store eσ1 eσ2) 27 | (for/fold ([eσ eσ1]) 28 | ([(k v) (in-hash eσ2)]) 29 | (join eσ k v))) 30 | 31 | (define (update ∆s eσ) 32 | (for/fold ([eσ eσ]) ([a×vs (in-list ∆s)]) 33 | (join eσ (car a×vs) (cdr a×vs)))) 34 | 35 | (define (update/change ∆s eσ) 36 | (for/fold ([eσ eσ] [same? #t]) ([a×vs (in-list ∆s)]) 37 | (define-values (σ* a-same?) (join/change eσ (car a×vs) (cdr a×vs))) 38 | (values σ* (and same? a-same?)))) 39 | 40 | (define (would-update? ∆s eσ) 41 | (not (for/and ([a×vs (in-list ∆s)]) (no-change? eσ (car a×vs) (cdr a×vs))))) 42 | 43 | (define (((mk-reach ref) touches) eσ root) 44 | (define seen ∅) 45 | (let loop ([as root]) 46 | (for/union #:res acc ([a (in-set as)] 47 | #:unless (a . ∈ . seen)) 48 | (set! seen (∪1 seen a)) 49 | (for/union #:initial (∪1 acc a) 50 | ([v (in-set (ref eσ a))]) 51 | (loop (touches v)))))) 52 | 53 | (define ((mk-restrict-to-reachable ref) touches) 54 | (define reach ((mk-reach ref) touches)) 55 | (λ (eσ v) 56 | (for/hash ([a (in-set (reach eσ (touches v)))]) 57 | (values a (ref eσ a))))) 58 | 59 | (define reach (mk-reach hash-ref)) 60 | (define reach/vec (mk-reach vector-ref)) 61 | 62 | (define restrict-to-reachable (mk-restrict-to-reachable hash-ref)) 63 | (define restrict-to-reachable/vector (mk-restrict-to-reachable vector-ref)) 64 | -------------------------------------------------------------------------------- /code/fix.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "notation.rkt" "graph.rkt" racket/stxparam) 3 | (provide mk-fix fix appl fix-t fix-t2) 4 | 5 | ;; appl : (∀ (X) ((X -> (Setof X)) -> ((Setof X) -> (Setof X)))) 6 | (define ((appl f) s) 7 | (for/union ([x (in-set s)]) (f x))) 8 | 9 | ;; Calculate fixpoint of (appl f). 10 | ;; fix : (∀ (X) ((X -> (Setof X)) (Setof X) -> (Setof X))) 11 | (define (fix f s) 12 | (let loop ((accum ∅) (front s)) 13 | (cond [(∅? front) accum] 14 | [else (define new-front ((appl f) front)) 15 | (loop (∪ accum front) (new-front . ∖ . accum))]))) 16 | 17 | (define (fix-t f σ cs) 18 | (let loop ([accum ∅] [front cs] [σ σ] [t 0] [Σ (list σ)]) 19 | (cond [(∅? front) (values Σ accum)] 20 | [else (define-values (σ* stepped) (f σ front)) 21 | (define-values (t* Σ*) 22 | (if (equal? σ σ*) 23 | (values t Σ) 24 | (values (add1 t) (cons σ* Σ)))) 25 | (define-values (new-accum new-front) 26 | (for*/fold ([new-accum accum] 27 | [new-front ∅]) 28 | ([c (in-set stepped)] 29 | [s (in-value (cons t* c))] 30 | #:unless (set-member? accum s)) 31 | (values (∪1 new-accum s) (∪1 new-front c)))) 32 | (loop new-accum new-front σ* t* Σ*)]))) 33 | 34 | (define (fix-t2 f σ cs) 35 | (let loop ([accum ∅] [front cs] [σ σ] [t 0] [Σ (list σ)]) 36 | (cond [(∅? front) (values Σ accum)] 37 | [else (define-values (σ* ∆? stepped) (f σ front)) 38 | (define-values (t* Σ*) 39 | (if ∆? 40 | (values (add1 t) (cons σ* Σ)) 41 | (values t Σ))) 42 | (define-values (new-accum new-front) 43 | (for*/fold ([new-accum accum] 44 | [new-front ∅]) 45 | ([c (in-set stepped)] 46 | [s (in-value (cons t* c))] 47 | #:unless (set-member? accum s)) 48 | (values (∪1 new-accum s) (∪1 new-front c)))) 49 | (loop new-accum new-front σ* t* Σ*)]))) 50 | 51 | (define-simple-macro* (mk-fix name ans? ans-v) 52 | (define (name step fst) 53 | (define graph (make-hash)) 54 | (define ss (fix #,(if (syntax-parameter-value #'generate-graph?) 55 | #'(λ (s) 56 | (define res (step s)) 57 | (for ([s* (in-set res)]) 58 | (add-edge! graph s s*)) 59 | res) 60 | #'step) 61 | fst)) 62 | #,@(if (syntax-parameter-value #'generate-graph?) #'((dump-dot graph)) #'()) 63 | (values (format "State count: ~a" (set-count ss)) 64 | (for/set ([s ss] #:when (ans? s)) (ans-v s))))) -------------------------------------------------------------------------------- /code/generators.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "do.rkt" "env.rkt" "notation.rkt" "primitives.rkt" racket/splicing racket/stxparam 3 | "imperative.rkt" "store-passing.rkt" 4 | (rename-in racket/generator [yield real-yield])) 5 | (provide mk-generator/wide/σ-∆s-fixpoint 6 | mk-generator/wide/imperative-fixpoint 7 | with-σ-passing-generators 8 | with-global-σ-generators) 9 | 10 | (define-syntax-rule (pull gen ∆-base cs-base) 11 | (let*-values ([(cs ∆) 12 | (for/fold ([cs cs-base] [last #f]) 13 | ([c (in-producer gen (λ (x) (eq? 'done x)))]) 14 | (cond [(list? c) (values cs (if last (append c last) c))] 15 | [else (values (set-add cs c) last)]))] 16 | [(∆*) (if (list? ∆) (append ∆ ∆-base) ∆-base)]) 17 | (values cs ∆*))) 18 | 19 | (define-syntax-rule (σ-∆s/generator/wide-step-specialized step ans?) 20 | (λ (state) 21 | (match state 22 | [(cons gσ cs) 23 | (define-values (cs* ∆) 24 | (for/fold ([cs* ∅] [∆* '()]) 25 | ([c cs] #:unless (ans? c)) 26 | (pull (step (cons gσ c)) ∆* cs*))) 27 | (cons (update ∆ gσ) (set-union cs cs*))]))) 28 | 29 | (define-syntax-rule (mk-generator/wide/σ-∆s-fixpoint name ans? touches) 30 | (define-syntax-rule (name step fst) 31 | (let () 32 | (define wide-step (σ-∆s/generator/wide-step-specialized step ans?)) 33 | (define clean-σ (restrict-to-reachable touches)) 34 | (define-values (cs ∆) (pull fst '() ∅)) 35 | (define fst-s (cons (update ∆ (hash)) cs)) 36 | (define snd (wide-step fst-s)) 37 | (let loop ((next snd) (prev fst-s)) 38 | (cond [(equal? next prev) 39 | (define answers 40 | (for/set ([c (cdr prev)] 41 | #:when (ans? c)) 42 | c)) 43 | (values (format "State count: ~a" (set-count (cdr prev))) 44 | (clean-σ (car prev) answers) 45 | answers)] 46 | [else (loop (wide-step next) next)]))))) 47 | 48 | (define-syntax-rule (pull-global gen cs-base) 49 | (for/set #:initial cs-base 50 | ([c (in-producer gen (λ (x) (eq? 'done x)))]) 51 | c)) 52 | 53 | (define-syntax-rule (imperative/generator/wide-step-specialized step ans?) 54 | (match-lambda 55 | [(cons σ-count cs) 56 | (define cs* 57 | (for/fold ([cs* ∅]) 58 | ([c cs] #:unless (ans? c)) 59 | (pull-global (step c) cs*))) 60 | (cons unions (∪ cs cs*))])) 61 | 62 | (define-syntax-rule (mk-generator/wide/imperative-fixpoint name ans? ans-v touches) 63 | (define-syntax-rule (name step fst) 64 | (let () 65 | (define wide-step (imperative/generator/wide-step-specialized step ans?)) 66 | (define clean-σ (restrict-to-reachable touches)) 67 | (reset-globals! (make-hash)) 68 | (define cs (pull-global fst ∅)) 69 | (define fst-s (cons unions cs)) 70 | (define snd (wide-step fst-s)) 71 | (let loop ((next snd) (prev fst-s)) 72 | (cond [(equal? next prev) 73 | (define answers (for/set ([c (cdr prev)] 74 | #:when (ans? c)) 75 | (ans-v c))) 76 | (values (format "State count: ~a" (set-count (cdr prev))) 77 | (clean-σ global-σ answers) 78 | answers)] 79 | [else 80 | (loop (wide-step next) next)]))))) 81 | 82 | (define-syntax-rule (with-σ-passing-generators body) 83 | (splicing-syntax-parameterize 84 | ([yield-meaning (syntax-rules () [(_ e) (begin (real-yield e) target-σ)])]) 85 | body)) 86 | 87 | (define-syntax-rule (with-global-σ-generators body) 88 | (splicing-syntax-parameterize 89 | ([yield-meaning (syntax-rules () [(_ e) (real-yield e)])]) 90 | body)) -------------------------------------------------------------------------------- /code/graph.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require racket/stxparam racket/trace) 3 | (provide graph-file dump-dot add-edge! generate-graph? 4 | ev-state! co-after-var-state! reset-kind! state-kind) 5 | ;; for destination for *.dot files 6 | (define graph-file (make-parameter #f)) 7 | (define state-kind #f) (define (reset-kind!) (set! state-kind #f)) 8 | (define (ev-state!) (set! state-kind 'ev)) 9 | (define (co-after-var-state!) (set! state-kind 'co-after-var)) 10 | 11 | (define-syntax-parameter generate-graph? #t) 12 | 13 | (struct ev (s) #:transparent) 14 | (struct cov (s) #:transparent) 15 | (struct other (s) #:transparent) 16 | (define (tag-kind s) 17 | (case state-kind 18 | [(ev) (ev s)] 19 | [(co-after-var) (cov s)] 20 | [else (other s)])) 21 | (define (untag s) 22 | (match s 23 | [(or (ev s) (cov s) (other s)) s] 24 | [s s])) 25 | 26 | (define (add-edge! g from to) 27 | (hash-set! g from (set-add (hash-ref g from (set)) (tag-kind to)))) 28 | 29 | ;; The given graph will be from states to sets of states. 30 | ;; Rename states with symbols for node names. 31 | (define (symbolize-graph graph ev-var? ev? co? compiled?) 32 | (define names (make-hash)) 33 | (define nodes (make-hash)) 34 | (define (cov-state? s) 35 | (and (co? s) 36 | (if compiled? 37 | (for*/or ([(from tos) (in-hash graph)] 38 | [to (in-set tos)]) 39 | (and (cov? to) (equal? (untag to) s))) 40 | (for*/or ([(from tos) (in-hash graph)] 41 | #:when (ev-var? from) 42 | [to (in-set tos)]) 43 | (equal? (untag to) s))))) 44 | (define (name-of s) (hash-ref! names (untag s) 45 | (λ _ (define n (gensym 'n)) 46 | (hash-set! nodes n (untag s)) 47 | n))) 48 | (define (node-of n) 49 | (hash-ref nodes n 50 | (λ () (error 'symbolize-graph "Name unmapped ~a~%~a~%~a" n names nodes)))) 51 | (begin0 52 | (for/hash ([(from tos) (in-hash graph)]) 53 | (values (name-of from) (for/set ([to (in-set tos)]) (name-of to)))) 54 | (for ([n (hash-values names)]) 55 | (define s (node-of n)) 56 | (printf " ~a [label = \"\", style = filled, fillcolor = ~a];~%" 57 | n 58 | (cond [(cov-state? s) "gray"] 59 | [(ev? s) "black"] 60 | [else "white"]))))) 61 | 62 | (define (dump-dot graph ev-var? ev? co? compiled?) 63 | (with-output-to-file (graph-file) #:mode 'text #:exists 'replace 64 | (λ () 65 | (printf "digraph Foo {~%") 66 | (for* ([(from adj) (in-hash (symbolize-graph graph ev-var? ev? co? compiled?))] 67 | [to (in-set adj)]) 68 | (printf " ~a -> ~a ;~%" from to)) 69 | (printf "~%}")))) 70 | -------------------------------------------------------------------------------- /code/handle-limits.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/sandbox) 3 | (provide with-limit-handler state-count start-time state-rate) 4 | 5 | (define state-count (make-parameter #f)) 6 | (define start-time (make-parameter #f)) 7 | 8 | (define (state-rate) 9 | (define time-taken-in-seconds (/ (- (current-milliseconds) 10 | (unbox (start-time))) 11 | 1000)) 12 | (printf "States/second: ~a~%" (exact->inexact ;; for decimal places 13 | (/ (unbox (state-count)) 14 | time-taken-in-seconds)))) 15 | 16 | (define-syntax-rule (with-limit-handler body ...) 17 | (parameterize ([state-count (box #f)] 18 | [start-time (box #f)]) 19 | (with-handlers ([exn:fail:resource? 20 | (λ (e) 21 | (state-rate) 22 | (case (exn:fail:resource-resource e) 23 | [(time) (dump-memory-stats) (printf "Result: Timeout~%")] 24 | [(memory) (printf "Result: Exhausted memory~%")]))] 25 | [exn:fail? (λ (e) (printf "Barf ~a" e))]) 26 | body ...))) -------------------------------------------------------------------------------- /code/iswim/0cfa-compile.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide aval^) 3 | (require "ast.rkt" 4 | "fix.rkt" 5 | "data.rkt") 6 | 7 | ;; 0CFA in the AAM style, but with a compilation phase, on 8 | ;; some hairy Church numeral churning 9 | 10 | ;; Moral: a simple compilation strategy can eliminate a lot 11 | ;; of analysis-time interpretive overhead. 12 | 13 | 14 | (define-syntax do 15 | (syntax-rules () 16 | [(do [(x se) ...] e) 17 | (for*/set ([x se] ...) 18 | e)])) 19 | 20 | 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | ;; "Compiled" Machine 23 | 24 | ;; Compile away interpretive overhead of "ev" states 25 | 26 | ;; Expr -> (Store Env Cont -> State) 27 | (define (compile e) 28 | (match e 29 | [(var l x) 30 | (λ (σ ρ k) 31 | (do ([v (lookup ρ σ x)]) 32 | (co σ k v)))] 33 | [(num l n) (λ (σ ρ k) (set (co σ k n)))] 34 | [(bln l b) (λ (σ ρ k) (set (co σ k b)))] 35 | [(lam l x e) 36 | (define c (compile e)) 37 | (λ (σ ρ k) (set (co σ k (clos l x c ρ))))] 38 | [(rec f (lam l x e)) 39 | (define c (compile e)) 40 | (λ (σ ρ k) (set (co σ k (rlos l f x c ρ))))] 41 | [(app l e0 e1) 42 | (define c0 (compile e0)) 43 | (define c1 (compile e1)) 44 | (λ (σ ρ k) 45 | ;; "ev" simulated for push's sake. 46 | (define-values (σ* a) (push (ev σ (app l e0 e1) ρ k))) 47 | (c0 σ* ρ (ar c1 ρ a)))] 48 | [(ife l e0 e1 e2) 49 | (define c0 (compile e0)) 50 | (define c1 (compile e1)) 51 | (define c2 (compile e2)) 52 | (λ (σ ρ k) 53 | (define-values (σ* a) (push (ev σ (ife l e0 e1 e2) ρ k))) 54 | (c0 σ* ρ (ifk c1 c2 ρ a)))] 55 | [(1op l o e) 56 | (define c (compile e)) 57 | (λ (σ ρ k) 58 | (define-values (σ* a) (push (ev σ (1op l o e) ρ k))) 59 | (c σ* ρ (1opk o a)))] 60 | [(2op l o e0 e1) 61 | (define c0 (compile e0)) 62 | (define c1 (compile e1)) 63 | (λ (σ ρ k) 64 | (define-values (σ* a) (push (ev σ (2op l o e0 e1) ρ k))) 65 | (c0 σ* ρ (2opak o c1 ρ a)))])) 66 | 67 | 68 | ;; "Bytecode" interpreter 69 | ;; State -> State 70 | (define (step-compiled s) 71 | (match s 72 | [(co σ k v) 73 | (match k 74 | ['mt (set (ans σ v))] 75 | [(ar c ρ l) (c σ ρ (fn v l))] 76 | [(fn f l) (do ([k (get-cont σ l)]) 77 | (ap σ f v k))] 78 | [(ifk c a ρ l) 79 | (for/fold ([s (set)]) ;; Ugly 80 | ([k (get-cont σ l)]) 81 | (set-union s ((if v c a) σ ρ k))) 82 | #; 83 | (do ([k (get-cont σ l)]) 84 | ((if v c a) σ ρ k))] 85 | [(1opk o l) 86 | (do ([k (get-cont σ l)]) 87 | (ap-op σ o (list v) k))] 88 | [(2opak o c ρ l) 89 | (c σ ρ (2opfk o v l))] 90 | [(2opfk o u l) 91 | (do ([k (get-cont σ l)]) 92 | (ap-op σ o (list v u) k))])] 93 | 94 | [(ap σ fun a k) 95 | (match fun 96 | [(clos l x c ρ) 97 | (define-values (ρ* σ*) (bind s)) 98 | (c σ* ρ* k)] 99 | [(rlos l f x c ρ) 100 | (define-values (ρ* σ*) (bind s)) 101 | (c σ* ρ* k)] 102 | [_ (set s)])] 103 | 104 | [(ap-op σ o vs k) 105 | (match* (o vs) 106 | [('zero? (list (? number? n))) (set (co σ k (zero? n)))] 107 | [('sub1 (list (? number? n))) (set (co σ k (widen (sub1 n))))] 108 | [('add1 (list (? number? n))) (set (co σ k (widen (add1 n))))] 109 | [('zero? (list 'number)) 110 | (set (co σ k #t) 111 | (co σ k #f))] 112 | [('sub1 (list 'number)) (set (co σ k 'number))] 113 | [('* (list (? number? n) (? number? m))) 114 | (set (co σ k (widen (* m n))))] 115 | [('* (list (? number? n) 'number)) 116 | (set (co σ k 'number))] 117 | [('* (list 'number 'number)) 118 | (set (co σ k 'number))] 119 | [(_ _) (set s)])] 120 | 121 | [_ (set s)])) 122 | 123 | 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | ;; Concrete semantics 126 | #;#;#; 127 | (define (widen b) 128 | (cond [(number? b) b] 129 | [else (error "Unknown base value" b)])) 130 | 131 | (define (bind s) 132 | (match s 133 | [(ap σ (clos l x e ρ) v k) 134 | (define a 135 | (add1 (for/fold ([i 0]) 136 | ([k (in-hash-keys σ)]) 137 | (max i k)))) 138 | (values (extend ρ x a) 139 | (join σ a (set v)))] 140 | [(ap σ (rlos l f x e ρ) v k) 141 | (define a 142 | (add1 (for/fold ([i 0]) 143 | ([k (in-hash-keys σ)]) 144 | (max i k)))) 145 | (define b (add1 a)) 146 | (values (extend (extend ρ x a) f b) 147 | (join (join σ a (set v)) b (set (rlos l f x e ρ))))])) 148 | 149 | (define (push s) 150 | (match s 151 | [(ev σ e ρ k) 152 | (define a 153 | (add1 (for/fold ([i 0]) 154 | ([k (in-hash-keys σ)]) 155 | (max i k)))) 156 | (values (join σ a (set k)) 157 | a)])) 158 | 159 | 160 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 161 | ;; 0CFA-style Abstract semantics 162 | (define (widen b) 163 | (cond [(number? b) 'number] 164 | [else (error "Unknown base value" b)])) 165 | 166 | (define (bind s) 167 | (match s 168 | [(ap σ (clos l x e ρ) v k) 169 | (values (extend ρ x x) 170 | (join σ x (set v)))] 171 | [(ap σ (rlos l f x e ρ) v k) 172 | (values (extend (extend ρ x x) f f) 173 | (join (join σ x (set v)) f (set (rlos l f x e ρ))))])) 174 | 175 | (define (push s) 176 | (match s 177 | [(ev σ e ρ k) 178 | (define a (exp-lab e)) 179 | (values (join σ a (set k)) 180 | a)])) 181 | 182 | 183 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 184 | 185 | ;; Exp -> Set Val 186 | ;; 0CFA without store widening 187 | (define (aval e) 188 | (for/set ([s (fix step-compiled (inj e))] 189 | #:when (ans? s)) 190 | (ans-v s))) 191 | 192 | ;; Exp -> Set Vlal 193 | ;; 0CFA with store widening 194 | (define (aval^ e) 195 | (for/fold ([vs (set)]) 196 | ([s (fix wide-step (inj-wide e))]) 197 | (set-union vs 198 | (match s 199 | [(cons cs σ) 200 | (for/set ([c cs] 201 | #:when (ans^? c)) 202 | (ans^-v c))])))) 203 | 204 | ;; Exp -> Set State 205 | (define (inj e) 206 | ((compile e) (hash) (hash) 'mt)) 207 | 208 | ;; Exp -> Set State^ 209 | (define (inj-wide e) 210 | (for/first ([s (inj e)]) 211 | (set (cons (set (s->c s)) (state-σ s))))) 212 | 213 | 214 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 215 | ;; Widening State to State^ 216 | 217 | ;; State^ = (cons (Set Conf) Store) 218 | 219 | ;; State^ -> { State^ } 220 | (define (wide-step state) 221 | (match state 222 | [(cons cs σ) 223 | (define ss (for/set ([c cs]) (c->s c σ))) 224 | (define ss* ((appl step-compiled) ss)) 225 | (set (cons (for/set ([s ss*]) (s->c s)) 226 | (join-stores ss*)))])) 227 | 228 | 229 | -------------------------------------------------------------------------------- /code/iswim/0cfa-delta.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide aval^) 3 | (require "ast.rkt" 4 | "data.rkt") 5 | 6 | ;; 0CFA in the AAM style on some hairy Church numeral churning 7 | 8 | ;; + compilation phase 9 | ;; + lazy non-determinism 10 | ;; + specialized step & iterator 0m34.248s vs 0m16.339s 11 | ;; + compute store ∆s 0m16.339s vs 0m1.065s (!!!) 12 | 13 | ;; State = (cons Conf Store) 14 | ;; State^ = (cons (Set Conf) Store) 15 | 16 | ;; Comp = Store Env Cont -> State^ 17 | 18 | ;; A Cont is one of: 19 | ;; - 'mt 20 | ;; - (ar Comp Env Cont) 21 | ;; - (fn Val Cont) 22 | ;; - (ifk Comp Comp Env Cont) 23 | ;; - (1opk Opr Cont) 24 | ;; - (2opak Opr Comp Env Cont) 25 | ;; - (2opfk Opr Val Cont) 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | ;; "Compiled" Machine 29 | 30 | ;; Compile away interpretive overhead of "ev" states 31 | 32 | ;; Expr -> Comp 33 | (define (compile e) 34 | (match e 35 | [(var l x) 36 | (λ (∆ ρ k) 37 | (cons ∆ (set (co^ k (addr (lookup-env ρ x))))))] 38 | [(num l n) (λ (∆ ρ k) (cons ∆ (set (co^ k n))))] 39 | [(bln l b) (λ (∆ ρ k) (cons ∆ (set (co^ k b))))] 40 | [(lam l x e) 41 | (define c (compile e)) 42 | (λ (∆ ρ k) (cons ∆ (set (co^ k (clos l x c ρ)))))] 43 | [(rec f (lam l x e)) 44 | (define c (compile e)) 45 | (λ (∆ ρ k) (cons ∆ (set (co^ k (rlos l f x c ρ)))))] 46 | [(app l e0 e1) 47 | (define c0 (compile e0)) 48 | (define c1 (compile e1)) 49 | (λ (∆ ρ k) 50 | (define-values (∆* a) (push∆ ∆ l ρ k)) 51 | (c0 ∆* ρ (ar c1 ρ a)))] 52 | [(ife l e0 e1 e2) 53 | (define c0 (compile e0)) 54 | (define c1 (compile e1)) 55 | (define c2 (compile e2)) 56 | (λ (∆ ρ k) 57 | (define-values (∆* a) (push∆ ∆ l ρ k)) 58 | (c0 ∆* ρ (ifk c1 c2 ρ a)))] 59 | [(1op l o e) 60 | (define c (compile e)) 61 | (λ (∆ ρ k) 62 | (define-values (∆* a) (push∆ ∆ l ρ k)) 63 | (c ∆* ρ (1opk o a)))] 64 | [(2op l o e0 e1) 65 | (define c0 (compile e0)) 66 | (define c1 (compile e1)) 67 | (λ (∆ ρ k) 68 | (define-values (∆* a) (push∆ ∆ l ρ k)) 69 | (c0 ∆* ρ (2opak o c1 ρ a)))])) 70 | 71 | ;; Store (Addr + Val) -> Set Val 72 | (define (get-val σ v) 73 | (match v 74 | [(addr loc) (hash-ref σ loc (λ () (error "~a ~a" loc σ)))] 75 | [_ (set v)])) 76 | 77 | 78 | ;; "Bytecode" interpreter 79 | ;; State -> State^ 80 | ;; State -> (cons [Listof (cons Addr (Setof Storable))] (Setof Conf)) 81 | (define (step-compiled^ s) 82 | (match s 83 | [(cons σ (co^ k v)) 84 | (match k 85 | ['mt (cons '() 86 | (for*/set ((v (get-val σ v))) 87 | (ans^ v)))] 88 | [(ar c ρ l) (c '() ρ (fn v l))] 89 | [(fn f l) 90 | (cons '() 91 | (for*/set ([k (get-cont σ l)] 92 | [f (get-val σ f)]) 93 | (ap^ f v k)))] 94 | [(ifk c a ρ l) 95 | (define res^ 96 | (for*/set ([k (get-cont σ l)] 97 | [v (get-val σ v)]) 98 | ((if v c a) '() ρ k))) 99 | 100 | (define-values (∆* cs*) 101 | (for/fold ([∆ '()] [cs (set)]) 102 | ([s res^]) 103 | (match s 104 | [(cons ∆* cs*) 105 | (values (append ∆* ∆) 106 | (set-union cs* cs))]))) 107 | (cons ∆* cs*)] 108 | 109 | [(1opk o l) 110 | (cons '() 111 | (for*/set ([k (get-cont σ l)] 112 | [v (get-val σ v)]) 113 | (ap-op^ o (list v) k)))] 114 | [(2opak o c ρ l) 115 | (c '() ρ (2opfk o v l))] 116 | [(2opfk o u l) 117 | (cons '() 118 | (for*/set ([k (get-cont σ l)] 119 | [v (get-val σ v)] 120 | [u (get-val σ u)]) 121 | (ap-op^ o (list v u) k)))])] 122 | 123 | [(cons σ (ap^ fun a k)) 124 | (match fun 125 | [(clos l x c ρ) 126 | (define-values (ρ* ∆*) (bind s)) 127 | (c ∆* ρ* k)] 128 | [(rlos l f x c ρ) 129 | (define-values (ρ* ∆*) (bind s)) 130 | (c ∆* ρ* k)] 131 | ;; Anything else is stuck 132 | [_ (cons '() (set))])] 133 | 134 | [(cons σ (ap-op^ o vs k)) 135 | (match* (o vs) 136 | [('zero? (list (? number? n))) (cons '() (set (co^ k (zero? n))))] 137 | [('sub1 (list (? number? n))) (cons '() (set (co^ k (widen (sub1 n)))))] 138 | [('add1 (list (? number? n))) (cons '() (set (co^ k (widen (add1 n)))))] 139 | [('not (list #t)) (cons '() (set (co σ k #f)))] 140 | [('not (list #f)) (cons '() (set (co σ k #t)))] 141 | [('zero? (list 'number)) 142 | (cons '() (set (co^ k #t) 143 | (co^ k #f)))] 144 | [('sub1 (list 'number)) (cons '() (set (co^ k 'number)))] 145 | [('* (list (? number? n) (? number? m))) 146 | (cons '() (set (co^ k (widen (* m n)))))] 147 | [('* (list (? number? n) 'number)) 148 | (cons '() (set (co^ k 'number)))] 149 | [('* (list 'number 'number)) 150 | (cons '() (set (co^ k 'number)))] 151 | ;; Anything else is stuck 152 | [(_ _) (cons '() (set))])] 153 | 154 | [(cons σ c) 155 | (cons '() (set))])) 156 | 157 | 158 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | ;; 0CFA-style Abstract semantics 160 | (define (widen b) 161 | (cond [(number? b) 'number] 162 | [else (error "Unknown base value" b)])) 163 | 164 | (define (bind s) 165 | (match s 166 | [(cons σ (ap^ (clos l x e ρ) v k)) 167 | (values (extend ρ x x) 168 | (list (cons x (get-val σ v))))] 169 | [(cons σ (ap^ (rlos l f x e ρ) v k)) 170 | (values (extend (extend ρ x x) f f) 171 | (list (cons f (set (rlos l f x e ρ))) 172 | (cons x (get-val σ v))))])) 173 | 174 | (define (push∆ ∆ l ρ k) 175 | (values (cons (cons l (set k)) ∆) 176 | l)) 177 | 178 | 179 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 180 | 181 | ;; Exp -> Set Val 182 | ;; 0CFA with store widening and specialized iteration 183 | (define (aval^ e) 184 | (define fst (inj e)) 185 | (define snd (wide-step-specialized fst)) 186 | ;; wide-step-specialized is monotonic so we only need to check the current 187 | ;; state against it's predecessor to see if we have reached a fixpoint. 188 | (let loop ((next snd) (prev fst)) 189 | (if (equal? next prev) 190 | (for/set ([c (cdr prev)] 191 | #:when (ans^? c)) 192 | (ans^-v c)) 193 | (loop (wide-step-specialized next) next)))) 194 | 195 | ;; Exp -> Set State 196 | (define (inj e) 197 | (match ((compile e) '() (hash) 'mt) 198 | [(cons ∆ cs) 199 | (cons (update ∆ (hash)) cs)])) 200 | 201 | (define (update ∆ σ) 202 | (match ∆ 203 | ['() σ] 204 | [(cons (cons a xs) ∆) 205 | (update ∆ (join σ a xs))])) 206 | 207 | 208 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 209 | ;; Widening State to State^ 210 | 211 | ;; State^ -> State^ 212 | ;; Specialized from wide-step : State^ -> { State^ } ≈ State^ -> State^ 213 | (define (wide-step-specialized state) 214 | (match state 215 | [(cons σ cs) 216 | (define-values (cs* ∆) 217 | (for/fold ([cs* (set)] [∆* '()]) 218 | ([c cs]) 219 | (match (step-compiled^ (cons σ c)) 220 | [(cons ∆** cs**) 221 | (values (set-union cs* cs**) (append ∆** ∆*))]))) 222 | (cons (update ∆ σ) (set-union cs cs*))])) 223 | -------------------------------------------------------------------------------- /code/iswim/0cfa-lazy-compile.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide aval^) 3 | (require "ast.rkt" 4 | "fix.rkt" 5 | "data.rkt") 6 | 7 | ;; 0CFA in the AAM style, but with a compilation phase, on 8 | ;; some hairy Church numeral churning 9 | 10 | ;; Moral: a simple compilation strategy can eliminate a lot 11 | ;; of analysis-time interpretive overhead. 12 | 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | ;; "Compiled" Machine 15 | 16 | ;; Compile away interpretive overhead of "ev" states 17 | 18 | ;; Expr -> (Store Env Cont -> State) 19 | (define (compile e) 20 | (match e 21 | [(var l x) 22 | (λ (σ ρ k) 23 | (set (co σ k (addr (lookup-env ρ x)))))] 24 | [(num l n) (λ (σ ρ k) (set (co σ k n)))] 25 | [(bln l b) (λ (σ ρ k) (set (co σ k b)))] 26 | [(lam l x e) 27 | (define c (compile e)) 28 | (λ (σ ρ k) (set (co σ k (clos l x c ρ))))] 29 | [(rec f (lam l x e)) 30 | (define c (compile e)) 31 | (λ (σ ρ k) (set (co σ k (rlos l f x c ρ))))] 32 | [(app l e0 e1) 33 | (define c0 (compile e0)) 34 | (define c1 (compile e1)) 35 | (λ (σ ρ k) 36 | (define-values (σ* a) (push σ l ρ k)) 37 | (c0 σ* ρ (ar c1 ρ a)))] 38 | [(ife l e0 e1 e2) 39 | (define c0 (compile e0)) 40 | (define c1 (compile e1)) 41 | (define c2 (compile e2)) 42 | (λ (σ ρ k) 43 | (define-values (σ* a) (push σ l ρ k)) 44 | (c0 σ* ρ (ifk c1 c2 ρ a)))] 45 | [(1op l o e) 46 | (define c (compile e)) 47 | (λ (σ ρ k) 48 | (define-values (σ* a) (push σ l ρ k)) 49 | (c σ* ρ (1opk o a)))] 50 | [(2op l o e0 e1) 51 | (define c0 (compile e0)) 52 | (define c1 (compile e1)) 53 | (λ (σ ρ k) 54 | (define-values (σ* a) (push σ l ρ k)) 55 | (c0 σ* ρ (2opak o c1 ρ a)))])) 56 | 57 | #;(struct addr (a) #:transparent) 58 | ;; Store (Addr + Val) -> Set Val 59 | (define (get-val σ v) 60 | (match v 61 | [(addr loc) (hash-ref σ loc (λ () (error "~a ~a" loc σ)))] 62 | [_ (set v)])) 63 | 64 | 65 | ;; "Bytecode" interpreter 66 | ;; State -> State 67 | (define (step-compiled s) 68 | (match s 69 | [(co σ k v) 70 | (match k 71 | ['mt (for*/set ((v (get-val σ v))) 72 | (ans σ v))] 73 | [(ar c ρ l) (c σ ρ (fn v l))] 74 | [(fn f l) 75 | (for*/set ([k (get-cont σ l)] 76 | [f (get-val σ f)]) 77 | (ap σ f v k))] 78 | [(ifk c a ρ l) 79 | (for/fold ([s (set)]) 80 | ([k (get-cont σ l)] 81 | [v (get-val σ v)]) 82 | (set-union s ((if v c a) σ ρ k)))] 83 | [(1opk o l) 84 | (for*/set ([k (get-cont σ l)] 85 | [v (get-val σ v)]) 86 | (ap-op σ o (list v) k))] 87 | [(2opak o c ρ l) 88 | (c σ ρ (2opfk o v l))] 89 | [(2opfk o u l) 90 | (for*/set ([k (get-cont σ l)] 91 | [v (get-val σ v)] 92 | [u (get-val σ u)]) 93 | (ap-op σ o (list v u) k))])] 94 | 95 | [(ap σ fun a k) 96 | (match fun 97 | [(clos l x c ρ) 98 | (define-values (ρ* σ*) (bind s)) 99 | (c σ* ρ* k)] 100 | [(rlos l f x c ρ) 101 | (define-values (ρ* σ*) (bind s)) 102 | (c σ* ρ* k)] 103 | [_ (set s)])] 104 | 105 | [(ap-op σ o vs k) 106 | (match* (o vs) 107 | [('zero? (list (? number? n))) (set (co σ k (zero? n)))] 108 | [('sub1 (list (? number? n))) (set (co σ k (widen (sub1 n))))] 109 | [('add1 (list (? number? n))) (set (co σ k (widen (add1 n))))] 110 | [('zero? (list 'number)) 111 | (set (co σ k #t) 112 | (co σ k #f))] 113 | [('sub1 (list 'number)) (set (co σ k 'number))] 114 | [('* (list (? number? n) (? number? m))) 115 | (set (co σ k (widen (* m n))))] 116 | [('* (list (? number? n) 'number)) 117 | (set (co σ k 'number))] 118 | [('* (list 'number 'number)) 119 | (set (co σ k 'number))] 120 | [(_ _) (set s)])] 121 | 122 | [_ (set s)])) 123 | 124 | 125 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 126 | ;; Concrete semantics 127 | #;#;#; 128 | (define (widen b) 129 | (cond [(number? b) b] 130 | [else (error "Unknown base value" b)])) 131 | 132 | (define (bind s) 133 | (match s 134 | [(ap σ (clos l x e ρ) v k) 135 | (define a 136 | (add1 (for/fold ([i 0]) 137 | ([k (in-hash-keys σ)]) 138 | (max i k)))) 139 | (values (extend ρ x a) 140 | (join σ a (set v)))] 141 | [(ap σ (rlos l f x e ρ) v k) 142 | (define a 143 | (add1 (for/fold ([i 0]) 144 | ([k (in-hash-keys σ)]) 145 | (max i k)))) 146 | (define b (add1 a)) 147 | (values (extend (extend ρ x a) f b) 148 | (join (join σ a (set v)) b (set (rlos l f x e ρ))))])) 149 | 150 | (define (push σ l ρ k) 151 | (define a 152 | (add1 (for/fold ([i 0]) 153 | ([k (in-hash-keys σ)]) 154 | (max i k)))) 155 | (values (join σ a (set k)) 156 | a)) 157 | 158 | 159 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 160 | ;; 0CFA-style Abstract semantics 161 | (define (widen b) 162 | (cond [(number? b) 'number] 163 | [else (error "Unknown base value" b)])) 164 | 165 | (define (bind s) 166 | (match s 167 | [(ap σ (clos l x e ρ) v k) 168 | (values (extend ρ x x) 169 | (join σ x (get-val σ v)))] 170 | [(ap σ (rlos l f x e ρ) v k) 171 | (values (extend (extend ρ x x) f f) 172 | (join (join σ x (get-val σ v)) f (set (rlos l f x e ρ))))])) 173 | 174 | (define (push σ l ρ k) 175 | (values (join σ l (set k)) 176 | l)) 177 | 178 | 179 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 180 | 181 | ;; Exp -> Set Val 182 | ;; 0CFA without store widening 183 | (define (aval e) 184 | (for/set ([s (fix step-compiled (inj e))] 185 | #:when (ans? s)) 186 | (ans-v s))) 187 | 188 | ;; Exp -> Set Val 189 | ;; 0CFA with store widening 190 | (define (aval^ e) 191 | (for/fold ([vs (set)]) 192 | ([s (fix wide-step (inj-wide e))]) 193 | (set-union vs 194 | (match s 195 | [(cons cs σ) 196 | (for/set ([c cs] 197 | #:when (ans^? c)) 198 | (ans^-v c))])))) 199 | 200 | ;; Exp -> Set State 201 | (define (inj e) 202 | ((compile e) (hash) (hash) 'mt)) 203 | 204 | ;; Exp -> Set State^ 205 | (define (inj-wide e) 206 | (for/first ([s (inj e)]) 207 | (set (cons (set (s->c s)) (state-σ s))))) 208 | 209 | 210 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 211 | ;; Widening State to State^ 212 | 213 | ;; State^ = (cons (Set Conf) Store) 214 | 215 | ;; State^ -> { State^ } 216 | (define (wide-step state) 217 | (match state 218 | [(cons cs σ) 219 | (define ss (for/set ([c cs]) (c->s c σ))) 220 | (define ss* ((appl step-compiled) ss)) 221 | (set (cons (for/set ([s ss*]) (s->c s)) 222 | (join-stores ss*)))])) 223 | 224 | -------------------------------------------------------------------------------- /code/iswim/0cfa-lazy.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide aval^) 3 | (require "ast.rkt" "data.rkt") 4 | 5 | ;; 0CFA in the AAM style on some hairy Church numeral churning 6 | ;; using lazy non-determinism (wait until your in demand before 7 | ;; forking). 8 | 9 | ;; (X -> Set X) -> (Set X) -> (Set X) 10 | (define ((appl f) s) 11 | (for/fold ([i (set)]) 12 | ([x (in-set s)]) 13 | (set-union i (f x)))) 14 | 15 | ;; (X -> Set X) (Set X) -> (Set X) 16 | ;; Calculate fixpoint of (appl f). 17 | (define (fix f s) 18 | (let loop ((accum (set)) (front s)) 19 | (if (set-empty? front) 20 | accum 21 | (let ((new-front ((appl f) front))) 22 | (loop (set-union accum front) 23 | (set-subtract new-front accum)))))) 24 | 25 | (define-syntax do 26 | (syntax-rules () 27 | [(do [(x se) ...] e) 28 | (for*/set ([x se] ...) 29 | e)])) 30 | 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;; Machine 34 | 35 | #;(struct addr (a) #:transparent) 36 | ;; Store (Addr + Val) -> Set Val 37 | (define (get-val σ v) 38 | (match v 39 | [(addr loc) (hash-ref σ loc (λ () (error "~a ~a" loc σ)))] 40 | [_ (set v)])) 41 | 42 | ;; State -> Set State 43 | (define (step state) 44 | ;(printf "~a~n" state) 45 | (match state 46 | [(ev σ e ρ k) 47 | (match e 48 | [(var l x) (set (co σ k (addr (lookup-env ρ x))))] 49 | [(num l n) (set (co σ k n))] 50 | [(bln l b) (set (co σ k b))] 51 | [(lam l x e) (set (co σ k (clos l x e ρ)))] 52 | [(rec f (lam l x e)) (set (co σ k (rlos l f x e ρ)))] 53 | [(app l f e) 54 | (define-values (σ* a) (push state)) 55 | (set (ev σ* f ρ (ar e ρ a)))] 56 | [(ife l e0 e1 e2) 57 | (define-values (σ* a) (push state)) 58 | (set (ev σ* e0 ρ (ifk e1 e2 ρ a)))] 59 | [(1op l o e) 60 | (define-values (σ* a) (push state)) 61 | (set (ev σ* e ρ (1opk o a)))] 62 | [(2op l o e f) 63 | (define-values (σ* a) (push state)) 64 | (set (ev σ* e ρ (2opak o f ρ a)))])] 65 | 66 | [(co σ k v) 67 | (match k 68 | ['mt (do ((v (get-val σ v))) 69 | (ans σ v))] 70 | [(ar e ρ l) (set (ev σ e ρ (fn v l)))] 71 | [(fn f l) 72 | (do ([k (get-cont σ l)] 73 | [f (get-val σ f)]) 74 | (ap σ f v k))] 75 | [(ifk c a ρ l) 76 | (do ([k (get-cont σ l)] 77 | [v (get-val σ v)]) 78 | (ev σ (if v c a) ρ k))] 79 | [(1opk o l) 80 | (do ([k (get-cont σ l)] 81 | [v (get-val σ v)]) 82 | (ap-op σ o (list v) k))] 83 | [(2opak o e ρ l) 84 | (set (ev σ e ρ (2opfk o v l)))] 85 | [(2opfk o u l) 86 | (do ([k (get-cont σ l)] 87 | [v (get-val σ v)] 88 | [u (get-val σ u)]) 89 | (ap-op σ o (list v u) k))])] 90 | 91 | [(ap σ fun a k) 92 | (match fun 93 | [(clos l x e ρ) 94 | (define-values (ρ* σ*) (bind state)) 95 | (set (ev σ* e ρ* k))] 96 | [(rlos l f x e ρ) 97 | (define-values (ρ* σ*) (bind state)) 98 | (set (ev σ* e ρ* k))] 99 | [_ (set state)])] 100 | 101 | [(ap-op σ o vs k) 102 | (match* (o vs) 103 | [('zero? (list (? number? n))) (set (co σ k (zero? n)))] 104 | [('sub1 (list (? number? n))) (set (co σ k (widen (sub1 n))))] 105 | [('add1 (list (? number? n))) (set (co σ k (widen (add1 n))))] 106 | [('zero? (list 'number)) 107 | (set (co σ k #t) 108 | (co σ k #f))] 109 | [('sub1 (list 'number)) (set (co σ k 'number))] 110 | [('* (list (? number? n) (? number? m))) 111 | (set (co σ k (widen (* m n))))] 112 | [('* (list (? number? n) 'number)) 113 | (set (co σ k 'number))] 114 | [('* (list 'number 'number)) 115 | (set (co σ k 'number))] 116 | [(_ _) (set state)])] 117 | 118 | [_ (set state)])) 119 | 120 | 121 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 122 | ;; Concrete semantics 123 | #;#;#; 124 | (define (widen b) 125 | (cond [(number? b) b] 126 | [else (error "Unknown base value" b)])) 127 | 128 | (define (bind s) 129 | (match s 130 | [(ap σ (clos l x e ρ) v k) 131 | (define a 132 | (add1 (for/fold ([i 0]) 133 | ([k (in-hash-keys σ)]) 134 | (max i k)))) 135 | (values (extend ρ x a) 136 | (extend σ a (get-val σ v)))] 137 | [(ap σ (rlos l f x e ρ) v k) 138 | (define a 139 | (add1 (for/fold ([i 0]) 140 | ([k (in-hash-keys σ)]) 141 | (max i k)))) 142 | (define b (add1 a)) 143 | (values (extend (extend ρ x a) f b) 144 | (join (join σ a (get-val σ v)) b (set (rlos l f x e ρ))))])) 145 | 146 | (define (push s) 147 | (match s 148 | [(ev σ e ρ k) 149 | (define a 150 | (add1 (for/fold ([i 0]) 151 | ([k (in-hash-keys σ)]) 152 | (max i k)))) 153 | (values (join σ a (set k)) 154 | a)])) 155 | 156 | 157 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 158 | ;; 0CFA-style Abstract semantics 159 | 160 | (define (widen b) 161 | (cond [(number? b) 'number] 162 | [else (error "Unknown base value" b)])) 163 | 164 | (define (bind s) 165 | (match s 166 | [(ap σ (clos l x e ρ) v k) 167 | (values (extend ρ x x) 168 | (extend σ x (get-val σ v)))] 169 | [(ap σ (rlos l f x e ρ) v k) 170 | (values (extend (extend ρ x x) f f) 171 | (join (join σ x (get-val σ v)) f (set (rlos l f x e ρ))))])) 172 | 173 | (define (push s) 174 | (match s 175 | [(ev σ e ρ k) 176 | (define a (exp-lab e)) 177 | (values (join σ a (set k)) 178 | a)])) 179 | 180 | 181 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 182 | 183 | ;; Exp -> Set Val 184 | ;; 0CFA without store widening 185 | (define (aval e) 186 | (for/set ([s (fix step (inj e))] 187 | #:when (ans? s)) 188 | (ans-v s))) 189 | 190 | ;; Exp -> Set Vlal 191 | ;; 0CFA with store widening 192 | (define (aval^ e) 193 | (for/fold ([vs (set)]) 194 | ([s (fix wide-step (inj-wide e))]) 195 | (set-union vs 196 | (match s 197 | [(cons cs σ) 198 | (for/set ([c cs] 199 | #:when (ans^? c)) 200 | (ans^-v c))])))) 201 | 202 | ;; Exp -> Set State 203 | (define (inj e) 204 | (set (ev (hash) e (hash) 'mt))) 205 | 206 | ;; Exp -> Set State^ 207 | (define (inj-wide e) 208 | (set (cons (set (ev^ e (hash) 'mt)) (hash)))) 209 | 210 | 211 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 212 | ;; Widening State to State^ 213 | 214 | ;; State^ = (cons (Set Conf) Store) 215 | 216 | ;; State^ -> { State^ } 217 | (define (wide-step state) 218 | (match state 219 | [(cons cs σ) 220 | (define ss (for/set ([c cs]) (c->s c σ))) 221 | (define ss* ((appl step) ss)) 222 | (set (cons (for/set ([s ss*]) (s->c s)) 223 | (join-stores ss*)))])) 224 | 225 | 226 | -------------------------------------------------------------------------------- /code/iswim/0cfa-prealloc-generators.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide aval^ widen) 3 | (require "ast.rkt" 4 | (except-in "data.rkt" get-cont ap^ ap-op^) 5 | "progs.rkt" 6 | (for-syntax syntax/parse)) 7 | 8 | (define-syntax-rule (for/union guards body1 body ...) 9 | (for/fold ([res (set)]) guards (set-union res (let () body1 body ...)))) 10 | (define-syntax-rule (for*/union guards body1 body ...) 11 | (for*/fold ([res (set)]) guards (set-union res (let () body1 body ...)))) 12 | 13 | ;; 0CFA in the AAM style on some hairy Church numeral churning 14 | 15 | ;; + compilation phase 16 | ;; + lazy non-determinism 17 | ;; + specialized step & iterator 18 | 19 | ;; State = (cons Conf Store) 20 | ;; State^ = (cons (Set Conf) Store) 21 | 22 | ;; Comp = Store Env Cont -> State^ 23 | 24 | ;; Global store 25 | (define σ #f) 26 | (define unions 0) 27 | (define todo '()) 28 | (define seen #f) 29 | 30 | (define (get-cont σ l) 31 | (vector-ref σ l)) 32 | 33 | (define (yield s) 34 | (unless (= unions (hash-ref seen s -1)) 35 | (hash-set! seen s unions) 36 | (set! todo (cons s todo)))) 37 | 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | ;; "Compiled" Machine 40 | 41 | ;; Compile away interpretive overhead of "ev" states 42 | 43 | ;; Expr -> Comp 44 | (define (compile e) 45 | (match e 46 | [(var l x) 47 | (λ (ρ k) 48 | (yield (co^ k (addr (lookup-env ρ x)))))] 49 | [(num l n) (λ (ρ k) (yield (co^ k n)))] 50 | [(bln l b) (λ (ρ k) (yield (co^ k b)))] 51 | [(lam l x e) 52 | (define c (compile e)) 53 | (λ (ρ k) (yield (co^ k (clos l x c ρ))))] 54 | [(rec f (lam l x e)) 55 | (define c (compile e)) 56 | (λ (ρ k) (yield (co^ k (rlos l f x c ρ))))] 57 | [(app l e0 e1) 58 | (define c0 (compile e0)) 59 | (define c1 (compile e1)) 60 | (λ (ρ k) 61 | (define a (push l ρ k)) 62 | (c0 ρ (ar c1 ρ a)))] 63 | [(ife l e0 e1 e2) 64 | (define c0 (compile e0)) 65 | (define c1 (compile e1)) 66 | (define c2 (compile e2)) 67 | (λ (ρ k) 68 | (define a (push l ρ k)) 69 | (c0 ρ (ifk c1 c2 ρ a)))] 70 | [(1op l o e) 71 | (define c (compile e)) 72 | (λ (ρ k) 73 | (define a (push l ρ k)) 74 | (c ρ (1opk o a)))] 75 | [(2op l o e0 e1) 76 | (define c0 (compile e0)) 77 | (define c1 (compile e1)) 78 | (λ (ρ k) 79 | (define a (push l ρ k)) 80 | (c0 ρ (2opak o c1 ρ a)))] 81 | [_ (error 'compile "Bad ~a" e)])) 82 | 83 | ;; Store (Addr + Val) -> Set Val 84 | (define (get-val σ v) 85 | (match v 86 | [(addr loc) (vector-ref σ loc)] 87 | [_ (list v)])) 88 | 89 | 90 | (define (ap^ fun v k) 91 | (match fun 92 | [(clos l x c ρ) 93 | (define ρ* (bind fun v k)) 94 | (c ρ* k)] 95 | [(rlos l f x c ρ) 96 | (define ρ* (bind fun v k)) 97 | (c ρ* k)] 98 | ;; Anything else is stuck 99 | [_ #f])) 100 | 101 | (define (ap-op^ o vs k) 102 | (match* (o vs) 103 | [('zero? (list (? number? n))) (yield (co^ k (zero? n)))] 104 | [('sub1 (list (? number? n))) (yield (co^ k (widen (sub1 n))))] 105 | [('add1 (list (? number? n))) (yield (co^ k (widen (add1 n))))] 106 | [('zero? (list 'number)) 107 | (yield (co^ k #t)) 108 | (yield (co^ k #f))] 109 | [('sub1 (list 'number)) (yield (co^ k 'number))] 110 | [('* (list (? number? n) (? number? m))) 111 | (yield (co^ k (widen (* m n))))] 112 | [('* (list (? number? n) 'number)) 113 | (yield (co^ k 'number))] 114 | [('* (list 'number 'number)) 115 | (yield (co^ k 'number))] 116 | ;; Anything else is stuck 117 | [(_ _) 118 | (void)])) 119 | 120 | ;; "Bytecode" interpreter 121 | ;; State -> State^ 122 | (define (step-compiled^ s) 123 | (match s 124 | [(co^ k v) 125 | (match k 126 | ['mt (for ([v (get-val σ v)]) 127 | (yield (ans^ v)))] 128 | [(ar c ρ l) (c ρ (fn v l))] 129 | [(fn f l) 130 | (for* ([k (get-cont σ l)] 131 | [f (get-val σ f)]) 132 | (ap^ f v k))] 133 | [(ifk c a ρ l) 134 | (for* ([k (get-cont σ l)] 135 | [v (get-val σ v)]) 136 | ((if v c a) ρ k))] 137 | 138 | [(1opk o l) 139 | (for* ([k (get-cont σ l)] 140 | [v (get-val σ v)]) 141 | (ap-op^ o (list v) k))] 142 | [(2opak o c ρ l) 143 | (c ρ (2opfk o v l))] 144 | [(2opfk o u l) 145 | (for* ([k (get-cont σ l)] 146 | [v (get-val σ v)] 147 | [u (get-val σ u)]) 148 | (ap-op^ o (list v u) k))] 149 | [_ (error 'step-compiled^ "Bad ~a" k)])] 150 | 151 | [s s])) 152 | 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | ;; 0CFA-style Abstract semantics 155 | (define (widen b) 156 | (cond [(number? b) 'number] 157 | [else (error "Unknown base value" b)])) 158 | 159 | (define (bind fun v k) 160 | (match fun 161 | [(clos l x e ρ) 162 | (join-many! x (get-val σ v)) 163 | (extend ρ x x)] 164 | [(rlos l f x e ρ) 165 | (join-one! f fun) 166 | (join-many! x (get-val σ v)) 167 | (extend (extend ρ x x) f f)] 168 | [_ (error 'bind "Bad ~a" fun)])) 169 | 170 | (define (push l ρ k) 171 | (join-one! l k) 172 | l) 173 | 174 | (define (join-one! a v) 175 | (define prev (vector-ref σ a)) 176 | (unless (member v prev) 177 | (vector-set! σ a (cons v prev)) 178 | (set! unions (add1 unions)))) 179 | 180 | (define (join-many! a vs) 181 | (define prev (vector-ref σ a)) 182 | (define-values (next added?) 183 | (for/fold ([res prev] [added? #f]) 184 | ([v (in-list vs)] 185 | #:unless (member v prev)) 186 | (values (cons v res) #t))) 187 | (when added? 188 | (vector-set! σ a next) 189 | (set! unions (add1 unions)))) 190 | 191 | 192 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 193 | 194 | ;; Exp -> Set Val 195 | ;; 0CFA with store widening and specialized iteration 196 | (define (aval^ e) 197 | (set! todo '()) 198 | (set! seen (make-hash)) 199 | (define fst (inj e)) 200 | (time ;; ignore preprocessing 201 | (let loop () 202 | (cond [(null? todo) 203 | (for*/set ([(c at-unions) (in-hash seen)] 204 | #:when (ans^? c)) 205 | (ans^-v c))] 206 | [else 207 | (wide-step-specialized seen) 208 | (loop)])))) 209 | 210 | ;; Sexp -> Set State 211 | (define (inj sexp) 212 | (define-values (e nlabels) (parse sexp)) 213 | (set! σ (make-vector nlabels '())) 214 | ((compile e) #;empty-environment-> (hash) 'mt)) 215 | 216 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 217 | ;; Widening State to State^ 218 | 219 | ;; State^ -> State^ 220 | ;; Specialized from wide-step : State^ -> { State^ } ≈ State^ -> State^ 221 | (define (wide-step-specialized seen) 222 | (define todo-old todo) 223 | (set! todo '()) 224 | (for ([c (in-list todo-old)]) (step-compiled^ c))) 225 | 226 | (aval^ church) 227 | -------------------------------------------------------------------------------- /code/iswim/0cfa-prealloc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide aval^ widen) 3 | (require "ast.rkt" 4 | (except-in "data.rkt" get-cont) 5 | "progs.rkt" 6 | (for-syntax syntax/parse)) 7 | 8 | (define-syntax-rule (for/union guards body1 body ...) 9 | (for/fold ([res (set)]) guards (set-union res (let () body1 body ...)))) 10 | (define-syntax-rule (for*/union guards body1 body ...) 11 | (for*/fold ([res (set)]) guards (set-union res (let () body1 body ...)))) 12 | 13 | ;; 0CFA in the AAM style on some hairy Church numeral churning 14 | 15 | ;; + compilation phase 16 | ;; + lazy non-determinism 17 | ;; + specialized step & iterator 18 | 19 | ;; State = (cons Conf Store) 20 | ;; State^ = (cons (Set Conf) Store) 21 | 22 | ;; Comp = Store Env Cont -> State^ 23 | 24 | ;; Global store 25 | (define σ #f) 26 | (define unions 0) 27 | (define nlabels #f) 28 | 29 | (define (get-cont σ l) 30 | (vector-ref σ l)) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;; "Compiled" Machine 34 | 35 | ;; Compile away interpretive overhead of "ev" states 36 | 37 | ;; Expr -> Comp 38 | (define (compile e) 39 | (match e 40 | [(var l x) 41 | (λ (ρ k) 42 | (set (co^ k (addr (lookup-env ρ x)))))] 43 | [(num l n) (λ (ρ k) (set (co^ k n)))] 44 | [(bln l b) (λ (ρ k) (set (co^ k b)))] 45 | [(lam l x e) 46 | (define c (compile e)) 47 | (λ (ρ k) (set (co^ k (clos l x c ρ))))] 48 | [(rec f (lam l x e)) 49 | (define c (compile e)) 50 | (λ (ρ k) (set (co^ k (rlos l f x c ρ))))] 51 | [(app l e0 e1) 52 | (define c0 (compile e0)) 53 | (define c1 (compile e1)) 54 | (λ (ρ k) 55 | (define a (push l ρ k)) 56 | (c0 ρ (ar c1 ρ a)))] 57 | [(ife l e0 e1 e2) 58 | (define c0 (compile e0)) 59 | (define c1 (compile e1)) 60 | (define c2 (compile e2)) 61 | (λ (ρ k) 62 | (define a (push l ρ k)) 63 | (c0 ρ (ifk c1 c2 ρ a)))] 64 | [(1op l o e) 65 | (define c (compile e)) 66 | (λ (ρ k) 67 | (define a (push l ρ k)) 68 | (c ρ (1opk o a)))] 69 | [(2op l o e0 e1) 70 | (define c0 (compile e0)) 71 | (define c1 (compile e1)) 72 | (λ (ρ k) 73 | (define a (push l ρ k)) 74 | (c0 ρ (2opak o c1 ρ a)))] 75 | [_ (error 'compile "Bad ~a" e)])) 76 | 77 | ;; Store (Addr + Val) -> Set Val 78 | (define (get-val σ v) 79 | (match v 80 | [(addr loc) (vector-ref σ loc)] 81 | [_ (list v)])) 82 | 83 | ;; "Bytecode" interpreter 84 | ;; State -> State^ 85 | (define (step-compiled^ s) 86 | (match s 87 | [(co^ k v) 88 | (match k 89 | ['mt (for*/set ([v (get-val σ v)]) 90 | (ans^ v))] 91 | [(ar c ρ l) (c ρ (fn v l))] 92 | [(fn f l) 93 | (for*/set ([k (get-cont σ l)] 94 | [f (get-val σ f)]) 95 | (ap^ f v k))] 96 | [(ifk c a ρ l) 97 | (for*/union ([k (get-cont σ l)] 98 | [v (get-val σ v)]) 99 | ((if v c a) ρ k))] 100 | 101 | [(1opk o l) 102 | (for*/set ([k (get-cont σ l)] 103 | [v (get-val σ v)]) 104 | (ap-op^ o (list v) k))] 105 | [(2opak o c ρ l) 106 | (c ρ (2opfk o v l))] 107 | [(2opfk o u l) 108 | (for*/set ([k (get-cont σ l)] 109 | [v (get-val σ v)] 110 | [u (get-val σ u)]) 111 | (ap-op^ o (list v u) k))] 112 | [_ (error 'step-compiled^ "Bad ~a" k)])] 113 | 114 | [(ap^ fun a k) 115 | (match fun 116 | [(clos l x c ρ) 117 | (define ρ* (bind s)) 118 | (c ρ* k)] 119 | [(rlos l f x c ρ) 120 | (define ρ* (bind s)) 121 | (c ρ* k)] 122 | ;; Anything else is stuck 123 | [_ (set s)])] 124 | 125 | [(ap-op^ o vs k) 126 | (match* (o vs) 127 | [('zero? (list (? number? n))) (set (co^ k (zero? n)))] 128 | [('sub1 (list (? number? n))) (set (co^ k (widen (sub1 n))))] 129 | [('add1 (list (? number? n))) (set (co^ k (widen (add1 n))))] 130 | [('zero? (list 'number)) 131 | (set (co^ k #t) 132 | (co^ k #f))] 133 | [('sub1 (list 'number)) (set (co^ k 'number))] 134 | [('* (list (? number? n) (? number? m))) 135 | (set (co^ k (widen (* m n))))] 136 | [('* (list (? number? n) 'number)) 137 | (set (co^ k 'number))] 138 | [('* (list 'number 'number)) 139 | (set (co^ k 'number))] 140 | ;; Anything else is stuck 141 | [(_ _) 142 | (set s)])] 143 | 144 | [s (set s)])) 145 | 146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | ;; 0CFA-style Abstract semantics 148 | (define (widen b) 149 | (cond [(number? b) 'number] 150 | [else (error "Unknown base value" b)])) 151 | 152 | (define (bind s) 153 | (match s 154 | [(ap^ (clos l x e ρ) v k) 155 | (join-many! x (get-val σ v)) 156 | (extend ρ x x)] 157 | [(ap^ (rlos l f x e ρ) v k) 158 | (join-one! f (rlos l f x e ρ)) 159 | (join-many! x (get-val σ v)) 160 | (extend (extend ρ x x) f f)] 161 | [_ (error 'bind "Bad ~a" s)])) 162 | 163 | (define (push l ρ k) 164 | (join-one! l k) 165 | l) 166 | 167 | (define (join-one! a v) 168 | (define prev (vector-ref σ a)) 169 | (unless (member v prev) 170 | (vector-set! σ a (cons v prev)) 171 | (set! unions (add1 unions)))) 172 | 173 | (define (join-many! a vs) 174 | (define prev (vector-ref σ a)) 175 | (define-values (next added?) 176 | (for/fold ([res prev] [added? #f]) 177 | ([v (in-list vs)] 178 | #:unless (member v prev)) 179 | (values (cons v res) #t))) 180 | (when added? 181 | (vector-set! σ a next) 182 | (set! unions (add1 unions)))) 183 | 184 | 185 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 186 | 187 | ;; Exp -> Set Val 188 | ;; 0CFA with store widening and specialized iteration 189 | (define (aval^ e) 190 | (define fst (inj e)) 191 | (define seen (make-hash (for/list ([c (in-set fst)]) 192 | (cons c unions)))) 193 | (time ;; ignore preprocessing 194 | (let loop ([todo fst]) 195 | (cond [(set-empty? todo) 196 | (for*/set ([(c at-unions) (in-hash seen)] 197 | #:when (ans^? c)) 198 | (ans^-v c))] 199 | [else 200 | (loop (wide-step-specialized todo seen))])))) 201 | 202 | ;; Sexp -> Set State 203 | (define (inj sexp) 204 | (define-values (e nlabels) (parse sexp)) 205 | (set! σ (make-vector nlabels '())) 206 | ((compile e) #;empty-environment-> (hash) 'mt)) 207 | 208 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 209 | ;; Widening State to State^ 210 | 211 | ;; State^ -> State^ 212 | ;; Specialized from wide-step : State^ -> { State^ } ≈ State^ -> State^ 213 | (define (wide-step-specialized cs seen) 214 | (for*/fold ([cs* (set)]) 215 | ([c (in-set cs)] 216 | [s (in-set (step-compiled^ c))] 217 | #:unless (= unions (hash-ref seen s -1))) 218 | (when (set? s) (error 'wide-step-specialized "Bad step ~a" c)) 219 | (hash-set! seen s unions) 220 | (set-add cs* s))) 221 | 222 | (aval^ church) -------------------------------------------------------------------------------- /code/iswim/0cfa-specialize-lazy-compile.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide aval^) 3 | (require "ast.rkt" "data.rkt") 4 | 5 | ;; 0CFA in the AAM style on some hairy Church numeral churning 6 | 7 | ;; + compilation phase 8 | ;; + lazy non-determinism 9 | ;; + specialized step & iterator 10 | 11 | ;; State = (cons Conf Store) 12 | ;; State^ = (cons (Set Conf) Store) 13 | 14 | ;; Comp = Store Env Cont -> State^ 15 | 16 | 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | ;; "Compiled" Machine 19 | 20 | ;; Compile away interpretive overhead of "ev" states 21 | 22 | ;; Expr -> Comp 23 | (define (compile e) 24 | (match e 25 | [(var l x) 26 | (λ (σ ρ k) 27 | (cons σ (set (co^ k (addr (lookup-env ρ x))))))] 28 | [(num l n) (λ (σ ρ k) (cons σ (set (co^ k n))))] 29 | [(bln l b) (λ (σ ρ k) (cons σ (set (co^ k b))))] 30 | [(lam l x e) 31 | (define c (compile e)) 32 | (λ (σ ρ k) (cons σ (set (co^ k (clos l x c ρ)))))] 33 | [(rec f (lam l x e)) 34 | (define c (compile e)) 35 | (λ (σ ρ k) (cons σ (set (co^ k (rlos l f x c ρ)))))] 36 | [(app l e0 e1) 37 | (define c0 (compile e0)) 38 | (define c1 (compile e1)) 39 | (λ (σ ρ k) 40 | (define-values (σ* a) (push σ l ρ k)) 41 | (c0 σ* ρ (ar c1 ρ a)))] 42 | [(ife l e0 e1 e2) 43 | (define c0 (compile e0)) 44 | (define c1 (compile e1)) 45 | (define c2 (compile e2)) 46 | (λ (σ ρ k) 47 | (define-values (σ* a) (push σ l ρ k)) 48 | (c0 σ* ρ (ifk c1 c2 ρ a)))] 49 | [(1op l o e) 50 | (define c (compile e)) 51 | (λ (σ ρ k) 52 | (define-values (σ* a) (push σ l ρ k)) 53 | (c σ* ρ (1opk o a)))] 54 | [(2op l o e0 e1) 55 | (define c0 (compile e0)) 56 | (define c1 (compile e1)) 57 | (λ (σ ρ k) 58 | (define-values (σ* a) (push σ l ρ k)) 59 | (c0 σ* ρ (2opak o c1 ρ a)))])) 60 | 61 | ;; Store (Addr + Val) -> Set Val 62 | (define (get-val σ v) 63 | (match v 64 | [(addr loc) (hash-ref σ loc (λ () (error "~a ~a" loc σ)))] 65 | [_ (set v)])) 66 | 67 | ;; "Bytecode" interpreter 68 | ;; State -> State^ 69 | (define (step-compiled^ s) 70 | (match s 71 | [(cons σ (co^ k v)) 72 | (match k 73 | ['mt (cons σ (for*/set ((v (get-val σ v))) 74 | (ans^ v)))] 75 | [(ar c ρ l) (c σ ρ (fn v l))] 76 | [(fn f l) 77 | (cons σ 78 | (for*/set ([k (get-cont σ l)] 79 | [f (get-val σ f)]) 80 | (ap^ f v k)))] 81 | [(ifk c a ρ l) 82 | (define states^ 83 | (for*/set ([k (get-cont σ l)] 84 | [v (get-val σ v)]) 85 | ((if v c a) σ ρ k))) 86 | 87 | (define-values (σ* cs*) 88 | (for/fold ([σ σ] [cs (set)]) 89 | ([s states^]) 90 | (match s 91 | [(cons σ* cs*) 92 | (values (join-store σ* σ) 93 | (set-union cs* cs))]))) 94 | (cons σ* cs*)] 95 | 96 | [(1opk o l) 97 | (cons σ 98 | (for*/set ([k (get-cont σ l)] 99 | [v (get-val σ v)]) 100 | (ap-op^ o (list v) k)))] 101 | [(2opak o c ρ l) 102 | (c σ ρ (2opfk o v l))] 103 | [(2opfk o u l) 104 | (cons σ 105 | (for*/set ([k (get-cont σ l)] 106 | [v (get-val σ v)] 107 | [u (get-val σ u)]) 108 | (ap-op^ o (list v u) k)))])] 109 | 110 | [(cons σ (ap^ fun a k)) 111 | (match fun 112 | [(clos l x c ρ) 113 | (define-values (ρ* σ*) (bind s)) 114 | (c σ* ρ* k)] 115 | [(rlos l f x c ρ) 116 | (define-values (ρ* σ*) (bind s)) 117 | (c σ* ρ* k)] 118 | ;; Anything else is stuck 119 | [_ (cons σ (set))])] 120 | 121 | [(cons σ (ap-op^ o vs k)) 122 | (match* (o vs) 123 | [('zero? (list (? number? n))) (cons σ (set (co^ k (zero? n))))] 124 | [('sub1 (list (? number? n))) (cons σ (set (co^ k (widen (sub1 n)))))] 125 | [('add1 (list (? number? n))) (cons σ (set (co^ k (widen (add1 n)))))] 126 | [('zero? (list 'number)) 127 | (cons σ (set (co^ k #t) 128 | (co^ k #f)))] 129 | [('sub1 (list 'number)) (cons σ (set (co^ k 'number)))] 130 | [('* (list (? number? n) (? number? m))) 131 | (cons σ (set (co^ k (widen (* m n)))))] 132 | [('* (list (? number? n) 'number)) 133 | (cons σ (set (co^ k 'number)))] 134 | [('* (list 'number 'number)) 135 | (cons σ (set (co^ k 'number)))] 136 | ;; Anything else is stuck 137 | [(_ _) (cons σ (set))])] 138 | 139 | [(cons σ c) 140 | (cons σ (set))])) 141 | 142 | 143 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 144 | ;; Concrete semantics 145 | #;#;#; 146 | (define (widen b) 147 | (cond [(number? b) b] 148 | [else (error "Unknown base value" b)])) 149 | 150 | (define (bind s) 151 | (match s 152 | [(ap σ (clos l x e ρ) v k) 153 | (define a 154 | (add1 (for/fold ([i 0]) 155 | ([k (in-hash-keys σ)]) 156 | (max i k)))) 157 | (values (extend ρ x a) 158 | (join σ a (set v)))] 159 | [(ap σ (rlos l f x e ρ) v k) 160 | (define a 161 | (add1 (for/fold ([i 0]) 162 | ([k (in-hash-keys σ)]) 163 | (max i k)))) 164 | (define b (add1 a)) 165 | (values (extend (extend ρ x a) f b) 166 | (join (join σ a (set v)) b (set (rlos l f x e ρ))))])) 167 | 168 | (define (push σ l ρ k) 169 | (define a 170 | (add1 (for/fold ([i 0]) 171 | ([k (in-hash-keys σ)]) 172 | (max i k)))) 173 | (values (join σ a (set k)) 174 | a)) 175 | 176 | 177 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 178 | ;; 0CFA-style Abstract semantics 179 | (define (widen b) 180 | (cond [(number? b) 'number] 181 | [else (error "Unknown base value" b)])) 182 | 183 | (define (bind s) 184 | (match s 185 | [(cons σ (ap^ (clos l x e ρ) v k)) 186 | (values (extend ρ x x) 187 | (join σ x (get-val σ v)))] 188 | [(cons σ (ap^ (rlos l f x e ρ) v k)) 189 | (values (extend (extend ρ x x) f f) 190 | (join-one (join σ x (get-val σ v)) f (rlos l f x e ρ)))])) 191 | 192 | (define (push σ l ρ k) 193 | (values (join-one σ l k) 194 | l)) 195 | 196 | 197 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 198 | 199 | ;; Exp -> Set Val 200 | ;; 0CFA with store widening and specialized iteration 201 | (define (aval^ e) 202 | (define fst (inj e)) 203 | (define snd (wide-step-specialized fst)) 204 | ;; wide-step-specialized is monotonic so we only need to check the current 205 | ;; state against it's predecessor to see if we have reached a fixpoint. 206 | (let loop ((next snd) (prev fst)) 207 | (if (equal? next prev) 208 | (for/set ([c (cdr prev)] 209 | #:when (ans^? c)) 210 | (ans^-v c)) 211 | (loop (wide-step-specialized next) next)))) 212 | 213 | ;; Exp -> Set State 214 | (define (inj e) 215 | ((compile e) (hash) (hash) 'mt)) 216 | 217 | 218 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 219 | ;; Widening State to State^ 220 | 221 | ;; State^ -> State^ 222 | ;; Specialized from wide-step : State^ -> { State^ } ≈ State^ -> State^ 223 | (define (wide-step-specialized state) 224 | (match state 225 | [(cons σ cs) 226 | (define-values (cs* σ*) 227 | (for/fold ([cs* (set)] [σ* σ]) 228 | ([c cs]) 229 | (match (step-compiled^ (cons σ c)) 230 | [(cons σ** cs**) 231 | (values (set-union cs* cs**) (join-store σ* σ**))]))) 232 | (cons σ* (set-union cs cs*))])) 233 | 234 | 235 | -------------------------------------------------------------------------------- /code/iswim/README: -------------------------------------------------------------------------------- 1 | This directory contains a bunch of simple versions of the 2 | different analyzers. -------------------------------------------------------------------------------- /code/iswim/ast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (struct-out exp) 4 | (struct-out var) 5 | (struct-out num) 6 | (struct-out bln) 7 | (struct-out lam) 8 | (struct-out app) 9 | (struct-out rec) 10 | (struct-out ife) 11 | (struct-out 1op) 12 | (struct-out 2op) 13 | parse) 14 | ;; An Exp is one of: 15 | ;; (var Lab Exp) 16 | ;; (num Lab Number) 17 | ;; (bln Lab Boolean) 18 | ;; (lam Lab Sym Exp) 19 | ;; (app Lab Exp Exp) 20 | ;; (rec Sym Lam) 21 | ;; (if Lab Exp Exp Exp) 22 | (struct exp (lab) #:transparent) 23 | (struct var exp (name) #:transparent) 24 | (struct num exp (val) #:transparent) 25 | (struct bln exp (b) #:transparent) 26 | (struct lam exp (var exp) #:transparent) 27 | (struct app exp (rator rand) #:transparent) 28 | (struct rec (name fun) #:transparent) 29 | (struct ife exp (t c a) #:transparent) 30 | (struct 1op exp (o a) #:transparent) 31 | (struct 2op exp (o a b) #:transparent) 32 | 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | ;; Parser 35 | 36 | (define (parse sexp fresh-label! fresh-variable!) 37 | (let parse ([sexp sexp] 38 | [ρ (hash)]) 39 | (define (parse* sexp) (parse sexp ρ)) 40 | (match sexp 41 | [`(let* () ,e) (parse* e)] 42 | [`(let* ((,x ,e) . ,r) ,b) 43 | (parse* `((lambda (,x) (let* ,r ,b)) ,e))] 44 | [`(lambda (,x) ,e) 45 | (define x-lab (fresh-variable! x)) 46 | (lam (fresh-label!) x-lab (parse e (hash-set ρ x x-lab)))] 47 | [`(if ,e0 ,e1 ,e2) 48 | (ife (fresh-label!) (parse* e0) (parse* e1) (parse* e2))] 49 | [`(rec ,f ,e) 50 | (define f-lab (fresh-variable! f)) 51 | (rec f-lab (parse e (hash-set ρ f f-lab)))] 52 | [`(sub1 ,e) 53 | (1op (fresh-label!) 'sub1 (parse* e))] 54 | [`(add1 ,e) 55 | (1op (fresh-label!) 'add1 (parse* e))] 56 | [`(zero? ,e) 57 | (1op (fresh-label!) 'zero? (parse* e))] 58 | [`(* ,e0 ,e1) 59 | (2op (fresh-label!) '* (parse* e0) (parse* e1))] 60 | [`(,e0 ,e1) 61 | (app (fresh-label!) 62 | (parse* e0) 63 | (parse* e1))] 64 | [(? boolean? b) (bln (fresh-label!) b)] 65 | [(? number? n) (num (fresh-label!) n)] 66 | [(? symbol? s) (var (fresh-label!) (hash-ref ρ s (λ () (error 'parse "Open program: ~a" s))))]))) -------------------------------------------------------------------------------- /code/iswim/data.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (all-defined-out)) 3 | 4 | ;; A Val is one of: 5 | ;; - Number 6 | ;; - Boolean 7 | ;; - (clos Lab Sym Exp Env) 8 | ;; - (rlos Lab Sym Sym Exp Env) 9 | (struct clos (l x e ρ) #:transparent) 10 | (struct rlos (l f x e ρ) #:transparent) 11 | 12 | ;; A Cont is one of: 13 | ;; - 'mt 14 | ;; - (ar Exp Env Cont) 15 | ;; - (fn Val Cont) 16 | ;; - (ifk Exp Exp Env Cont) 17 | ;; - (1opk Opr Cont) 18 | ;; - (2opak Opr Exp Env Cont) 19 | ;; - (2opfk Opr Val Cont) 20 | (struct ar (e ρ k) #:transparent) 21 | (struct fn (v k) #:transparent) 22 | (struct ifk (c a ρ k) #:transparent) 23 | (struct 1opk (o k) #:transparent) 24 | (struct 2opak (o e ρ k) #:transparent) 25 | (struct 2opfk (o v k) #:transparent) 26 | 27 | ;; State 28 | (struct state (σ) #:transparent) 29 | (struct ev state (e ρ k) #:transparent) 30 | (struct co state (k v) #:transparent) 31 | (struct ap state (f a k) #:transparent) 32 | (struct ap-op state (o vs k) #:transparent) 33 | (struct ans state (v) #:transparent) 34 | 35 | (struct addr (a) #:transparent) 36 | 37 | (define (lookup ρ σ x) 38 | (define a (hash-ref ρ x (λ () (error 'lookup "Unbound var ~a" x)))) 39 | (hash-ref σ a (λ () (error 'lookup "Unbound address ~a" a)))) 40 | (define (lookup-env ρ x) 41 | (hash-ref ρ x (λ () (error 'lookup-env "Unbound var ~a" x)))) 42 | (define (get-cont σ l) 43 | (hash-ref σ l (λ () (error 'get-cont "Unbound cont ~a" l)))) 44 | (define (extend ρ x v) 45 | (hash-set ρ x v)) 46 | (define (join σ a s) 47 | (hash-set σ a 48 | (set-union s (hash-ref σ a (set))))) 49 | 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | ;; Widening representations 52 | ;; State^ = (cons (Set Conf) Store) 53 | 54 | ;; Conf 55 | (struct ev^ (e ρ k) #:transparent) 56 | (struct co^ (k v) #:transparent) 57 | (struct ap^ (f a k) #:transparent) 58 | (struct ap-op^ (o vs k) #:transparent) 59 | (struct ans^ (v) #:transparent) 60 | 61 | ;; Conf Store -> State 62 | (define (c->s c σ) 63 | (match c 64 | [(ev^ e ρ k) (ev σ e ρ k)] 65 | [(co^ k v) (co σ k v)] 66 | [(ap^ f a k) (ap σ f a k)] 67 | [(ap-op^ o vs k) (ap-op σ o vs k)] 68 | [(ans^ v) (ans σ v)])) 69 | 70 | ;; State -> Conf 71 | (define (s->c s) 72 | (match s 73 | [(ev _ e ρ k) (ev^ e ρ k)] 74 | [(co _ k v) (co^ k v)] 75 | [(ap _ f a k) (ap^ f a k)] 76 | [(ap-op _ o vs k) (ap-op^ o vs k)] 77 | [(ans _ v) (ans^ v)])) 78 | 79 | ;; Store Store -> Store 80 | (define (join-store σ1 σ2) 81 | (for/fold ([σ σ1]) 82 | ([k×v (in-hash-pairs σ2)]) 83 | (hash-set σ (car k×v) 84 | (set-union (cdr k×v) 85 | (hash-ref σ (car k×v) (set)))))) 86 | 87 | ;; Set State -> Store 88 | (define (join-stores ss) 89 | (for/fold ([σ (hash)]) 90 | ([s ss]) 91 | (join-store σ (state-σ s)))) 92 | 93 | (define (join-one σ a x) 94 | (hash-set σ a 95 | (set-add (hash-ref σ a (set)) x))) 96 | (define (join-one* σ as xs) 97 | (cond [(empty? as) σ] 98 | [else (join-one* (join-one σ (first as) (first xs)) 99 | (rest as) 100 | (rest xs))])) -------------------------------------------------------------------------------- /code/iswim/env.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ;; Common environment metafunctions for functional representations 6 | (define (join-store σ1 σ2) 7 | (for/fold ([σ σ1]) 8 | ([k×v (in-hash-pairs σ2)]) 9 | (hash-set σ (car k×v) 10 | (set-union (cdr k×v) 11 | (hash-ref σ (car k×v) (set)))))) 12 | 13 | ;; Set State -> Store 14 | (define (join-stores ss) 15 | (for/fold ([σ (hash)]) 16 | ([s ss]) 17 | (join-store σ (car s)))) 18 | 19 | (define (join-one σ a x) 20 | (hash-set σ a 21 | (set-add (hash-ref σ a (set)) x))) 22 | (define (join-one* σ as xs) 23 | (cond [(empty? as) σ] 24 | [else (join-one* (join-one σ (first as) (first xs)) 25 | (rest as) 26 | (rest xs))])) 27 | (define (join σ a s) 28 | (hash-set σ a 29 | (set-union s (hash-ref σ a (set))))) 30 | 31 | (define (get-cont σ l) 32 | (hash-ref σ l (λ () (error 'get-cont "Unbound cont ~a" l)))) 33 | 34 | (define (extend ρ x v) 35 | (hash-set ρ x v)) 36 | 37 | (define (lookup-store σ a) 38 | (hash-ref σ a (λ () (error 'lookup-store "Unbound address ~a" a)))) -------------------------------------------------------------------------------- /code/iswim/fix.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide fix appl) 3 | 4 | ;; appl : (∀ (X) ((X -> (Setof X)) -> ((Setof X) -> (Setof X)))) 5 | (define ((appl f) s) 6 | (for/fold ([i (set)]) 7 | ([x (in-set s)]) 8 | (set-union i (f x)))) 9 | 10 | ;; Calculate fixpoint of (appl f). 11 | ;; fix : (∀ (X) ((X -> (Setof X)) (Setof X) -> (Setof X))) 12 | (define (fix f s) 13 | (let loop ((accum (set)) (front s)) 14 | (if (set-empty? front) 15 | accum 16 | (let ((new-front ((appl f) front))) 17 | (loop (set-union accum front) 18 | (set-subtract new-front accum)))))) 19 | -------------------------------------------------------------------------------- /code/iswim/progs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide church) 4 | 5 | (define church 6 | ;; Ian's example, curried, alpha renamed and 7 | ;; let* in place of define where possible. 8 | '(let* ((plus (lambda (p1) 9 | (lambda (p2) 10 | (lambda (pf) 11 | (lambda (x) ((p1 pf) ((p2 pf) x))))))) 12 | (mult (lambda (m1) 13 | (lambda (m2) 14 | (lambda (mf) (m2 (m1 mf)))))) 15 | (pred (lambda (n) 16 | (lambda (rf) 17 | (lambda (rx) 18 | (((n (lambda (g) (lambda (h) (h (g rf))))) 19 | (lambda (ignored) rx)) 20 | (lambda (id) id)))))) 21 | (sub (lambda (s1) 22 | (lambda (s2) 23 | ((s2 pred) s1)))) 24 | 25 | (church0 (lambda (f0) (lambda (x0) x0))) 26 | (church1 (lambda (f1) (lambda (x1) (f1 x1)))) 27 | (church2 (lambda (f2) (lambda (x2) (f2 (f2 x2))))) 28 | (church3 (lambda (f3) (lambda (x3) (f3 (f3 (f3 x3)))))) 29 | (church0? (lambda (z) ((z (lambda (zx) #f)) #t))) 30 | (c->n (lambda (cn) ((cn (lambda (u) (add1 u))) 0))) 31 | (church=? (rec c=? 32 | (lambda (e1) 33 | (lambda (e2) 34 | (if (church0? e1) 35 | (church0? e2) 36 | (if (church0? e2) 37 | #f 38 | ((c=? ((sub e1) church1)) ((sub e2) church1))))))))) 39 | 40 | ((church=? ((mult church2) ((plus church1) church3))) 41 | ((plus ((mult church2) church1)) ((mult church2) church3))))) -------------------------------------------------------------------------------- /code/lazy-strict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "data.rkt" "primitives.rkt" racket/splicing) 3 | (provide with-lazy with-strict) 4 | 5 | (define-syntax-rule (lazy-force lfσ x) 6 | (match x 7 | [(addr a) (getter lfσ a)] 8 | [v (singleton v)])) 9 | (define-syntax-rule (strict-force lfσ x) (singleton x)) 10 | 11 | (define-syntax-rule (lazy-delay ldσ a) (singleton (addr a))) 12 | (define-syntax-rule (strict-delay ldσ a) (getter ldσ a)) 13 | 14 | (define-syntax-rule (with-lazy body) 15 | (splicing-syntax-parameterize 16 | ([delay (make-rename-transformer #'lazy-delay)] 17 | [force (make-rename-transformer #'lazy-force)]) 18 | body)) 19 | 20 | (define-syntax-rule (with-strict body) 21 | (splicing-syntax-parameterize 22 | ([delay (make-rename-transformer #'strict-delay)] 23 | [force (make-rename-transformer #'strict-force)]) 24 | body)) 25 | 26 | -------------------------------------------------------------------------------- /code/macros.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (for-syntax racket/syntax) "data.rkt") 4 | (provide macro-env define-ctx-tf 5 | igensym 6 | void$ quote$ 7 | special kwote define-ctx) 8 | 9 | (define-nonce special) 10 | (define-nonce define-ctx) 11 | (define-nonce kwote) 12 | ;; Directives to make special abstract data from "large" literals. 13 | (define-syntax (mk-specials stx) 14 | (syntax-case stx () 15 | [(_ names ...) 16 | (with-syntax ([(names$ ...) (map (λ (i) (format-id i "~a$" i)) (syntax->list #'(names ...)))]) 17 | #'(begin (define names$ (cons special 'names)) ...))])) 18 | (mk-specials begin car cdr cons let letrec lambda if eq? or quote void not vector 19 | qlist^ qimproper^ qvector^ qhash^) 20 | 21 | (define (igensym [start 'g]) (string->symbol (symbol->string (gensym start)))) 22 | 23 | (define ((rename-tf to) inp) (cons to (cdr inp))) 24 | 25 | (define (quote-tf inp) 26 | (define limit (cons-limit)) 27 | (define (improper-length l) 28 | (cond [(pair? l) (add1 (improper-length (cdr l)))] 29 | [else 0])) 30 | (define (split-improper l) 31 | (let loop ([l l] [front '()]) 32 | (cond [(pair? l) (loop (cdr l) (cons (car l) front))] 33 | [else (values front l)]))) 34 | (match inp 35 | [`(quote ,d) 36 | (let loop ([d d]) 37 | (cond [(atomic? d) `(,kwote ,d)] 38 | [(list? d) 39 | (if (< (length d) limit) 40 | `(,cons$ ,(loop (car d)) ,(loop (cdr d))) 41 | `(,qlist^$ . ,(map loop d)))] 42 | ;; List literals get exploded into conses 43 | [(pair? d) 44 | (cond [(< (improper-length d) limit) 45 | `(,cons$ ,(loop (car d)) ,(loop (car d)))] 46 | [else (define-values (front last) (split-improper d)) 47 | `(,qimproper^$ (loop last) . ,(map loop front))])] 48 | [(vector? d) 49 | (cond [(< (vector-length d) limit) 50 | `(,kwote ,d)] 51 | [else `(,qvector^$ . ,(map loop (vector->list d)))])] 52 | [(hash? d) 53 | (cond [(< (hash-count d) limit) `(,kwote ,d)] 54 | ;; qhash^ k v k v k v ... .... 55 | [else `(,qhash^$ . 56 | ,(append-map 57 | (match-lambda [(cons k v) (list (loop k) (loop v))]) 58 | (hash->list d)))])] 59 | [else (error 'parse "Unsupported datum ~a" d)]))] 60 | [_ (error 'quote-tf "Bad input ~a" inp)])) 61 | 62 | (module+ test 63 | (require rackunit) 64 | (check equal? (quote-tf '(quote (0 1 2 3 4 5 6 7 8 9))) 65 | `(,qlist^$ (,kwote 0) (,kwote 1) (,kwote 2) (,kwote 3) (,kwote 4) (,kwote 5) 66 | (,kwote 6) (,kwote 7) (,kwote 8) (,kwote 9)))) 67 | 68 | (define (begin-tf inp) 69 | (match inp 70 | [`(begin ,e) e] 71 | [`(begin ,e . ,es) `((,lambda$ (,(igensym)) ,(begin-tf `(begin . ,es))) ,e)] 72 | ['(begin) (error 'begin-tf "Expected at least one expression")] 73 | [_ (error 'begin-tf "Bad input ~a" inp)])) 74 | 75 | (define (let-tf inp) 76 | (match inp 77 | [`(let () . ,b) `(,define-ctx . ,b)] 78 | [`(let ([,xs ,es] ...) . ,b) 79 | `((,lambda$ ,xs . ,b) . ,es)] 80 | [`(let ,(? symbol? loop) ([,xs ,es] ...) . ,b) 81 | `(,letrec$ ([,loop (,lambda$ ,xs . ,b)]) 82 | (,loop . ,es))] 83 | [_ (error 'let-tf "Bad input ~a" inp)])) 84 | 85 | (define (let*-tf inp) 86 | (match inp 87 | [`(let* () . ,b) `(,define-ctx . ,b)] 88 | [`(let* ([,x ,e] . ,rest) . ,b) 89 | `(let ([,x ,e]) ,(let*-tf `(let* ,rest . ,b)))] 90 | [_ (error 'let*-tf "Bad input ~a" inp)])) 91 | 92 | (define (or-tf inp) 93 | (match inp 94 | ['(or) #f] 95 | [`(or ,e) e] 96 | [`(or ,e . ,es) 97 | (define x (igensym 'or-temp)) 98 | `(,let$ ([,x ,e]) (,if$ ,x ,x ,(or-tf `(or . ,es))))])) 99 | 100 | (define (and-tf inp) 101 | (match inp 102 | ['(and) #t] 103 | [`(and ,e) e] 104 | [`(and ,e . ,es) `(,if$ ,e ,(and-tf `(and . ,es)) #f)])) 105 | 106 | (define (case-tf inp) 107 | (define x (igensym 'case-tmp)) 108 | (define (xin-datums datums) 109 | (cons or$ (for/list ([datum (in-list datums)]) 110 | `(,eq?$ ,x (,quote$ ,datum))))) 111 | (define (tf datumss rhsss lasts) 112 | (match* (datumss rhsss lasts) 113 | [('() '() #f) `(,void$)] ;; XXX: needs explicit renaming to be correct 114 | [('() '() lasts) `(,define-ctx . ,lasts)] 115 | [((cons datums datumss) (cons rhss rhsss) lasts) 116 | `(,if$ ,(xin-datums datums) 117 | (,define-ctx . ,rhss) 118 | ,(tf datumss rhsss lasts))])) 119 | (match inp 120 | [`(case ,in [(,datumss ...) . ,rhsss] ... [else . ,last]) 121 | `(,let$ ([,x ,in]) ,(tf datumss rhsss last))] 122 | [`(case ,in [(,datumss ...) . ,rhsss] ...) 123 | `(,let$ ([,x ,in]) ,(tf datumss rhsss #f))] 124 | [`(case . ,rst) (error 'case-tf "Bad input ~a" rst)])) 125 | 126 | ;; XXX: improper handling of else and =>. Oh well. 127 | (define (cond-tf inp) 128 | (match inp 129 | [`(cond) `(,void$)] 130 | [`(cond [else . ,lasts]) `(,define-ctx . ,lasts)] 131 | [`(cond [,guard => ,rhs] . ,rest) 132 | (define x (igensym 'cond-proc)) 133 | `(,let$ ([,x ,guard]) 134 | (,if$ ,x 135 | (,rhs ,x) 136 | ,(cond-tf `(cond . ,rest))))] 137 | [`(cond [,guard ,rhss ...] . ,rest) 138 | `(,if$ ,guard (,define-ctx . ,rhss) ,(cond-tf `(cond . ,rest)))] 139 | [_ (error 'cond-tf "Bad input ~a" inp)])) 140 | 141 | (define (define-ctx-tf inp) 142 | (define (parse-defns ds) 143 | (match ds 144 | ['() '()] 145 | [`((define (,f . ,xs) . ,b) . ,ds) 146 | (parse-defns `((define ,f (lambda ,xs . ,b)) . ,ds))] 147 | [`((define ,f ,e) . ,ds) 148 | (cons (list f e) 149 | (parse-defns ds))])) 150 | (match inp 151 | [(list e) e] 152 | [(list (and ds `(define ,_ . ,_)) ... es ...) 153 | (when (null? es) 154 | (error 'define-ctx "expected at least one expression after defines ~a" inp)) 155 | `(,letrec$ ,(parse-defns ds) (,begin$ ,@es))])) 156 | 157 | (define (do-tf inp) 158 | (let loop ([e (cdr inp)]) 159 | (match e 160 | ;; (((var init . step) ...) (e0 e1 ...) c ...) 161 | [(list-rest (? list? vis) (cons e0 (? list? e1)) (? list? c)) 162 | (if (andmap (match-lambda 163 | [(list-rest _ _ _) #t] 164 | [_ #f]) 165 | vis) 166 | (let* ([var (map car vis)] 167 | [init (map cadr vis)] 168 | [step (map cddr vis)] 169 | [step (map (lambda (v s) 170 | (match s 171 | [`() v] 172 | [`(,e) e] 173 | [_ (error 'do-tf "invalid do expression ~a" inp)])) 174 | var 175 | step)]) 176 | (let ([doloop (gensym)]) 177 | (match e1 178 | ['() 179 | `(,let$ ,doloop ,(map list var init) 180 | (,if$ (,not$ ,e0) 181 | (,begin$ ,@c (,doloop ,@step) (void)) 182 | (,void$)))] 183 | [(list body0 body ...) 184 | `(,let$ ,doloop ,(map list var init) 185 | (,if$ ,e0 186 | (,begin$ ,body0 ,@body) 187 | (,begin$ ,@c (,doloop ,@step))))] 188 | [_ (error 'do-tf "invalid do expression ~a" inp)]))) 189 | (error 'do-tf "invalid do expression ~a" inp))] 190 | (_ (error 'do-tf "invalid do expression ~a" inp))))) 191 | 192 | (define (unless-tf inp) 193 | (match inp 194 | [`(unless ,guard . ,body) 195 | `(if ,guard (,void$) (,define-ctx . ,body))])) 196 | 197 | (define macro-env 198 | (hasheq 'quote quote-tf 199 | 'begin begin-tf 200 | 'do do-tf 201 | 'or or-tf 202 | 'and and-tf 203 | 'case case-tf 204 | 'cond cond-tf 205 | 'let let-tf 206 | 'let* let*-tf 207 | 'unless unless-tf 208 | 'λ (rename-tf 'lambda) 209 | 'letrec* (rename-tf 'letrec))) 210 | -------------------------------------------------------------------------------- /code/mk-graph.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "kcfa-instantiations.rkt" "run-benchmark.rkt" "graph.rkt" (only-in "data.rkt" cons-limit)) 3 | (require racket/stxparam) 4 | 5 | (define benchmark (make-parameter "../benchmarks/introspective.sch")) 6 | (define (prefix) 7 | (let-values ([(base filename dir?) (split-path (string->path (benchmark)))]) 8 | filename)) 9 | 10 | (define (print-values . vs) (for ([v vs]) (display v) (newline))) 11 | 12 | (define (do eval suffix) 13 | (thread 14 | (λ () 15 | (define p (prefix)) 16 | (syntax-parameterize ([generate-graph? #t]) 17 | (parameterize ([graph-file (path-replace-suffix p (format "~a.dot" suffix))] 18 | [aval eval]) 19 | (call-with-values (λ () (test (prep (benchmark)))) values)))))) 20 | 21 | (define (all-three) 22 | (define ts (list (do 0cfa^ "-base") 23 | (do lazy-0cfa^ "-lazy") 24 | (do lazy-0cfa^/c "-lazyc"))) 25 | (for ([t ts]) (thread-wait t))) 26 | 27 | (all-three) 28 | -------------------------------------------------------------------------------- /code/nonsparse.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "do.rkt" "data.rkt" "primitives.rkt" racket/stxparam racket/splicing) 3 | (provide with-nonsparse) 4 | 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ;; Non-sparse analyses do not need to accumulate actions 7 | (define-syntax-rule (bind-get-nonsparse (res σ a) body) 8 | (let ([res (getter σ a)]) body)) 9 | 10 | (define-syntax-rule (bind-force-nonsparse (res σ v) body) 11 | (let ([res (force σ v)]) body)) 12 | 13 | (define-syntax-rule (bind-delay-nonsparse (res σ a) body) 14 | (let ([res (delay σ a)]) body)) 15 | 16 | (define-syntax-rule (bind-big-alias-nonsparse (σ* σ alias all-to-alias) body) 17 | (bind-join (σ* σ alias (for/fold ([acc nothing]) ([a (in-list all-to-alias)]) 18 | (⊓ acc (getter σ a)))) 19 | body)) 20 | (define-syntax-rule (bind-alias*-nonsparse (σ* σ aliases all-to-alias) body) 21 | (bind-join* (σ* σ aliases (for/list ([a (in-list all-to-alias)]) (getter σ a))) body)) 22 | 23 | (define-syntax-rule (with-nonsparse body) 24 | (splicing-syntax-parameterize 25 | ([bind-get (make-rename-transformer #'bind-get-nonsparse)] 26 | [bind-force (make-rename-transformer #'bind-force-nonsparse)] 27 | [bind-delay (make-rename-transformer #'bind-delay-nonsparse)] 28 | [bind-big-alias (make-rename-transformer #'bind-big-alias-nonsparse)] 29 | [bind-alias* (make-rename-transformer #'bind-alias*-nonsparse)]) 30 | body)) 31 | -------------------------------------------------------------------------------- /code/notation.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (for-syntax syntax/parse)) 4 | (provide for/append for/union for*/union for/set for*/set 5 | define-simple-macro* hash-reverse 6 | ∅ ∅? ¬∅? ∪ ∩ ⊆? ∖ ∪1 ∪/l ∖1 ∖/l ∈) 7 | 8 | ;; define-simple-macro does not have an implicit quasisyntax. 9 | (define-syntax (define-simple-macro* stx) 10 | (syntax-parse stx 11 | [(_ (name:id . pattern) directives ... template) 12 | (syntax/loc stx 13 | (define-syntax (name syn) 14 | (syntax-parse syn 15 | [(name . pattern) directives ... (quasisyntax/loc syn template)])))])) 16 | 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | ;; for/union 19 | 20 | (begin-for-syntax 21 | (define-splicing-syntax-class (ops initial) 22 | #:attributes (init res) 23 | (pattern (~seq (~or (~optional (~seq #:initial init:expr) 24 | #:defaults ([init initial])) 25 | (~optional (~seq #:res res:id) 26 | #:defaults ([res #'acc]))) ...)))) 27 | 28 | (define-simple-macro* (for/append (~var o (ops #''())) guards body ...+) 29 | (for/fold ([o.res o.init]) guards (append (let () body ...) o.res))) 30 | 31 | ;; Set notations 32 | (define-values (∅ ∅? ¬∅? ∪ ∩ ⊆? ∖ ∪1 ∪/l ∖1 ∖/l ∈) 33 | (let ([set-add* 34 | (λ (s xs) (for/fold ([s s]) ([x (in-list xs)]) (set-add s x)))] 35 | [set-remove* 36 | (λ (s xs) (for/fold ([s s]) ([x (in-list xs)]) (set-remove s x)))] 37 | [in? (λ (x s) (set-member? s x))]) 38 | (values (set) set-empty? (λ (s) (not (set-empty? s))) 39 | set-union set-intersect subset? set-subtract 40 | set-add set-add* 41 | set-remove set-remove* in?))) 42 | 43 | (define (hash-reverse h) 44 | (for/hash ([(k v) (in-hash h)]) 45 | (values v k))) 46 | 47 | (define-simple-macro* (for/union (~var o (ops #'∅)) guards body ...+) 48 | (for/fold ([o.res o.init]) guards (∪ o.res (let () body ...)))) 49 | (define-simple-macro* (for*/union (~var o (ops #'∅)) guards body ...+) 50 | (for*/fold ([o.res o.init]) guards (∪ o.res (let () body ...)))) 51 | (define-simple-macro* (for/set (~var o (ops #'∅)) guards body ...+) 52 | (for/fold ([o.res o.init]) guards (∪1 o.res (let () body ...)))) 53 | (define-simple-macro* (for*/set (~var o (ops #'∅)) guards body ...+) 54 | (for*/fold ([o.res o.init]) guards (∪1 o.res (let () body ...)))) 55 | -------------------------------------------------------------------------------- /code/op-struct.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require (for-syntax racket/syntax 3 | syntax/parse 4 | syntax/id-table 5 | racket/match 6 | syntax/struct)) 7 | (provide mk-op-struct) 8 | 9 | ;; Specialize representations 10 | (define-syntax mk-op-struct 11 | (syntax-parser 12 | [(_ name:id (fields:id ...) (subfields:id ...) 13 | (~bind [container (format-id #'name "~a-container" #'name)]) 14 | (~or 15 | (~optional (~seq #:expander 16 | (~or (~and #:with-first-cons 17 | (~bind [expander 18 | #`(syntax-rules () 19 | [(_ fσ #,@(cdr (syntax->list #'(fields ...)))) 20 | (cons fσ (container subfields ...))])])) 21 | expander:expr)) ;; want a different match expander? 22 | #:defaults ([expander 23 | #'(syntax-rules () 24 | [(_ fields ...) 25 | (container subfields ...)])])) 26 | (~optional (~seq #:expander-id name-ex:id) 27 | #:defaults ([name-ex (format-id #'name "~a:" #'name)]))) ...) 28 | #:do [(define (populate fs) 29 | (let ([start (make-free-id-table)]) 30 | (for ([f (in-list fs)]) (free-id-table-set! start f #t)) 31 | start)) 32 | (define fieldsl (syntax->list #'(fields ...))) 33 | (define subfieldsl (syntax->list #'(subfields ...))) 34 | (define fs (populate fieldsl)) 35 | (define sfs (populate subfieldsl)) 36 | (match-define (list-rest _ _ name? sels) 37 | (build-struct-names #'name fieldsl #f #t #'name)) 38 | (match-define (list-rest _ _ real-name? real-sels) 39 | (build-struct-names #'container fieldsl #f #t #'container)) 40 | (define-values (good-sels bad-sels) 41 | (for/fold ([good '()] [bad '()]) ([f (in-list fieldsl)] 42 | [sel (in-list sels)] 43 | [real (in-list real-sels)]) 44 | ;; Supposed field is actually present. Pair the container's 45 | ;; selector with the desired selector name. 46 | (cond [(free-id-table-ref sfs f #f) 47 | (values `((,sel ,real) . ,good) bad)] 48 | [else (values good (cons sel bad))])))] 49 | #:fail-unless (for/and ([s (in-list subfieldsl)]) 50 | (free-id-table-ref fs s #f)) 51 | "Subfields should be contained in fields list." 52 | (with-syntax ([((good real-good) ...) good-sels] 53 | [(bad ...) bad-sels]) 54 | #`(begin (struct container (subfields ...) #:prefab) 55 | (define-syntax (name syn) 56 | (syntax-parse syn 57 | [(_ fields ...) #'(container subfields ...)] 58 | [n:id (raise-syntax-error #f "Not first class" syn)])) 59 | (define #,name? #,real-name?) 60 | (define good real-good) ... 61 | ;; Make sure things compile but I get good error messages 62 | ;; if I have runtime logic errors. 63 | (define (bad . rest) 64 | (error 'bad "Not present in specialized representation")) ... 65 | (define-match-expander name-ex expander)))])) -------------------------------------------------------------------------------- /code/parse.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide parse parse-prog unparse) 3 | (require "ast.rkt" "primitives.rkt" "data.rkt" "macros.rkt" 4 | racket/trace) 5 | 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | ;; Parser 8 | 9 | (define (parse-prog sexp [fresh-label! igensym] [fresh-variable! igensym]) 10 | (parse (cons define-ctx sexp) fresh-label! fresh-variable!)) 11 | 12 | (define (parse sexp [fresh-label! igensym] [fresh-variable! igensym]) 13 | ;; in order for the renaming to work on open programs, we not only have to return 14 | ;; the renamed program, but also a map from free variables to their new names. 15 | (define open (make-hasheq)) 16 | (define ((new-free x)) 17 | (match (hash-ref open x #f) 18 | [#f (define x-id (fresh-variable! x)) 19 | (hash-set! open x x-id) 20 | x-id] 21 | [s s])) 22 | (define expr 23 | (let parse* ([sexp sexp] 24 | [ρ (hasheq)]) 25 | (define (parse sexp) (parse* sexp ρ)) 26 | (define ((parse_ ρ) sexp) (parse* sexp ρ)) 27 | (define (rename x) (hash-ref ρ x (new-free x))) 28 | (define (parse-seq s [ρ ρ]) (parse* (define-ctx-tf s) ρ)) 29 | (define (fresh-xs xs) 30 | (define xs-id (map fresh-variable! xs)) 31 | (values xs-id 32 | (for/fold ([ρ ρ]) ([x xs] [x-id xs-id]) (hash-set ρ x x-id)))) 33 | (define (parse-core sexp) 34 | (match sexp 35 | [`(set! ,x ,e) (st! (fresh-label!) (rename x) (parse e))] 36 | [`(letrec () . ,s) (parse-seq s)] 37 | [`(letrec ((,xs ,es) ...) . ,s) 38 | (define-values (xs-id ρ) (fresh-xs xs)) 39 | (lrc (fresh-label!) xs-id (map (parse_ ρ) es) (parse-seq s ρ))] 40 | [`(lambda (,xs ...) . ,s) 41 | (define-values (xs-id ρ) (fresh-xs xs)) 42 | (lam (fresh-label!) xs-id (parse-seq s ρ))] 43 | [`(lambda (,xs ... . ,rest) . ,s) 44 | (define-values (xs-id ρ) (fresh-xs xs)) 45 | (define r-id (fresh-variable! rest)) 46 | (rlm (fresh-label!) xs-id r-id (parse-seq s (hash-set ρ rest r-id)))] 47 | [`(lambda ,x . ,s) 48 | (define x-id (fresh-variable! x)) 49 | (rlm (fresh-label!) '() x-id (parse-seq s (hash-set ρ x x-id)))] 50 | [`(if ,e0 ,e1 ,e2) 51 | (ife (fresh-label!) (parse e0) (parse e1) (parse e2))] 52 | [`(if ,g ,t) 53 | (printf "Warning: If without else: ~a~%" sexp) 54 | (parse-core `(if ,g ,t (,void$)))] 55 | [`(let/cc ,x ,e) 56 | (define x-id (fresh-variable! x)) 57 | (lcc (fresh-label!) x-id (parse* e (hash-set ρ x x-id)))] 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | ;; Continuation marks forms 60 | [`(test (,(? symbol? Rs) ...) ,t ,e) 61 | (tst (fresh-label!) (list->set Rs) (parse t) (parse e))] 62 | [`(grant (,(? symbol? Rs) ...) ,e) 63 | (grt (fresh-label!) (list->set Rs) (parse e))] 64 | ['(fail) (fal (fresh-label!))] 65 | [`(frame (,(? symbol? Rs) ...) ,e) 66 | (frm (fresh-label!) (list->set Rs) (parse e))] 67 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 68 | ;; End Continuation marks forms 69 | [`(,(or 'lambda 'if 'letrec 'set! 70 | #;for-continuation-marks 71 | 'test 'grant 'fail 'frame) . ,rest) 72 | (error 'parse-core "Ill-formed core form ~a" sexp)] 73 | [`(,(== kwote) ,d) (datum (fresh-label!) d)] 74 | [`(,(== define-ctx) . ,forms) (parse-seq forms)] 75 | [`(,s . ,es) (=> fail) 76 | (match (hash-ref macro-env s #f) 77 | [#f (fail)] 78 | [tf (parse (tf sexp))])] 79 | [`(,e . ,es) 80 | (app (fresh-label!) (parse e) (map parse es))])) 81 | 82 | (match sexp 83 | [`(,(== special) . ,s) (primr (fresh-label!) s)] 84 | [`((,(== special) . ,s) . ,es) 85 | (if (primitive? s) 86 | (app (fresh-label!) 87 | (primr (fresh-label!) s) 88 | (map parse es)) 89 | (parse-core (cons s es)))] 90 | [`(,e . ,es) 91 | (cond [(hash-has-key? ρ e) 92 | (app (fresh-label!) 93 | (var (fresh-label!) (rename e)) 94 | (map parse es))] 95 | [else (parse-core sexp)])] 96 | [(? symbol? s) 97 | (define (mkvar) (var (fresh-label!) (rename s))) 98 | (cond [(hash-has-key? ρ s) (mkvar)] 99 | [(primitive? s) (primr (fresh-label!) s)] 100 | [(hash-ref prim-constants s #f) => 101 | (λ (d) (datum (fresh-label!) d))] 102 | [else (mkvar)])] ;; will error 103 | [(? atomic? d) (datum (fresh-label!) d)] 104 | [(? vector? d) (parse `(,quote$ ,d))] ;; ick 105 | [err (error 'parse "Unknown form ~a" err)]))) 106 | (values expr open)) 107 | #; 108 | (trace parse) 109 | (define (unparse e) 110 | (match e 111 | [(or (var _ x) (datum _ x) (primr _ x)) x] 112 | [(app _ e es) (map unparse (cons e es))] 113 | [(lam _ xs body) `(λ ,xs ,(unparse body))] 114 | [(ife _ g t e) `(if ,(unparse g) ,(unparse t) ,(unparse e))] 115 | [(st! _ x e) `(set! ,x ,(unparse e))] 116 | [(lrc _ xs es body) `(letrec ,(map list xs (map unparse es)) ,(unparse body))] 117 | [_ (error 'unparse "Bad exp ~a" e)])) -------------------------------------------------------------------------------- /code/prealloc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "do.rkt" "env.rkt" "notation.rkt" "primitives.rkt" racket/splicing racket/stxparam 3 | "data.rkt" "imperative.rkt" "context.rkt" "add-lib.rkt" 4 | "deltas.rkt") 5 | (provide prepare-prealloc 6 | prepare-prealloc/stacked 7 | with-0-ctx/prealloc 8 | mk-prealloc/timestamp^-fixpoint 9 | mk-prealloc/timestamp^-fixpoint/stacked 10 | mk-prealloc/∆s/acc^-fixpoint 11 | mk-prealloc/∆s^-fixpoint 12 | with-σ-∆s/acc/prealloc! 13 | with-σ-∆s/prealloc! 14 | grow-vector ;; helper 15 | next-loc contour-table 16 | with-prealloc/timestamp-store 17 | with-prealloc/timestamp-store/stacked) 18 | 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | ;; Mutable pre-allocated store 21 | (define next-loc #f) 22 | (define contour-table #f) 23 | 24 | (define nothing-proxy nothing) 25 | (define (inc-next-loc!) (set! next-loc (add1 next-loc))) 26 | 27 | (define (grow-vector σ old-size) 28 | (for/vector #:length (* 2 old-size) #:fill nothing-proxy ;; ∅ → '() 29 | ([v (in-vector σ)] 30 | [i (in-naturals)] 31 | #:when (< i old-size)) 32 | v)) 33 | (define (ensure-σ-size) 34 | (when (= next-loc (vector-length global-σ)) 35 | (set-global-σ! (grow-vector global-σ next-loc)))) 36 | 37 | (define-syntax-rule (get-contour-index!-0 c) 38 | (or (hash-ref contour-table c #f) 39 | (begin0 next-loc 40 | (ensure-σ-size) 41 | (hash-set! contour-table c next-loc) 42 | (inc-next-loc!)))) 43 | 44 | (define-syntax-rule (make-var-contour-0-prealloc x δ) 45 | (cond [(exact-nonnegative-integer? x) x] 46 | [else (get-contour-index!-0 x)])) 47 | 48 | (define (prepare-prealloc-base parser sexp) 49 | (define nlabels 0) 50 | (define (fresh-label!) (begin0 nlabels (set! nlabels (add1 nlabels)))) 51 | (define (fresh-variable! x) (begin0 nlabels (set! nlabels (add1 nlabels)))) 52 | (define-values (e renaming) (parser sexp fresh-label! fresh-variable!)) 53 | (define e* (add-lib e renaming fresh-label! fresh-variable!)) 54 | ;; Start with a constant factor larger store since we are likely to 55 | ;; allocate some composite data. This way we don't incur a reallocation 56 | ;; right up front. 57 | (set! next-loc nlabels) 58 | (set! contour-table (make-hash)) 59 | (reset-globals! (make-vector (* 2 nlabels) nothing-proxy)) 60 | e*) 61 | (define (prepare-prealloc parser sexp) 62 | (set! nothing-proxy nothing) 63 | (prepare-prealloc-base parser sexp)) 64 | (define (prepare-prealloc/stacked parser sexp) 65 | (set! nothing-proxy '()) 66 | (prepare-prealloc-base parser sexp)) 67 | 68 | (mk-global-store-getter global-vector-getter vector-ref-ignore-third) 69 | 70 | (define-syntax-rule (with-0-ctx/prealloc body) 71 | (splicing-syntax-parameterize 72 | ([bind (make-rename-transformer #'bind-0)] 73 | [bind-rest (make-rename-transformer #'bind-rest-0)] 74 | [make-var-contour (make-rename-transformer #'make-var-contour-0-prealloc)]) 75 | body)) 76 | 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | ;; Timestamp approximation 79 | (mk-joiner join! vector-ref-ignore-third vector-set!) 80 | (mk-join* join*! join!) 81 | (mk-bind-joiner bind-join! join!) 82 | (mk-bind-joiner bind-join*! join*!) 83 | 84 | (mk-mk-imperative/timestamp^-fixpoint 85 | mk-prealloc/timestamp^-fixpoint restrict-to-reachable/vector (void)) 86 | 87 | (mk-with-store with-prealloc/timestamp-store 88 | bind-join! 89 | bind-join*! 90 | global-vector-getter) 91 | 92 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 93 | ;; Lossless timestamp approximation 94 | (mk-global-store-getter/stacked global-vector-getter/stacked vector-ref-ignore-third) 95 | (mk-joiner/stacked join/stacked! vector-ref-ignore-third vector-set!) 96 | (mk-join* join*/stacked! join/stacked!) 97 | (mk-bind-joiner bind-join/stacked! join/stacked!) 98 | (mk-bind-joiner bind-join*/stacked! join*/stacked!) 99 | 100 | (define (restrict-to-reachable/vector/stacked touches) 101 | (define rtr (restrict-to-reachable touches)) 102 | (λ (σ v) 103 | (rtr 104 | (for/hash ([stack (in-vector σ)] 105 | [i (in-naturals)]) 106 | (match stack 107 | [(cons (cons t vs) stack) 108 | (values i vs)] 109 | [_ (values i ∅)])) 110 | v))) 111 | 112 | (mk-mk-imperative/timestamp^-fixpoint 113 | mk-prealloc/timestamp^-fixpoint/stacked restrict-to-reachable/vector/stacked (reset-∆?!)) 114 | 115 | (mk-with-store with-prealloc/timestamp-store/stacked 116 | bind-join/stacked! 117 | bind-join*/stacked! 118 | global-vector-getter/stacked) 119 | 120 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 121 | ;; Accumulated deltas 122 | (define-syntax-rule (vector-ref-ignore-third v a ignore) (vector-ref v a)) 123 | 124 | (mk-add-∆/s add-∆/acc/prealloc add-∆s/acc/prealloc bind-join/∆s/acc/prealloc bind-join*/∆s/acc/prealloc 125 | vector-ref-ignore-third) 126 | 127 | (define-syntax-rule (with-σ-∆s/acc/prealloc! body) 128 | (with-σ-∆s/acc! 129 | (splicing-syntax-parameterize 130 | ([bind-join (make-rename-transformer #'bind-join/∆s/acc/prealloc)] 131 | [bind-join* (make-rename-transformer #'bind-join*/∆s/acc/prealloc)] 132 | [getter (make-rename-transformer #'global-vector-getter)]) 133 | body))) 134 | (mk-mk-imperative/∆s/acc^-fixpoint 135 | mk-prealloc/∆s/acc^-fixpoint restrict-to-reachable/vector join! vector-set! vector-ref-ignore-third) 136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 137 | ;; Imperative deltas 138 | (mk-add-∆/s! add-∆/prealloc! add-∆s/prealloc! bind-join/∆s/prealloc bind-join*/∆s/prealloc 139 | vector-ref-ignore-third) 140 | 141 | (define-syntax-rule (with-σ-∆s/prealloc! body) 142 | (with-σ-∆s! 143 | (splicing-syntax-parameterize 144 | ([bind-join (make-rename-transformer #'bind-join/∆s/prealloc)] 145 | [bind-join* (make-rename-transformer #'bind-join*/∆s/prealloc)] 146 | [getter (make-rename-transformer #'global-vector-getter)]) 147 | body))) 148 | (mk-mk-imperative/∆s^-fixpoint 149 | mk-prealloc/∆s^-fixpoint restrict-to-reachable/vector join! vector-set! vector-ref-ignore-third) 150 | -------------------------------------------------------------------------------- /code/racket-to-sexp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide rkt->sexp sch->sexp 4 | expand-sexp-expr 5 | expand-sexp-prog) 6 | 7 | ;; expect top level forms 8 | (define (sch->sexp file) 9 | (top-level->sexp 10 | (parameterize ([current-namespace (make-base-namespace)]) 11 | (with-input-from-file file 12 | (lambda () (for/list ([form (in-port read-syntax)]) 13 | (syntax->datum (expand form)))))))) 14 | ;; expect a #lang and module stuff. 15 | (define (rkt->sexp file) 16 | (match (syntax->datum 17 | (parameterize ([read-accept-reader #t] ;; #lang ok 18 | [current-namespace (make-base-namespace)]) 19 | (expand (with-input-from-file file read-syntax)))) 20 | [`(module ,name ,path (#%module-begin ,forms ...)) 21 | ;; ignore provide/require forms 22 | (top-level->sexp (filter (match-lambda [(or `(#%provide . ,rest) 23 | `(#%require . ,rest)) #f] 24 | [_ #t]) 25 | forms))])) 26 | 27 | (define (expand-sexp sexp) 28 | (syntax->datum (expand (datum->syntax #f sexp)))) 29 | (define (expand-sexp-expr sexp) 30 | (parameterize ([current-namespace (make-base-namespace)]) 31 | (expr->sexp (expand-sexp sexp)))) 32 | (define (expand-sexp-prog sexp) 33 | (parameterize ([current-namespace (make-base-namespace)]) 34 | (define-values (defs expr) (split-at-right (map expand-sexp sexp) 1)) 35 | (append (map define-values->sexp defs) 36 | (map expr->sexp expr)))) 37 | 38 | (define (top-level->sexp forms) 39 | (define-values (defs exps) 40 | (split-at-right forms 1)) 41 | (append (for/list ([def defs]) (define-values->sexp def)) 42 | (list (expr->sexp (car exps))))) 43 | 44 | (define (define-values->sexp sexp) 45 | (match sexp 46 | [`(define-values (,id) ,body) 47 | `(define ,id ,(expr->sexp body))] 48 | [_ (error 'define-values->sexp "Bad define ~a" sexp)])) 49 | 50 | (define (expr->sexp sexp) 51 | (match sexp 52 | [`(let-values ([(,ids) ,es] ...) ,body ...) 53 | `(let ,(for/list ([id ids] [e es]) `[,id ,(expr->sexp e)]) 54 | ,(expr->sexp `(begin . ,body)))] 55 | [`(begin ,e) (expr->sexp e)] 56 | [`(begin ,e . ,es) 57 | `((lambda (,(gensym '_)) ,(expr->sexp `(begin ,@es))) ,(expr->sexp e))] 58 | [`(letrec-values ([(,ids) ,es] ...) ,body) 59 | `(letrec ,(for/list ([id ids] [e es]) `[,id ,(expr->sexp e)]) 60 | ,(expr->sexp body))] 61 | [`(if ,g ,t ,e) 62 | `(if ,(expr->sexp g) ,(expr->sexp t) ,(expr->sexp e))] 63 | [`(set! ,x ,e) `(set! ,x ,(expr->sexp e))] 64 | [(or `(#%plain-app ,es ...) 65 | `(#%app ,es ...)) 66 | (map expr->sexp es)] 67 | [(or `(#%plain-lambda (,xs ...) ,body ...) 68 | `(lambda (,xs ...) ,body ...)) 69 | `(lambda ,xs ,(expr->sexp `(begin . ,body)))] 70 | [`(quote ,d) sexp] 71 | [(? symbol? x) x] 72 | [`(#%top . ,(? symbol? x)) x] 73 | [_ (error 'expr->sexp "Bad or unsupported form ~a" sexp)])) 74 | -------------------------------------------------------------------------------- /code/run-benchmark.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "parse.rkt" "kcfa-instantiations.rkt" "LK-instantiations.rkt" 3 | "handle-limits.rkt" 4 | racket/sandbox) 5 | (provide test aval prep) 6 | 7 | (define (sch->sexp file) 8 | (with-input-from-file file 9 | (λ () (for/list ([form (in-port read)]) form)))) 10 | ;; Used to be different 11 | (define prep sch->sexp) 12 | 13 | (define-syntax-rule (log-thread kind) 14 | (let ([lr (make-log-receiver (current-logger) kind)]) 15 | (thread (λ () (let loop () (define vs (sync lr)) (write vs) (newline) (loop)))))) 16 | 17 | (define (print-values . vs) (for ([v vs]) (display v) (newline))) 18 | 19 | (define aval (make-parameter #f)) 20 | 21 | (define (test e) 22 | (parameterize ([current-logger (make-logger 'stuck-states)]) 23 | #;#; 24 | (log-thread 'info) 25 | (log-thread 'debug) 26 | ;; we want to make sure that we are testing the implementation and not 27 | ;; Racket's startup cost. 28 | (collect-garbage) 29 | (collect-garbage) 30 | (collect-garbage) 31 | (with-limit-handler ;; Prints state rate even if timeout/oom 32 | (with-limits (* 30 #;run-for-30-minutes 33 | 60 #;seconds-in-minutes) 34 | 1024 ;; Max memory: 1GiB 35 | (call-with-values (λ () 36 | (begin0 (time ((aval) e)) 37 | (void) 38 | (dump-memory-stats) 39 | (flush-output) 40 | (printf "Result: Complete~%"))) 41 | ;; Fixpoints return their results and strings with 42 | ;; statistics in them. Print it all. 43 | print-values))))) 44 | 45 | (module+ main 46 | (require racket/cmdline) 47 | (define test-file 48 | (command-line #:once-any 49 | #; [("--bl") "Benchmark baseline" 50 | (aval baseline)] ;; least optimized 51 | [("--sp") "Benchmark specialized fixpoint" 52 | (aval 0cfa^)] 53 | [("--spt") "Benchmark specialized fixpoint with timestamps" 54 | (aval 0cfa^/t)] 55 | [("--sdt") "Benchmark specialized fixpoint with timestamps and store deltas" 56 | (aval 0cfa^-∆s/t)] 57 | [("--ls") "Benchmark specialized lazy non-determinism" 58 | (aval lazy-0cfa^)] 59 | [("--lst") "Benchmark specialized lazy non-determinism with timestamps" 60 | (aval lazy-0cfa^-∆s/t)] 61 | [("--lc") "Benchmark compiled specialized lazy non-determinism" 62 | (aval lazy-0cfa^/c)] 63 | [("--lct") "Benchmark compiled specialized lazy non-determinism with timestamps" 64 | (aval lazy-0cfa^-∆s/t/c)] 65 | [("--ld") 66 | "Benchmark compiled store-diff lazy non-determinism" 67 | (aval lazy-0cfa^/c/∆s)] 68 | #; [("--fd") 69 | "Benchmark compiled store-diff lazy non-determinism functional timestamp nonapprox" 70 | (aval lazy-0cfa^/c/∆s/t)] 71 | #; [("--ia") 72 | "Benchmark compiled imperative accumulated store-diff lazy non-determinism" 73 | (aval lazy-0cfa^/c/∆s/acc!)] 74 | #; [("--id") 75 | "Benchmark compiled imperative store-diff lazy non-determinism" 76 | (aval lazy-0cfa^/c/∆s!)] 77 | #; [("--is") 78 | "Benchmark compiled imperative stacked store lazy non-determinism" 79 | (aval lazy-0cfa^/c/∆s/stacked!)] 80 | #; [("--pa") 81 | "Benchmark compiled preallocated accumulated store-diff lazy non-determinism" 82 | (aval lazy-0cfa^/c/∆s/acc/prealloc!)] 83 | #; [("--pd") 84 | "Benchmark compiled preallocated store-diff lazy non-determinism" 85 | (aval lazy-0cfa^/c/∆s/prealloc!)] 86 | [("--ps") 87 | "Benchmark compiled preallocated stacked store lazy non-determinism" 88 | (aval lazy-0cfa^/c/∆s/prealloc/stacked!)] 89 | #; [("--it") 90 | "Benchmark compiled imperative store lazy non-determinism timestap approx" 91 | (aval lazy-0cfa^/c/timestamp!)] 92 | #; [("--pt") 93 | "Benchmark compiled preallocated store lazy non-determinism timestamp approx" 94 | (aval lazy-0cfa^/c/prealloc/timestamp!)] ;; most optimized 95 | ;; Continuation-mark enabled analyses 96 | #; [("--cb") 97 | "Benchmark baseline continuation marks" 98 | (aval baseline/cm)] 99 | ;; Lazy language analysis 100 | [("--kb") 101 | "Benchmark baseline lazy-Krivine machine" 102 | (aval LK-baseline)] 103 | [("--kp") 104 | "Benchmark best lazy-Krivine machine" 105 | (aval LK-lazy-0cfa^/c/∆s/prealloc!)] 106 | ;; Not benchmarked for paper 107 | #| 108 | [("--ls2") "Benchmark specialized2 lazy non-determinism" 109 | (aval lazy-0cfa^2)] 110 | [("--ls3") "Benchmark specialized3 lazy non-determinism" 111 | (aval lazy-0cfa^3)] 112 | [("--lazy-0cfa") 113 | "Benchmark specialized narrow lazy non-determinism" 114 | (aval lazy-0cfa)] 115 | [("--lazy-0cfa/c") 116 | "Benchmark specialized compiled narrow lazy non-determinism" 117 | (aval lazy-0cfa/c)] 118 | [("--lazy-0cfa-gen^/c") 119 | "Benchmark compiled generators lazy non-determinism" 120 | (aval lazy-0cfa-gen^/c)] 121 | [("--lazy-0cfa^-gen-σ-∆s") 122 | "Benchmark store-diff generators lazy non-determinism" 123 | (aval lazy-0cfa-gen-σ-∆s^)] 124 | [("--lazy-0cfa-gen-σ-∆s^/c") 125 | "Benchmark compiled store-diff generators lazy non-determinism" 126 | (aval lazy-0cfa-gen-σ-∆s^/c)] 127 | [("--lazy-0cfa^/prealloc!") 128 | "Benchmark preallocated store lazy non-determinism" 129 | (aval lazy-0cfa^/prealloc!)] 130 | |# 131 | #:args (filename) 132 | filename)) 133 | (test (prep test-file))) -------------------------------------------------------------------------------- /paper/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *clean 3 | *aux 4 | *log 5 | *blg 6 | *space.pdf 7 | *speed.pdf 8 | *time.pdf 9 | introspective*pdf 10 | compiled/ 11 | -------------------------------------------------------------------------------- /paper/Makefile: -------------------------------------------------------------------------------- 1 | CURRENT=icfp105-johnson 2 | 3 | WGETDVANHORNBIB=curl -o dvanhorn.bib "http://www.citeulike.org/bibtex/user/dvanhorn?fieldmap=posted-at:date-added&do_username_prefix=1&key_type=4&fieldmap=url:x-url&fieldmap=doi:x-doi&fieldmap=address:x-address&fieldmap=isbn:x-isbn&fieldmap=issn:x-issn&fieldmap=month:x-month&fieldmap=comment:comment&fieldmap=booktitle:booktitle&fieldmap=abstract:x-abstract&fieldmap=pages:pages&volume:volume" 4 | 5 | WGETIANJBIB=curl -o ianj.bib "http://www.citeulike.org/bibtex/user/ianjohnson?fieldmap=posted-at:date-added&do_username_prefix=1&key_type=4&fieldmap=url:x-url&fieldmap=doi:x-doi&fieldmap=address:x-address&fieldmap=isbn:x-isbn&fieldmap=issn:x-issn&fieldmap=month:x-month&fieldmap=comment:comment&fieldmap=booktitle:booktitle&fieldmap=abstract:x-abstract&fieldmap=pages:pages&volume:volume" 6 | 7 | default: introspective-base.pdf introspective-lazy.pdf introspective-lazyc.pdf \ 8 | church-relative-space.pdf church-relative-time.pdf church-relative-speed.pdf \ 9 | all-relative-space.pdf all-relative-speed.pdf all-relative-time.pdf \ 10 | bench-overview.tex 11 | pdflatex $(CURRENT) 12 | 13 | refresh: getbib 14 | 15 | getbib: 16 | $(WGETDVANHORNBIB) 17 | $(WGETIANJBIB) 18 | -bibclean dvanhorn.bib > dvh-bibliography.bib.clean 19 | -bibclean ianj.bib > ianj.bib.clean 20 | cat ianj.bib.clean dvh-bibliography.bib.clean > bibliography.bib 21 | 22 | bibtex: 23 | bibtex $(CURRENT) 24 | 25 | %.dvi: %.tex 26 | latex $(basename $@) 27 | 28 | %.dot: 29 | racket ../code/mk-graph.rkt 30 | 31 | all-relative-space.pdf: vis-bench.rkt 32 | racket vis-bench.rkt 33 | 34 | all-relative-speed.pdf: vis-bench.rkt 35 | racket vis-bench.rkt 36 | 37 | all-relative-time.pdf: vis-bench.rkt 38 | racket vis-bench.rkt 39 | 40 | introspective-base.pdf: introspective-base.dot 41 | dot -Tpdf introspective-base.dot -o introspective-base.pdf 42 | 43 | introspective-lazy.pdf: introspective-lazy.dot 44 | dot -Tpdf introspective-lazy.dot -o introspective-lazy.pdf 45 | 46 | introspective-lazyc.pdf: introspective-lazyc.dot 47 | dot -Tpdf introspective-lazyc.dot -o introspective-lazyc.pdf 48 | 49 | church-relative-speed.pdf: vardoulakis-shivers-numbers.rkt 50 | racket vardoulakis-shivers-numbers.rkt 51 | 52 | church-relative-time.pdf: vardoulakis-shivers-numbers.rkt 53 | racket vardoulakis-shivers-numbers.rkt 54 | 55 | church-relative-space.pdf: vardoulakis-shivers-numbers.rkt 56 | racket vardoulakis-shivers-numbers.rkt 57 | 58 | all-relative-speed.ps: vis-bench.rkt 59 | racket vis-bench.rkt 60 | 61 | all-relative-time.ps: vis-bench.rkt 62 | racket vis-bench.rkt 63 | racket vardoulakis-shivers-numbers.rkt 64 | 65 | all-relative-space.ps: vis-bench.rkt 66 | racket vis-bench.rkt 67 | 68 | bench-overview.tex: 69 | racket bench-overview.rkt 70 | 71 | #%.pdf: %.dvi 72 | # dvipdfm -o $(basename $@).pdf $(basename $@).dvi 73 | 74 | response-pldi13.txt: 75 | openssl base64 -d -aes-256-cbc -in response-pldi13.out -out response-pldi13.txt 76 | 77 | response-pldi13.out: 78 | openssl base64 -aes-256-cbc -salt -in response-pldi13.txt -out response-pldi13.out 79 | 80 | reviews-pldi13.txt: 81 | openssl base64 -d -aes-256-cbc -in reviews-pldi13.out -out reviews-pldi13.txt 82 | 83 | reviews-pldi13.out: 84 | openssl base64 -aes-256-cbc -salt -in reviews-pldi13.txt -out reviews-pldi13.out 85 | 86 | reviews-icfp13.txt: 87 | openssl base64 -d -aes-256-cbc -in reviews-icfp13.out -out reviews-icfp13.txt 88 | 89 | reviews-icfp13.out: 90 | openssl base64 -aes-256-cbc -salt -in reviews-icfp13.txt -out reviews-icfp13.out 91 | 92 | 93 | flush: clean 94 | rm -f dvanhorn.bib 95 | 96 | clean: 97 | rm -f $(CURRENT).{dvi,ps,pdf,log,toc,blg,bbl,aux,rel} *.log *~ *.out reviews.txt 98 | 99 | 100 | -------------------------------------------------------------------------------- /paper/bench-overview.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;; Generate numbers tabular (Program, LOC, Time (ms), Space (mb), Speed (states/sec) 4 | (require (submod "../code/drive-benchmarks.rkt" data) "proctime.rkt") 5 | 6 | (define (file->name s) 7 | (define path (string->path s)) 8 | (define-values (base filename dir?) (split-path path)) 9 | (path->string (path-replace-suffix filename ""))) 10 | (define (loc f) 11 | (with-input-from-file f 12 | (λ () 13 | (for/sum ([l (in-port read-line)]) 1)))) 14 | (define (entry name fn conv n) 15 | (match (average (fn n)) 16 | [#f (cond [(vector-ref (numbers-timeout? n) 0) 17 | "\\text{{\\small $t$}}"] 18 | [(vector-ref (numbers-exhaust? n) 0) 19 | "\\text{{\\small $m$}}"] 20 | [else (error 'bench-overview "No numbers, timeout or oom!: ~a" name)])] 21 | [n (conv n)])) 22 | 23 | (define (byte->mib b) (/ b (* 1024 1024))) 24 | (define (nfigs n) 25 | (compose number->string 26 | (cond [(zero? n) (compose inexact->exact round)] 27 | [else 28 | (define factor (expt 10 n)) 29 | (λ (x) 30 | (if (integer? x) 31 | x 32 | (exact->inexact (/ (round (* factor x)) factor))))]))) 33 | 34 | (define ((suffixed-number figs) n) 35 | (define num-zeros (truncate (/ (log n) (log 10)))) 36 | (define (order k suff) 37 | (and (>= num-zeros k) 38 | (format "~a~a" ((nfigs figs) (/ n (expt 10 k))) suff))) 39 | (or (order 9 "G") 40 | (order 6 "M") 41 | (order 3 "K") 42 | ((nfigs figs) n))) 43 | 44 | 45 | (define files (list nucleic matrix nbody earley maze church lattice boyer mbrotZ)) 46 | (define comparisons (list numbers-run numbers-peak-mem numbers-state-rate)) 47 | (define conversions (list (compose (suffixed-number 1) (λ (x) (/ x 1000))) 48 | (compose (nfigs 0) byte->mib) 49 | (suffixed-number 0))) 50 | (define algos (list "sp" "ps")) 51 | 52 | (define-syntax-rule (for/append guards body ...) 53 | (for/fold ([acc '()]) guards (let ([r (let () body ...)]) (append acc r)))) 54 | 55 | (with-output-to-file "bench-overview.tex" #:mode 'text #:exists 'replace 56 | (λ () 57 | (printf "\\begin{tabular}{@{}l||r||r|r||r|r||r|r@{}}~%") 58 | (printf "Program & LOC~%") 59 | (printf "& \\multicolumn{2}{c||}{Time {\\small (sec)}}~%") 60 | (printf "& \\multicolumn{2}{c||}{Space {\\small (MB)}}~%") 61 | (printf "& \\multicolumn{2}{c@{}}{Speed {\\small $\\frac{state}{sec}$}}~%") 62 | (printf "\\\\~%") 63 | (printf "\\hline\\hline~%") 64 | (printf 65 | (string-join 66 | (for/list ([file files]) 67 | (define name (file->name file)) 68 | (define numbers (hash-ref timings name)) 69 | (format "~a & ~a & ~a" 70 | name 71 | (loc file) 72 | (string-join 73 | (for/append ([fn comparisons] 74 | [conversion conversions]) 75 | (for/list ([algo algos]) 76 | (entry `(,name ,algo) fn conversion (hash-ref numbers algo)))) 77 | " & "))) 78 | " \\\\~%")) 79 | (printf "~%\\end{tabular}~%"))) -------------------------------------------------------------------------------- /paper/bench-overview.tex: -------------------------------------------------------------------------------- 1 | \begin{tabular}{@{}l||r||r|r||r|r||r|r@{}} 2 | Program & LOC 3 | & \multicolumn{2}{c||}{Time {\small (sec)}} 4 | & \multicolumn{2}{c||}{Space {\small (MB)}} 5 | & \multicolumn{2}{c@{}}{Speed {\small $\frac{state}{sec}$}} 6 | \\ 7 | \hline\hline 8 | nucleic & 3492 & \text{{\small $m$}} & 66.9 & \text{{\small $m$}} & 238 & 44 & 9K \\ 9 | matrix & 747 & \text{{\small $t$}} & 3.4 & 294 & 114 & 68 & 87K \\ 10 | nbody & 1435 & \text{{\small $t$}} & 22.9 & 361 & 171 & 67 & 57K \\ 11 | earley & 667 & 1.1K & 0.4 & 409 & 114 & 252 & 95K \\ 12 | maze & 681 & \text{{\small $t$}} & 2.6 & 332 & 114 & 55 & 118K \\ 13 | church & 42 & 44.9 & 0.1 & 86 & 114 & 714 & 56K \\ 14 | lattice & 214 & 348.5 & 0.2 & 231 & 114 & 382 & 104K \\ 15 | boyer & 642 & \text{{\small $m$}} & 13.4 & \text{{\small $m$}} & 130 & 39 & 39K \\ 16 | mbrotZ & 69 & 373.6 & 0.1 & 295 & 114 & 540 & 63K 17 | \end{tabular} 18 | -------------------------------------------------------------------------------- /paper/data.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide (all-defined-out)) 3 | (define start-run 4) 4 | (define end-run 8) 5 | (define algos '("bl" "sp" "ls" "lc" "ld" "li" "lp")) 6 | (define names '("church" "mbrotZ" "earley" "boyer" "graphs" 7 | "lattice" "matrix" "maze" "nbody" "nucleic")) 8 | -------------------------------------------------------------------------------- /paper/fanout.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dvanhorn/oaam/79bc68ecb79fef45474a948deec1de90d255f307/paper/fanout.pdf -------------------------------------------------------------------------------- /paper/fanoutdot2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dvanhorn/oaam/79bc68ecb79fef45474a948deec1de90d255f307/paper/fanoutdot2.pdf -------------------------------------------------------------------------------- /paper/icfp105-johnson.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dvanhorn/oaam/79bc68ecb79fef45474a948deec1de90d255f307/paper/icfp105-johnson.pdf -------------------------------------------------------------------------------- /paper/introspective-lazyc.dot: -------------------------------------------------------------------------------- 1 | digraph Foo { 2 | n173 [label = "", style = filled, fillcolor = white]; 3 | n161 [label = "", style = filled, fillcolor = white]; 4 | n172 [label = "", style = filled, fillcolor = gray]; 5 | n155 [label = "", style = filled, fillcolor = white]; 6 | n170 [label = "", style = filled, fillcolor = white]; 7 | n164 [label = "", style = filled, fillcolor = gray]; 8 | n177 [label = "", style = filled, fillcolor = white]; 9 | n117 [label = "", style = filled, fillcolor = gray]; 10 | n119 [label = "", style = filled, fillcolor = white]; 11 | n149 [label = "", style = filled, fillcolor = white]; 12 | n114 [label = "", style = filled, fillcolor = gray]; 13 | n137 [label = "", style = filled, fillcolor = white]; 14 | n139 [label = "", style = filled, fillcolor = gray]; 15 | n135 [label = "", style = filled, fillcolor = white]; 16 | n122 [label = "", style = filled, fillcolor = white]; 17 | n131 [label = "", style = filled, fillcolor = white]; 18 | n142 [label = "", style = filled, fillcolor = white]; 19 | n175 [label = "", style = filled, fillcolor = white]; 20 | n176 [label = "", style = filled, fillcolor = gray]; 21 | n115 [label = "", style = filled, fillcolor = gray]; 22 | n147 [label = "", style = filled, fillcolor = white]; 23 | n154 [label = "", style = filled, fillcolor = white]; 24 | n126 [label = "", style = filled, fillcolor = white]; 25 | n165 [label = "", style = filled, fillcolor = gray]; 26 | n151 [label = "", style = filled, fillcolor = white]; 27 | n132 [label = "", style = filled, fillcolor = white]; 28 | n174 [label = "", style = filled, fillcolor = white]; 29 | n166 [label = "", style = filled, fillcolor = white]; 30 | n145 [label = "", style = filled, fillcolor = gray]; 31 | n167 [label = "", style = filled, fillcolor = white]; 32 | n171 [label = "", style = filled, fillcolor = white]; 33 | n133 [label = "", style = filled, fillcolor = white]; 34 | n168 [label = "", style = filled, fillcolor = white]; 35 | n143 [label = "", style = filled, fillcolor = white]; 36 | n157 [label = "", style = filled, fillcolor = white]; 37 | n124 [label = "", style = filled, fillcolor = white]; 38 | n163 [label = "", style = filled, fillcolor = gray]; 39 | n138 [label = "", style = filled, fillcolor = white]; 40 | n162 [label = "", style = filled, fillcolor = white]; 41 | n160 [label = "", style = filled, fillcolor = gray]; 42 | n158 [label = "", style = filled, fillcolor = white]; 43 | n156 [label = "", style = filled, fillcolor = gray]; 44 | n153 [label = "", style = filled, fillcolor = white]; 45 | n121 [label = "", style = filled, fillcolor = white]; 46 | n152 [label = "", style = filled, fillcolor = white]; 47 | n148 [label = "", style = filled, fillcolor = white]; 48 | n146 [label = "", style = filled, fillcolor = white]; 49 | n130 [label = "", style = filled, fillcolor = white]; 50 | n150 [label = "", style = filled, fillcolor = white]; 51 | n144 [label = "", style = filled, fillcolor = gray]; 52 | n141 [label = "", style = filled, fillcolor = white]; 53 | n140 [label = "", style = filled, fillcolor = white]; 54 | n159 [label = "", style = filled, fillcolor = gray]; 55 | n136 [label = "", style = filled, fillcolor = white]; 56 | n134 [label = "", style = filled, fillcolor = gray]; 57 | n129 [label = "", style = filled, fillcolor = white]; 58 | n169 [label = "", style = filled, fillcolor = white]; 59 | n116 [label = "", style = filled, fillcolor = white]; 60 | n128 [label = "", style = filled, fillcolor = white]; 61 | n127 [label = "", style = filled, fillcolor = white]; 62 | n125 [label = "", style = filled, fillcolor = white]; 63 | n123 [label = "", style = filled, fillcolor = white]; 64 | n120 [label = "", style = filled, fillcolor = white]; 65 | n118 [label = "", style = filled, fillcolor = white]; 66 | n114 -> n115 ; 67 | n118 -> n119 ; 68 | n116 -> n117 ; 69 | n115 -> n171 ; 70 | n117 -> n156 ; 71 | n121 -> n154 ; 72 | n120 -> n122 ; 73 | n120 -> n121 ; 74 | n122 -> n136 ; 75 | n122 -> n173 ; 76 | n119 -> n114 ; 77 | n125 -> n126 ; 78 | n123 -> n124 ; 79 | n124 -> n117 ; 80 | n126 -> n137 ; 81 | n128 -> n130 ; 82 | n128 -> n129 ; 83 | n127 -> n120 ; 84 | n129 -> n128 ; 85 | n130 -> n126 ; 86 | n134 -> n135 ; 87 | n131 -> n133 ; 88 | n131 -> n132 ; 89 | n132 -> n139 ; 90 | n133 -> n134 ; 91 | n138 -> n138 ; 92 | n136 -> n137 ; 93 | n135 -> n141 ; 94 | n137 -> n140 ; 95 | n141 -> n142 ; 96 | n141 -> n143 ; 97 | n140 -> n138 ; 98 | n142 -> n116 ; 99 | n142 -> n136 ; 100 | n142 -> n162 ; 101 | n139 -> n127 ; 102 | n146 -> n147 ; 103 | n144 -> n145 ; 104 | n143 -> n167 ; 105 | n145 -> n158 ; 106 | n150 -> n151 ; 107 | n148 -> n149 ; 108 | n149 -> n118 ; 109 | n147 -> n123 ; 110 | n147 -> n125 ; 111 | n147 -> n146 ; 112 | n153 -> n155 ; 113 | n152 -> n153 ; 114 | n151 -> n176 ; 115 | n154 -> n177 ; 116 | n158 -> n159 ; 117 | n156 -> n157 ; 118 | n157 -> n165 ; 119 | n155 -> n133 ; 120 | n162 -> n123 ; 121 | n162 -> n125 ; 122 | n162 -> n146 ; 123 | n160 -> n161 ; 124 | n159 -> n152 ; 125 | n161 -> n174 ; 126 | n164 -> n150 ; 127 | n163 -> n164 ; 128 | n165 -> n166 ; 129 | n166 -> n131 ; 130 | n169 -> n170 ; 131 | n168 -> n160 ; 132 | n167 -> n144 ; 133 | n170 -> n133 ; 134 | n174 -> n175 ; 135 | n171 -> n172 ; 136 | n172 -> n169 ; 137 | n173 -> n130 ; 138 | n173 -> n129 ; 139 | n177 -> n163 ; 140 | n176 -> n168 ; 141 | n175 -> n132 ; 142 | 143 | } -------------------------------------------------------------------------------- /paper/lazy.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dvanhorn/oaam/79bc68ecb79fef45474a948deec1de90d255f307/paper/lazy.pdf -------------------------------------------------------------------------------- /paper/lazydot.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dvanhorn/oaam/79bc68ecb79fef45474a948deec1de90d255f307/paper/lazydot.pdf -------------------------------------------------------------------------------- /paper/local.bib: -------------------------------------------------------------------------------- 1 | @techreport{local:DOsualdo:12B, 2 | author = {E. D'Osualdo and J. Kochems and C.-H. L. Ong}, 3 | title = {Soter: An Automatic Safety Verifier for {E}rlang}, 4 | institution = {University of Oxford DCS Technical Report}, 5 | note = {\url{http://mjolnir.cs.ox.ac.uk/soter/papers/soter-demo.pdf}}, 6 | year = 2012, 7 | } 8 | 9 | @techreport{local:DOsualdo:12A, 10 | author = {E. D'Osualdo and J. Kochems and C.-H. L. Ong}, 11 | title = {Automatic Verification of {Erlang}-Style Concurrency}, 12 | institution = {University of Oxford DCS Technical Report}, 13 | note = {\url{http://mjolnir.cs.ox.ac.uk/soter/papers/erlang-verif.pdf}}, 14 | year = 2012, 15 | } 16 | 17 | @article{local:DBLP:journals/corr/abs-1109-4467, 18 | author = {David Van{ }Horn and 19 | Matthew Might}, 20 | title = {An Analytic Framework for {JavaScript}}, 21 | journal = {CoRR}, 22 | volume = {abs/1109.4467}, 23 | year = {2011}, 24 | ee = {http://arxiv.org/abs/1109.4467}, 25 | bibsource = {DBLP, http://dblp.uni-trier.de} 26 | } 27 | 28 | @misc{local:harvard, 29 | author = {Greg Morrisett}, 30 | title = {Harvard University course CS252r: Advanced Functional Language Compilation}, 31 | note = {\url{http://www.eecs.harvard.edu/~greg/cs252rfa12/}} 32 | } 33 | 34 | @techreport{local:dalvik, 35 | author = {Matthew Might and David Van{ }Horn}, 36 | title = {Scalable and Precise Abstractions of Programs for Trustworthy Software}, 37 | year = {2012} 38 | } -------------------------------------------------------------------------------- /paper/pfsteps/Makefile: -------------------------------------------------------------------------------- 1 | PDFLATEX = pdflatex 2 | LATEX = latex 3 | MAKEINDEX = makeindex 4 | 5 | PKG = pfsteps 6 | 7 | all: $(PKG).sty $(PKG).pdf 8 | 9 | %.sty: %.ins %.dtx 10 | $(RM) $@ listproc.sty 11 | $(LATEX) $< 12 | 13 | $(PKG).pdf: $(PKG).sty $(PKG).ind $(PKG).gls 14 | 15 | %.pdf: %.dtx 16 | $(LATEX) $< 17 | $(PDFLATEX) $< 18 | 19 | %.idx %.glo: %.dtx %.sty 20 | $(LATEX) $< 21 | 22 | %.ind: %.idx 23 | $(MAKEINDEX) -s gind.ist $< 24 | 25 | %.gls: %.glo 26 | $(MAKEINDEX) -s gglo.ist -o $@ $< 27 | 28 | CLEAN = $(PKG).ind $(PKG).idx \ 29 | $(PKG).gls $(PKG).glo $(PKG).aux $(PKG).log \ 30 | $(PKG).out $(PKG).dvi $(PKG).ilg $(PKG).hd \ 31 | $(PKG).toc 32 | 33 | VCLEAN = $(CLEAN) $(PKG).pdf $(PKG).sty listproc.sty 34 | 35 | clean: 36 | $(RM) $(CLEAN) 37 | 38 | vclean: 39 | $(RM) $(VCLEAN) 40 | -------------------------------------------------------------------------------- /paper/pfsteps/pfsteps.ins: -------------------------------------------------------------------------------- 1 | %% File: pfsteps.ins 2 | %% Copyright 2011 Jesse A. Tov 3 | %% 4 | %% This is the pfsteps installation file for extracting package and driver 5 | %% files from the original source file. Simply process it with 6 | %% TeX or LaTeX. 7 | 8 | \input docstrip.tex 9 | \keepsilent 10 | 11 | \usedir{tex/latex/pfsteps} 12 | 13 | \preamble 14 | 15 | Copyright (C) 2011 by Jesse A. Tov 16 | 17 | This file may be distributed and/or modified under the conditions of the 18 | LaTeX Project Public License, either version 1.2 of this license or (at 19 | your option) any later version. The latest version of this license is 20 | in: 21 | 22 | http://www.latex-project.org/lppl.txt 23 | 24 | and version 1.2 or later is part of all distributions of LaTeX 25 | version 1999/12/01 or later. 26 | 27 | \endpreamble 28 | 29 | \generate{\file{pfsteps.sty}{\from{pfsteps.dtx}{package}} 30 | \file{listproc.sty}{\from{listproc.dtx}{package}}} 31 | 32 | \obeyspaces 33 | 34 | \Msg{*********************************************************} 35 | \Msg{* pfsteps.sty *} 36 | \Msg{* *} 37 | \Msg{* To produce the documentation run the file *} 38 | \Msg{* pfsteps.dtx through LaTeX. *} 39 | \Msg{* *} 40 | \Msg{*********************************************************} 41 | 42 | \endbatchfile 43 | -------------------------------------------------------------------------------- /paper/preamble.tex: -------------------------------------------------------------------------------- 1 | \newcommand\ie{\emph{i}.\emph{e}.} 2 | 3 | \newcommand{\superscript}[1]{\ensuremath{^{#1}}} 4 | \newcommand{\subscript}[1]{\ensuremath{_{#1}}} 5 | \newcommand{\tuple}[3][\ ]{{\tt #2}{#1}({#3})} 6 | 7 | % Values 8 | \newcommand{\clos}[1]{\tuple{clos}{#1}} 9 | \newcommand{\rlos}[1]{\tuple{rlos}{#1}} 10 | 11 | % States 12 | \newcommand{\evalone}{{\tt ev}} 13 | \newcommand{\apalone}{{\tt ap}} 14 | \newcommand{\ev}[2][\ ]{\tuple[#1]{ev}{#2}} 15 | \newcommand{\co}[2][\ ]{\tuple[#1]{co}{#2}} 16 | \newcommand{\ap}[2][\ ]{\tuple[#1]{ap}{#2}} 17 | \newcommand{\call}[2][\ ]{\tuple[#1]{call}{#2}} 18 | \newcommand{\ans}[1]{\tuple{ans}{#1}} 19 | 20 | % Continuations 21 | \newcommand{\kfnalone}{{\tt fun}} 22 | \newcommand{\kmt}{{\tt halt}} 23 | \newcommand{\kar}[2][\ ]{\tuple[#1]{arg}{#2}} 24 | \newcommand{\kfn}[2][\ ]{\tuple[#1]{fun}{#2}} 25 | \newcommand{\kif}[2][\ ]{\tuple[#1]{ifk}{#2}} 26 | \newcommand{\kuop}[2][\ ]{\tuple[#1]{oa}{#2}} 27 | \newcommand{\kbopa}[2][\ ]{\tuple[#1]{oa1}{#2}} 28 | \newcommand{\kbopb}[2][\ ]{\tuple[#1]{oa2}{#2}} 29 | 30 | % Implementation forms 31 | \newcommand{\generator}{{\tt generator}} 32 | \newcommand{\yield}[1]{{\tt yield} #1} 33 | 34 | % Syntax 35 | \newcommand{\syntax}[1]{{\tt #1}} 36 | \newcommand{\sapp}[3][\ ]{\tuple[#1]{app}{#2,#3}} 37 | \newcommand{\slam}[3][\ ]{\tuple[#1]{lam}{#2,#3}} 38 | \newcommand{\srec}[4][\ ]{\tuple[#1]{rec}{#2,#3,#4}} 39 | \newcommand{\svar}[2][\ ]{\tuple[#1]{var}{#2}} 40 | \newcommand{\snum}[2][\ ]{\tuple[#1]{num}{#2}} 41 | \newcommand{\sbln}[2][\ ]{\tuple[#1]{bool}{#2}} 42 | 43 | \newcommand{\saddr}[1]{\tuple{addr}{#1}} 44 | \newcommand{\superposition}[1]{\tuple{sp}{#1}} 45 | 46 | % Use delayed lookups or superposition, respectively. Paper has both 47 | % implementations using this macro, so we can switch between them 48 | % agilely if we need to. 49 | 50 | \newcommand{\spchoice}[2]{#1} 51 | 52 | \newcommand{\sif}[4][\ ]{\tuple[#1]{if}{#2,#3,#4}} 53 | \newcommand{\sop}[2][\ ]{\tuple[#1]{op}{#2}} 54 | \newcommand{\sopu}[3][\ ]{\tuple[#1]{op}{#2,#3}} 55 | \newcommand{\sopb}[4][\ ]{\tuple[#1]{op2}{#2,#3,#4}} 56 | \newcommand{\strue}{{\tt tt}} 57 | \newcommand{\sfalse}{{\tt ff}} 58 | \newcommand{\saddone}{{\tt add1}} 59 | \newcommand{\ssubone}{{\tt sub1}} 60 | \newcommand{\szerohuh}{\syntax{zero?}} 61 | \newcommand{\szero}{\syntax{0}} 62 | \newcommand{\slit}[2][\ ]{\tuple[#1]{lit}{#2}} 63 | 64 | \newcommand{\sNum}{\syntax{Z}} 65 | 66 | 67 | \newcommand{\ext}[3]{#1\sqcup[#2\mapsto#3]} 68 | %\newcommand{\ext}[3]{ext(#1,#2,#3)} 69 | 70 | 71 | 72 | % Metavariables 73 | \newcommand{\maddr}{a} 74 | \newcommand{\mkaddr}{a_\kappa} 75 | \newcommand{\maddralt}{b} 76 | \newcommand{\mvar}{x} 77 | \newcommand{\mvarf}{f} 78 | \newcommand{\mexp}{e} 79 | \newcommand{\mexpi}[1]{e_{#1}} 80 | \newcommand{\mexpf}{f} 81 | \newcommand{\menv}{\rho} 82 | \newcommand{\mkont}{\kappa} 83 | \newcommand{\msto}{\sigma} 84 | \newcommand{\mop}{o} 85 | \newcommand{\mval}{v} 86 | \newcommand{\mvalstack}{V} 87 | \newcommand{\mnum}{z} 88 | \newcommand{\mbln}{b} 89 | \newcommand{\mvalx}[1]{#1} 90 | \newcommand{\machstep}{\mathbin{\longmapsto}} 91 | \newcommand{\multimachstep}{\longmapsto\!\!\!\!\!\rightarrow} 92 | \newcommand{\mlit}{l} 93 | \newcommand{\mstate}{\varsigma} 94 | \newcommand{\mcomp}{k} 95 | \newcommand{\mcompi}[1]{\mcomp_{#1}} 96 | \newcommand{\interpdelta}{\Delta} 97 | \newcommand{\msdiff}{\xi} 98 | 99 | \newcommand{\mseen}{S} 100 | \newcommand{\mseentime}{\hat{S}} 101 | 102 | \newcommand{\compile}[1]{\llbracket#1\rrbracket} 103 | \newcommand{\kpush}[2][\ ]{\lfloor #2 \rfloor{#1}} 104 | 105 | \newcommand{\mlab}{{\ell}} 106 | \newcommand{\mcntr}{{t}} 107 | \newcommand{\mtcntr}{{t_0}} 108 | 109 | \newcommand{\mtlst}{\epsilon} 110 | \newcommand{\cons}[2]{#1 {\tt :} #2} 111 | \newcommand{\ttuple}[2]{(#1, #2)} % two-tuple 112 | \newcommand{\Set}{\mathcal{P}} 113 | 114 | \newcommand{\lift}{\mathit{lift}} 115 | \newcommand{\eval}{\mathit{eval}} 116 | \newcommand{\traces}{\mathit{traces}} 117 | \newcommand{\alloc}{\mathit{alloc}} 118 | \newcommand{\allockont}{\mathit{allockont}} 119 | \newcommand{\tick}{\mathit{tick}} 120 | \newcommand{\replay}{\mathit{replay}} 121 | \newcommand{\diffp}{\mathit{\delta?}} 122 | \newcommand{\states}{\mathit{cs}} 123 | \newcommand{\concat}{\mathit{concat}} 124 | \newcommand{\append}{\mathit{append}} 125 | \newcommand{\appendall}{\mathit{appendall}} 126 | \newcommand{\step}{\mathit{step}} 127 | \newcommand{\wn}{\mathit{wn}} 128 | \newcommand{\fmerge}{\mathit{merge}} 129 | \newcommand{\force}{\mathit{force}} 130 | \newcommand{\bind}{\mathit{bind}} 131 | \newcommand{\push}{\mathit{push}} 132 | \newcommand{\stash}{\mathit{stash}} 133 | \newcommand{\inject}{\mathit{inject}} 134 | \newcommand{\lookup}{\mathit{lookup}} 135 | \newcommand{\update}{\mathit{update}} 136 | \newcommand{\setof}[1]{\{#1\}} 137 | 138 | % Notations for proofs 139 | \newcommand{\maddrx}[1]{#1} 140 | \newcommand{\mastate}{\hat{\mstate}} 141 | \newcommand{\masto}{\hat{\msto}} 142 | \newcommand{\maenv}{\hat{\menv}} 143 | \newcommand{\makont}{\hat{\mkont}} 144 | \newcommand{\maval}{\hat{\mval}} 145 | \newcommand{\CompState}{\compile{\State}} 146 | \newcommand{\Context}{\mathit{Context}} 147 | \newcommand{\cmachstep}{\mathbin{\compile{\machstep}}} 148 | \newcommand{\camachstep}{\mathbin{\compile{\widehat{\machstep}}}} 149 | \newcommand{\lmachstep}{\mathbin{\longmapsto_{{\mathcal L}}}} 150 | \newcommand{\dmachstep}{\mathbin{\longmapsto_{\mathit{\msto\msdiff}}}} 151 | \newcommand{\tmachstep}{\mathbin{\longmapsto_{T}}} 152 | \newcommand{\damachstep}{\mathbin{\widehat{\longmapsto}_{\mathit{\msto\msdiff}}}} 153 | \newcommand{\nmachstep}{\mathbin{\longmapsto_n}} 154 | \newcommand{\dcompile}[1]{\Delta\compile{#1}} 155 | \newcommand{\mstor}{s} 156 | \newcommand{\updatedp}{\mathit{updated?}} 157 | \newcommand{\joinp}{\mathit{join?}} 158 | \newcommand{\hd}{\mathit{hd}} 159 | \newcommand{\replayall}{\forall\mathit{replay}} 160 | \newcommand{\lfp}[1]{\mathbf{lfp}(#1)} 161 | \newcommand{\reachable}[1]{\mathit{reachable}(#1)} 162 | \newcommand{\nw}{\mathit{nw}} 163 | \newcommand{\commit}{\mathit{commit}} 164 | \newcommand{\commitev}{\mathit{commitev}} 165 | \newcommand{\prep}{\mathit{prep}} 166 | \newcommand{\replaychange}{\mathit{replay}\Delta} 167 | \newcommand{\replaychangeall}{\forall\mathit{replay}\Delta} 168 | \newcommand{\deceq}{\mathbin{\overset{?}{=}}} 169 | \newcommand{\Label}{\mathit{Label}} 170 | \newcommand{\Counter}{\mathit{Time}} 171 | \newcommand{\System}{\mathit{System}} 172 | \newcommand{\Compiled}{\mathit{Compiled}} 173 | \newcommand{\erankt}{\mathit{erankt}} 174 | \newcommand{\erankl}{\mathit{erankl}} 175 | \newcommand{\sort}{\mathit{sort}} 176 | \newcommand{\sorted}{\mathit{sorted}} 177 | \newcommand{\map}{\mathit{map}} 178 | 179 | % Spaces 180 | \newcommand{\Store}{\mathit{Store}} 181 | \newcommand{\StoreDelta}{\mathit{Store\Delta}} 182 | \newcommand{\Addr}{\mathit{Addr}} 183 | \newcommand{\Value}{\mathit{Value}} 184 | \newcommand{\Var}{\mathit{Var}} 185 | \newcommand{\Env}{\mathit{Env}} 186 | \newcommand{\Expr}{\mathit{Expr}} 187 | \newcommand{\Kont}{\mathit{Kont}} 188 | \newcommand{\State}{\mathit{State}} 189 | \newcommand{\Storeable}{\mathit{Storeable}} 190 | \newcommand{\Timestamp}{{\mathbb N}} %{\mathit{Time}} 191 | \newcommand{\Valstack}{\mathit{ValStack}} 192 | \newcommand{\Traces}{\mathit{Traces}} 193 | \newcommand{\Boolean}{\mathit{Boolean}} 194 | 195 | \newcommand{\changep}{\Delta\mbox{{\tt ?}}} 196 | 197 | \newcommand{\Church}{Vardoulakis and Shivers} 198 | -------------------------------------------------------------------------------- /paper/precision.tex: -------------------------------------------------------------------------------- 1 | \documentclass{llncs} 2 | \usepackage{amsmath,amssymb,pfsteps,multicol,stmaryrd,mathpartir,centernot} 3 | \input{preamble} 4 | 5 | \begin{document} 6 | 7 | \section{Wide semantics decisions and precision differences} 8 | 9 | There are a few straightforward ways to widen the state space to use a 10 | single, monotonically increasing store. By far the most common way is 11 | with a worklist algorithm for computing a least fixed point of a 12 | ``frontier-based'' collecting semantics. By dropping all the 13 | intermediate stores, we lose temporal information such as $x$ is never 14 | a number before $y$ is a string. This kind of information is 15 | interesting, e.g., for diagnosing possible errors that the analysis 16 | detects when $x$ is used in a call not defined for numbers. More 17 | usefully, this can help pinpoint what influenced execution that lead 18 | to a tainted value in an information flow analysis. Consider the 19 | following program: 20 | 21 | \begin{lstlisting} 22 | (define (f x y) 23 | (if (bytes? y) 24 | (f (string->number x) (string-append (bytes->string/utf-8 y) x)) 25 | (if (zero? x) 26 | y 27 | (f (sub1 x) (substring x))))) 28 | (f (read-numeric) (read-encoded/unencoded)) 29 | \end{lstlisting} 30 | 31 | There's a faux recursion to get the input into the right 32 | format. Obviously this is contrived, but in a program that uses 33 | polymorphic functions at different stages of its execution, the 34 | temporal information helps pinpoint when and under what circumstances 35 | an abstract address was poisoned with a value that causes an error. 36 | 37 | \subsection{Precision on the frontier} 38 | There is also a precision difference between the frontier-based method 39 | and the state-space stepping semantics that is the initial model for a 40 | widened store. That is, instead of separating states that need 41 | stepping from seen states like the frontier-based method does, the 42 | entire known state space steps with the current store: 43 | 44 | \begin{align*} 45 | \System &= \wp(\State) \times \Store \\ 46 | (S,\msto) &\machstep (S',\msto') \\ 47 | \text{ where } I &= \setof{\mstate \mid \mastate \in S, \exists \msto'. \wn(\mastate,\msto) \machstep \mstate} \\ 48 | S' &= \setof{\mastate \mid \exists \msto.\wn(\mastate,\msto) \in I} \\ 49 | \msto' &= \bigsqcup\limits_{\msto \mid \exists\mastate.\wn(\mastate,\msto) \in I}{\msto} 50 | \end{align*} 51 | Although simple, this formulation has serious performance implications 52 | and precision deficiencies compared to the frontier-based 53 | semantics. This means the frontier-based algorithm is not just a more 54 | efficient implementation strategy for a widened store semantics, its 55 | results are not equivalent (they are better). 56 | 57 | The reason for the difference is that store changes that would affect 58 | the execution of some function might not be exercised before that 59 | function may never be called after that change. The frontier semantics 60 | would not end up stepping the state with the store dependency, whereas 61 | the above semantics would. 62 | 63 | A contrived example: 64 | \begin{lstlisting} 65 | (define b (box #f)) 66 | (define (foo x) 67 | (if (unbox b) 68 | (bar x) 69 | (bar (- x)))) 70 | (define (bar y) (/ (log y) (log 2)) 71 | (foo 20) 72 | (set-box! b #t) 73 | 74 | \end{lstlisting} 75 | 76 | The frontier semantics would never find that {\tt bar} could cause an 77 | exception for {\tt log} called on a non-positive number, whereas the 78 | above semantics would, unnecessarily. Notice that not only are 79 | bindings not poisoned, fewer paths are explored. 80 | 81 | \end{document} 82 | -------------------------------------------------------------------------------- /paper/proctime.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require parser-tools/lex) 3 | (provide timings (struct-out numbers) 4 | average variance stddev) 5 | 6 | (struct numbers (cpu run gc state-rate peak-mem current-mem states points timeout? exhaust?) #:transparent) 7 | 8 | (module data racket/base 9 | (provide (all-defined-out)) 10 | ;; These numbers change if the base-num and run-num change in [code/drive-benchmarks.rkt] 11 | (define start-run 0) 12 | (define end-run 4) 13 | (define algos '("bl" "sp" "spt" "sdt" "ls" "lst" "lct" "lc" "li" "ld" "fd" "ia" "id" "pa" "pd" "it" "pt" "is" "ps" "lp")) 14 | (define names '("church" "mbrotZ" "earley" "boyer" "graphs" 15 | "lattice" "matrix" "maze" "nbody" "nucleic"))) 16 | (require 'data (for-syntax 'data)) 17 | 18 | ;; operations for the vectors of numbers 19 | (define (average v) ;; 'unset means no average 20 | (and (number? (vector-ref v 0)) 21 | (/ (for/sum ([i v]) i) (vector-length v)))) 22 | (define (variance v) 23 | (define avg (average v)) 24 | (and avg 25 | (/ (for/sum ([i v]) (sqr (- i avg))) (vector-length v)))) 26 | (define (stddev v) 27 | (define var (variance v)) 28 | (and var (sqrt var))) 29 | 30 | ;; Quick and dirty parser to reformat cpu/run time of benchmark output into 31 | ;; Map[benchmark,Map[algo,(Vector Vector[Number] Vector[Number] Vector[Number])]] 32 | 33 | (define timings (make-hash)) 34 | ;; Initialize the map. 35 | (for ([file names]) 36 | (define h (make-hash)) 37 | (define runs (add1 (- end-run start-run))) 38 | (hash-set! timings file h) 39 | (for ([algo algos]) 40 | (hash-set! h algo 41 | (apply numbers (build-list 10 (λ _ (make-vector runs 'unset))))))) 42 | 43 | (define-syntax (mk-lexer stx) 44 | (syntax-case stx () 45 | [(_ lexname) #`(lexer #,@(for/list ([name (append algos names)]) 46 | #`[#,name #,name]) 47 | ["cpu" 'cpu] 48 | ["States/second" 'rate] 49 | ["Point count" 'points] 50 | ["State count" 'states] 51 | ["Peak memory use after a collection" 'peak] 52 | ["Result: Timeout" 'timeout] 53 | ["Result: Exhausted memory" 'exhaust] 54 | ["Current memory use" 'current] 55 | [(union (repetition 1 +inf.0 numeric) 56 | (concatenation (repetition 1 +inf.0 numeric) "." 57 | (repetition 1 +inf.0 numeric))) 58 | (string->number lexeme)] 59 | [(union "." "/" "\"" "real" "gc" 60 | "time" "mem" 61 | whitespace ":") (lexname input-port)])])) 62 | 63 | (define L (mk-lexer L)) 64 | ;; ./out.sh 65 | (with-input-from-file "benchmark" 66 | (λ () 67 | (for ([line (in-port read-line)] 68 | #:unless (string=? "" (string-trim line))) 69 | (define sp (open-input-string line)) 70 | (define-values (file algo run#) 71 | (apply values (for/list ([i (in-range 3)]) (L sp)))) 72 | (define idx (- run# start-run)) 73 | (match-define 74 | (numbers cpu real gc state-rate peak-mem current-mem states points timeout? exhaust?) 75 | (hash-ref (hash-ref timings file) algo)) 76 | (case (L sp) 77 | ;; ./NAME.ALGO.time.RUN:cpu time: NUMBER real time: NUMBER gc time: NUMBER 78 | [(cpu) ;; Next three lexemes are numbers for cpu/real/gc times 79 | (vector-set! cpu idx (L sp)) 80 | (vector-set! real idx (L sp)) 81 | (vector-set! gc idx (L sp))] 82 | ;; ./NAME.ALGO.time.RUN:"States/second: NUMBER" 83 | [(rate) (vector-set! state-rate idx (L sp))] 84 | ;; ./NAME.ALGO.time.RUN:Timeout 85 | [(timeout) 86 | (vector-set! timeout? idx #t) 87 | (vector-set! exhaust? idx #f)] 88 | ;; ./NAME.ALGO.time.RUN:Exhausted Memory 89 | [(exhaust) 90 | (vector-set! timeout? idx #f) 91 | (vector-set! exhaust? idx #t)] 92 | [(peak) (vector-set! peak-mem idx (L sp))] 93 | [(current) (vector-set! current-mem idx (L sp))] 94 | ;; ./NAME.ALGO.time.RUN:"State count: NUMBER" 95 | [(states) (vector-set! states idx (L sp))] 96 | ;; ./NAME.ALGO.time.RUN:"Point count: NUMBER" 97 | [(points) (vector-set! points idx (L sp))] 98 | [else (printf "Whaaaat?~%")]) 99 | (close-input-port sp)))) 100 | -------------------------------------------------------------------------------- /paper/response-pldi13.out: -------------------------------------------------------------------------------- 1 | U2FsdGVkX1+oteL67/oZvYgTvXhrTvEKUM57qvzGAeRd2F2M+VT/7KqNakKifWG+ 2 | 6xzYIEPBhPY+KLrzWbvA/9qG+sojUhMVZ9lLeos8XxrR2dGPNEsyx7vQj4ZD2hRg 3 | aWzGgStvz1WPM7nvqKzGAqzY8tYQcOsdy5MHlruCAr+/cNb5SER+DR/9U1NK11U1 4 | PhT1qjGSgantpi/CRmpeZIM5BrTbYU6J82R0L2s7QYKwdQP0TVZMYmDy6wsiAdko 5 | xkIXc46wLbG4n8mecusn0LbFFUEKYDA7JsRcT4Pq8Wk71bmUlSWAa7l879tl6+Dy 6 | OZvxM9fAmVwpA432ydI+XUim91BMmDiNZsmzhBQoHyKx5ae7cq4y8w6pgVsodBKU 7 | DnDPIFXQPWEtZxw8Kd4dTCoPfrbxcxve1EH7sJSVEwkIaykmn+nnjBAa3qUTLrNq 8 | DsfOZ/sRPVwmlf7F+6uzFBdoYp0LBauOUk9onF6mUEDvrwcAFO5ntjlMR37uIRvQ 9 | IMwe7mGJvUepgW/+ekVQ0VAnP748v9rP2Q0zg8FMSGDE+Gh1JzdDVo+S/acqc+pb 10 | 3w1rfMPF6oXFcmTlCTWAG1uHlXHLimlmXtYrRMFxwlqDrpXgL6PUNdm3v0Qh6pAA 11 | P/h2SIq83KAGCDEcnqFrBhx+aF9hCyOddRVrdW5M4UBOBxf1qFlD1HG0Q99foCo+ 12 | mBjMagrKjOyc1KyitO79Ff0DBUEGDKPUOqiM/rpKhbl5StP11dFKp//HgL9DVjKk 13 | 3vLOQcsebAMOv9e5mPbLXR7IZNqPed5pzPBQE/HycPzUX0z+shKX0iV2UcuobRi0 14 | o9/h+cmx6Pnke/nyKnV1jHLGaU6EybEr9vHGyWnVYaeX395Cg9Oey26iVqg0uE2V 15 | DMHd/jZ7Tkp3KbO1QfuuhtSN3qwlGrGxgHPonZ3pB7JoK/HvHaqZS7zuTVcV7c9+ 16 | CYk16oiUwuaiV1MS70GCc39eZdewQ0pefoXSLWPS5p9hP2huCH/38LtONZUsJ3HD 17 | OP11ybTfYhG6KvE9apCRRKNDJJ9gaPfaTWpqpg30aNZTcn9UdpDOt6+HLZtDn35p 18 | RfDdOPZ3RNPsHG/cA3aA5KZ+f+c39aClBsGt+mpt9WiAgogI7h3ZRY6WjN6Zi+1a 19 | gagxdGevweaHGk7hxuBAy7k7HCrokrUeXRB1thtU1xVhq+T2Ymnlr0Sql7DtqZij 20 | L51BlmgJKOkTn4r3i/9JuZOnne/EdeceF8IqtiNJKhUUIU0dacdRmmZ/qT30Kcff 21 | vAT9xcImRaClBdGOKmaheXCRezqdsGpDVjEtfAwE3ME5653oFRU7jklQy1elYPp6 22 | dwh+cgJ2+CABfk3ddWT/snNmAG+ud7fQFt/hk6kkUhzof+KgpSxY8COeRShiewdJ 23 | ypb2Su25X8PF9VWLzmUXXIUwXSDh67to8pWZhnIywuo2/CVjHh140rn9QGSEXvg9 24 | pXlAvxpOU0NdJWlAVB/9lmibm7zLEzZ7bQnGxbOLfjRGuC4t38/x/n1OVj6i7PGQ 25 | eS7Dr82fUQ8QDoS9i65pgwzNn7W5FY4deZ6njzSQ2EjfTAaVpXH4lh5GoM25M/76 26 | 79tzuBvhl6E/CTod3BLdM0YbkPdp+x1gLRq0L4tFEUDcRevxqYV4Z8ZyQHJ5OSRi 27 | AkSNm12KhpABd5QMsOgXP3Rc/2LkU7WfpT5k+UmBHpqadU/vv6D8LR3SFZuEBWq+ 28 | D02sn5gvHmcFW54AtF0AcIfWz1ptexL49nL5i/ATqXXAG715gMUxK534axdS3JXU 29 | zqJPMPE+8D42c45pO4ROF3ZmMF317/hEjQgssHNO4eKr1iIaPOjOH3cBOUuUNyTp 30 | v6Ui5IrTXEqvUMAz1JsoR8UE8eTo/vxQQpdIJuNr9+u1yzpLC6Z4tIc4pmTqrTv8 31 | zSYGDmeFHtWfVuFGdArjePfo+Ak2R3cZyuU8ZgrTOv1QbgKXCeBITUfC6pmEGuGV 32 | 5cVU0bGvx6fcWfEsY0LPKNvXjJMDqjHWHLpfQO+A/++wuV32BjkmS/7AkFitTQ+2 33 | 356fXUTIT9uSihayJcmZm0BA6MmsFUYZB2OzmdsjgZn4rgCA6xNGzWr9J460hafI 34 | 5ul75U2yJAbG6O4TbMDEjoEwHRpTnUpn8rkS4ibSg/11zcIf+ZTWhZ+zXBn5RAlD 35 | LMeI+PaNpu574Kts4ORRG3n6HmphPC3oD3OdOOdrHQmwXaYib8tCwDvCmBaqT++N 36 | kMg7rrSp4wQdDGhNszSiXpDWpkF3qzY0OZJop7zUaLOKVCrUfVVrj7jcx7crG3wo 37 | Aln2plq5kaKxLqXao3Vllb2rq3hLGcGCE4tIqomNjiwJU7exNOvvkYlF8CU1zh/G 38 | JGNAeSP5UHX2khQvGpoN1VvIwCWUQ5uYlZZkskIVmag0h0ciA1s07eXKaibmw7xi 39 | Dn0EXzu230WECGddnZWVFXkuenkYs1C5MFSXDMS9VvYO3+YLhBiT4rJTuEssCBrj 40 | 59KN/HHPAUBdq5ulMvHGPl7mw0GGzggzr7JsLF2VZgAxjUdJ2g8vpzdSGjzQxCPU 41 | B7EEzU90BynemgaLlubMobLfPAkUUWiZ8LfzqhTEGo3yhpJ6C1TFRLg4XlSFWWXJ 42 | /m+5YnaSHdMvQSwNVbhfvLwYifYrvTt1RWqWc3NjBe8M8E9HmDt+keeWSBA7BY7A 43 | MaECWh1YYyWBsMkyatgiUo8GBMl449Hsye4fvLsYo76c5RrpZ3X7I9Ec018Igen7 44 | qWU6+DwXTAwq9zn7Aq0aWEMJlNMwJUA4pdMx5ItYLOd6G0+t4gu+n5voVzLL8DTJ 45 | -------------------------------------------------------------------------------- /paper/vardoulakis-shivers-numbers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "proctime.rkt" 3 | unstable/sequence 4 | plot) 5 | 6 | (define (vector-avg v) 7 | (define t (vector-filter (negate (λ (x) (eq? x 'unset))) v)) 8 | (if (zero? (vector-length t)) 9 | +inf.0 10 | (/ (for/sum ([x (in-vector t)]) x) 11 | (vector-length t)))) 12 | 13 | (define (pick-min alg-pairs) 14 | (argmin (λ (p) (second p)) alg-pairs)) 15 | 16 | (define (pick-max alg-pairs) 17 | (argmax (λ (p) (second p)) alg-pairs)) 18 | 19 | (define max-mins 20 | (for/list ([(name report) (in-hash timings)]) 21 | (define ls (for/list ([(alg ns) (in-hash report)]) 22 | (list alg (vector-avg (numbers-run ns))))) 23 | (cons name 24 | (list (pick-min ls) 25 | (pick-max ls))))) 26 | 27 | (define speedups 28 | (map (λ (l) 29 | (match l 30 | [(cons name (list (list _ min-time) (list _ max-time))) 31 | (define bounded-maxt (min max-time (* 30 60 1000))) 32 | (list name (/ max-time min-time) (/ bounded-maxt min-time))])) 33 | max-mins)) 34 | 35 | 36 | 37 | (define algo-name 38 | '(#;("bl" . "baseline") 39 | ("sp" . "baseline") ;; Specialized is the new baseline 40 | ("spt" . "frontier") 41 | ("sdt" . "deltas") 42 | ("lst" . "lazy") 43 | ("lct" . "compiled") 44 | #;("ls" . "lazy") 45 | #;("lc" . "compiled") 46 | #;("ld" . "deltas") 47 | #;("is" . "imperative stacked values") 48 | ("ps" . "preallocated stacked values") 49 | #;("ia" . "imperative accumulated deltas") 50 | #;("id" . "imperative deltas") 51 | #;("pa" . "preallocated accumulated deltas") 52 | #;("pd" . "preallocated deltas") 53 | #;("it" . "imperative timestamp") 54 | #;("pt" . "preallocated timestamp"))) 55 | 56 | 57 | ;; You can change this to get charts for other benchmarks but 58 | ;; likely that you have to tweak the max/min parameters below. 59 | (define bench-name "church") 60 | 61 | (define timeout (* 30 60)) 62 | (define memout (* 1024 1024 1024)) 63 | (define rateout 0) 64 | (define (->timeout n) (if (eq? n +inf.0) timeout n)) 65 | (define (->memout n) (if (eq? n +inf.0) memout n)) 66 | (define (->rateout n) (if (eq? n +inf.0) rateout n)) 67 | 68 | (define bench-timing (hash-ref timings bench-name)) 69 | (define baseline-time 70 | (->timeout (vector-avg (numbers-run (hash-ref (hash-ref timings bench-name) "sp"))))) 71 | (define baseline-mem 72 | (->memout 73 | (vector-avg (numbers-peak-mem (hash-ref (hash-ref timings bench-name) "sp"))))) 74 | (define baseline-rate 75 | (->rateout 76 | (vector-avg (numbers-state-rate (hash-ref (hash-ref timings bench-name) "sp"))))) 77 | 78 | (define rel-time-data 79 | (for/list ([(key desc) (in-pairs algo-name)] 80 | [n (in-naturals)]) 81 | (vector n 82 | (->timeout 83 | (/ baseline-time 84 | (vector-avg (numbers-run (hash-ref bench-timing key)))))))) 85 | (define rel-mem-data 86 | (for/list ([(key desc) (in-pairs algo-name)] 87 | [n (in-naturals)]) 88 | (vector n 89 | (->memout 90 | (/ baseline-mem 91 | (vector-avg (numbers-peak-mem (hash-ref bench-timing key)))))))) 92 | (define rel-states-per-sec-data 93 | (for/list ([(key desc) (in-pairs algo-name)] 94 | [n (in-naturals)]) 95 | (vector n 96 | (->rateout 97 | (/ (vector-avg (numbers-state-rate (hash-ref bench-timing key))) 98 | baseline-rate))))) 99 | 100 | (define (sec->anchor l) 101 | (case l 102 | (("§4") 'bottom-left) 103 | (("§5.4" "§5.5.3") 'top) 104 | (else 'bottom))) 105 | 106 | (define (sec-mem->anchor l) 107 | (case l 108 | (("§4") 'bottom-left) 109 | (else 'top))) 110 | 111 | (define sections 112 | (list "§4" 113 | "§5.1" 114 | "§5.2" 115 | "§5.3" 116 | "§5.4" 117 | "§5.5.3")) 118 | 119 | (define (sec-labels sec->anchor data) 120 | (map (λ (v l) (point-label v l #:anchor (sec->anchor l) #:point-size 12)) 121 | data 122 | sections)) 123 | 124 | (parameterize ([plot-x-ticks no-ticks] 125 | [plot-font-size 30] 126 | [plot-width (* (plot-width) 2)] 127 | [plot-height (quotient (plot-height) 2)]) 128 | (list 129 | (plot (list 130 | (lines rel-time-data #:color 2 #:width 4 131 | #:label "Run time speed-up") 132 | (sec-labels sec->anchor rel-time-data)) 133 | #:y-min -25 134 | #:y-max 400 135 | #:x-label "" 136 | #:x-min 0 137 | #:x-max 5.2 138 | #:y-label "" #;"Factor improvement over baseline" 139 | #:out-file (format "~a-relative-time.ps" bench-name)) 140 | 141 | (plot (list 142 | (lines rel-states-per-sec-data #:color 6 #:width 4 143 | #:label "Rate of state transitions speed-up") 144 | (sec-labels sec->anchor rel-states-per-sec-data)) 145 | #:y-min -9 146 | #:y-max 85 147 | #:x-min 0 148 | #:x-label "" 149 | #:x-max 5.2 150 | #:y-label "" 151 | #:out-file (format "~a-relative-speed.ps" bench-name)) 152 | 153 | (plot (list 154 | (lines rel-mem-data #:color 4 #:width 4 155 | #:label "Peak memory") 156 | (sec-labels sec-mem->anchor rel-mem-data)) 157 | #:y-min 0 158 | #:y-max 3 159 | #:x-label "" 160 | #:x-min 0 161 | #:x-max 5.2 162 | #:y-label "" 163 | #:out-file (format "~a-relative-space.ps" bench-name)))) 164 | -------------------------------------------------------------------------------- /paper/vis-bench.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "proctime.rkt" 3 | unstable/sequence 4 | plot) 5 | 6 | (define (vector-avg v) 7 | (define t (vector-filter (negate (λ (x) (eq? x 'unset))) v)) 8 | (if (zero? (vector-length t)) 9 | +inf.0 10 | (/ (for/sum ([x (in-vector t)]) x) 11 | (vector-length t)))) 12 | 13 | (define (constant-stream c) 14 | (make-do-sequence (λ () 15 | (values (λ _ c) (λ _ #f) #f (λ _ #t) (λ _ #t) (λ _ #t))))) 16 | 17 | (define algo-name 18 | '(#;("bl" . "baseline") 19 | ("sp" . "baseline") ;; Specialized is the new baseline 20 | ("spt" . "frontier") 21 | ("sdt" . "deltas") 22 | ("lst" . "lazy") 23 | ("lct" . "compiled") 24 | #;("ls" . "lazy") 25 | #;("lc" . "compiled") 26 | #;("ld" . "deltas") 27 | #;("is" . "imperative stacked values") 28 | ("ps" . "preallocated stacked values") 29 | #;("ia" . "imperative accumulated deltas") 30 | #;("id" . "imperative deltas") 31 | #;("pa" . "preallocated accumulated deltas") 32 | #;("pd" . "preallocated deltas") 33 | #;("it" . "imperative timestamp") 34 | #;("pt" . "preallocated timestamp"))) 35 | 36 | (define (numbers->relative bench-name accessors exponents defaults) 37 | (define bench-timing (hash-ref timings bench-name)) 38 | (define baseline-numbers (hash-ref bench-timing "sp")) 39 | (define baseline-avgs 40 | (for/list ([acc accessors]) (vector-avg (acc baseline-numbers)))) 41 | (flatten 42 | (for/list ([acc accessors] 43 | [base baseline-avgs] 44 | [k exponents] 45 | [d defaults]) ;; base/num or num/base? (expt n 1), (expt n -1) 46 | (for/list ([(key desc) (in-pairs algo-name)] 47 | [n (in-naturals)]) 48 | (define avg (vector-avg (acc (hash-ref bench-timing key)))) 49 | (vector n 50 | (cond [(and (infinite? base) (infinite? avg)) 51 | 1] 52 | [(infinite? base) (expt (/ d avg) k)] 53 | [(infinite? avg) (expt (/ base d) k)] 54 | [else (expt (/ base avg) k)])))))) 55 | 56 | 57 | (define (sec->anchor l) 58 | (case l 59 | (("§4") 'bottom-left) 60 | (("§5.4" "§5.5.3") 'top) 61 | (else 'bottom))) 62 | 63 | (define (sec-mem->anchor l) 64 | (case l 65 | (("§4") 'bottom-left) 66 | (else 'top))) 67 | 68 | (define sections 69 | (list "§4" 70 | "§5.1" 71 | "§5.2" 72 | "§5.3" 73 | "§5.4" 74 | "§5.5.3")) 75 | 76 | (define accs (list numbers-run numbers-peak-mem numbers-state-rate)) 77 | (define exps (list 1 ;; Base / New number grows since time goes down 78 | 1 ;; Base / new same 79 | -1)) ;; Rate goes up 80 | (define descs (list "time" "space" "speed")) 81 | (define xmins '((0 . 5.2) 82 | (0 . 5.2) 83 | (0 . 5.2))) 84 | (define ymins '((0.9 . 8000) 85 | (0 . 10) 86 | (0.1 . 15000))) 87 | (define ytranss (list log-transform #f log-transform)) 88 | (define ytickss (list log-ticks #f log-ticks)) 89 | (define defaults (list (* 30 60 1000) (* 1024 1024 1024) 150)) 90 | 91 | (define (sec-labels sec->anchor data) 92 | (map (λ (v l) (point-label v l #:anchor (sec->anchor l) #:point-size 12)) 93 | data 94 | sections)) 95 | 96 | (define ((unbend data) x) 97 | (define-values (firstx firsty nextx nexty) 98 | (let* ([firstx 99 | (for/last ([v data] 100 | [i (in-naturals)] 101 | #:when (>= x (vector-ref v 0))) 102 | i)] 103 | [firstx (or firstx 0)] 104 | [nextx (if (and firstx (< firstx (sub1 (length data)))) 105 | (add1 firstx) 106 | (sub1 (length data)))]) 107 | (values firstx (vector-ref (list-ref data firstx) 1) 108 | nextx (vector-ref (list-ref data nextx) 1)))) 109 | (define dx (- nextx firstx)) 110 | (cond [(zero? dx) firsty] 111 | [(zero? nexty) nexty] 112 | [else 113 | (define c (/ (log (/ nexty firsty)) dx)) 114 | (* firsty (exp (* c (- x firstx))))])) 115 | 116 | (parameterize ([plot-x-ticks no-ticks] 117 | [plot-font-size 13] 118 | [plot-width (* (plot-width) 2)] 119 | [plot-height (inexact->exact (truncate (/ (plot-height) 1.4)))]) 120 | (for/list ([acc accs] 121 | [exp exps] 122 | [desc descs] 123 | [(ymin ymax) (in-pairs ymins)] 124 | [(xmin xmax) (in-pairs xmins)] 125 | [ytrans ytranss] 126 | [yticks ytickss] 127 | [default defaults]) 128 | (parameterize ([plot-y-transform (or ytrans (plot-y-transform))] 129 | [plot-y-ticks (if yticks (yticks) (plot-y-ticks))]) 130 | (plot (cons 131 | (x-ticks (for/list ([sec sections] 132 | [i (in-naturals)]) 133 | (tick i #t sec))) 134 | (for/list ([bench (list "church" "maze" "nucleic" "boyer" "matrix" "lattice" "earley" "mbrotZ" "nbody" "graphs")] 135 | [i (in-naturals)]) 136 | (define col (if (> i 4) "black" "gray")) 137 | (define data (numbers->relative bench (list acc) (list exp) (list default))) 138 | (list 139 | (if ytrans 140 | (function (unbend data) #:color col #:style i #:width 2 #:label bench) 141 | (lines data #:color col #:style i #:width 2 #:label bench)) 142 | #;(sec-labels sec->anchor data)))) 143 | #:y-min ymin 144 | #:y-max ymax 145 | #:x-label "" 146 | #:x-min xmin 147 | #:x-max xmax 148 | #:y-label "" #;"Factor improvement over baseline" 149 | #:out-file (format "all-relative-~a.ps" desc)) 150 | ))) -------------------------------------------------------------------------------- /tests/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | compiled/ 3 | -------------------------------------------------------------------------------- /tests/parse.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require rackunit) 3 | (require "../code/ast.rkt" 4 | "../code/parse.rkt") 5 | 6 | (define (exp=/lab e0 e1) 7 | (match* (e0 e1) 8 | [((var _ x) (var _ x)) #t] 9 | [((num _ n) (num _ n)) #t] 10 | [((bln _ b) (bln _ b)) #t] 11 | [((lrc _ xs es e) 12 | (lrc _ xs fs f)) 13 | (and (exp=/lab e f) 14 | (andmap exp=/lab es fs))] 15 | [((lam _ x e) (lam _ x f)) 16 | (exp=/lab e f)] 17 | [((app _ e es) 18 | (app _ f fs)) 19 | (and (exp=/lab e f) 20 | (andmap exp=/lab es fs))] 21 | ;rec -- should go away 22 | [((ife _ e0 e1 e2) 23 | (ife _ f0 f1 f2)) 24 | (and (exp=/lab e0 f0) 25 | (exp=/lab e1 f1) 26 | (exp=/lab e2 f2))] 27 | [((1op _ o e) (1op _ o f)) 28 | (exp=/lab e f)] 29 | [((2op _ o e0 e1) (2op _ o f0 f1)) 30 | (and (exp=/lab e0 f0) 31 | (exp=/lab e1 f1))] 32 | [((st! _ x e) (st! _ x f)) 33 | (exp=/lab e f)] 34 | [(_ _) #f])) 35 | 36 | 37 | (check exp=/lab (parse '5) (num '_ '5)) 38 | (check exp=/lab (parse 'x) (var '_ 'x)) 39 | (check exp=/lab (parse '(let () 5)) (num '_ 5)) 40 | (check exp=/lab (parse '(let* () x)) (var '_ 'x)) 41 | (check exp=/lab (parse '(lambda (x) x)) (lam '_ '(x) (var '_ 'x))) 42 | (check exp=/lab (parse '(f x)) (app '_ (var '_ 'f) (list (var '_ 'x)))) 43 | (check exp=/lab (parse '(set! x 1)) (st! '_ 'x (num '_ 1))) 44 | 45 | (check exp=/lab 46 | (parse '(let ((x 1) (y 2)) x)) 47 | (parse '((lambda (x y) x) 1 2))) 48 | 49 | ;; Can't write this test because of the stupid fresh name thing. 50 | #; 51 | (check exp=/lab 52 | (parse '(let () 1 2)) 53 | (parse '(begin 1 2))) 54 | 55 | (check exp=/lab 56 | (parse-prog 57 | '[(define (fact n) 58 | (if (zero? n) 59 | 1 60 | (* n (fact (sub1 n))))) 61 | (fact 5)]) 62 | (parse 63 | '(letrec ((fact (lambda (n) 64 | (if (zero? n) 65 | 1 66 | (* n (fact (sub1 n))))))) 67 | (fact 5)))) 68 | 69 | ;; parse really shouln't pick fresh names 70 | #; 71 | (check exp=/lab 72 | (parse-prog '[1 2]) 73 | (parse '(begin 1 2))) 74 | -------------------------------------------------------------------------------- /tests/run.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require rackunit) 3 | 4 | (require "../code/parse.rkt") 5 | (require "../benchmarks/progs.rkt") 6 | 7 | (require "../code/kcfa.rkt" 8 | #;(prefix-in lazy: "../code/0cfa-lazy.rkt") 9 | #;(prefix-in delta: "../code/0cfa-delta.rkt")) 10 | 11 | 12 | (define (check-∈ x xs) (check set-member? xs x)) 13 | (define (check-⊑ x xs) 14 | (check (λ (xs x) 15 | (or (set-member? xs x) 16 | (set-member? xs (widen x)))) 17 | xs 18 | x)) 19 | 20 | (define (overlap? s1 s2) 21 | (not (set-empty? (set-intersect s1 s2)))) 22 | 23 | (define (simple-tests ev widen) 24 | (define (check->> p x) (check overlap? 25 | (set x (widen x)) 26 | (ev (parse-prog p)))) 27 | 28 | (check->> '[#t] #t) 29 | (check->> '[(or #t)] #t) 30 | (check->> '[(or #f)] #f) 31 | (check->> '[(= 4 4)] #t) 32 | (check->> '[(= 4 3)] #f) 33 | (check->> '[((lambda (x) x) 3)] 3) 34 | (check->> '[(define (box x) 35 | (lambda (z) (z (lambda () x) (lambda (y) (set! x y) y)))) 36 | (define (getter b) (b (lambda (x1 x2) x1))) 37 | (define (setter c) (c (lambda (z1 z2) z2))) 38 | (define b1 (box 5)) 39 | (define b2 (box 7)) 40 | ((setter b2) 18) 41 | ((getter b1))] 42 | 5) 43 | (check->> '[(letrec ((f (lambda (z) x)) (x 3)) (f 1))] 44 | 3) 45 | (check->> '[(define x 1) 46 | (set! x 2) 47 | x] 48 | 2) 49 | (check->> '[(define (fact n) 50 | (if (zero? n) 51 | 1 52 | (* n (fact (sub1 n))))) 53 | (fact 5)] 54 | 120) 55 | #; 56 | (check->> '[(define (ack m n) 57 | (if (zero? m) 58 | (add1 n) 59 | (if (zero? n) 60 | (ack (sub1 m) 1) 61 | (ack (sub1 m) (ack m (sub1 n)))))) 62 | (ack 2 2)] 63 | 7)) 64 | 65 | (simple-tests eval (λ (x) x)) 66 | (simple-tests eval^ (λ (x) x)) 67 | (simple-tests eval/c (λ (x) x)) 68 | (simple-tests eval/c^ (λ (x) x)) 69 | 70 | (simple-tests lazy-eval (λ (x) x)) 71 | (simple-tests lazy-eval^ (λ (x) x)) 72 | (simple-tests lazy-eval/c (λ (x) x)) 73 | (simple-tests lazy-eval/c^ (λ (x) x)) 74 | 75 | (simple-tests 0cfa widen) 76 | (simple-tests 0cfa^ widen) 77 | (simple-tests 0cfa/c widen) 78 | (simple-tests 0cfa/c^ widen) 79 | 80 | (simple-tests lazy-0cfa widen) 81 | (simple-tests lazy-0cfa^ widen) 82 | (simple-tests lazy-0cfa/c widen) 83 | (simple-tests lazy-0cfa/c^ widen) 84 | 85 | (simple-tests 1cfa widen) 86 | (simple-tests 1cfa^ widen) 87 | (simple-tests 1cfa/c widen) 88 | (simple-tests 1cfa/c^ widen) 89 | 90 | (simple-tests lazy-1cfa widen) 91 | (simple-tests lazy-1cfa^ widen) 92 | (simple-tests lazy-1cfa/c widen) 93 | (simple-tests lazy-1cfa/c^ widen) 94 | 95 | 96 | ;(check-in #t (eval (parse-prog church))) ; expensive 97 | (check-∈ #f (eval (parse-prog vhm08))) 98 | 99 | (check-∈ 2 (eval (parse-prog mj09))) 100 | (check-∈ #f (eval (parse-prog eta))) 101 | (check-∈ #f (eval (parse-prog kcfa2))) 102 | (check-∈ #f (eval (parse-prog kcfa3))) 103 | (check-∈ #f (eval (parse-prog blur))) 104 | ;(check-∈ 550 (eval (parse-prog loop2))) ; too expensive 105 | (check-∈ #t (eval (parse-prog sat))) 106 | 107 | ;(check-in #t (0cfa^ (parse-prog church))) ; expensive 108 | (check-∈ #f (0cfa^ (parse-prog vhm08))) 109 | 110 | (check-∈ 2 (0cfa^ (parse-prog mj09))) 111 | (check-∈ #f (0cfa^ (parse-prog eta))) 112 | (check-∈ #f (0cfa^ (parse-prog kcfa2))) 113 | (check-∈ #f (0cfa^ (parse-prog kcfa3))) 114 | (check-∈ #f (0cfa^ (parse-prog blur))) 115 | ;(check-∈ 550 (0cfa^ (parse-prog loop2))) ; too expensive 116 | (check-∈ #t (0cfa^ (parse-prog sat))) 117 | 118 | 119 | ;; mutually recursive top-level functions 120 | (check-∈ #t 121 | (eval 122 | (parse-prog 123 | '[(define (even? x) 124 | (if (zero? x) 125 | #t 126 | (not (odd? (sub1 x))))) 127 | (define (odd? y) 128 | (if (zero? y) 129 | #f 130 | (not (even? (sub1 y))))) 131 | (even? 2)]))) 132 | 133 | (check-∈ 3 (0cfa^ (parse '(letrec ((f (lambda (z) x)) (x 3)) (f 1))))) 134 | (check-∈ 3 (0cfa^ (parse '(letrec ((x 3) (f (lambda (z) x))) (f 1))))) 135 | 136 | #| 137 | ;; Check result of evaluation against analysis 138 | 139 | (check-in 2 (delta:0cfa^ (parse-prog mj09))) 140 | (check-in #t (delta:0cfa^ (parse-prog church))) 141 | 142 | (check-in 2 (0cfa^ (parse-prog mj09))) 143 | (check-in 2 (lazy:0cfa^ (parse-prog mj09))) 144 | (check-in #f (lazy:0cfa^ (parse-prog blur))) 145 | (check-in #f (delta:0cfa^ (parse-prog blur))) 146 | |# 147 | ;; run parser tests 148 | (require "parse.rkt") 149 | --------------------------------------------------------------------------------