├── dvl ├── macro.scm ├── read.scm ├── .gitignore ├── letrec.scm ├── syntax.scm ├── doc │ ├── adventures-talk-apr-2013 │ │ ├── .gitignore │ │ ├── celestial.scm │ │ ├── slides.txt │ │ ├── mandelbrot.scm │ │ ├── Makefile │ │ ├── mandelbrot.vl │ │ └── talk.txt │ ├── boston-slug-talk-aug-2013 │ │ ├── .gitignore │ │ ├── analyzed.fol │ │ ├── mandel.dvl │ │ ├── mandel.js │ │ ├── cognoscenti.txt │ │ ├── credits.txt │ │ ├── Makefile │ │ ├── mandel.html │ │ └── mandel-driver.js │ └── type-annotations.txt ├── examples │ ├── mandelbrot │ │ ├── .gitignore │ │ ├── spinner.gif │ │ ├── Makefile │ │ ├── README.md │ │ ├── mandel.dvl │ │ ├── mandel.html │ │ └── mandelbrot.ghc-2.hs │ ├── .gitignore │ ├── amazing-bug.dvl │ ├── example-opt.dvl │ ├── amazing-bug-4.dvl │ ├── unknown-derivatives.dvl │ ├── amazing-bug-2.dvl │ ├── sqrt.dvl │ ├── runge-kutta │ │ ├── integrations.dvl │ │ ├── gnuplot.scm │ │ ├── runge-kutta.dvl │ │ └── runge-kutta-driver.scm │ ├── sqrt-again.dvl │ ├── amazing-bug-5.dvl │ ├── celestial │ │ ├── README.md │ │ ├── celestial-driver.lisp │ │ └── celestial-driver.scm │ ├── non-bug.dvl │ ├── derivative-examples.dvl │ ├── amazing-bug-3.dvl │ ├── streams.dvl │ └── richardson.dvl ├── test │ ├── load.scm │ └── dvl-error-detection-test.scm ├── stdlib │ ├── stdlib.dvl │ ├── forward-mode.dvl │ ├── vlad-compatibility.dvl │ ├── basics.dvl │ └── vectors.dvl ├── dvl ├── Makefile ├── dvl-watch-benchmark ├── dvl-benchmarks ├── load.scm ├── eval.scm └── errors.scm ├── fol ├── .gitignore ├── examples │ ├── .gitignore │ └── factorial.fol ├── fol ├── Makefile ├── test │ ├── load.scm │ └── utils.scm ├── runtime.sc ├── todo.txt ├── doc │ ├── rule-system.txt │ ├── objectives.txt │ ├── simplification.txt │ └── type-transformations.txt ├── haskell.scm ├── runtime.scm ├── dead-types.scm ├── primitives.scm └── nomenclature.scm ├── haskell-fol ├── .gitignore ├── examples │ ├── .gitignore │ ├── fact.fol │ ├── celestial.html │ ├── driver.js │ └── Makefile ├── README ├── Setup.hs ├── fol2js.hs ├── fol.cabal ├── FOL │ └── Language │ │ ├── Pretty.hs │ │ ├── Unique.hs │ │ └── Common.hs └── fol2hs.hs ├── vl ├── examples │ ├── .gitignore │ └── euler-integral.vl ├── .gitignore ├── vlad-tech-report.pdf ├── test │ ├── load.scm │ └── test-programs.vl ├── vl ├── Makefile ├── load.scm ├── eval.scm ├── syntax.scm ├── nomenclature.scm ├── read.scm └── env.scm ├── .gitignore ├── vlad-manual ├── .gitignore └── Makefile ├── .gitmodules ├── Makefile └── support ├── srfi-11.scm ├── hash-tables.scm ├── two-way-table.scm └── auto-compilation.scm /dvl/macro.scm: -------------------------------------------------------------------------------- 1 | ../vl/macro.scm -------------------------------------------------------------------------------- /dvl/read.scm: -------------------------------------------------------------------------------- 1 | ../vl/read.scm -------------------------------------------------------------------------------- /dvl/.gitignore: -------------------------------------------------------------------------------- 1 | benchmarks/ 2 | -------------------------------------------------------------------------------- /dvl/letrec.scm: -------------------------------------------------------------------------------- 1 | ../vl/letrec.scm -------------------------------------------------------------------------------- /dvl/syntax.scm: -------------------------------------------------------------------------------- 1 | ../vl/syntax.scm -------------------------------------------------------------------------------- /fol/.gitignore: -------------------------------------------------------------------------------- 1 | test-output/ 2 | -------------------------------------------------------------------------------- /haskell-fol/.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | -------------------------------------------------------------------------------- /dvl/doc/adventures-talk-apr-2013/.gitignore: -------------------------------------------------------------------------------- 1 | *.pdf 2 | *.ps 3 | -------------------------------------------------------------------------------- /dvl/doc/boston-slug-talk-aug-2013/.gitignore: -------------------------------------------------------------------------------- 1 | *.pdf 2 | *.ps 3 | -------------------------------------------------------------------------------- /dvl/examples/mandelbrot/.gitignore: -------------------------------------------------------------------------------- 1 | answer.pbm 2 | mandelbrot.ghc-2.ghc_run 3 | -------------------------------------------------------------------------------- /vl/examples/.gitignore: -------------------------------------------------------------------------------- 1 | *.fol 2 | *.lisp 3 | *.scm 4 | *.opt 5 | *.fasl 6 | -------------------------------------------------------------------------------- /vl/.gitignore: -------------------------------------------------------------------------------- 1 | workbook.ps 2 | workbook*.ps 3 | *.bci 4 | *.com 5 | *.bin 6 | *.ext 7 | -------------------------------------------------------------------------------- /vl/vlad-tech-report.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/axch/dysvunctional-language/HEAD/vl/vlad-tech-report.pdf -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.bci 2 | *.com 3 | *.bin 4 | *.ext 5 | *.fol-scm 6 | *.bfo 7 | stanozzle* 8 | test-compiler-output* 9 | -------------------------------------------------------------------------------- /dvl/examples/.gitignore: -------------------------------------------------------------------------------- 1 | *.fol 2 | *.opt 3 | *.scm 4 | !*driver.scm 5 | *.lisp 6 | !*driver.lisp 7 | *.js 8 | !*driver.js 9 | -------------------------------------------------------------------------------- /dvl/examples/mandelbrot/spinner.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/axch/dysvunctional-language/HEAD/dvl/examples/mandelbrot/spinner.gif -------------------------------------------------------------------------------- /fol/examples/.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.opt 3 | *.scm 4 | !*driver.scm 5 | *.lisp 6 | !*driver.lisp 7 | *.hs 8 | !*driver.hs 9 | Factorial 10 | -------------------------------------------------------------------------------- /haskell-fol/examples/.gitignore: -------------------------------------------------------------------------------- 1 | *.js 2 | !*driver.js 3 | *.hs 4 | !*driver.hs 5 | *.lisp 6 | !*driver.lisp 7 | *.scm 8 | !*driver.scm 9 | *.opt 10 | -------------------------------------------------------------------------------- /haskell-fol/examples/fact.fol: -------------------------------------------------------------------------------- 1 | (begin 2 | (define (fact n) 3 | (argument-types real real) 4 | (if (= n 0) 5 | 1 6 | (* n (fact (- n 1))))) 7 | (lambda (x) (fact x))) 8 | -------------------------------------------------------------------------------- /vlad-manual/.gitignore: -------------------------------------------------------------------------------- 1 | /manual.aux 2 | /manual.cp 3 | /manual.fn 4 | /manual.fns 5 | /manual.html 6 | /manual.info 7 | /manual.ky 8 | /manual.log 9 | /manual.pdf 10 | /manual.pg 11 | /manual.toc 12 | /manual.tp 13 | /manual.vr 14 | /manual/ 15 | -------------------------------------------------------------------------------- /dvl/examples/mandelbrot/Makefile: -------------------------------------------------------------------------------- 1 | mandelbrot.ghc-2.ghc_run: mandelbrot.ghc-2.hs 2 | ghc --make -O2 -XBangPatterns -rtsopts -fexcess-precision mandelbrot.ghc-2.hs -o mandelbrot.ghc-2.ghc_run 3 | 4 | bench: mandelbrot.ghc-2.ghc_run 5 | time ./mandelbrot.ghc-2.ghc_run 16000 > answer.pbm 6 | 7 | .PHONY: bench 8 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "support/rules"] 2 | path = support/rules 3 | url = git://github.com/axch/rules.git 4 | [submodule "testing"] 5 | path = testing 6 | url = git://github.com/axch/test-manager.git 7 | [submodule "support/pattern-case"] 8 | path = support/pattern-case 9 | url = git://github.com/axch/pattern-case.git 10 | -------------------------------------------------------------------------------- /vlad-manual/Makefile: -------------------------------------------------------------------------------- 1 | targets = manual.pdf manual.info manual.html 2 | 3 | all: $(targets) 4 | 5 | %.html: %.texi; $(MAKEINFO) --html --no-split $^ 6 | %.pdf: %.texi; env LC_ALL=C texi2pdf $^ 7 | 8 | clean: 9 | rm -f $(targets) 10 | rm -f manual.aux manual.cp manual.fn manual.fns manual.ky 11 | rm -f manual.log manual.pg manual.toc manual.tp manual.vr 12 | 13 | .PHONY: all clean 14 | -------------------------------------------------------------------------------- /haskell-fol/README: -------------------------------------------------------------------------------- 1 | cabal configure 2 | cabal build 3 | cabal install --user 4 | 5 | should build two executables, fol2haskell (the FOL to Haskell 6 | compiler), and fol2js (the FOL to Javascript compiler), and install 7 | them to $HOME/.cabal/bin, so that they become available from the 8 | command line. If you don't want to install them, you can find the 9 | executables somewhere in the dist/ directory. 10 | -------------------------------------------------------------------------------- /haskell-fol/examples/celestial.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 7 | 17 | 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /dvl/doc/boston-slug-talk-aug-2013/analyzed.fol: -------------------------------------------------------------------------------- 1 | ;; This is iterate, specialized to f being 2 | ;; (step c) and x having shape (R . R) 3 | (define (op-231 self-env count f-env x) 4 | (type env-226 real env-235 (cons real real) 5 | (cons real real)) 6 | (if (<= count 0) 7 | x 8 | ;; Calls itself because the arguments to 9 | ;; the recursive call have the same shapes 10 | (op-231 self-env (- count 1) 11 | f-env (op-23 f-env x)))) 12 | 13 | ;; This is (step c) specialized to c having shape 14 | ;; (R . R) and z having shape (R . R) 15 | (define (op-23 self-env z) 16 | (type env-235 (cons real real) 17 | (cons real real)) 18 | (op-423 ; complex + 19 | (env-235-c:+-env self-env) 20 | (op-249 ; complex * 21 | (env-235-c:*-env self-env) z z) 22 | (env-235-c self-env))) 23 | -------------------------------------------------------------------------------- /dvl/doc/boston-slug-talk-aug-2013/mandel.dvl: -------------------------------------------------------------------------------- 1 | ;;; Complex arithmetic library 2 | (define (c:+ z1 z2) 3 | (cons (+ (car z1) (car z2)) 4 | (+ (cdr z1) (cdr z2)))) 5 | 6 | (define (c:* z1 z2) 7 | (cons (- (* (car z1) (car z2)) 8 | (* (cdr z1) (cdr z2))) 9 | (+ (* (car z1) (cdr z2)) 10 | (* (cdr z1) (car z2))))) 11 | 12 | (define c:0 (cons (real 0) (real 0))) 13 | 14 | (define (magnitude z) 15 | (sqrt (+ (* (car z) (car z)) 16 | (* (cdr z) (cdr z))))) 17 | ;;; Iteration library 18 | (define (iterate count f x) 19 | (if (<= count 0) 20 | x 21 | (iterate (- count 1) f (f x)))) 22 | 23 | ;;; Mandelbrot set membership test 24 | (define ((step c) z) 25 | (c:+ (c:* z z) c)) 26 | 27 | (define (mandelbrot? c) 28 | (< (magnitude 29 | (iterate (real 400) (step c) c:0)) 30 | 2)) 31 | -------------------------------------------------------------------------------- /haskell-fol/examples/driver.js: -------------------------------------------------------------------------------- 1 | function force(thunk) 2 | { 3 | return thunk(); 4 | }; 5 | 6 | function constant_arg_for_dvl_stream(argument, dvl_stream) 7 | { 8 | function do_it(dvl_stream) 9 | { 10 | return [dvl_stream[0], 11 | function () { return do_it(dvl_stream[1](argument)) }]; 12 | }; 13 | return do_it(dvl_stream); 14 | }; 15 | 16 | function stream_for_each(f, stream) 17 | { 18 | return [f(stream[0]), 19 | function () { return stream_for_each(f, force(stream[1])) }]; 20 | }; 21 | 22 | function stream_take(count, stream) 23 | { 24 | if (count == 0) 25 | return stream; 26 | else 27 | return stream_take(count-1, force(stream[1])); 28 | }; 29 | 30 | function drive(count, step, dt) 31 | { 32 | return stream_take(count, 33 | constant_arg_for_dvl_stream(dt, (__main__())(step))); 34 | }; 35 | -------------------------------------------------------------------------------- /dvl/doc/adventures-talk-apr-2013/celestial.scm: -------------------------------------------------------------------------------- 1 | (define (potential-function objects) 2 | (lambda (positions) 3 | (potential 4 | (map update-position objects positions)))) 5 | 6 | (define (forces objects) 7 | (* -1 (gradient (potential-function objects) 8 | (map position objects)))) 9 | 10 | (define (state-derivative state) 11 | (let ((time (car state)) 12 | (objects (cdr state))) 13 | (cons 1 ; d(time) = 1 14 | (map make-object 15 | ;; d(masses) = 0 16 | (map (lambda (obj) 0) objects) 17 | ;; d(positions) = velocities 18 | (map velocity objects) 19 | ;; d(velocities) = forces / masses 20 | (map / (forces objects) 21 | (map mass objects)))))) 22 | 23 | (downsampled-stream 24 | (step-stream 25 | rk4 26 | state-derivative 27 | (cons 0 (list sun jupiter saturn 28 | uranus neptune))) 29 | 10000) 30 | -------------------------------------------------------------------------------- /dvl/doc/boston-slug-talk-aug-2013/mandel.js: -------------------------------------------------------------------------------- 1 | function fol_program(stdlib, foreign, heap) { 2 | "use asm"; 3 | var heap_view = new stdlib.Float32Array(heap); 4 | var sqrt = stdlib.Math.sqrt; 5 | function op_231(count, c_x, c_y, z_x, z_y) { 6 | count = +count; 7 | c_x = +c_x; 8 | c_y = +c_y; 9 | z_x = +z_x; 10 | z_y = +z_y; 11 | if (count <= 0.0) { 12 | heap_view[0] = z_x; 13 | heap_view[1] = z_y; 14 | return; 15 | } else { 16 | return op_231(count - 1.0, c_x, c_y, 17 | ((z_x*z_x - z_y*z_y) + c_x), 18 | ((z_x*z_y + z_y*z_x) + c_y)); 19 | } 20 | } 21 | 22 | function __main__(x, y) { 23 | x = +x; 24 | y = +y; 25 | var z_x = 0.0; 26 | var z_y = 0.0; 27 | op_231(400.0, x, y, 0.0, 0.0); 28 | z_x = +heap_view[0]; 29 | z_y = +heap_view[1]; 30 | return (sqrt(z_x*z_x + z_y*z_y) < 2.0)|0; 31 | } 32 | return __main__; 33 | } 34 | -------------------------------------------------------------------------------- /dvl/doc/boston-slug-talk-aug-2013/cognoscenti.txt: -------------------------------------------------------------------------------- 1 | One slide for the cognoscenti 2 | 3 | - Whole-program polyvariant flow analysis 4 | by abstract interpretation 5 | - Fine-grained abstract value domain (every 6 | closure body makes a distinct abstract value) 7 | - No bounds on the polyvariance 8 | - Imprecision introduced by programmer annotation 9 | - This is probably equivalent to 10 | - some form of online partial evaluation (with 11 | partially static data and closure 12 | environments) and/or 13 | - some form of (positive) supercompilation, but 14 | - If the analysis terminates, you have all the 15 | information you need. 16 | One more slide for the cognoscenti 17 | 18 | - Generate closure-converted intermediate 19 | language 20 | - This is now first-order, with all call sites 21 | known statically 22 | - Then beat it to death with standard 23 | optimizations 24 | - Inlining 25 | - Common subexpression elimination 26 | - Algebraic simplification 27 | - Dead code elimination 28 | - Scalar replacement of aggregates 29 | -------------------------------------------------------------------------------- /dvl/doc/adventures-talk-apr-2013/slides.txt: -------------------------------------------------------------------------------- 1 | References: 2 | 3 | Jeffrey Mark Siskind and Barak A. Pearlmutter, 4 | "Using Polyvariant Union-Free Flow Analysis to 5 | Compile a Higher-Order Functional Programming 6 | Language with a First-Class Derivative Operator 7 | to Efficient Fortran-like Code." Purdue 8 | University ECE Technical Report, 2008. 9 | http://docs.lib.purdue.edu/ecetr/367 10 | is the inspiration for this particular code 11 | 12 | Jones, Gomard, and Sestoft 1993 "Partial 13 | Evaluation and Automatic Program Generation" is a 14 | canonical book 15 | 16 | Neil Mitchell, "Rethinking Supercompilation", 17 | ICFP 2010 is the only comprehensible paper on 18 | supercompilation that I found 19 | 20 | Credits: 21 | 22 | I worked on this at the Hamilton Institute at the 23 | National University of Ireland, Maynooth 24 | 25 | With Barak A. Pearlmutter, Jeffrey Mark Siskind 26 | (Purdue University), Oleksandr Manzyuk, and David 27 | Rush. 28 | 29 | Now working at Docurated, a small but funded 30 | startup that is hiring awesome hackers (interns 31 | and full-time) 32 | -------------------------------------------------------------------------------- /haskell-fol/Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | -- ---------------------------------------------------------------------- 3 | -- Copyright 2010-2011 National University of Ireland. 4 | -- ---------------------------------------------------------------------- 5 | -- This file is part of DysVunctional Language. 6 | -- 7 | -- DysVunctional Language is free software; you can redistribute it and/or modify 8 | -- it under the terms of the GNU Affero General Public License as 9 | -- published by the Free Software Foundation, either version 3 of the 10 | -- License, or (at your option) any later version. 11 | -- 12 | -- DysVunctional Language is distributed in the hope that it will be useful, 13 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | -- GNU General Public License for more details. 16 | -- 17 | -- You should have received a copy of the GNU Affero General Public License 18 | -- along with DysVunctional Language. If not, see . 19 | -- ---------------------------------------------------------------------- 20 | 21 | import Distribution.Simple 22 | 23 | main = defaultMain 24 | -------------------------------------------------------------------------------- /dvl/examples/mandelbrot/README.md: -------------------------------------------------------------------------------- 1 | Drawing the Mandelbrot Set in Javascript 2 | ======================================== 3 | 4 | This example illustrates use of the [asm.js](http://asmjs.org/) 5 | backend for efficient client-side numerical computation. 6 | 7 | Caution: the asm.js backend hasn't been ironed out yet; at the moment, 8 | the output may still need to be manually post-edited sometimes. 9 | 10 | A Haskell program for the same job, from the [Computer Language Benchmarks 11 | Game](http://benchmarksgame.alioth.debian.org/u32/performance.php?test=mandelbrot), 12 | is retained for comparison in `mandelbrot.ghc-2.hs`. Unfortunately 13 | their performance cannot be compared directly because the Haskell 14 | benchmark uses short-circuiting, so they do not perform exactly the 15 | same computation. 16 | 17 | Instructions: 18 | 19 | 1. Generate the Mandelbrot tester function from its DVL program 20 | with 21 | 22 | ```scheme 23 | (fol->asm.js 24 | (fol-optimize 25 | (compile-to-fol 26 | (dvl-source "examples/mandelbrot/mandel.dvl"))) 27 | "examples/mandelbrot/mandel.js") 28 | ``` 29 | 30 | 2. Open `mandel.html` in your favorite web browser. 31 | 3. Then click "Go!". 32 | -------------------------------------------------------------------------------- /fol/examples/factorial.fol: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2013 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (begin 21 | (define (fiction m) 22 | (argument-types real real) 23 | (if (= m 0) 24 | 1 25 | (* m (fiction (- m 1))))) 26 | (fiction 4)) 27 | -------------------------------------------------------------------------------- /vl/test/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (load-relative "../../testing/load") 21 | 22 | (for-each load-relative-compiled 23 | '("utils" 24 | "vl-test" 25 | "post-processing-test")) 26 | -------------------------------------------------------------------------------- /dvl/doc/boston-slug-talk-aug-2013/credits.txt: -------------------------------------------------------------------------------- 1 | So, what do we have? 2 | 3 | Can write modular programs 4 | 5 | Let compiler specialize abstractions for speed 6 | 7 | On general programs, challenge is when to stop 8 | 9 | Prototype intended for numerical kernels 10 | - functional 11 | - not too complex 12 | 13 | Lots of caveats 14 | 15 | https://github.com/axch/dysvunctional-language 16 | Credits: 17 | 18 | I worked on this at the Hamilton Institute at the 19 | National University of Ireland, Maynooth 20 | 21 | With Barak A. Pearlmutter, Jeffrey Mark Siskind 22 | (Purdue University), Oleksandr Manzyuk, and David 23 | Rush. 24 | References: 25 | 26 | Jeffrey Mark Siskind and Barak A. Pearlmutter, 27 | "Using Polyvariant Union-Free Flow Analysis to 28 | Compile a Higher-Order Functional Programming 29 | Language with a First-Class Derivative Operator 30 | to Efficient Fortran-like Code." Purdue 31 | University ECE Technical Report, 2008. 32 | http://docs.lib.purdue.edu/ecetr/367 33 | is the inspiration for this particular code 34 | 35 | Jones, Gomard, and Sestoft 1993 "Partial 36 | Evaluation and Automatic Program Generation" is a 37 | canonical book 38 | 39 | Neil Mitchell, "Rethinking Supercompilation", 40 | ICFP 2010 is the only comprehensible paper on 41 | supercompilation that I found 42 | -------------------------------------------------------------------------------- /dvl/test/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (load-relative "../../testing/load") 21 | (load-relative-compiled "../../vl/test/utils") 22 | (load-relative-compiled "dvl-test") 23 | (load-relative-compiled "dvl-error-detection-test") 24 | -------------------------------------------------------------------------------- /dvl/examples/amazing-bug.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (((f x) g) y) 21 | (g (+ x y))) 22 | 23 | (define f-hat ((derivative f) 3.)) 24 | 25 | ((f-hat (f-hat exp)) 1.) ===> 1096.6331584284585 ; (exp 7) 26 | 27 | ;; N.B. This tickles a non-idempotence in fol-optimize. 28 | -------------------------------------------------------------------------------- /haskell-fol/fol2js.hs: -------------------------------------------------------------------------------- 1 | -- ---------------------------------------------------------------------- 2 | -- Copyright 2010-2011 National University of Ireland. 3 | -- ---------------------------------------------------------------------- 4 | -- This file is part of DysVunctional Language. 5 | -- 6 | -- DysVunctional Language is free software; you can redistribute it and/or modify 7 | -- it under the terms of the GNU Affero General Public License as 8 | -- published by the Free Software Foundation, either version 3 of the 9 | -- License, or (at your option) any later version. 10 | -- 11 | -- DysVunctional Language is distributed in the hope that it will be useful, 12 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | -- GNU General Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU Affero General Public License 17 | -- along with DysVunctional Language. If not, see . 18 | -- ---------------------------------------------------------------------- 19 | 20 | import FOL.Language.Pretty 21 | 22 | import FOL.Compiler.JavaScript.Parser 23 | import FOL.Compiler.JavaScript.CodeGen 24 | 25 | compile :: String -> String 26 | compile = pprint . compileProg . parse 27 | 28 | main :: IO () 29 | main = interact compile 30 | -------------------------------------------------------------------------------- /fol/fol: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2013 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of DysVunctional Language. 5 | ### 6 | ### DysVunctional Language is free software; you can redistribute it and/or modify 7 | ### it under the terms of the GNU Affero General Public License as 8 | ### published by the Free Software Foundation, either version 3 of the 9 | ### License, or (at your option) any later version. 10 | ### 11 | ### DysVunctional Language is distributed in the hope that it will be useful, 12 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ### GNU General Public License for more details. 15 | ### 16 | ### You should have received a copy of the GNU Affero General Public License 17 | ### along with DysVunctional Language. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | #!/bin/bash 21 | 22 | SELFDIR=$(dirname $0) 23 | 24 | if [ `uname -m` == 'x86_64' ]; then 25 | HEAP=150000 26 | else 27 | HEAP=6000 28 | fi 29 | 30 | exec mit-scheme --heap $HEAP --stack 2000 --batch-mode --no-init-file \ 31 | --load "${SELFDIR}/load.scm" --eval "(fol-main \"$*\")" 32 | -------------------------------------------------------------------------------- /dvl/stdlib/stdlib.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; -*- scheme -*- 21 | 22 | (include "basics.dvl") 23 | 24 | (include "vectors.dvl") 25 | 26 | (include "ad-structures.dvl") 27 | (include "ad-overloads.dvl") 28 | (include "forward-mode.dvl") 29 | (include "reverse-mode.dvl") 30 | 31 | (include "vlad-compatibility.dvl") 32 | -------------------------------------------------------------------------------- /dvl/dvl: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ### ---------------------------------------------------------------------- 4 | ### Copyright 2010-2011 National University of Ireland; 2013 Alexey Radul. 5 | ### ---------------------------------------------------------------------- 6 | ### This file is part of DysVunctional Language. 7 | ### 8 | ### DysVunctional Language is free software; you can redistribute it and/or modify 9 | ### it under the terms of the GNU Affero General Public License as 10 | ### published by the Free Software Foundation, either version 3 of the 11 | ### License, or (at your option) any later version. 12 | ### 13 | ### DysVunctional Language is distributed in the hope that it will be useful, 14 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ### GNU General Public License for more details. 17 | ### 18 | ### You should have received a copy of the GNU Affero General Public License 19 | ### along with DysVunctional Language. If not, see . 20 | ### ---------------------------------------------------------------------- 21 | 22 | SELFDIR=$(dirname $0) 23 | 24 | if [ `uname -m` == 'x86_64' ]; then 25 | HEAP=150000 26 | else 27 | HEAP=6000 28 | fi 29 | 30 | exec mit-scheme --heap $HEAP --stack 2000 --batch-mode --no-init-file \ 31 | --load "${SELFDIR}/load.scm" --eval "(dvl-main \"$*\")" 32 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2010-2011 National University of Ireland; 2013 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of DysVunctional Language. 5 | ### 6 | ### DysVunctional Language is free software; you can redistribute it and/or modify 7 | ### it under the terms of the GNU Affero General Public License as 8 | ### published by the Free Software Foundation, either version 3 of the 9 | ### License, or (at your option) any later version. 10 | ### 11 | ### DysVunctional Language is distributed in the hope that it will be useful, 12 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ### GNU General Public License for more details. 15 | ### 16 | ### You should have received a copy of the GNU Affero General Public License 17 | ### along with DysVunctional Language. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | clean: 21 | @find . -regextype posix-extended -regex ".*\.(bci|bin|com|ext)$$" -delete 22 | 23 | test: test-fol test-vl test-dvl 24 | 25 | test-fol: ; $(MAKE) -C fol test 26 | test-vl: ; $(MAKE) -C vl test 27 | test-dvl: ; $(MAKE) -C dvl test 28 | 29 | .PHONY: clean test test-fol test-vl test-dvl 30 | -------------------------------------------------------------------------------- /haskell-fol/examples/Makefile: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2013 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of DysVunctional Language. 5 | ### 6 | ### DysVunctional Language is free software; you can redistribute it and/or modify 7 | ### it under the terms of the GNU Affero General Public License as 8 | ### published by the Free Software Foundation, either version 3 of the 9 | ### License, or (at your option) any later version. 10 | ### 11 | ### DysVunctional Language is distributed in the hope that it will be useful, 12 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ### GNU General Public License for more details. 15 | ### 16 | ### You should have received a copy of the GNU Affero General Public License 17 | ### along with DysVunctional Language. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | FOLJS = $(shell which fol2js) 21 | 22 | celestial.js: celestial-no-fractions.fol 23 | ifneq (,$(strip $(FOLJS))) 24 | fol2js < celestial-no-fractions.fol > celestial.js 25 | else 26 | @echo No 'fol2js' executable found. 27 | @echo Run 'cabal configure && cabal build && cabal install' in the FOL root directory first. 28 | endif 29 | -------------------------------------------------------------------------------- /support/srfi-11.scm: -------------------------------------------------------------------------------- 1 | (declare (usual-integrations)) 2 | ;; This code is in the public domain. 3 | 4 | (define-syntax let-values 5 | (syntax-rules () 6 | ((let-values (?binding ...) ?body0 ?body1 ...) 7 | (let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...))) 8 | 9 | ((let-values "bind" () ?tmps ?body) 10 | (let ?tmps ?body)) 11 | 12 | ((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body) 13 | (let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body)) 14 | 15 | ((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body) 16 | (call-with-values 17 | (lambda () ?e0) 18 | (lambda ?args 19 | (let-values "bind" ?bindings ?tmps ?body)))) 20 | 21 | ((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body) 22 | (let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body)) 23 | 24 | ((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body) 25 | (call-with-values 26 | (lambda () ?e0) 27 | (lambda (?arg ... . x) 28 | (let-values "bind" ?bindings (?tmp ... (?a x)) ?body)))))) 29 | 30 | (define-syntax let*-values 31 | (syntax-rules () 32 | ((let*-values () ?body0 ?body1 ...) 33 | (begin ?body0 ?body1 ...)) 34 | 35 | ((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...) 36 | (let-values (?binding0) 37 | (let*-values (?binding1 ...) ?body0 ?body1 ...))))) 38 | -------------------------------------------------------------------------------- /dvl/Makefile: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2013 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of DysVunctional Language. 5 | ### 6 | ### DysVunctional Language is free software; you can redistribute it and/or modify 7 | ### it under the terms of the GNU Affero General Public License as 8 | ### published by the Free Software Foundation, either version 3 of the 9 | ### License, or (at your option) any later version. 10 | ### 11 | ### DysVunctional Language is distributed in the hope that it will be useful, 12 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ### GNU General Public License for more details. 15 | ### 16 | ### You should have received a copy of the GNU Affero General Public License 17 | ### along with DysVunctional Language. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | ARCH = $(shell uname -m) 21 | 22 | ifeq ($(ARCH), x86_64) 23 | HEAP = 100000 24 | else 25 | HEAP = 6000 26 | endif 27 | 28 | test: 29 | mit-scheme --compiler --heap $(HEAP) --stack 2000 --batch-mode --no-init-file \ 30 | --eval '(set! load/suppress-loading-message? #t)' \ 31 | --eval '(begin (load "load") (load "test/load") (run-tests-and-exit))' 32 | 33 | .PHONY: test 34 | -------------------------------------------------------------------------------- /dvl/doc/adventures-talk-apr-2013/mandelbrot.scm: -------------------------------------------------------------------------------- 1 | ;;; Complex arithmetic library 2 | (define (c:+ z1 z2) 3 | (cons (+ (car z1) (car z2)) 4 | (+ (cdr z1) (cdr z2)))) 5 | 6 | (define (c:* z1 z2) 7 | (cons (- (* (car z1) (car z2)) 8 | (* (cdr z1) (cdr z2))) 9 | (+ (* (car z1) (cdr z2)) 10 | (* (cdr z1) (car z2))))) 11 | 12 | (define c:0 (cons 0 0)) 13 | 14 | (define (magnitude z) 15 | (sqrt (+ (* (car z) (car z)) 16 | (* (cdr z) (cdr z))))) 17 | ;;; Iteration library 18 | (define (iterate count f x) 19 | (if (<= count 0) 20 | x 21 | (iterate (- count 1) f (f x)))) 22 | 23 | ;;; Mandelbrot set membership test 24 | (define ((step c) z) 25 | (c:+ (c:* z z) c)) 26 | 27 | (define (mandelbrot? c) 28 | (< (magnitude (iterate 100 (step c) c:0)) 2)) 29 | 30 | ;;; Example 31 | (mandelbrot? (cons 0.5 0.7)) 32 | ;;; Compiled (variables renamed for clarity) 33 | (define (iteration count c-real c-imag 34 | z-real z-imag) 35 | (if (<= count 0) 36 | (values z-real z-imag) 37 | (iteration (- count 1) 38 | c-real c-imag 39 | (+ (- (* z-real z-real) 40 | (* z-imag z-imag)) 41 | c-real) 42 | (+ (+ (* z-real z-imag) 43 | (* z-imag z-real)) 44 | c-imag)))) 45 | (let-values 46 | (((ans-real ans-imag) 47 | (iteration 100 .5 .7 0 0))) 48 | (< (sqrt 49 | (+ (* ans-real ans-real) 50 | (* ans-imag ans-imag))) 51 | 2)) 52 | -------------------------------------------------------------------------------- /fol/Makefile: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2013 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of DysVunctional Language. 5 | ### 6 | ### DysVunctional Language is free software; you can redistribute it and/or modify 7 | ### it under the terms of the GNU Affero General Public License as 8 | ### published by the Free Software Foundation, either version 3 of the 9 | ### License, or (at your option) any later version. 10 | ### 11 | ### DysVunctional Language is distributed in the hope that it will be useful, 12 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ### GNU General Public License for more details. 15 | ### 16 | ### You should have received a copy of the GNU Affero General Public License 17 | ### along with DysVunctional Language. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | ARCH = $(shell uname -m) 21 | 22 | ifeq ($(ARCH), x86_64) 23 | HEAP = 100000 24 | else 25 | HEAP = 6000 26 | endif 27 | 28 | test: 29 | mit-scheme --compiler --heap $(HEAP) --stack 2000 --batch-mode --no-init-file \ 30 | --eval '(set! load/suppress-loading-message? #t)' \ 31 | --eval '(begin (load "load") (load "test/load") ((access run-tests-and-exit fol-environment)))' 32 | 33 | .PHONY: test 34 | -------------------------------------------------------------------------------- /dvl/dvl-watch-benchmark: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ### ---------------------------------------------------------------------- 4 | ### Copyright 2010-2011 National University of Ireland. 5 | ### ---------------------------------------------------------------------- 6 | ### This file is part of DysVunctional Language. 7 | ### 8 | ### DysVunctional Language is free software; you can redistribute it and/or modify 9 | ### it under the terms of the GNU Affero General Public License as 10 | ### published by the Free Software Foundation, either version 3 of the 11 | ### License, or (at your option) any later version. 12 | ### 13 | ### DysVunctional Language is distributed in the hope that it will be useful, 14 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ### GNU General Public License for more details. 17 | ### 18 | ### You should have received a copy of the GNU Affero General Public License 19 | ### along with DysVunctional Language. If not, see . 20 | ### ---------------------------------------------------------------------- 21 | 22 | ulimit -t 600 23 | 24 | SELFDIR=$(dirname $0) 25 | 26 | if [ `uname -m` == 'x86_64' ]; then 27 | HEAP=160000 28 | STACK=40000 29 | else 30 | HEAP=6000 31 | STACK=2000 32 | fi 33 | 34 | mkdir -p $SELFDIR/benchmarks 35 | exec mit-scheme --heap $HEAP --stack $STACK --batch-mode --no-init-file --load "${SELFDIR}/load.scm" --eval "(begin (pp (dvl-benchmark \"$1\")) (%exit 0))" < /dev/null 36 | -------------------------------------------------------------------------------- /dvl/doc/boston-slug-talk-aug-2013/Makefile: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2013 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of DysVunctional Language. 5 | ### 6 | ### DysVunctional Language is free software; you can redistribute it and/or modify 7 | ### it under the terms of the GNU Affero General Public License as 8 | ### published by the Free Software Foundation, either version 3 of the 9 | ### License, or (at your option) any later version. 10 | ### 11 | ### DysVunctional Language is distributed in the hope that it will be useful, 12 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ### GNU General Public License for more details. 15 | ### 16 | ### You should have received a copy of the GNU Affero General Public License 17 | ### along with DysVunctional Language. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | FONT1=Courier-Bold24 21 | 22 | %.ps: % 23 | enscript -r -M letter --header=$(ENSCRIPT_HEADER) -E$(ENSCRIPT_HIGHLIGHT_LANG) --color --font=$(FONT1) -o $@ $< 24 | 25 | %.dvl.ps: ENSCRIPT_HIGHLIGHT_LANG=scheme 26 | %.fol.ps: ENSCRIPT_HIGHLIGHT_LANG=scheme 27 | 28 | ENSCRIPT_HEADER='||$$n ($$%/$$=)' 29 | %.txt.ps: ENSCRIPT_HEADER= 30 | 31 | %.pdf: %.ps 32 | ps2pdf $< $@ 33 | 34 | presentation.pdf: mandel.js.pdf mandel.dvl.pdf cognoscenti.txt.pdf analyzed.fol.pdf credits.txt.pdf 35 | pdfjoin -o $@ $+ 36 | -------------------------------------------------------------------------------- /vl/vl: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ### ---------------------------------------------------------------------- 4 | ### Copyright 2010-2011 National University of Ireland. 5 | ### ---------------------------------------------------------------------- 6 | ### This file is part of DysVunctional Language. 7 | ### 8 | ### DysVunctional Language is free software; you can redistribute it and/or modify 9 | ### it under the terms of the GNU Affero General Public License as 10 | ### published by the Free Software Foundation, either version 3 of the 11 | ### License, or (at your option) any later version. 12 | ### 13 | ### DysVunctional Language is distributed in the hope that it will be useful, 14 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ### GNU General Public License for more details. 17 | ### 18 | ### You should have received a copy of the GNU Affero General Public License 19 | ### along with DysVunctional Language. If not, see . 20 | ### ---------------------------------------------------------------------- 21 | 22 | SELFDIR=$(dirname $0) 23 | 24 | if [ `uname -m` == 'x86_64' ]; then 25 | HEAP=50000 26 | else 27 | HEAP=6000 28 | fi 29 | 30 | # Explicit tail call here forwards exit state to the parent better 31 | # (notably, an MIT-Scheme run-shell-command calling this script will 32 | # error out in the subsidiary mit-scheme is killed, whereas it would 33 | # return normally otherwise). 34 | exec mit-scheme --heap $HEAP --batch-mode --no-init-file --load "${SELFDIR}/load.scm" --eval "(begin (vl-run-file \"$1\") (%exit 0))" 35 | -------------------------------------------------------------------------------- /haskell-fol/fol.cabal: -------------------------------------------------------------------------------- 1 | -- ---------------------------------------------------------------------- 2 | -- Copyright 2010-2011 National University of Ireland. 3 | -- ---------------------------------------------------------------------- 4 | -- This file is part of DysVunctional Language. 5 | -- 6 | -- DysVunctional Language is free software; you can redistribute it and/or modify 7 | -- it under the terms of the GNU Affero General Public License as 8 | -- published by the Free Software Foundation, either version 3 of the 9 | -- License, or (at your option) any later version. 10 | -- 11 | -- DysVunctional Language is distributed in the hope that it will be useful, 12 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | -- GNU General Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU Affero General Public License 17 | -- along with DysVunctional Language. If not, see . 18 | -- ---------------------------------------------------------------------- 19 | 20 | Name: FOL 21 | Version: 0.2 22 | Build-Type: Simple 23 | Cabal-Version: >= 1.2 24 | 25 | Executable fol2hs 26 | Build-Depends: base, mtl, pretty, parsec, containers, syb, uniplate 27 | Main-Is: fol2hs.hs 28 | Extensions: PatternGuards 29 | ghc-options: -Wall -Werror -fno-warn-name-shadowing 30 | 31 | Executable fol2js 32 | Build-Depends: base, mtl, pretty, parsec, containers, syb, uniplate 33 | Main-Is: fol2js.hs 34 | Extensions: PatternGuards 35 | ghc-options: -Wall -Werror -fno-warn-name-shadowing 36 | -------------------------------------------------------------------------------- /dvl/examples/example-opt.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (argmin f x0) 21 | (let loop ((x x0)) 22 | (let ((grad ((gradient f) x))) 23 | (if (small? grad) 24 | x 25 | (let ((line (lambda (d) (+ x (* d grad))))) 26 | (loop (line (line-search (compose f line))))))))) 27 | 28 | (define (line-search f) 29 | ;; For example, one step of Newton's method, involves first and 30 | ;; second derivatives of f. 31 | ) 32 | 33 | ;; The optimization routine is generic 34 | ;; The line search routine is generic 35 | ;; They are independent 36 | ;; Etc. 37 | -------------------------------------------------------------------------------- /fol/test/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (load-relative "../../testing/load" fol-environment) 21 | 22 | (for-each 23 | (lambda (file) 24 | (load-relative-compiled file fol-environment)) 25 | '("utils" 26 | "fol-test" 27 | "cse-test" 28 | "interactions-test" 29 | "backend-test")) 30 | 31 | (let ((client-environment (the-environment))) 32 | (for-each 33 | (lambda (export) 34 | (environment-define 35 | client-environment export (environment-lookup fol-environment export))) 36 | '(;; Testing adverbs 37 | carefully 38 | meticulously 39 | ))) 40 | -------------------------------------------------------------------------------- /dvl/examples/amazing-bug-4.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; The same as amazing-bug-3.dvl, but supplies the arguments to f in 21 | ;;; the opposite order. It is clear that the answers should be 22 | ;;; identical, and makes it easier to check the correctness of the 23 | ;;; answer. 24 | 25 | (define (f recipient) 26 | (lambda (x) 27 | (recipient 28 | (lambda (y) (sin (* x y))) 29 | (lambda (g) 30 | (lambda (z) 31 | (g (+ x z))))))) 32 | 33 | (define recip (lambda (g-hat f-hat) 34 | ((f-hat g-hat) 3.14159))) 35 | 36 | ((derivative (f recip)) 3) 37 | ===> 8.32914929893078 38 | -------------------------------------------------------------------------------- /dvl/examples/unknown-derivatives.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; This is an example of a program that takes a statically-unknown 21 | ;;; number of derivatives. Ideally, an AD system that tries to 22 | ;;; migrate the AD transforms to compile time should not barf on this, 23 | ;;; but emit code that does AD at runtime (perhaps with a warning that 24 | ;;; such code will be slow). 25 | 26 | (define (foo f x) 27 | (let loop ((n (real 0)) 28 | (nth-derivative f)) 29 | (if (positive? (nth-derivative x)) 30 | n 31 | (loop (+ n 1) (derivative nth-derivative))))) 32 | 33 | (foo sin (real 5)) 34 | -------------------------------------------------------------------------------- /dvl/examples/amazing-bug-2.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; What should happen if we differentiate a function that returns a 21 | ;;; pair of functions? And then tries to confuse their perturbations 22 | ;;; with each other like the amazing-bug trick? They should refuse to 23 | ;;; confuse, and be separate. 24 | 25 | (define (f x) 26 | (cons (lambda (y) (sin (* x y))) 27 | (lambda (g) 28 | (lambda (z) 29 | (g (+ x z)))))) 30 | 31 | (let (((cons g-hat f-hat) ((derivative f) 3))) 32 | ((f-hat g-hat) 3.14159)) 33 | ===> 8.504448924508122 34 | 35 | ; ((lambda (y) (- (cos (* 3 y)) (* 3 y (sin (* 3 y))))) (+ 3.14159 3)) 36 | -------------------------------------------------------------------------------- /fol/runtime.sc: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;;; Stalin runtime system 21 | 22 | ;;; Here is the complement of definitions that needs to be loaded into 23 | ;;; Stalin in order to compile FOL code. 24 | 25 | (define (real x) 26 | x) 27 | 28 | (define read-real read) 29 | 30 | (define (write-real x) 31 | (write x) 32 | (newline) 33 | x) 34 | 35 | (define *the-gensym* 0) 36 | 37 | (define (gensym) 38 | (set! *the-gensym* (+ *the-gensym* 1)) 39 | (- *the-gensym* 1)) 40 | 41 | (define (gensym= gensym1 gensym2) 42 | (= gensym1 gensym2)) 43 | 44 | (define values list) 45 | 46 | (define (call-with-values values receiver) 47 | (apply receiver values)) 48 | -------------------------------------------------------------------------------- /dvl/examples/sqrt.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (nr-sqrt x) 21 | (letrec ((loop (lambda (y) 22 | (let ((y-prime (- y (/ (- (* y y) x) (+ y y))))) 23 | (if (<= (abs (- y y-prime)) 1e-5) 24 | y 25 | (loop y-prime)))))) 26 | (loop (- (+ x 1.0) x)))) 27 | 28 | ((derivative nr-sqrt) 4) 29 | 30 | 31 | #| 32 | (define raw-fol 33 | (show-time (lambda () (compile-to-raw-fol (dvl-source "examples/sqrt.dvl"))))) 34 | 35 | (define hairy-optimal (show-time (lambda () (fol-optimize raw-fol)))) 36 | 37 | (define done 38 | (show-time (lambda () (compile-to-fol (dvl-source "examples/sqrt.dvl"))))) 39 | |# 40 | -------------------------------------------------------------------------------- /dvl/dvl-benchmarks: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ### ---------------------------------------------------------------------- 4 | ### Copyright 2010-2011 National University of Ireland. 5 | ### ---------------------------------------------------------------------- 6 | ### This file is part of DysVunctional Language. 7 | ### 8 | ### DysVunctional Language is free software; you can redistribute it and/or modify 9 | ### it under the terms of the GNU Affero General Public License as 10 | ### published by the Free Software Foundation, either version 3 of the 11 | ### License, or (at your option) any later version. 12 | ### 13 | ### DysVunctional Language is distributed in the hope that it will be useful, 14 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ### GNU General Public License for more details. 17 | ### 18 | ### You should have received a copy of the GNU Affero General Public License 19 | ### along with DysVunctional Language. If not, see . 20 | ### ---------------------------------------------------------------------- 21 | 22 | time ./dvl-watch-benchmark sqrt 23 | time ./dvl-watch-benchmark saddle-FF 24 | time ./dvl-watch-benchmark saddle-FR 25 | # time ./dvl-watch-benchmark saddle-RF 26 | # time ./dvl-watch-benchmark saddle-RR 27 | time ./dvl-watch-benchmark particle-FF 28 | time ./dvl-watch-benchmark particle-FR 29 | time ./dvl-watch-benchmark particle-RF 30 | time ./dvl-watch-benchmark particle-RR 31 | time ./dvl-watch-benchmark prob-lambda-F 32 | # time ./dvl-watch-benchmark prob-lambda-R 33 | time ./dvl-watch-benchmark prob-prolog-F 34 | time ./dvl-watch-benchmark prob-prolog-R 35 | time ./dvl-watch-benchmark backprop-F 36 | # time ./dvl-watch-benchmark backprop-R 37 | -------------------------------------------------------------------------------- /dvl/examples/runge-kutta/integrations.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (include "runge-kutta.dvl") 21 | 22 | (define (exp-state-deriv (cons t y)) 23 | (cons 1 y)) 24 | 25 | (define exp-init (list (real 0) (real 1))) 26 | 27 | (define exp-euler (step-stream naive-euler exp-state-deriv exp-init)) 28 | (define exp-rk4 (step-stream rk4 exp-state-deriv exp-init)) 29 | 30 | (define (sin-state-deriv (list t y y-prime)) 31 | (list 1 y-prime (- 0 y))) 32 | 33 | (define sin-init (list (real 0) (real 0) (real 1))) 34 | 35 | (define sin-euler (step-stream naive-euler sin-state-deriv sin-init)) 36 | (define sin-rk4 (step-stream rk4 sin-state-deriv sin-init)) 37 | 38 | (list exp-euler exp-rk4 sin-euler sin-rk4) 39 | -------------------------------------------------------------------------------- /dvl/examples/sqrt-again.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (include "iterate-to-numeric-fix.dvl") 21 | 22 | (define (heron-sqrt x) 23 | (iterate-to-numeric-fix (lambda (y) (/ (+ y (/ x y)) 2)) 1.)) 24 | 25 | (heron-sqrt 4.) ===> 2.000000000000002 26 | (heron-sqrt 9.) ===> 3.0 27 | (heron-sqrt 16.) ===> 4.0 28 | 29 | ;;; TODO These tickle the bug that the inliner is not actually 30 | ;;; idempotent, even though it says it is. (Don't forget to check 31 | ;;; that dvl-test.scm loads this file before re-enabling these). 32 | ;; ((derivative heron-sqrt) 4.) ===> 0.25 33 | ;; ((derivative heron-sqrt) 9.) ===> 0.16666666666666666 34 | 35 | ;; ((derivative (derivative heron-sqrt)) 4.) ===> -.03125 36 | ;; ((derivative (derivative heron-sqrt)) 9.) ===> -.00390625 37 | 38 | -------------------------------------------------------------------------------- /fol/todo.txt: -------------------------------------------------------------------------------- 1 | - Do I want to make all the analysis stages treat the entry point 2 | as yet another definition? 3 | - Do I want to define a general destructurer of definitions, instead 4 | of all these rules? 5 | 6 | NB: SRA can remove call graph edges by eliminating contentless 7 | expressions that contain calls to procedures. However, all 8 | procedures are contentful, because otherwise the code generator 9 | would not have emitted them. Does the code generator emit 10 | expressions that request some content and then throw it away? In 11 | any case, there are FOL programs where SRA exposes work for 12 | inlining; should I explain this? Should I explain that VL and DVL 13 | do not emit such programs? 14 | 15 | NB: The reason that some of my recursions are broken into expression 16 | loops and a toplevel crunch is that the top level is the only 17 | place that introduces bindings with letrec scope. 18 | 19 | NB: INTERPROCEDURAL-DEAD-CODE-ELIMINATION is solving the following 20 | liveness equations: TODO 21 | 22 | ---------------------------------------------------------------------- 23 | 24 | Interprocedural must-alias analysis? 25 | - Can this collapse identical perturbations and recover tower mode on 26 | (D (D (lambda (x) ...)))? 27 | - Can this collapse primals and recover stack tangent mode? 28 | 29 | 30 | Sussman's example of where differentiating functions that output 31 | functions is useful: 32 | 33 | (define (((delta eta) f) q) 34 | (let ((g (lambda (eps) (f (+ q (* eps eta)))))) 35 | ((D g) 0))) 36 | 37 | ; Nonsense useage example: 38 | ((((delta cos) D) square) 3) 39 | 40 | A good testing strategy is to differentiate (lambda (x) (/ (f x) (f 41 | x))) for some suitably horrible f many times. 42 | 43 | Generate syntax checkers from the grammars? Generate random example 44 | programs from the grammars? 45 | -------------------------------------------------------------------------------- /dvl/doc/boston-slug-talk-aug-2013/mandel.html: -------------------------------------------------------------------------------- 1 | 2 | 20 | 21 | 22 | 23 | Boston Scheme and Lisp Demo 24 | 25 | 26 | 27 | 34 | 35 |
36 |

Mandelbrot Set in Pure Javascript

37 |

(don't worry, the Lisp will appear soon)

38 |
39 |
40 |
ResolutionMflopsTime (ms)
41 |
42 | 43 |
44 | 45 | 46 | -------------------------------------------------------------------------------- /dvl/doc/adventures-talk-apr-2013/Makefile: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2013 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of DysVunctional Language. 5 | ### 6 | ### DysVunctional Language is free software; you can redistribute it and/or modify 7 | ### it under the terms of the GNU Affero General Public License as 8 | ### published by the Free Software Foundation, either version 3 of the 9 | ### License, or (at your option) any later version. 10 | ### 11 | ### DysVunctional Language is distributed in the hope that it will be useful, 12 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ### GNU General Public License for more details. 15 | ### 16 | ### You should have received a copy of the GNU Affero General Public License 17 | ### along with DysVunctional Language. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | %.ps: %.txt 21 | enscript -r -M letter --highlight --color -fCourier-Bold24 -o $@ $< 22 | 23 | celestial-out.ps: celestial-out.scm 24 | enscript -M letter --highlight --color -fCourier-Bold12 -U 2 --nup-xpad=0 --nup-ypad=0 -o $@ $< 25 | 26 | %.ps: %.scm 27 | enscript -r -M letter --highlight --color -fCourier-Bold24 -o $@ $< 28 | 29 | %.pdf: %.ps 30 | ps2pdf $< $@ 31 | 32 | presentation.pdf: mandelbrot.pdf celestial.pdf celestial-out.pdf analysis.pdf slides.pdf 33 | pdfjoin -o $@ mandelbrot.pdf celestial.pdf celestial-out.pdf - celestial.pdf 1 analysis.pdf slides.pdf 34 | 35 | transparencies.pdf: mandelbrot.pdf celestial.pdf celestial-out.pdf analysis.pdf slides.pdf 36 | pdfjoin -o $@ mandelbrot.pdf celestial.pdf - celestial-out.pdf 1-4 analysis.pdf slides.pdf 37 | -------------------------------------------------------------------------------- /dvl/examples/amazing-bug-5.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (church-output f) 21 | (lambda (x) 22 | (lambda (recipient) 23 | (recipient (f x))))) 24 | 25 | (define (continue x) 26 | (* x x)) 27 | 28 | (continue ((derivative sin) 1.)) 29 | ===> .2919265817264289 30 | ; (* (cos 1) (cos 1)) 31 | 32 | (((derivative (church-output sin)) 1.) continue) 33 | ===> .9092974268256818 34 | 35 | (define (flip f) 36 | (lambda (x) 37 | (lambda (y) 38 | ((f y) x)))) 39 | 40 | ; (((derivative f) x) y) === ((derivative ((flip f) y)) x) 41 | 42 | ((derivative ((flip (church-output sin)) continue)) 1.) 43 | ===> .9092974268256818 44 | 45 | ; ((flip (church-output sin)) continue) = (lambda (x) (* (sin x) (sin x))) 46 | 47 | ((derivative (lambda (x) (* (sin x) (sin x)))) 1.) 48 | ===> .9092974268256818 49 | ; (* 2 (sin 1) (cos 1)) 50 | -------------------------------------------------------------------------------- /dvl/doc/adventures-talk-apr-2013/mandelbrot.vl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2013 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (car (cons x y)) x) 21 | (define (cdr (cons x y)) y) 22 | 23 | (define (c:+ z1 z2) 24 | (cons (+ (car z1) (car z2)) 25 | (+ (cdr z1) (cdr z2)))) 26 | 27 | (define (c:* z1 z2) 28 | (cons (- (* (car z1) (car z2)) 29 | (* (cdr z1) (cdr z2))) 30 | (+ (* (car z1) (cdr z2)) 31 | (* (cdr z1) (car z2))))) 32 | 33 | (define c:0 (cons (real 0) (real 0))) 34 | 35 | (define (magnitude z) 36 | (sqrt (+ (* (car z) (car z)) 37 | (* (cdr z) (cdr z))))) 38 | 39 | (define (iterate count f x) 40 | (if (<= count 0) 41 | x 42 | (iterate (- count 1) f (f x)))) 43 | 44 | (define ((step c) z) 45 | (c:+ (c:* z z) c)) 46 | 47 | (define (mandelbrot? c) 48 | (< (magnitude (iterate (real 100) (step c) c:0)) 2)) 49 | 50 | (mandelbrot? (cons (real 0.5) (real 0.7))) 51 | -------------------------------------------------------------------------------- /vl/Makefile: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2010-2011 National University of Ireland, 2013 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of DysVunctional Language. 5 | ### 6 | ### DysVunctional Language is free software; you can redistribute it and/or modify 7 | ### it under the terms of the GNU Affero General Public License as 8 | ### published by the Free Software Foundation, either version 3 of the 9 | ### License, or (at your option) any later version. 10 | ### 11 | ### DysVunctional Language is distributed in the hope that it will be useful, 12 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ### GNU General Public License for more details. 15 | ### 16 | ### You should have received a copy of the GNU Affero General Public License 17 | ### along with DysVunctional Language. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | ARCH = $(shell uname -m) 21 | 22 | ifeq ($(ARCH), x86_64) 23 | HEAP = 100000 24 | else 25 | HEAP = 6000 26 | endif 27 | 28 | test: 29 | mit-scheme --compiler --heap $(HEAP) --stack 2000 --batch-mode --no-init-file \ 30 | --eval '(set! load/suppress-loading-message? #t)' \ 31 | --eval '(begin (load "load") (load "test/load") (run-tests-and-exit))' 32 | 33 | FILES = examples/small.vl abstract-eval.scm code-generator.scm macro.scm eval.scm primitives.scm syntax.scm data.scm env.scm analysis.scm abstract-values.scm nomenclature.scm load.scm 34 | 35 | workbook: $(FILES) 36 | enscript -M a4 -fCourier-Bold12 -o workbook-a4.ps --file-align=2 README --color --highlight $(FILES) 37 | enscript -M letter -fCourier-Bold12 -o workbook-letter.ps --file-align=2 README --color --highlight $(FILES) 38 | 39 | .PHONY: workbook test 40 | -------------------------------------------------------------------------------- /haskell-fol/FOL/Language/Pretty.hs: -------------------------------------------------------------------------------- 1 | -- ---------------------------------------------------------------------- 2 | -- Copyright 2010-2011 National University of Ireland. 3 | -- ---------------------------------------------------------------------- 4 | -- This file is part of DysVunctional Language. 5 | -- 6 | -- DysVunctional Language is free software; you can redistribute it and/or modify 7 | -- it under the terms of the GNU Affero General Public License as 8 | -- published by the Free Software Foundation, either version 3 of the 9 | -- License, or (at your option) any later version. 10 | -- 11 | -- DysVunctional Language is distributed in the hope that it will be useful, 12 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | -- GNU General Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU Affero General Public License 17 | -- along with DysVunctional Language. If not, see . 18 | -- ---------------------------------------------------------------------- 19 | 20 | {-# LANGUAGE NoImplicitPrelude #-} 21 | module FOL.Language.Pretty 22 | ( Pretty 23 | , pp 24 | , real 25 | , pprint 26 | , sepMap 27 | , ppList 28 | , symbol 29 | , ppForm 30 | , module Text.PrettyPrint 31 | ) 32 | where 33 | 34 | import FOL.Language.Common 35 | 36 | import Text.PrettyPrint 37 | 38 | class Pretty a where 39 | pp :: a -> Doc 40 | 41 | real :: Real -> Doc 42 | real = double 43 | 44 | pprint :: Pretty a => a -> String 45 | pprint = render . pp 46 | 47 | sepMap :: (a -> Doc) -> [a] -> Doc 48 | sepMap f = sep . map f 49 | 50 | ppList :: [Doc] -> Doc 51 | ppList = parens . sep 52 | 53 | symbol :: String -> Doc 54 | symbol = text 55 | 56 | ppForm :: Pretty a => String -> [a] -> Doc 57 | ppForm name xs = ppList $ symbol name : map pp xs 58 | 59 | instance Pretty Name where 60 | pp (Name n) = symbol n 61 | -------------------------------------------------------------------------------- /haskell-fol/FOL/Language/Unique.hs: -------------------------------------------------------------------------------- 1 | -- ---------------------------------------------------------------------- 2 | -- Copyright 2010-2011 National University of Ireland. 3 | -- ---------------------------------------------------------------------- 4 | -- This file is part of DysVunctional Language. 5 | -- 6 | -- DysVunctional Language is free software; you can redistribute it and/or modify 7 | -- it under the terms of the GNU Affero General Public License as 8 | -- published by the Free Software Foundation, either version 3 of the 9 | -- License, or (at your option) any later version. 10 | -- 11 | -- DysVunctional Language is distributed in the hope that it will be useful, 12 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | -- GNU General Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU Affero General Public License 17 | -- along with DysVunctional Language. If not, see . 18 | -- ---------------------------------------------------------------------- 19 | 20 | {-# LANGUAGE NoImplicitPrelude #-} 21 | module FOL.Language.Unique where 22 | 23 | import FOL.Language.Common 24 | 25 | import Control.Monad.State 26 | 27 | type Unique = State Int 28 | 29 | evalUnique :: Unique a -> a 30 | evalUnique = flip evalState 0 31 | 32 | uniqueName :: String -> Unique Name 33 | uniqueName prefix = do i <- get 34 | let name = prefix ++ "-" ++ show i 35 | put (succ i) 36 | return (Name name) 37 | 38 | -- type UniqueT = StateT Int 39 | 40 | -- evalUniqueT :: Monad m => UniqueT m a -> m a 41 | -- evalUniqueT = flip evalStateT 0 42 | 43 | -- uniqueName :: Monad m => String -> UniqueT m Name 44 | -- uniqueName prefix = do i <- get 45 | -- let name = prefix ++ "-" ++ show i 46 | -- put (succ i) 47 | -- return (Name name) 48 | -------------------------------------------------------------------------------- /haskell-fol/FOL/Language/Common.hs: -------------------------------------------------------------------------------- 1 | -- ---------------------------------------------------------------------- 2 | -- Copyright 2010-2011 National University of Ireland. 3 | -- ---------------------------------------------------------------------- 4 | -- This file is part of DysVunctional Language. 5 | -- 6 | -- DysVunctional Language is free software; you can redistribute it and/or modify 7 | -- it under the terms of the GNU Affero General Public License as 8 | -- published by the Free Software Foundation, either version 3 of the 9 | -- License, or (at your option) any later version. 10 | -- 11 | -- DysVunctional Language is distributed in the hope that it will be useful, 12 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | -- GNU General Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU Affero General Public License 17 | -- along with DysVunctional Language. If not, see . 18 | -- ---------------------------------------------------------------------- 19 | 20 | {-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, TypeOperators, MultiParamTypeClasses #-} 21 | module FOL.Language.Common 22 | ( Real 23 | , Name (..) 24 | , primitives 25 | , compose 26 | , (:<:) (..) 27 | , module Prelude 28 | ) 29 | where 30 | 31 | import Data.Data 32 | 33 | import Prelude hiding (Real) 34 | 35 | type Real = Double 36 | 37 | data Name = Name String deriving (Eq, Ord, Show, Typeable, Data) 38 | 39 | primitives :: [Name] 40 | primitives 41 | = map Name [ "abs", "exp", "log" 42 | , "sin", "cos", "tan" 43 | , "asin", "acos", "sqrt", "real" 44 | , "+" , "-", "*", "/", "atan", "expt" 45 | , "zero?", "positive?", "negative?" 46 | , "<", "<=", ">", ">=", "=" 47 | ] 48 | 49 | compose :: [a -> a] -> a -> a 50 | compose = foldr (.) id 51 | 52 | class sub :<: sup where 53 | inj :: sub -> sup 54 | -------------------------------------------------------------------------------- /dvl/examples/celestial/README.md: -------------------------------------------------------------------------------- 1 | Motions of the Planets, with Modularity 2 | ======================================= 3 | 4 | This is the most elaborate DVL exmaple. What we have here is a 5 | program to integrate the motions of the four Jovian planets around the 6 | Sun. There isn't much here in the way of fancy numerical 7 | methods---just the Runge-Kutta family of integrators (RK4 by 8 | default)---but you should see how clear and modular this program is. 9 | A few quotations from the code: 10 | 11 | - "The forces are minus the gradient of the potential energy at the positions" 12 | (that gradient is computed by automatic differentiation of course, 13 | not by numerical approximation) 14 | 15 | ```scheme 16 | (define (forces objects) 17 | (* -1 (gradient (positions->potential objects) (map position objects)))) 18 | ``` 19 | 20 | - "The derivatives of the masses, positions, and velocities are 21 | 0, the velocities, and the forces, respectively" 22 | 23 | ```scheme 24 | (map3 make-object 25 | (map (lambda (obj) 0) objects) 26 | (map velocity objects) 27 | (map2 / (forces objects) (map mass objects)))))) 28 | ``` 29 | 30 | - "The fourth-order Runge-Kutta method is an integrator in the 31 | Runge-Kutta family given by the following tableau of coefficients" 32 | 33 | ```scheme 34 | (define rk4 35 | (coefficient-tableau->runge-kutta-integrator 36 | '(() 37 | (1/2) 38 | (0 1/2) 39 | (0 0 1) 40 | (1/6 1/3 1/3 1/6)))) 41 | ``` 42 | 43 | - "We want the stream of samples of the integrator applied to the 44 | state derivative at the initial conditions" 45 | 46 | ```scheme 47 | (step-stream rk4 state-derivative initial-conditions) 48 | ``` 49 | 50 | Try writing this program like this in Fortran and see what happens! 51 | And yet, DVL compiles this to as ugly and fast a mess as you could 52 | wish for. If you want to try it out, read the instructions in 53 | `celestial-driver.scm`. There is also a driver for compiling to SBCL 54 | in `celestial-driver.lisp`, but it doesn't draw the diagnostic graphic 55 | as it goes. 56 | -------------------------------------------------------------------------------- /dvl/examples/non-bug.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; Trying just plain old directional differentiation of a function 21 | ;;; from R^2 to R^2, using Chruch-encoded pairs. 22 | 23 | ; f R^2 -> R^2 24 | ; f(x,y) = (x+y,x*y) 25 | ; Church encoded 26 | 27 | (define (c-cons a d) 28 | (lambda (recipient) 29 | (recipient a d))) 30 | 31 | (define (c-car c) 32 | (c (lambda (a d) a))) 33 | 34 | (define (c-cdr c) 35 | (c (lambda (a d) d))) 36 | 37 | (define (c-+ v1 v2) 38 | (let ((x1 (c-car v1)) 39 | (y1 (c-cdr v1)) 40 | (x2 (c-car v2)) 41 | (y2 (c-cdr v2))) 42 | (c-cons (+ x1 x2) (+ y1 y2)))) 43 | 44 | (define (c-* r v) 45 | (let ((x (c-car v)) 46 | (y (c-cdr v))) 47 | (c-cons (* r x) (* r y)))) 48 | 49 | (define (c-directional-derivative f x dir) 50 | (let ((line (lambda (dist) 51 | (f (c-+ x (c-* dist dir)))))) 52 | ((derivative line) 0))) 53 | 54 | (define (f pt) 55 | (let ((x (c-car pt)) 56 | (y (c-cdr pt))) 57 | (c-cons (+ x y) (* x y)))) 58 | 59 | ((c-directional-derivative f (c-cons 7. 11.) (c-cons 2. 3.)) 60 | (lambda (a d) (cons a d))) 61 | ===> (5. . 43.) 62 | -------------------------------------------------------------------------------- /vl/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;;; Loading the system 21 | 22 | ;;; Why are you reading this file? You already know what it does. 23 | 24 | (define (self-relatively thunk) 25 | (if (current-eval-unit #f) 26 | (with-working-directory-pathname 27 | (directory-namestring (current-load-pathname)) 28 | thunk) 29 | (thunk))) 30 | 31 | (define (load-relative filename #!optional environment) 32 | (self-relatively (lambda () (load filename environment)))) 33 | 34 | (load-relative "../support/auto-compilation") 35 | (load-relative "../fol/load") 36 | 37 | (for-each 38 | load-relative-compiled 39 | '("../support/utils" 40 | "data" 41 | "env" 42 | "syntax" 43 | "macro" 44 | "letrec" 45 | "eval" 46 | "analysis" 47 | "abstract-values" 48 | "abstract-eval" 49 | "nomenclature" 50 | "code-generator" 51 | "primitives" 52 | "read")) 53 | 54 | (define (vl-run-file filename) 55 | (let* ((forms (read-source filename)) 56 | (program `(let () ,@forms)) 57 | (compiled-program (compile-to-fol program)) 58 | (compiled-answer (fol-eval compiled-program))) 59 | (pp compiled-answer))) 60 | -------------------------------------------------------------------------------- /dvl/examples/mandelbrot/mandel.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2013 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (car (cons x y)) x) 21 | (define (cdr (cons x y)) y) 22 | 23 | (define (c:+ z1 z2) 24 | (cons (+ (car z1) (car z2)) 25 | (+ (cdr z1) (cdr z2)))) 26 | 27 | (define (c:* z1 z2) 28 | (cons (- (* (car z1) (car z2)) 29 | (* (cdr z1) (cdr z2))) 30 | (+ (* (car z1) (cdr z2)) 31 | (* (cdr z1) (car z2))))) 32 | 33 | (define c:0 (cons (real 0) (real 0))) 34 | 35 | (define (magnitude z) 36 | (sqrt (+ (* (car z) (car z)) 37 | (* (cdr z) (cdr z))))) 38 | 39 | (define (iterate count f x) 40 | (if (<= count 0) 41 | x 42 | (iterate (- count 1) f (f x)))) 43 | 44 | (define ((step c) z) 45 | (c:+ (c:* z z) c)) 46 | 47 | (define (mandelbrot? c) 48 | (< (magnitude (iterate (real 400) (step c) c:0)) 2)) 49 | 50 | ;; This entry point form hacks around a limitation of the DVL and FOL 51 | ;; foreign interfaces that prevents me from exporting the 52 | ;; `mandelbrot?` function directly (or even a two-real-argument 53 | ;; version of it). The constants 0.5 and 0.7 are significant. See 54 | ;; the comment in fol/asm-js.scm. I apologize in advance. 55 | (mandelbrot? (cons (real 0.5) (real 0.7))) 56 | -------------------------------------------------------------------------------- /fol/doc/rule-system.txt: -------------------------------------------------------------------------------- 1 | Rule-based Term Rewriter 2 | 3 | FOL makes extensive use of a rule-based term-rewriting system to 4 | manipulate the data structures representing FOL programs. Every time 5 | you see the RULE macro, that's what's going on. 6 | 7 | Don't worry about understanding this rule system; it is its own pile 8 | of stuff, good for a few lectures of Sussman's MIT class Adventures in 9 | Advanced Symbolic Programming. It works, and it's very good for 10 | peephole manipulations of structured expressions (like the output of 11 | the VL code generator). If you really want to see it, though, it's 12 | included in support/rules. 13 | 14 | Rules for the term-rewriting system consist of a pattern to try to 15 | match and an expression to evaluate to compute a replacement for that 16 | match should a match be found. Patterns match themselves; the 17 | construct (? name) introduces a pattern variable named NAME; the 18 | construct (? name ,predicate) is a restricted pattern variable which 19 | only matches things the predicate accepts; the construct (?? name) 20 | introduces a sublist pattern variable. The pattern matcher will 21 | search through possible lengths of sublists to find a match. Repeated 22 | pattern variables must match equal structures in all the corresponding 23 | places. 24 | 25 | A rule by itself is a one-argument procedure that tries to match its 26 | pattern. If the match succeeds, the rule will evaluate the the 27 | replacement expression in an environment where the pattern variables 28 | are bound to the things they matched and return the result. If the 29 | replacement expression returns #f, that tells the matcher to backtrack 30 | and look for another match. If the match fails, the rule will return 31 | the original argument unchanged. 32 | 33 | A rule simplifier has a set of rules, and applies them to every 34 | subexpression of the input expression repeatedly until the result 35 | settles down. The rule system also offers the ON-SUBEXPRESSIONS 36 | combinator, which will try its rule on every subexpression of its 37 | argument once each (bottom up), but will not rerun the rules to 38 | convergence. Finally, there is the ITERATED combinator, which 39 | iterates its rule on its argument until convergence, but does not 40 | descend into subexpressions. 41 | -------------------------------------------------------------------------------- /dvl/examples/celestial/celestial-driver.lisp: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (defmacro delay (exp) 21 | `(lambda () ,exp)) 22 | 23 | (defun force (thunk) 24 | (funcall thunk)) 25 | 26 | (defun constant-arg-for-dvl-stream (argument dvl-stream) 27 | (labels ((do-it (dvl-stream) 28 | (cons (car dvl-stream) 29 | (delay (do-it (funcall (cdr dvl-stream) argument)))))) 30 | (do-it dvl-stream))) 31 | 32 | (defun stream-for-each (f stream) 33 | (cons (funcall f (car stream)) 34 | (delay (stream-for-each f (force (cdr stream)))))) 35 | 36 | (defun stream-take (count stream) 37 | (if (= count 0) 38 | stream 39 | (stream-take (- count 1) (force (cdr stream))))) 40 | 41 | (defun drive (count step dt) 42 | (stream-take count 43 | (constant-arg-for-dvl-stream (coerce dt 'double-float) 44 | (funcall (__main__) (coerce step 'double-float))))) 45 | 46 | ;; Compile the DVL program with 47 | ;(fol->common-lisp (compile-to-fol (dvl-source "examples/celestial/celestial.dvl") visibly)) 48 | ;; or compile the DVL program with 49 | ;$ dvl compile example/celestial/celestial.dvl via common-lisp 50 | ;; at the command line. 51 | 52 | ;; Then run with 53 | ;; (fasload "example/celestial/celestial.fasl") 54 | ;; (drive 1000 10.0 100.0) 55 | -------------------------------------------------------------------------------- /dvl/examples/derivative-examples.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; Identity function 21 | ((derivative (lambda (x) x)) 7) ===> 1 22 | 23 | ;;; Constant function 24 | ((derivative (lambda (x) 3)) 7) ===> 0 25 | 26 | ;;; Transform of + 27 | ((derivative (lambda (x) (+ x 1))) 7) ===> 1 28 | ((derivative (lambda (x) (+ x x))) 7) ===> 2 29 | 30 | ;;; Nested constant function (don't conflate the perturbations) 31 | (let () 32 | (define (one x) 33 | ((derivative (lambda (y) (+ x y))) 3)) 34 | ((derivative one) 7)) ===> 0 35 | 36 | ;;; Another don't conflate the perturbations 37 | (let () 38 | (define (one x) 39 | ((derivative (lambda (y) (+ x y))) 3)) 40 | ((derivative (lambda (x) 41 | (* x (one x)))) 42 | 7)) ===> 1 43 | 44 | ;;; Don't confuse the perturbations 45 | ;; I'm not sure this would catch a thing that swapped the 46 | ;; perturbations with each other, but it at least might. 47 | (let () 48 | (define (one x) 49 | ((derivative (lambda (y) (+ x y))) 3)) 50 | ((derivative (lambda (x) 51 | (* x (one (* 2 x))))) 52 | 7)) ===> 1 53 | 54 | ;;; Another don't confuse the perturbations. 55 | ((derivative 56 | (lambda (y) 57 | ((derivative 58 | (lambda (x) 59 | (* x (* x y)))) 60 | (* y 3)))) 61 | 5) ===> 60 62 | -------------------------------------------------------------------------------- /dvl/stdlib/forward-mode.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; Directional derivaitve 21 | ;;; derivaitve :: (R -> a) -> (R -> a) where the last a is interpreted 22 | ;;; as the tangent space of a. 23 | 24 | (define (derivative f) 25 | (let ((epsilon (gensym))) 26 | (lambda (x) 27 | (tangent epsilon (f (make-bundle epsilon x 1)))))) 28 | 29 | ;;; Jacobian by forward mode. 30 | ;;; jacobian-f :: (R^n -> a) -> (R^n -> a) 31 | ;;; where a is interpreted as in derivative, and R^n is an arbitrary 32 | ;;; cons tree containing real numbers. 33 | 34 | (define ((jacobian-f f) pt) 35 | (let loop ((thing pt) 36 | (eat f)) 37 | (cond ((or (real? thing) (forward? thing) (reverse? thing)) 38 | ((derivative eat) thing)) 39 | ((pair? thing) 40 | (let (((cons thing1 thing2) thing)) 41 | (cons (loop thing1 42 | (lambda (different-thing) 43 | (eat (cons different-thing thing2)))) 44 | (loop thing2 45 | (lambda (different-thing) 46 | (eat (cons thing1 different-thing))))))) 47 | ((null? thing) 48 | '()) 49 | ;; TODO This should probably be an error 50 | (else thing)))) 51 | 52 | (define gradient-f jacobian-f) 53 | -------------------------------------------------------------------------------- /dvl/examples/mandelbrot/mandel.html: -------------------------------------------------------------------------------- 1 | 2 | 20 | 21 | 22 | 23 | Mandelbrot Demo 24 | 25 | 26 | 27 | 36 | 37 |
38 |

Mandelbrot Set in Pure Javascript

39 |

(generated by DVL)

40 |
41 |

Instructions:

42 |
    43 |
  1. Generate the Mandelbrot tester function from its DVL program with 44 | 
    (fol->asm.js
45 |  (fol-optimize
46 |   (compile-to-fol
47 |    (dvl-source "examples/mandelbrot/mandel.dvl")))
48 |  "examples/mandelbrot/mandel.js")
    2. 49 |
  2. Reload this page.
    3. 50 |
  3. Then click "Go!".
51 |
52 |
53 |
54 |
ResolutionMflopsTime (ms)
55 |
56 | 57 |
58 | 59 | 60 | -------------------------------------------------------------------------------- /dvl/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;;; Loading the system 21 | 22 | ;;; Why are you reading this file? You already know what it does. 23 | 24 | (define (self-relatively thunk) 25 | (if (current-eval-unit #f) 26 | (with-working-directory-pathname 27 | (directory-namestring (current-load-pathname)) 28 | thunk) 29 | (thunk))) 30 | 31 | (define (load-relative filename #!optional environment) 32 | (self-relatively (lambda () (load filename environment)))) 33 | 34 | (load-relative "../support/auto-compilation") 35 | (load-relative "../support/rules/load") 36 | (load-relative "../fol/load") 37 | 38 | (for-each 39 | load-relative-compiled 40 | '("../support/utils" 41 | "errors" 42 | "data" 43 | "../vl/env" 44 | "syntax" 45 | "macro" 46 | "letrec" 47 | "eval" 48 | "analysis" 49 | "abstract-values" 50 | "abstract-eval" 51 | "../vl/nomenclature" 52 | "../vl/code-generator" 53 | "primitives" 54 | "read" 55 | "entry-point" 56 | "benchmarking")) 57 | 58 | ;;; TODO Where does this procedure go? 59 | (define (clear-analyze-and-generate-caches!) 60 | (clear-name-caches!) 61 | (reset-canonical-abstract-values!) 62 | (hash-table/clear! abstract-hash-cache-table) 63 | (hash-table/clear! free-variables-cache) 64 | (gc-flip) 65 | (hash-table/clean! (access eq-properties fol-environment))) 66 | -------------------------------------------------------------------------------- /fol/doc/objectives.txt: -------------------------------------------------------------------------------- 1 | Objectives of FOL 2 | March 5, 2012 3 | Alexey Radul 4 | 5 | If I were to push FOL out as a thing in its own right, what would be 6 | its distinguishing characteristics, that would make people want to use 7 | it? 8 | 9 | FOL is a middle-end in a compiler and an intermediate language for 10 | compilation. As such, the FOL system accepts input in the FOL 11 | language, optimizes it, and produces output in a slightly restricted 12 | subset of FOL called FOL-- (this difference is on the logic that a 13 | machine should be liberal in the inputs it accepts and strict in the 14 | outputs it produces). The FOL system also comes with several 15 | back-ends that translate FOL-- to other languages. 16 | 17 | FOL has several design objectives: 18 | - FOL must be a convenient target for code generation 19 | - FOL-- must be compilable to efficient machine code 20 | - FOL programs should interoperate with the outside world 21 | - FOL and FOL-- should not be unduly illegible 22 | 23 | The above objectives are narrowed by several choices one might call 24 | arbitrary, that I made for FOL because they were what I needed. These 25 | choices put FOL in a particular point in the design space of 26 | intermediate languages. 27 | - FOL has a Scheme-like syntax (making it easy to parse and generate) 28 | - FOL is first-order 29 | - FOL is statically typed 30 | - With sum and product types 31 | - FOL is tail-recursive 32 | - FOL is garbage-collected 33 | - FOL supports multiple-value returns 34 | - Interoperation is done by having the back-end generate callable code 35 | in the target language 36 | 37 | The choices and objectives entail several FOL design principles: 38 | - FOL and FOL-- should be clearly and precisely specified 39 | - with clear semantics and 40 | - (to the extent possible) a clear cost model 41 | - FOL should impose no arbitrary limits. In particular, no limits besides 42 | available memory on: 43 | - the size of an input program, or 44 | - the number of procedures, or 45 | - the size of procedures, or 46 | - the nesting depth of expressions, or 47 | - the number of formal parameters to procedures, or 48 | - the number of values returned from procedures, or 49 | - the number of members in product and sum types 50 | - The FOL optimizer should have clearly-stated (and good) asymptotic 51 | performance as any of above counts grow. 52 | -------------------------------------------------------------------------------- /vl/examples/euler-integral.vl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (car (cons x ())) 21 | x) 22 | 23 | (define (cdr (cons () y)) 24 | y) 25 | 26 | (define (v+ structure1 structure2) 27 | (cond ((and (pair? structure1) 28 | (pair? structure2)) 29 | (cons (v+ (car structure1) 30 | (car structure2)) 31 | (v+ (cdr structure1) 32 | (cdr structure2)))) 33 | ((and (null? structure1) (null? structure2)) 34 | ()) 35 | (#t ; (and (number? structure1) (number? structure2)) 36 | (+ structure1 structure2)))) 37 | 38 | (define (k*v number structure) 39 | (cond ((pair? structure) 40 | (cons (k*v number (car structure)) 41 | (k*v number (cdr structure)))) 42 | ((null? structure) 43 | ()) 44 | (#t ; (number? structure) 45 | (* number structure)))) 46 | 47 | (define (naive-euler state-derivative initial-state stop? step) 48 | (let loop ((state initial-state)) 49 | (if (stop? state) 50 | state 51 | (loop (v+ state (k*v step (state-derivative state))))))) 52 | 53 | (define (circle-field state) 54 | (cons (* (real -1) (cdr state)) (car state))) 55 | 56 | (define (upper-left-quadrant? state) 57 | (< (car state) (real 0))) 58 | 59 | (naive-euler circle-field (cons (real 1) (real 0)) upper-left-quadrant? (real 0.01)) 60 | -------------------------------------------------------------------------------- /dvl/examples/amazing-bug-3.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; Here we have the same program as in amazing-bug-2.dvl, but using a 21 | ;;; Church-encoded pair rather than a normal one. Should the answer 22 | ;;; be the same? 23 | 24 | (define (f x) 25 | (lambda (recipient) 26 | (recipient 27 | (lambda (y) (sin (* x y))) 28 | (lambda (g) 29 | (lambda (z) 30 | (g (+ x z))))))) 31 | 32 | (((derivative f) 3) 33 | (lambda (g-hat f-hat) 34 | ((f-hat g-hat) 3.14159))) 35 | 36 | ===> 8.32914929893078 37 | 38 | ; ((lambda (y) (* (cos (* 3 y)) (+ 3 y))) (+ 3 3.14159)) 39 | 40 | ;;; Arguably not. Consider that under the normal definition of 41 | ;;; addition on functions and pairs, Church-encoded pairs add 42 | ;;; differently from normal ones: 43 | ;;; (lambda (cont) (cont x1 y1)) + (lambda (cont) (cont x2 y2)) = 44 | ;;; (lambda (cont) (+ (cont x1 y1) (cont x2 y2))) != 45 | ;;; (lambda (cont) (cont (+ x1 x2) (+ y1 y2))) 46 | 47 | ;;; These are only different if the CONT procedure is non-linear. The 48 | ;;; interpretation is that in the Church-encoded case, the encoding 49 | ;;; respects the non-linearity in the CONT procedure, whereas in the 50 | ;;; pair case, adding pairs does not respect the non-linearity of the 51 | ;;; result. (In fact, the same is true of ordinary addition of 52 | ;;; numbers). Since differentiation is supposed to expose linear 53 | ;;; structure, it makes sense that it would expose different things in 54 | ;;; these two cases. 55 | -------------------------------------------------------------------------------- /fol/haskell.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2013 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | ;;;; Compilation with the fol2hs backend and GHC 22 | 23 | (define (fol->haskell program #!optional output-base) 24 | (if (default-object? output-base) 25 | (set! output-base "hanozzle")) 26 | (let* ((module-name (as-haskell-module-name (pathname-name output-base))) 27 | (directory (->namestring (pathname-new-name output-base #f))) 28 | (path (->namestring (pathname-new-type (pathname-new-name output-base module-name) #f))) 29 | (written-program (with-output-to-string (lambda () (pp program))))) 30 | (force-shell-command (format #f "fol2hs -e value -m ~A --directory=~A" module-name directory) 31 | 'input (open-input-string written-program)) 32 | (let* ((file (->namestring (pathname-new-type path "hs"))) 33 | (cmd (format #f "ghc ~A -main-is ~A.main -outputdir ~A -o ~A" 34 | file module-name directory path))) 35 | (force-shell-command cmd)))) 36 | 37 | (define (as-haskell-module-name string) 38 | ;; TODO Increase the accuracy of this model 39 | (string-set! string 0 (char-upcase (string-ref string 0))) 40 | string) 41 | 42 | (define (run-haskell #!optional output-base) 43 | (if (default-object? output-base) 44 | (set! output-base "hanozzle")) 45 | (let* ((module-name (as-haskell-module-name (pathname-name output-base))) 46 | (path (->namestring (pathname-new-type (pathname-new-name output-base module-name) #f)))) 47 | (force-shell-command path))) 48 | -------------------------------------------------------------------------------- /dvl/stdlib/vlad-compatibility.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (derivative-f f) 21 | (derivative f)) 22 | 23 | (define (derivative-using-j* f) 24 | (derivative f)) 25 | 26 | (define (derivative-r f) 27 | (gradient-r f)) 28 | 29 | (define (derivative-using-*j f) 30 | (gradient-r f)) 31 | 32 | (define (v+ u v) (map2 g:+ u v)) 33 | 34 | (define (v- u v) (map2 g:- u v)) 35 | 36 | (define (jacobian-using-j* f) 37 | (gradient-f f)) 38 | 39 | (define (j-transpose*v f) 40 | (lambda (x y-grave) 41 | ((gradient-r (lambda (x) (dot (f x) y-grave))) 42 | x))) 43 | 44 | (define (perturb thing) thing) 45 | 46 | (define (unperturb thing) thing) 47 | 48 | (define (sensitize thing) thing) 49 | 50 | (define (unsensitize thing) thing) 51 | 52 | ;;; DVL does not lift constants to zero-tangent bundles, expecting the 53 | ;;; arithmetic operations to deal with any asymmetries. Sadly, if one 54 | ;;; branch of an IF wants to return a constant and the other a bundle, 55 | ;;; DVL has a problem. If DVL supported union types, this would just 56 | ;;; become a union -- inefficient perhaps, but not deadly. If DVL 57 | ;;; supported a mechanism to define automatic coersions of one type to 58 | ;;; another, that IF could be taught to apply, the union in question 59 | ;;; could even be eliminated. As it stands, however, the only way to 60 | ;;; compile examples that experience this phenomenon is by manually 61 | ;;; inserting a hack like this. 62 | (define (HACK-raise-to-same-bundle-level thing target) 63 | (g:+ (g:- thing target) target)) 64 | -------------------------------------------------------------------------------- /support/hash-tables.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | 22 | (define (hash-table/fold-with-key procedure initial hash-table) 23 | (let ((result initial)) 24 | (hash-table/for-each 25 | hash-table 26 | (lambda (key value) 27 | (set! result (procedure key value result)))) 28 | result)) 29 | 30 | (define (hash-table/fold procedure initial hash-table) 31 | (hash-table/fold-with-key 32 | (lambda (_ value result) 33 | (procedure value result)) 34 | initial 35 | hash-table)) 36 | 37 | (define (hash-table/insert-with! procedure key new-value hash-table) 38 | (hash-table/lookup 39 | hash-table 40 | key 41 | (lambda (old-value) 42 | (hash-table/put! hash-table key (procedure new-value old-value))) 43 | (lambda () 44 | (hash-table/put! hash-table key new-value)))) 45 | 46 | (define (hash-table/adjust-with-key! procedure key hash-table) 47 | (hash-table/lookup 48 | hash-table 49 | key 50 | (lambda (value) 51 | (hash-table/put! hash-table key (procedure key value))) 52 | (lambda () #f))) 53 | 54 | (define (hash-table/adjust! procedure key hash-table) 55 | (hash-table/adjust-with-key! 56 | (lambda (_ value) (procedure value)) 57 | key 58 | hash-table)) 59 | 60 | (define (hash-table/put-alist! table alist) 61 | (for-each (lambda (k.v) 62 | (hash-table/put! table (car k.v) (cdr k.v))) 63 | alist)) 64 | 65 | (define (alist->eq-hash-table alist) 66 | (abegin1 67 | (make-eq-hash-table) 68 | (hash-table/put-alist! it alist))) 69 | -------------------------------------------------------------------------------- /fol/runtime.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | 22 | ;;;; Runtime system 23 | 24 | ;;; Here is the complement of definitions that needs to be loaded into 25 | ;;; MIT Scheme in order to execute FOL code (in addition to SRFI 11). 26 | ;;; See also mit-scheme.scm and FOL-EVAL in syntax.scm. 27 | 28 | (define-syntax argument-types 29 | (syntax-rules () 30 | ((_ arg ...) 31 | (begin)))) 32 | 33 | (define-syntax define-type 34 | (syntax-rules () 35 | ((_ name (structure (field type) ...)) 36 | (define-structure name field ...)) 37 | ((_ name (escaper type ...)) ; Escaper types are annotations only 38 | (begin)))) 39 | 40 | (define-syntax type 41 | (syntax-rules () 42 | ((_ stuff ...) ; type annotations are just annotations 43 | (begin)))) 44 | 45 | (define (real x) 46 | (if (real? x) 47 | x 48 | (error "A non-real object is asserted to be real" x))) 49 | 50 | (define read-real read) 51 | 52 | (define (write-real x) 53 | (write x) 54 | (newline) 55 | x) 56 | 57 | (define-structure 58 | (gensym 59 | safe-accessors 60 | (print-procedure 61 | (simple-unparser-method 'gensym 62 | (lambda (gensym) 63 | (list (gensym-number gensym)))))) 64 | number) 65 | 66 | (define *the-gensym* 0) 67 | 68 | (define (gensym) 69 | (set! *the-gensym* (+ *the-gensym* 1)) 70 | (make-gensym (- *the-gensym* 1))) 71 | 72 | (define (gensym= gensym1 gensym2) 73 | (= (gensym-number gensym1) (gensym-number gensym2))) 74 | 75 | (define (gensym< gensym1 gensym2) 76 | (< (gensym-number gensym1) (gensym-number gensym2))) 77 | -------------------------------------------------------------------------------- /vl/eval.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | ;;;; Concrete evaluator for VL 22 | 23 | ;;; Functions take only one argument (which they may destructure 24 | ;;; inside). CONS is a special form. LAMBDA and CONS are the only 25 | ;;; non-macro special forms. IF macroexpands into the only primitive 26 | ;;; procedure that accepts and calls VL procedures as arguments. 27 | 28 | (define (concrete-eval exp env) 29 | (cond ((constant? exp) (constant-value exp)) 30 | ((variable? exp) (lookup exp env)) 31 | ((lambda-form? exp) 32 | (make-closure exp env)) 33 | ((pair-form? exp) 34 | (cons (concrete-eval (car-subform exp) env) 35 | (concrete-eval (cdr-subform exp) env))) 36 | ((application? exp) 37 | (concrete-apply (concrete-eval (operator-subform exp) env) 38 | (concrete-eval (operand-subform exp) env))) 39 | (else 40 | (error "Invalid expression type" exp)))) 41 | 42 | (define (concrete-apply proc arg) 43 | (cond ((primitive? proc) 44 | (apply-primitive proc arg)) 45 | ((closure? proc) 46 | (concrete-eval (closure-body proc) 47 | (extend-env (closure-formal proc) 48 | arg 49 | (closure-env proc)))) 50 | (else 51 | (error "Invalid procedure type" proc)))) 52 | 53 | (define (apply-primitive proc arg) 54 | ((primitive-implementation proc) arg)) 55 | 56 | (define (interpret form) 57 | (concrete-eval (macroexpand form) (initial-user-env))) 58 | 59 | -------------------------------------------------------------------------------- /dvl/examples/streams.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;; A poor man's stream library 21 | 22 | (define (promise thunk) 23 | thunk) 24 | 25 | (define (force promise) 26 | (promise)) 27 | 28 | (define (head stream) 29 | (car (force stream))) 30 | 31 | (define (tail stream) 32 | (cdr (force stream))) 33 | 34 | (define ((iterate f) state) 35 | (promise 36 | (lambda () 37 | (cons state ((iterate f) (f state)))))) 38 | 39 | (define ((drop n) stream) 40 | (if (<= n 0) 41 | stream 42 | ((drop (- n 1)) 43 | (cdr (force stream))))) 44 | 45 | (define (nth-stream stream k) 46 | (let (((cons first rest) (force stream))) 47 | (if (<= k 0) 48 | first 49 | (nth-stream rest (- k 1))))) 50 | 51 | (define (stream-map f stream) 52 | (promise 53 | (lambda () 54 | (let (((cons x xs) (force stream))) 55 | (cons (f x) ((stream-map f) xs)))))) 56 | 57 | (define (stream-map2 f s1 s2) 58 | (promise 59 | (lambda () 60 | (let (((cons s1-first s1-rest) (force s1)) 61 | ((cons s2-first s2-rest) (force s2))) 62 | (cons (f s1-first s2-first) 63 | (stream-map2 f s1-rest s2-rest)))))) 64 | 65 | (define (stream-of-adjacent-pairs stream) 66 | ;; This is not implemented as the semantically equivalent 67 | ;; (stream-map2 cons stream (cdr stream)) because since these 68 | ;; streams are not memoized, that version would duplicate 69 | ;; computation. 70 | (let (((cons first rest) (force stream))) 71 | (let loop ((first first) (rest rest)) 72 | (promise 73 | (lambda () 74 | (let (((cons second rest) (force rest))) 75 | (cons (cons first second) 76 | (loop second rest)))))))) 77 | -------------------------------------------------------------------------------- /dvl/test/dvl-error-detection-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | 22 | (define (expect-dvl-error thunk) 23 | (let ((result (ignore-errors thunk))) 24 | (cond ((dvl-error? result) 25 | (if (dvl-error-binding result) 26 | 'ok 27 | (test-fail 28 | (messagify 29 | (ensure-forced 30 | (build-message 31 | "A DVL error was signaled not on behalf of any binding" 32 | '("<" ">") result)))))) 33 | ((and (condition? result) 34 | (condition/error? result)) 35 | (error result)) 36 | (else 37 | (test-fail 38 | (messagify 39 | (ensure-forced 40 | (build-message 41 | "Expected a DVL error, got" '("<" ">") result)))))))) 42 | 43 | (define-syntax broken-programs 44 | (syntax-rules () 45 | ((_ (test-name program) ...) 46 | (begin 47 | (define-test (test-name) 48 | (expect-dvl-error 49 | (lambda () 50 | (check-fol-types 51 | (compile-to-raw-fol 'program))))) ...)))) 52 | 53 | (in-test-group 54 | dvl-error-detection 55 | 56 | (define-test (smoke) 57 | (expect-dvl-error 58 | (lambda () 59 | (analyze-and-generate 60 | '(1 2))))) 61 | 62 | (broken-programs 63 | (well-typed-* (* sin 3)) 64 | (no-ternary-* (* 1 2 3)) 65 | (no-ternary-*-2 (* (real 1) 2 3)) 66 | (no-ternary-*-3 (* 1 (real 2) 3)) 67 | (well-typed-sin (sin sin)) 68 | (well-typed-real-declaration (real sin)) 69 | (well-typed-gensym= (gensym= 1 2)) 70 | (well-typed-gensym= (gensym= (gensym) 2)) 71 | (well-typed-gensym= (gensym= 1 (gensym))) 72 | )) 73 | -------------------------------------------------------------------------------- /dvl/examples/runge-kutta/gnuplot.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | 22 | ;;;; Gnuplot output of alist data 23 | 24 | (load-option 'synchronous-subprocess) 25 | 26 | (define (gnuplot-write-alist alist filename) 27 | (with-output-to-file filename 28 | (lambda () 29 | (for-each 30 | (lambda (x.y) 31 | (write (exact->inexact (car x.y))) 32 | (display " ") 33 | (write (exact->inexact (cdr x.y))) 34 | (newline)) 35 | alist)))) 36 | 37 | (define (gnuplot-alist alist . adverbs) 38 | (let ((gnuplot-extra (lax-alist-lookup adverbs 'commanding "")) 39 | (gnuplot-prefix (lax-alist-lookup adverbs 'prefixing ""))) 40 | (call-with-temporary-file-pathname 41 | (lambda (pathname) 42 | (gnuplot-write-alist alist pathname) 43 | (let ((command (string-append 44 | "gnuplot -p -e \'" 45 | "set style data lines; " 46 | "set key noautotitles; " 47 | gnuplot-prefix 48 | "; plot \"" 49 | (->namestring pathname) 50 | "\" " 51 | gnuplot-extra 52 | "'"))) 53 | (display command) 54 | (newline) 55 | (run-shell-command command)))))) 56 | 57 | ;; A "lax alist" is a list whose pairs are treated as alist elements, 58 | ;; but which is allowed to have non-pairs also (which are ignored). 59 | (define (lax-alist-lookup alist item default #!optional =) 60 | (let ((binding (assoc item (filter pair? alist) =))) 61 | (if binding 62 | ;; I really want to be looking up from two-element lists 63 | ;; rather than pairs, so this does not iterpret proper alists. 64 | (cadr binding) 65 | default))) 66 | -------------------------------------------------------------------------------- /support/two-way-table.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | 22 | ;;; For CSE, I need an associative data structure that supports 23 | ;;; reverse lookups, from value to key. This is complicated by the 24 | ;;; fact that the forward map is many-to-one, but when doing reverse 25 | ;;; lookups, I want to find a very specfic one of the many. This is 26 | ;;; implemented by taking a predicate that says which entries to put 27 | ;;; into the reverse map. The predicate accepts two arguments, the 28 | ;;; (forward) key and the datum. For my application, I only need 29 | ;;; equal? checking of keys and data, so I will not bother 30 | ;;; generalizing on that score. 31 | 32 | (define-structure (two-way safe-accessors) 33 | forward 34 | reverse 35 | reverse?) 36 | 37 | (define (make-two-way-table reverse?) 38 | (make-two-way 39 | (make-equal-hash-table) 40 | (make-equal-hash-table) 41 | reverse?)) 42 | 43 | (define (forward-get table key default) 44 | (hash-table/get (two-way-forward table) key default)) 45 | 46 | (define (forward-lookup table key win lose) 47 | (hash-table/lookup (two-way-forward table) key win lose)) 48 | 49 | (define (reverse-lookup table datum win lose) 50 | (hash-table/lookup (two-way-reverse table) datum win lose)) 51 | 52 | (define (two-way-put! table key datum) 53 | (hash-table/put! (two-way-forward table) key datum) 54 | (if ((two-way-reverse? table) key datum) 55 | (hash-table/put! (two-way-reverse table) datum key))) 56 | 57 | (define (two-way-remove! table key) 58 | (let ((forward (two-way-forward table))) 59 | (hash-table/lookup forward key 60 | (lambda (old-datum) 61 | (if ((two-way-reverse? table) key old-datum) 62 | (hash-table/remove! (two-way-reverse table) old-datum))) 63 | (lambda () 64 | 'ok)) 65 | (hash-table/remove! forward key))) 66 | -------------------------------------------------------------------------------- /fol/dead-types.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2013 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | (declare (integrate-external "syntax")) 22 | (declare (integrate-external "../support/pattern-case/pattern-case")) 23 | ;;;; Dead type elimination 24 | 25 | ;;; Eliminating unused type declarations 26 | 27 | (define (%dead-type-elimination program) 28 | (if (begin-form? program) 29 | (let ((live-types (make-eq-hash-table)) 30 | (queue '()) 31 | (type-map (type-map program))) 32 | (define (live-type! type) 33 | (cond ((null? type) 'ok) 34 | ((symbol? type) 35 | (hash-table/lookup live-types type 36 | (lambda (datum) 37 | 'ok) 38 | (lambda () 39 | (hash-table/put! live-types type #t) 40 | (set! queue (cons type queue))))) 41 | (else 42 | (for-each live-type! (type-references type))))) 43 | (define (a-live-type!) 44 | (if (null? queue) 45 | #f 46 | (begin1 (car queue) 47 | (set! queue (cdr queue))))) 48 | (for-each-fol-expression program 49 | (lambda (expression type) 50 | (live-type! type))) 51 | (for-each 52 | (rule `(define (? stuff) 53 | (argument-types (?? types)) 54 | (? body)) 55 | (for-each live-type! types)) 56 | program) 57 | (let loop ((next (a-live-type!))) 58 | (if next 59 | (begin 60 | (live-type! (hash-table/get type-map next #f)) 61 | (loop (a-live-type!))))) 62 | (tidy-begin 63 | (filter (lambda (item) 64 | (or (not (type-definition? item)) 65 | (hash-table/get live-types (cadr item) #f))) 66 | program))) 67 | program)) 68 | -------------------------------------------------------------------------------- /fol/primitives.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | ;;;; FOL Primitivies 22 | 23 | (define-structure (primitive safe-accessors) 24 | name 25 | type 26 | pure?) 27 | 28 | (define (primitive-impure? primitive) 29 | (not (primitive-pure? primitive))) 30 | 31 | (define-structure 32 | (function-type 33 | (constructor function-type) 34 | safe-accessors 35 | (print-procedure 36 | (lambda (state object) 37 | (with-current-unparser-state state 38 | (lambda (port) 39 | (format port "(-> ~S ~S)" 40 | (arg-types object) (return-type object))))))) 41 | args 42 | return) 43 | 44 | (define return-type function-type-return) 45 | (define arg-types function-type-args) 46 | 47 | (define (real->real thing) 48 | (make-primitive thing (function-type '(real) 'real) #t)) 49 | (define (real*real->real thing) 50 | (make-primitive thing (function-type '(real real) 'real) #t)) 51 | (define (real->bool thing) 52 | (make-primitive thing (function-type '(real) 'bool) #t)) 53 | (define (real*real->bool thing) 54 | (make-primitive thing (function-type '(real real) 'bool) #t)) 55 | 56 | ;; Type testers real? gensym? null? pair? procedure? have other types, but 57 | ;; should never be emitted by VL or DVL on union-free inputs. 58 | 59 | (define *primitives* 60 | `(,(make-primitive 'read-real (function-type '() 'real) #f) 61 | ,(make-primitive 'write-real (function-type '(real) 'real) #f) 62 | ,@(map real->real 63 | '(abs exp log sin cos tan asin acos sqrt real)) 64 | ,@(map real*real->real '(+ - * / atan expt)) 65 | ,@(map real->bool '(zero? positive? negative?)) 66 | ,@(map real*real->bool '(< <= > >= =)) 67 | ,(make-primitive 'gensym (function-type '() 'gensym) #f) 68 | ,(make-primitive 'gensym= (function-type '(gensym gensym) 'bool) #t) 69 | ,(make-primitive 'gensym< (function-type '(gensym gensym) 'bool) #t))) 70 | -------------------------------------------------------------------------------- /vl/syntax.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | ;;;; Abstract Syntax 22 | 23 | (define ((tagged-list? tag) thing) 24 | (and (pair? thing) 25 | (eq? (car thing) tag))) 26 | 27 | (define (constant? thing) 28 | (or (number? thing) 29 | (boolean? thing) 30 | (null? thing) 31 | (quoted? thing))) 32 | 33 | (define (constant-value thing) 34 | (if (quoted? thing) 35 | (cadr thing) 36 | thing)) 37 | 38 | (define quoted? (tagged-list? 'quote)) 39 | 40 | (define (variable? thing) 41 | (symbol? thing)) 42 | 43 | (define variable. 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | 22 | ;;; In addition to the Scheme tradition of using symbols for names, 23 | ;;; FOL also uses FOL-NAME objects to serve as variables. This much 24 | ;;; simplifies autogeneration of unique names, without having to 25 | ;;; intern huge numbers of Scheme symbols. Particularly if such any 26 | ;;; such autogenerated names are temporary to the process of 27 | ;;; compilation and do not appear in the final output, they can be 28 | ;;; garbage collected. 29 | 30 | ;;; FOL-NAME objects print like valid Scheme identifiers so that FOL 31 | ;;; source containing them is easy to read (this makes them not 32 | ;;; read-write invariant). They are also convertible to symbols to 33 | ;;; allow FOL source containing them to be evaluated directly by 34 | ;;; Scheme. 35 | 36 | (define *symbol-count* 0) 37 | 38 | (define-structure 39 | (fol-name 40 | safe-accessors 41 | (print-procedure 42 | (lambda (state object) 43 | (with-current-unparser-state state 44 | (lambda (port) 45 | (write (fol-name-base object) port) 46 | (write '- port) 47 | (write (fol-name-count object) port)))))) 48 | base 49 | count) 50 | 51 | (define (name-base thing) 52 | (cond ((fol-name? thing) 53 | (fol-name-base thing)) 54 | ((symbol? thing) thing) 55 | (else (error "Invalid name" thing)))) 56 | 57 | (define (make-name template) 58 | (set! *symbol-count* (+ *symbol-count* 1)) 59 | (make-fol-name (name-base template) *symbol-count*)) 60 | 61 | (define (name->symbol thing) 62 | (cond ((fol-name? thing) 63 | (symbol (fol-name-base thing) '- (fol-name-count thing))) 64 | ((symbol? thing) thing) 65 | (else "Invalid var" thing))) 66 | 67 | (define prepare-for-scheme 68 | (rule-simplifier 69 | (list 70 | (rule `(? name ,fol-name?) (name->symbol name))))) 71 | 72 | (define (reset-fol-names!) 73 | (set! *symbol-count* 0)) 74 | -------------------------------------------------------------------------------- /dvl/stdlib/basics.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (car (cons x y)) x) 21 | (define (cdr (cons x y)) y) 22 | (define (not x) (if x #f #t)) 23 | (define (append l1 l2) 24 | (if (pair? l1) 25 | (cons (car l1) (append (cdr l1) l2)) 26 | l2)) 27 | 28 | (define least-gensym (gensym)) 29 | (define (gensym-max g1 g2) 30 | (if (gensym< g1 g2) g2 g1)) 31 | 32 | (define (length l) 33 | (if (null? l) 34 | 0 35 | (+ (length (cdr l)) 1))) 36 | 37 | (define (reverse l) 38 | (let loop ((l l) 39 | (answer '())) 40 | (if (null? l) 41 | answer 42 | (loop (cdr l) (cons (car l) answer))))) 43 | 44 | (define (map f l) 45 | (if (null? l) 46 | '() 47 | (cons (f (car l)) (map f (cdr l))))) 48 | 49 | (define (map2 f l1 l2) 50 | (if (null? l1) 51 | '() 52 | (cons (f (car l1) (car l2)) (map2 f (cdr l1) (cdr l2))))) 53 | 54 | (define (map3 f l1 l2 l3) 55 | (if (null? l1) 56 | '() 57 | (cons (f (car l1) (car l2) (car l3)) 58 | (map3 f (cdr l1) (cdr l2) (cdr l3))))) 59 | 60 | (define (tree-map f tree) 61 | (cond ((pair? tree) 62 | (cons (tree-map f (car tree)) 63 | (tree-map f (cdr tree)))) 64 | ((null? tree) tree) 65 | (else (f tree)))) 66 | 67 | (define (map-n f n) 68 | (letrec ((loop (lambda (i) (if (= i n) '() (cons (f i) (loop (+ i 1))))))) 69 | (loop 0))) 70 | 71 | (define (abs x) 72 | (if (g:negative? x) 73 | (g:- 0 x) 74 | x)) 75 | 76 | (define (equal? x y) 77 | (or 78 | (and (null? x) (null? y)) 79 | (and (boolean? x) (boolean? y) (or (and x y) (and (not x) (not y)))) 80 | (and (real? x) (real? y) (= x y)) 81 | (and (pair? x) (pair? y) (equal? (car x) (car y)) (equal? (cdr x) (cdr y))) 82 | (and (gensym? x) (gensym? y) (gensym= x y)))) 83 | 84 | (define ((reduce f i) l) 85 | (if (null? l) i (f (car l) ((reduce f i) (cdr l))))) 86 | 87 | (define sum (reduce g:+ zero)) 88 | (define product (reduce g:* 1)) 89 | 90 | -------------------------------------------------------------------------------- /haskell-fol/fol2hs.hs: -------------------------------------------------------------------------------- 1 | -- ---------------------------------------------------------------------- 2 | -- Copyright 2010-2011 National University of Ireland. 3 | -- ---------------------------------------------------------------------- 4 | -- This file is part of DysVunctional Language. 5 | -- 6 | -- DysVunctional Language is free software; you can redistribute it and/or modify 7 | -- it under the terms of the GNU Affero General Public License as 8 | -- published by the Free Software Foundation, either version 3 of the 9 | -- License, or (at your option) any later version. 10 | -- 11 | -- DysVunctional Language is distributed in the hope that it will be useful, 12 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | -- GNU General Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU Affero General Public License 17 | -- along with DysVunctional Language. If not, see . 18 | -- ---------------------------------------------------------------------- 19 | 20 | {-# LANGUAGE RecordWildCards #-} 21 | import FOL.Language.Common 22 | import FOL.Language.Parser 23 | import FOL.Language.Pretty 24 | 25 | import FOL.Compiler.Haskell.CodeGen 26 | 27 | import Control.Applicative 28 | 29 | import System.Console.GetOpt 30 | import System.Environment 31 | import System.Exit 32 | import Data.Maybe(fromMaybe) 33 | 34 | data Conf = Conf 35 | { moduleName :: String 36 | , exportName :: String 37 | , directory :: Maybe String 38 | } deriving Show 39 | 40 | defaultConf :: Conf 41 | defaultConf = Conf 42 | { moduleName = abort "You must specify a module name" 43 | , exportName = abort "You must specify an exported function name" 44 | , directory = Nothing 45 | } 46 | 47 | usage :: String 48 | usage = usageInfo header options 49 | where 50 | header = "Usage: fol2hs [OPTIONS...] FILE" 51 | 52 | abort :: String -> a 53 | abort msg = error $ msg ++ "\n\n" ++ usage 54 | 55 | options :: [OptDescr (Conf -> IO Conf)] 56 | options = 57 | [ Option ['h'] ["help"] 58 | (NoArg (\_ -> putStrLn usage >> exitWith ExitSuccess)) 59 | "help" 60 | , Option ['m'] ["module"] 61 | (ReqArg (\m conf -> return conf { moduleName = m }) "NAME") 62 | "module NAME" 63 | , Option ['e'] ["export"] 64 | (ReqArg (\e conf -> return conf { exportName = e }) "NAME") 65 | "exported function NAME" 66 | , Option ['d'] ["directory"] 67 | (OptArg (\d conf -> return conf { directory = d }) "PATH") 68 | "output directory PATH" 69 | ] 70 | 71 | main :: IO () 72 | main = do 73 | args <- getArgs 74 | (Conf {..}, input) <- case getOpt Permute options args of 75 | (o, [file], [] ) -> (,) <$> parseOpts o <*> readFile file 76 | (o, [], [] ) -> (,) <$> parseOpts o <*> getContents 77 | (_, _, [] ) -> abort "Too many input files" 78 | (_, _, errors) -> abort $ concat errors 79 | let output = pprint 80 | . compileProgAsModule (Name moduleName) 81 | (Name exportName) 82 | . parse 83 | $ input 84 | outputFile = (fromMaybe "" directory) ++ moduleName ++ ".hs" 85 | writeFile outputFile output 86 | where 87 | parseOpts = foldl (>>=) (return defaultConf) 88 | -------------------------------------------------------------------------------- /vl/nomenclature.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | ;;;; Scheme names for generated code pieces 22 | 23 | ;;; Nothing to see here. 24 | 25 | (define (vl-variable->scheme-variable var) var) 26 | 27 | (define (vl-variable->scheme-field-name var) var) 28 | 29 | (define (vl-variable->scheme-record-access var closure) 30 | `(,(symbol (abstract-closure->scheme-structure-name closure) 31 | '- (vl-variable->scheme-field-name var)) 32 | the-closure)) 33 | 34 | (define (fresh-temporary) 35 | (make-name 'temp)) 36 | 37 | (define *closure-names* (make-abstract-hash-table)) 38 | 39 | (define (abstract-closure->scheme-structure-name closure) 40 | (hash-table/intern! *closure-names* closure 41 | (lambda () (name->symbol (make-name 'closure))))) 42 | 43 | (define (abstract-closure->scheme-constructor-name closure) 44 | (symbol 'make- (abstract-closure->scheme-structure-name closure))) 45 | 46 | (define *call-site-names* (make-abstract-hash-table)) 47 | 48 | (define (call-site->scheme-function-name closure abstract-arg) 49 | (hash-table/intern! *call-site-names* (cons closure abstract-arg) 50 | (lambda () (name->symbol (make-name 'operation))))) 51 | 52 | (define *escaper-names* (make-abstract-hash-table)) 53 | 54 | (define (escaping-closure->scheme-function-name closure) 55 | (hash-table/intern! *escaper-names* closure 56 | (lambda () (name->symbol (make-name 'escaping-operation))))) 57 | 58 | (define *escaper-type-names* (make-abstract-hash-table)) 59 | 60 | (define (escaping-closure->scheme-type-name closure) 61 | (hash-table/intern! *escaper-type-names* closure 62 | (lambda () (name->symbol (make-name 'escaper-type))))) 63 | 64 | (define (clear-name-caches!) 65 | (set! *closure-names* (make-abstract-hash-table)) 66 | (set! *call-site-names* (make-abstract-hash-table)) 67 | (set! *escaper-names* (make-abstract-hash-table)) 68 | (set! *escaper-type-names* (make-abstract-hash-table))) 69 | 70 | (define (initialize-name-caches!) 71 | (set! *closure-names* (make-abstract-hash-table)) 72 | (set! *call-site-names* (make-abstract-hash-table)) 73 | (set! *escaper-names* (make-abstract-hash-table)) 74 | (set! *escaper-type-names* (make-abstract-hash-table)) 75 | (reset-fol-names!)) 76 | -------------------------------------------------------------------------------- /dvl/stdlib/vectors.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (pointwise f obj) 21 | (cond ((real? obj) 22 | (f obj)) 23 | ((pair? obj) 24 | (cons (f (car obj)) (f (cdr obj)))) 25 | ((procedure? obj) 26 | (lambda (x) (f (obj x)))) 27 | (else 28 | obj))) 29 | 30 | (define (pointwise2 f obj1 obj2) 31 | (cond ((and (real? obj1) (real? obj2)) 32 | (f obj1 obj2)) 33 | ((and (pair? obj1) (pair? obj2)) 34 | (cons (f (car obj1) (car obj2)) 35 | (f (cdr obj1) (cdr obj2)))) 36 | ((and (procedure? obj1) (procedure? obj2)) 37 | (lambda (z) 38 | (f (obj1 z) (obj2 z)))) 39 | ((equal? obj1 obj2) 40 | obj1) 41 | (else (error)) ; TODO Error string "Object shape mismatch" 42 | )) 43 | 44 | (define (v:+ x y) 45 | (cond ((universal-zero? x) y) 46 | ((universal-zero? y) x) 47 | ((and (real? x) (real? y)) 48 | (+ x y)) 49 | (else 50 | (pointwise2 g:+ x y)))) 51 | 52 | (define (v:- x y) 53 | (g:+ x (g:* -1 y))) 54 | 55 | (define (v:* obj1 obj2) 56 | (if (real? obj1) 57 | (if (real? obj2) 58 | (* obj1 obj2) 59 | (pointwise (lambda (x) (g:* obj1 x)) obj2)) 60 | (if (real? obj2) 61 | (pointwise (lambda (x) (g:* x obj2)) obj1) 62 | (error)) ; TODO Error string "Multiplication mismatch" 63 | )) 64 | 65 | (define (v:/ obj1 obj2) 66 | (if (real? obj2) 67 | (if (real? obj1) 68 | (/ obj1 obj2) 69 | (pointwise (lambda (x) (g:/ x obj2)) obj1)) 70 | (error) ; TODO Error string "Dividing by a non-real" 71 | )) 72 | 73 | (define zero (gensym)) 74 | 75 | (define (universal-zero? thing) 76 | (and (gensym? thing) 77 | (gensym= thing zero))) 78 | 79 | (define (dot u v) (sum (map2 g:* u v))) 80 | 81 | (define (magnitude-squared v) (dot v v)) 82 | 83 | (define (magnitude v) (g:sqrt (magnitude-squared v))) 84 | 85 | (define (distance pos1 pos2) 86 | (magnitude (g:- pos2 pos1))) 87 | 88 | ;;; TODO Do I need e and ex for anything? They used to be used for, 89 | ;;; e.g., gradient-f, but I don't need them for that anymore. 90 | 91 | ;;; An n-dimensional vector with x in position i and zeros elsewhere. 92 | (define (ex x i n) 93 | (if (zero? n) 94 | '() 95 | (cons (if (zero? i) x (real 0)) (ex x (- i 1) (- n 1))))) 96 | 97 | ;;; The ith n-dimensional basis vector. 98 | (define (e i n) (ex (real 1) i n)) 99 | -------------------------------------------------------------------------------- /dvl/eval.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | ;;;; Concrete evaluator for DVL 22 | 23 | ;;; Functions take only one argument (which they may destructure 24 | ;;; inside). CONS is a special form. LAMBDA and CONS are the only 25 | ;;; non-macro special forms. IF macroexpands into the only primitive 26 | ;;; procedure that accepts and calls DVL procedures as arguments. 27 | ;;; DVL-VALUE->SCHEME-VALUE suffices to let it work its magic properly 28 | ;;; in the concrete evaluator. 29 | 30 | (define (concrete-eval exp env world win) 31 | (cond ((constant? exp) (win (constant-value exp) world)) 32 | ((variable? exp) (win (lookup exp env) world)) 33 | ((null? exp) (win '() world)) 34 | ((lambda-form? exp) 35 | (win (make-closure exp env) world)) 36 | ((pair-form? exp) 37 | (concrete-eval (car-subform exp) env world 38 | (lambda (car-value post-car-world) 39 | (concrete-eval (cdr-subform exp) env post-car-world 40 | (lambda (cdr-value new-world) 41 | (win (cons car-value cdr-value) new-world)))))) 42 | ((application? exp) 43 | (concrete-eval (operator-subform exp) env world 44 | (lambda (operator post-operator-world) 45 | (concrete-eval (operand-subform exp) env post-operator-world 46 | (lambda (operand new-world) 47 | (concrete-apply operator operand new-world win)))))) 48 | (else 49 | (syntax-error "Invalid expression type" exp)))) 50 | 51 | (define (concrete-apply proc arg world win) 52 | (cond ((primitive? proc) 53 | (apply-primitive proc arg world win)) 54 | ((closure? proc) 55 | (concrete-eval (closure-body proc) 56 | (extend-env (closure-formal proc) 57 | arg 58 | (closure-env proc)) 59 | world 60 | win)) 61 | (else 62 | (error "Invalid procedure type" proc)))) 63 | 64 | (define (apply-primitive proc arg world win) 65 | ((primitive-implementation proc) arg world win)) 66 | 67 | (define (interpret form) 68 | (concrete-eval 69 | (macroexpand form) (initial-user-env) (initial-world) 70 | (lambda (value world) 71 | value))) 72 | 73 | (define (dvl-eval form) 74 | (concrete-eval 75 | (macroexpand form) (initial-user-env) (initial-world) 76 | (lambda (value world) 77 | (pp world) 78 | value))) 79 | -------------------------------------------------------------------------------- /vl/read.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | ;;;; Reader 22 | 23 | ;;; This is a little wrapper around the underlying MIT Scheme reader 24 | ;;; that does two interesting things: it parses (include "foo") 25 | ;;; directives (at the top level only) by recursively reading those 26 | ;;; files and splicing their contents into the current one (beware, no 27 | ;;; loop detection); and it interprets the symbol ===> as an 28 | ;;; s-expression comment when used at the top level. The latter is 29 | ;;; for compatibility with a testing framework that would use that 30 | ;;; symbol to delimit expected answers. 31 | 32 | (define (default-extension-to-vlad pathname) 33 | (merge-pathnames (->pathname pathname) (->pathname "foo.vlad"))) 34 | 35 | (define (include-directive? form) 36 | (and (list? form) 37 | (= (length form) 2) 38 | (eq? (first form) 'include) 39 | (string? (second form)))) 40 | 41 | (define (include-definitions-directive? form) 42 | (and (list? form) 43 | (= (length form) 2) 44 | (eq? (first form) 'include-definitions) 45 | (string? (second form)))) 46 | 47 | (define (read-source pathname) 48 | (let ((pathname (default-extension-to-vlad pathname))) 49 | (with-input-from-file pathname 50 | (lambda () 51 | (let loop ((forms '())) 52 | (let ((form (read))) 53 | (if (eof-object? form) 54 | (expand-toplevel-source (reverse forms) pathname) 55 | (loop (cons form forms))))))))) 56 | 57 | (define (expand-toplevel-source forms pathname) 58 | (let loop ((forms forms) (ignore? #f)) 59 | (if (null? forms) 60 | '() 61 | (let ((form (car forms)) (rest (cdr forms))) 62 | (cond 63 | (ignore? (loop rest #f)) 64 | ((eq? '===> form) (loop rest #t)) 65 | ((include-directive? form) 66 | (append (with-working-directory-pathname 67 | (directory-namestring pathname) 68 | (lambda () 69 | (read-source (second form)))) 70 | (loop rest #f))) 71 | ((include-definitions-directive? form) 72 | (append (filter definition? 73 | (with-working-directory-pathname 74 | (directory-namestring pathname) 75 | (lambda () 76 | (read-source (second form))))) 77 | (loop rest #f))) 78 | (else (cons form (loop rest #f)))))))) 79 | -------------------------------------------------------------------------------- /dvl/examples/celestial/celestial-driver.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | 22 | ;;; To play with this, you need the ScmUtils library (for the 23 | ;;; graphics). Then 24 | ;;; - load dvl with (load "load") 25 | ;;; - load this file 26 | ;;; - compile the dvl program 27 | ;;; - execute an integration 28 | 29 | ;;; To compile from the REPL (be sure to start Scheme with enough heap 30 | ;;; and stack space; see the dvl script) 31 | #; 32 | (fol->mit-scheme 33 | (fol-optimize ; Optimize a second time 34 | (compile-to-fol (dvl-source "examples/celestial/celestial.dvl") visibly)) 35 | "examples/celestial/celestial") 36 | 37 | ;;; To compile from the command line 38 | ;$ dvl compile examples/celestial/celestial.dvl visibly optimizing twice 39 | 40 | ;;; To run, do something like this: 41 | ; (go 1000 10. 100.) 42 | 43 | (define (go num-samples time-step num-steps-per-sample) 44 | (stream-take 45 | num-samples 46 | (stream-for-each 47 | (plot-objects window) 48 | ((constant-arg-for-dvl-stream (exact->inexact time-step)) 49 | ((run-mit-scheme compiled-path) 50 | (exact->inexact num-steps-per-sample)))))) 51 | 52 | (define compiled-path 53 | (string-append 54 | (->namestring (self-relatively working-directory-pathname)) 55 | "celestial")) 56 | 57 | (define (constant-arg-for-dvl-stream argument) 58 | (lambda (dvl-stream) 59 | (let loop ((dvl-stream dvl-stream)) 60 | (cons (car dvl-stream) 61 | (delay (loop ((cdr dvl-stream) argument))))))) 62 | 63 | (define (stream-for-each f stream) 64 | (cons (f (car stream)) 65 | (delay (stream-for-each f (force (cdr stream)))))) 66 | 67 | (define ((plot-object window) object) 68 | (let ((position (cadr object))) 69 | (let ((x (car position)) 70 | (y (cadr position))) 71 | ;(pp `(object-at ,x ,y ,z)) 72 | ;(pp `(speed ,@(caddr object))) 73 | ; Drop z coord in plot 74 | (plot-point window x y)))) 75 | 76 | (define ((plot-objects window) state) 77 | (for-each (plot-object window) (cdr state))) 78 | 79 | (define window (frame -60 60 -60 60)) 80 | 81 | (define (stream-take count stream) 82 | (if (= count 0) 83 | stream 84 | (stream-take (- count 1) (force (cdr stream))))) 85 | 86 | (define (compare state1 state2) 87 | (cond ((pair? state1) 88 | (cons (compare (car state1) (car state2)) 89 | (compare (cdr state1) (cdr state2)))) 90 | ((null? state1) 91 | '()) 92 | (else (/ (- state1 state2) state1)))) 93 | -------------------------------------------------------------------------------- /dvl/errors.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | 22 | ;;; Error system. 23 | 24 | ;;; For now these are just hooks for a more elaborate error system, but 25 | ;;; you should respect them. In particular, 26 | ;;; - use internal-error when reporting a situation that should never 27 | ;;; occur regardless of the program being analyzed 28 | ;;; - use syntax-error to report that a putative DVL program is grossly 29 | ;;; malformed 30 | ;;; - use dvl-error when flow-analysis discovers an error in a 31 | ;;; well-formed DVL program 32 | 33 | (define internal-error error) 34 | 35 | (define syntax-error error) 36 | 37 | (define (report-dvl-error dvl-error port) 38 | (format-error-message 39 | (dvl-error-message dvl-error) 40 | `(,(error-irritant/noise " in") 41 | ,(dvl-error-binding dvl-error) 42 | ,(error-irritant/noise ":") 43 | ,@(dvl-error-irritants dvl-error)) 44 | port)) 45 | 46 | (define condition-type:dvl-error 47 | (make-condition-type 48 | 'dvl-error condition-type:simple-error '(binding) report-dvl-error)) 49 | 50 | (define make-dvl-error 51 | (condition-constructor condition-type:dvl-error '(message binding irritants))) 52 | (define dvl-error? (condition-predicate condition-type:dvl-error)) 53 | (define dvl-error-message (condition-accessor condition-type:dvl-error 'message)) 54 | (define dvl-error-binding (condition-accessor condition-type:dvl-error 'binding)) 55 | (define dvl-error-irritants (condition-accessor condition-type:dvl-error 'irritants)) 56 | (define signal-dvl-error 57 | (condition-signaller 58 | condition-type:dvl-error '(message binding irritants) standard-error-handler)) 59 | 60 | (define (dvl-error message . irritants) 61 | (signal-dvl-error message *on-behalf-of* irritants)) 62 | 63 | ;;; Inspecting and debugging tools 64 | 65 | (define (run-up-binding-chain binding stop?) 66 | (cond ((not (= 1 (length (binding-notify binding)))) 67 | binding) 68 | ((stop? (car (binding-notify binding))) 69 | binding) 70 | (else (run-up-binding-chain (car (binding-notify binding)) stop?)))) 71 | 72 | (define (run-up-eval-binding-chain binding) 73 | (run-up-binding-chain binding apply-binding?)) 74 | 75 | (define (confusing-apply-binding? binding) 76 | (and (apply-binding? binding) 77 | (or (not (= 1 (length (binding-notify binding)))) 78 | (let* ((predecessor (car (binding-notify binding))) 79 | (pred-exp (binding-exp predecessor)) 80 | (pred-operator (car pred-exp))) 81 | (not (or (eq? 'if-procedure pred-operator) 82 | (lambda-form? pred-operator))))))) 83 | -------------------------------------------------------------------------------- /dvl/examples/runge-kutta/runge-kutta.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (((manual-naive-euler state-deriv) step) state) 21 | (+ state (* step (state-deriv state)))) 22 | 23 | (define (((manual-rk4 state-deriv) step) state) 24 | (let* ((k1 (* step (state-deriv state))) 25 | (k2 (* step (state-deriv (+ state (* 1/2 k1))))) 26 | (k3 (* step (state-deriv (+ state (* 1/2 k2))))) 27 | (k4 (* step (state-deriv (+ state k3))))) 28 | (+ state (* 1/6 (+ k1 (+ (* 2 k2) (+ (* 2 k3) k4))))))) 29 | 30 | ;; A tableau is a matrix of coefficients for the various steps 31 | (define ((((coefficient-tableau->runge-kutta-integrator tableau) 32 | state-deriv) step) state) 33 | (let loop ((state-deltas '()) 34 | (derivatives '()) 35 | (coeff-lists (map reverse tableau))) 36 | (if (null? coeff-lists) 37 | ;; TODO Should check for null state-deltas (which would have 38 | ;; meant a null tableau) but need an error system for that. 39 | (+ state (car state-deltas)) 40 | (let* ((new-state-delta 41 | (sum (map2 * (car coeff-lists) derivatives))) 42 | (new-derivative 43 | (* step (state-deriv (+ state new-state-delta))))) 44 | (loop (cons new-state-delta state-deltas) 45 | (cons new-derivative derivatives) 46 | (cdr coeff-lists)))))) 47 | 48 | 49 | ;; Things I wish the system would (effectively) deduce by itself 50 | ;; 1) naive-euler is 51 | ;; 0 | 52 | ;; | 1 53 | ;; heun's method, RK4, midpoint method, etc. 54 | ;; 2) RK4 reduces to the simpson rule for quadrature when f(t,y) 55 | ;; doesn't depend on y. 56 | 57 | (define naive-euler 58 | (coefficient-tableau->runge-kutta-integrator 59 | '(() 60 | (1)))) 61 | 62 | (define rk4 63 | (coefficient-tableau->runge-kutta-integrator 64 | '(() 65 | (1/2) 66 | (0 1/2) 67 | (0 0 1) 68 | (1/6 1/3 1/3 1/6)))) 69 | 70 | (define (step-stream method state-deriv init-state) 71 | (let loop ((state init-state)) 72 | (cons state 73 | (lambda (step) 74 | (loop (((method state-deriv) step) state)))))) 75 | 76 | (define (downsampled-stream stream count) 77 | (let loop ((stream stream)) 78 | (let ((state (car stream)) 79 | (next (cdr stream))) 80 | (cons state 81 | (lambda (arg) 82 | (let countdown ((count count) 83 | (stream stream)) 84 | (if (<= count 0) 85 | (loop stream) 86 | (countdown (- count 1) 87 | ((cdr stream) arg))))))))) 88 | -------------------------------------------------------------------------------- /support/auto-compilation.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2013 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | 22 | ;;;; Auto-compilation 23 | 24 | ;;; A facility for automatically (re)compiling files at load time so 25 | ;;; as to avoid both the hassle of manual recompilations and the 26 | ;;; slowness of running interpreted code. Takes care around macros 27 | ;;; from previously loaded files. 28 | 29 | (define (self-relatively thunk) 30 | (let ((place (ignore-errors current-load-pathname))) 31 | (if (pathname? place) 32 | (with-working-directory-pathname 33 | (directory-namestring place) 34 | thunk) 35 | (thunk)))) 36 | 37 | (define (load-relative filename #!optional environment) 38 | (self-relatively (lambda () (load filename environment)))) 39 | 40 | (define (compiled-code-type) 41 | ;; Trying to support the C backend 42 | (if (lexical-unbound? 43 | (nearest-repl/environment) 44 | 'compiler:compiled-code-pathname-type) 45 | "com" 46 | (compiler:compiled-code-pathname-type))) 47 | 48 | ;; The environment argument is the one to take macro definitions from 49 | ;; for sf. 50 | (define (cf-conditionally filename #!optional environment) 51 | (define (default-environment) 52 | (if (current-eval-unit #f) 53 | (current-load-environment) 54 | (nearest-repl/environment))) 55 | (if (default-object? environment) 56 | (set! environment (default-environment))) 57 | (fluid-let ((sf/default-syntax-table environment)) 58 | (sf-conditionally filename)) 59 | (if (cf-seems-necessary? filename) 60 | (compile-bin-file filename))) 61 | 62 | (define (compiler-available?) 63 | (not (lexical-unbound? (nearest-repl/environment) 'cf))) 64 | 65 | (define (compilation-seems-necessary? filename) 66 | (or (sf-seems-necessary? filename) 67 | (cf-seems-necessary? filename))) 68 | 69 | (define (sf-seems-necessary? filename) 70 | (not (file-processed? filename "scm" "bin"))) 71 | 72 | (define (cf-seems-necessary? filename) 73 | (not (file-processed? filename "bin" (compiled-code-type)))) 74 | 75 | (define (load-compiled filename #!optional environment) 76 | (if (compiler-available?) 77 | (begin (cf-conditionally filename environment) 78 | (load filename environment)) 79 | (if (compilation-seems-necessary? filename) 80 | (begin (warn "The compiler does not seem to be loaded") 81 | (warn "Are you running Scheme with --compiler?") 82 | (warn "Skipping compilation; loading source interpreted") 83 | (load (pathname-default-type filename "scm") environment)) 84 | (load filename environment)))) 85 | 86 | (define (load-relative-compiled filename #!optional environment) 87 | (self-relatively (lambda () (load-compiled filename environment)))) 88 | -------------------------------------------------------------------------------- /dvl/examples/runge-kutta/runge-kutta-driver.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; To try this out 21 | ;;; - load dvl with (load "load") 22 | ;;; - load this file 23 | ;;; - feel free to draw some pictures, such as the below: 24 | 25 | #| 26 | ;; Naive Euler is not so good: its errors accumulate 27 | ;; (see the red points diverge from the real answer, in green) 28 | (plot estimate "with points, exp(x)" 29 | (integrate exp-euler 0.25 10)) ; The numbers are time step and total time 30 | 31 | ;; Runge-Kutta 4 is much better, even holding constant the number of 32 | ;; function evaluations rather than the time step 33 | (plot estimate "with points, exp(x)" 34 | (integrate exp-rk4 1.0 10)) ; RK4 calls the function 4 times per step 35 | 36 | ;; Here's what RK4's relative error looks like (note scale). 37 | (plot (relative-error exp) "with points" 38 | (integrate exp-rk4 1.0 10)) 39 | 40 | ;; Same story with sin rather than exp; naive euler consistently 41 | ;; overshoots. 42 | (plot estimate "with points, sin(x)" 43 | (integrate sin-euler 0.25 10)) 44 | 45 | (plot estimate "with points, sin(x)" 46 | (integrate sin-rk4 1.0 10)) ; RK4 calls the function 4 times per step 47 | 48 | (plot (relative-error sin) "with points" 49 | (integrate sin-rk4 1.0 10)) 50 | |# 51 | 52 | (load-relative-compiled "gnuplot") 53 | (self-relatively 54 | (lambda () 55 | (fol->floating-mit-scheme 56 | (compile-to-fol (dvl-source "integrations.dvl") visibly) 57 | "integrations"))) 58 | 59 | (define integrations 60 | (self-relatively 61 | (lambda () 62 | (run-mit-scheme "integrations")))) 63 | 64 | (define exp-euler (car integrations)) 65 | (define exp-rk4 (cadr integrations)) 66 | (define sin-euler (caddr integrations)) 67 | (define sin-rk4 (cadddr integrations)) 68 | 69 | (define (integrate integration time-step total-time) 70 | (let loop ((result '()) 71 | (integration integration)) 72 | (let* ((state (car integration)) 73 | (current-time (car state)) 74 | (func (cdr integration))) 75 | (if (> current-time total-time) 76 | (reverse result) 77 | (loop (cons state result) 78 | (func time-step)))))) 79 | 80 | (define (plot xxx command time-series) 81 | (gnuplot-alist 82 | (map (lambda (datum) 83 | (let ((time (car datum)) 84 | (estimate (cadr datum))) 85 | (cons time (xxx time estimate)))) 86 | time-series) 87 | `(commanding ,command))) 88 | 89 | (define (estimate time estimate) estimate) 90 | 91 | (define ((relative-error truth) time estimate) 92 | (if (>= (abs (truth time)) 1) 93 | (/ (- (truth time) estimate) (truth time)) 94 | (- (truth time) estimate))) 95 | 96 | -------------------------------------------------------------------------------- /dvl/examples/mandelbrot/mandelbrot.ghc-2.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- The Computer Language Benchmarks Game 3 | -- http://benchmarksgame.alioth.debian.org/ 4 | -- 5 | -- Contributed by Spencer Janssen, Trevor McCort, Christophe Poucet and Don Stewart 6 | -- Parallelised by Tim Newsham 7 | -- 8 | -- Must be compiled with the -fexcess-precision flag as a pragma. GHC 9 | -- currently doesn't recognise the -fexcess-precision flag on the command 10 | -- line (!). 11 | -- 12 | -- The following flags are suggested when compiling: 13 | -- 14 | -- ghc -optc-march=pentium4 -optc-mfpmath=sse -optc-msse2 -threaded --make 15 | -- 16 | -- Run with -N6 on a quad core (more capabilities to hide latency) 17 | -- 18 | -- $ time ./A 6400 +RTS -N6 19 | -- 20 | 21 | import System.Environment 22 | import System.IO 23 | import Foreign 24 | import Foreign.Marshal.Array 25 | import Control.Concurrent 26 | import Control.Concurrent.MVar 27 | import Control.Concurrent.Chan 28 | import Control.Monad 29 | 30 | main = do 31 | -- width in pixels 32 | w <- getArgs >>= readIO . head 33 | -- width in bytes 34 | let n = w `div` 8 35 | -- width of a pixel in the complex plane 36 | m = 2 / fromIntegral w 37 | coords = [T 1 0 y (fromIntegral y * m - 1) | y <- [0..w-1]] 38 | q <- newChan 39 | replies <- replicateM w newEmptyMVar 40 | mapM_ (writeChan q) $ zip coords replies 41 | replicateM_ 4 . forkIO $ worker q w m n 42 | 43 | putStrLn ("P4\n"++show w++" "++show w) 44 | mapM_ (takeMVar >=> \b -> hPutBuf stdout b n) replies 45 | 46 | -- Worker computes one line of the image and sends it to the master 47 | -- q - work queue 48 | -- w - width in pixels 49 | -- m - width of a pixel in the complex plane 50 | -- n - width in bytes 51 | worker q w m n = forever (do 52 | (coord, reply) <- readChan q 53 | p <- mallocArray0 n 54 | unfold (next_x w m n) p coord 55 | putMVar reply p) 56 | 57 | -- f - takes coordinates and returns Nothing if done 58 | -- or the next byte of the bitmap otherwise. 59 | -- ptr - buffer to write to 60 | -- x0 - initial coordinates 61 | unfold :: (T -> Maybe (Word8,T)) -> Ptr Word8 -> T -> IO (Ptr Word8) 62 | unfold !f !ptr !x0 = go ptr x0 63 | where 64 | -- p - pointer into the buffer 65 | -- x - coordinates 66 | go !p !x = case f x of 67 | Just (w,y) -> poke p w >> go (p `plusPtr` 1) y 68 | Nothing -> return ptr 69 | 70 | -- T bs x y ci 71 | -- bx - x position in bytes 72 | -- x - x position in pixels 73 | -- y - y position in pixels 74 | -- ci - y position in complex plane 75 | data T = T !Int !Int !Int !Double 76 | 77 | -- w - image width in pixels 78 | -- iw - pixel width in the complex plane 79 | -- bw - image width in bytes 80 | next_x !w !iw !bw (T bx x y ci) 81 | | bx == bw = Nothing 82 | | otherwise = Just (loop_x w x 8 iw ci 0, T (bx+1) (x+8) y ci) 83 | 84 | -- w - image width in pixels 85 | -- x - current x coordinate in pixels 86 | -- n - bit positition from 8 to 0 87 | -- iw - pixel width in the complex plane 88 | -- ci - current y coordinate in complex plane 89 | -- b - accumulated bit value. 90 | loop_x !w !x !n !iw !ci !b 91 | | x < w = if n == 0 92 | then b 93 | else loop_x w (x+1) (n-1) iw ci (b+b+v) 94 | | otherwise = b `shiftL` n 95 | where 96 | v = fractal 0 0 (fromIntegral x * iw - 1.5) ci 50 97 | 98 | -- julia function (r :+ i) (cr :+ ci) with max iterations k. 99 | fractal :: Double -> Double -> Double -> Double -> Int -> Word8 100 | fractal !r !i !cr !ci !k 101 | | r2 + i2 > 4 = 0 102 | | k == 0 = 1 103 | | otherwise = fractal (r2-i2+cr) ((r+r)*i+ci) cr ci (k-1) 104 | where 105 | (!r2,!i2) = (r*r,i*i) 106 | -------------------------------------------------------------------------------- /fol/doc/simplification.txt: -------------------------------------------------------------------------------- 1 | Algebraic Simplification 2 | June 1, 2011 3 | Alexey Radul 4 | 5 | The FOL common subexpression eliminator performs some algebraic 6 | simplification of the program to expose additional common 7 | subexpressions. For example, 8 | 9 | (+ x 1) == (+ (+ x 0) 1) 10 | 11 | only if you know that (+ x 0) is the same as x. So collapsing (+ x 0) 12 | to x saves not only the redundant add of 0, it also allows one to 13 | recognize a potentially large pile of consequent common-subexpression 14 | optimizations. 15 | 16 | There are two things to ask about every algebraic simplificiation: 17 | - Does it preserve the semantics of the program? 18 | - What part of the compilation process should do it? 19 | 20 | The eliminator performs the following simplifications: 21 | 22 | (+ x 0) --> x 23 | (+ 0 x) --> x 24 | (- x 0) --> x 25 | 26 | (* x 1) --> x 27 | (* 1 x) --> x 28 | (/ x 1) --> x 29 | 30 | (* x 0) --> 0 31 | (* 0 x) --> 0 32 | (/ 0 x) --> 0 33 | 34 | (if foo bar bar) --> bar 35 | 36 | The first six of these preserve the semantics of FOL programs, even 37 | for floating point numbers. CSE is also the best place in the 38 | software stack for them, because they would have no effect on flow 39 | analysis (because if x were known at compile time they would get done 40 | by constant folding, and if x were an abstract-real at compile time, 41 | the output would still be an abstract-real), so might as well not 42 | clutter it with them. 43 | 44 | The next three are considerably more complicated. First of all, they 45 | do not conform to the floating point standard: 46 | 47 | (* 0 Inf) = NaN, not 0 48 | (* 0 NaN) = NaN, not 0 49 | (/ 0 NaN) = NaN, not 0 50 | (/ 0 0) = NaN, not 0 51 | 52 | Second, transforming (* 0 x) to 0 changes the strictness properties of 53 | *, namely allows it to be lazy in the non-zero argument. This may be 54 | an issue if evaluating x would have produced some interesting 55 | behavior. If the program is in A-normal form, that problem can be 56 | punted to the dead code eliminator, but if it is not, some care should 57 | be taken about the subexpression that would produce x. 58 | 59 | On the other hand, (* 0 x) --> 0 is worth thinking about despite these 60 | problems, because it chains and can therefore eliminate lots of excess 61 | code by itself. In particular, taking tangents of things that are not 62 | bundles and asking for sensitivities of things that get dropped will 63 | generate lots of zeros which will constantly get multiplied by things, 64 | and eliminating all that work can probably lead to much acceleration. 65 | TODO Is there a really compelling example of this? 66 | 67 | On the third hand, the importance of (* 0 x) --> 0 also complicates 68 | its position in the software stack. It would be effective directly in 69 | flow analysis, because it would allow x not to be analyzed at all, and 70 | would yield a nice constant to propagate through its return value. On 71 | the other hand, that would involve putting at least some 72 | simplification machinery into the flow analysis, which would be 73 | redundant with the simplification machinery that CSE needs anyway. 74 | Finally, simplifying (* 0 x) to 0 kills that use of x, which may 75 | expose more dead code (and, if the input program were not in A-normal 76 | form, the consequences of removing that dead code, like more procedure 77 | inlining). This is both a great benefit of doing this optimization, 78 | and also puts more constraints on the ordering of FOL compilation 79 | stages. 80 | 81 | The last simplification, (if foo bar bar) --> bar, is intermediate in 82 | complexity. It changes the strictness of IF, allowing it to be lazy 83 | in the predicate when the consequent and alternate are the same 84 | expression, but it doesn't cause any other trouble. 85 | -------------------------------------------------------------------------------- /fol/test/utils.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | 22 | ;;; Two more adverbs that are useful in tests 23 | 24 | (define (carefully stage-data) 25 | (define (check-annotations program) 26 | (if (present? 'structures-as-vectors program) 27 | (check (equal? program (structure-definitions->vectors program)))) 28 | (if (present? 'unique-names program) 29 | (check (unique-names? program))) 30 | (if (present? 'type program) 31 | (let ((annotated-type (property-value 'type program))) 32 | (check (equal-type? 33 | annotated-type 34 | (check-program-types program) 35 | ;; TODO Actually, I should use the type map from the 36 | ;; pre-transform program, because the transform may 37 | ;; remove but may not add type names. 38 | (type-map program))))) 39 | (if (present? 'a-normal-form program) 40 | (check (approximate-anf? program))) 41 | (if (present? 'lets-lifted program) 42 | (check (lets-lifted? program))) 43 | (if (present? 'fully-inlined program) 44 | (check (equal? program (inline program)))) 45 | (if (and (present? 'aggregates-replaced program) 46 | (present? 'a-normal-form program)) 47 | (check (equal? program (scalar-replace-aggregates program)))) 48 | (if (present? 'dead-types-eliminated program) 49 | (check (equal? program (eliminate-dead-types program)))) 50 | (if (and (present? 'no-common-subexpressions program) 51 | (present? 'a-normal-form program) 52 | (present? 'lets-lifted program)) 53 | (check (equal? program (intraprocedural-cse program)))) 54 | (if (present? 'no-intraprocedural-dead-variables program) 55 | (check (equal? program 56 | (eliminate-intraprocedural-dead-code program)))) 57 | (if (present? 'no-interprocedural-dead-variables program) 58 | (check (equal? program 59 | (eliminate-interprocedural-dead-code program)))) 60 | program) 61 | (lambda (exec) 62 | (lambda (program . extra) 63 | ;; TODO Also check counterfactual invariants: 64 | ;; - Inlining commutes with ANF up to removal of aliases. Why 65 | ;; aliases? Because inlining saves ANF work by naming the 66 | ;; expressions that are arguments to inlined procedures. 67 | ;; - Inlining preserves ANF 68 | ;; - Inlining commutes with SRA+ANF up to aliases. 69 | (check-annotations (apply exec program extra))))) 70 | 71 | (define ((meticulously answer) stage-data) 72 | (lambda (exec) 73 | (lambda (program) 74 | (abegin1 75 | (((carefully stage-data) exec) program) 76 | (check (equal? answer (fol-eval it))))))) 77 | -------------------------------------------------------------------------------- /vl/env.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (declare (usual-integrations)) 21 | ;;;; Environments 22 | 23 | ;;; In this code, environments are flat, restricted to the variables 24 | ;;; actually referenced by the closure whose environment it is, and 25 | ;;; sorted by the bound names. This canonical form much simplifies 26 | ;;; comparing and unioning them during the abstract analysis. 27 | 28 | (define-structure (env (safe-accessors #t) (constructor %make-env (bindings))) 29 | bindings 30 | (cached-abstract-hash #f)) 31 | 32 | (define (make-env bindings) 33 | (%make-env 34 | (sort 35 | bindings 36 | (lambda (binding1 binding2) 37 | (variable. 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; Variations on IF 21 | 22 | (if (< (real 3) (real 6)) 23 | (real 4) 24 | (real 3)) ===> 4 25 | 26 | (if (< 3 6) 27 | (real 4) 28 | (real 3)) ===> 4 29 | 30 | ;;; Variations on destructuring 31 | 32 | (let ((my-add (lambda (x y) (+ (real x) (real y))))) 33 | (my-add 3 6)) ===> 9 34 | 35 | (let ((my-add (lambda (foo) (+ foo)))) 36 | (my-add (cons (real 3) (real 6)))) ===> 9 37 | 38 | (let ((my-add (lambda (foo) (+ foo)))) 39 | (my-add (cons 3 (real 6)))) ===> 9 40 | 41 | (let ((my-add (lambda (foo) (real (+ foo))))) 42 | (my-add 3 6)) ===> 9 43 | 44 | (let ((delay-add (lambda (x y) (lambda () (+ x y))))) 45 | ((delay-add (real 3) (real 6)))) ===> 9 46 | 47 | (let ((frobnicate (lambda (x) (real x)))) 48 | (frobnicate 3)) ===> 3 49 | 50 | ;;; Recursion with non-primitive procedures 51 | 52 | (let ((my-* (lambda (x y) (* x y)))) 53 | (letrec ((fact (lambda (n) 54 | (if (= n 1) 55 | 1 56 | (my-* n (fact (- n 1))))))) 57 | (fact (real 5)))) ===> 120 58 | 59 | (let ((my-* (lambda (x y) (* x y)))) 60 | (letrec ((fact (lambda (n) 61 | (if (= n 1) 62 | 1 63 | (my-* n (fact (- n 1))))))) 64 | (fact 5))) ===> 120 65 | 66 | ;;; Factorial, with letrec manually macro expanded 67 | 68 | (let ((Z (lambda (f) 69 | ((lambda (x) 70 | (f (lambda (y) ((x x) y)))) 71 | (lambda (x) 72 | (f (lambda (y) ((x x) y)))))))) 73 | (let ((fact (Z (lambda (fact) 74 | (lambda (n) 75 | (if (= n 1) 76 | 1 77 | (* n (fact (- n 1))))))))) 78 | (fact (real 5)))) ===> 120 79 | 80 | ;;; Mutual recursion with non-primitives 81 | 82 | (let () 83 | (define (my-- x y) 84 | (- x y)) 85 | (define (even? n) 86 | (if (= n 0) 87 | #t 88 | (odd? (my-- n 1)))) 89 | (define (odd? n) 90 | (if (= n 0) 91 | #f 92 | (even? (my-- n 1)))) 93 | (even? (real 5))) ===> #f 94 | 95 | (let () 96 | (define (my-* x y) 97 | (* x y)) 98 | (define (fact-1 n) 99 | (if (= n 0) 100 | 1 101 | (my-* n (fact-2 (- n 1))))) 102 | (define (fact-2 n) 103 | (if (= n 0) 104 | 1 105 | (my-* n (fact-1 (- n 1))))) 106 | (fact-1 (real 6))) ===> 720 107 | 108 | 109 | (let () 110 | (define (car (cons x y)) x) 111 | (define (cdr (cons x y)) y) 112 | (define (map f l) 113 | (if (null? l) 114 | '() 115 | (cons (f (car l)) (map f (cdr l))))) 116 | (map sqrt (list 1 4 9 16))) ===> (1 2 3 4) 117 | 118 | (let () 119 | (define (car (cons x y)) x) 120 | (define (cdr (cons x y)) y) 121 | (define (map f l) 122 | (if (null? l) 123 | '() 124 | (cons (f (car l)) (map f (cdr l))))) 125 | (map sqrt (list (real 1) (real 4) (real 9) (real 16)))) ===> (1 2 3 4) 126 | -------------------------------------------------------------------------------- /dvl/doc/adventures-talk-apr-2013/talk.txt: -------------------------------------------------------------------------------- 1 | A great deal of this class has been about 2 | modularity and flexibility. I want to spend a 3 | lecture talking about a way to avoid its costs. 4 | 5 | Can get SBCL to within 2-3x of Fortran 6 | - but only by writing your program in Lisptran 7 | (if with nice macros) 8 | 9 | Fortran is fast simply because it doesn't give 10 | you any modularity constructs that would confuse 11 | the compilers. 12 | 13 | Lisp compilers give comparable performance, but 14 | only without those same modularity constructs. 15 | 16 | There is another way; it has its own price. 17 | What's the trouble with modularity? Can't 18 | optimize across module boundaries. 19 | - (map f lst): don't know f, don't know where the 20 | lst came from 21 | - modularity means map can be used in many 22 | places; can't improve the one global map 23 | - small example: mandelbrot 24 | - Want to write (iterate (real 100) (step c) 0) 25 | - Want to get integrated arithmetic 26 | no consing, no stack, just arithmetic 27 | - bigger example: ODE simulation 29 | 30 | Local optimizations are mostly useless, because 31 | (good) programmers tend to write fairly optimal 32 | code within modularity boundaries (e.g., 33 | functions). 34 | The only game in town for fixing this is copying 35 | and specialization in some form. 36 | 37 | Inlining: make copies of revelant functions that 38 | are used only here, then do local optimizations. 39 | - e.g., map-over-iota 40 | 41 | Big problem: intermediate expression bulge. You 42 | have to copy (which costs) before seeing 43 | optimizations (benefits). This tends to get 44 | combinatorially large. 45 | 46 | Partial evaluation, supercompilation are all 47 | attempts to organize interleaving the copying 48 | with the reduction. 49 | 50 | I will show you another way to organize copying 51 | and specialization, from the perspective of flow 52 | analysis. 53 | Fundamentally, any kind of compiler has to have 54 | an interpreter in it. 55 | 56 | This interpreter has a problem: it has to go both 57 | ways on IF. 58 | 59 | To keep from running forever, have to stop 60 | somewhere. 61 | 62 | Can stop at module boundaries, but that defeats 63 | today's purpose. 64 | 65 | Other way: keep some representation of what's 66 | been seen, stop if you see the "same thing" 67 | again. 68 | 69 | So the analysis structure is a kind of cache for 70 | loop detection. 71 | In this program, an analysis looks like this: 72 | 73 | - expression-environment -> value 74 | - operator-argument -> value 75 | - abstract values 76 | 77 | A binding here is two things: 78 | - An assertion that this value is the smallest 79 | cover of things this expression is known to 80 | return in this environment 81 | - Aside about purity 82 | - A desire to find more possible things 83 | 84 | We are going from the bottom up in order to find 85 | the tightest solution 86 | - Avoid temptation: Start precise, become sound 87 | 88 | 89 | - bottom, constants, abstract-boolean, 90 | abstract-real, (), cons, environments, closures 91 | with all possible bodies, top 92 | - lattice simple; only good for some programs 93 | Walk through example of factorial (on 94 | abstract-real) 95 | - mention what would happen if we went from the 96 | top down 97 | 98 | interpreters, expand and "refine" 99 | - On hand: driver loop, analysis data structure 100 | 101 | IF is done as a primitive procedure that takes 102 | closures 103 | - Show IF? 104 | On code generation: 105 | 106 | Can generate first-order code directly from the 107 | analysis. 108 | 109 | Every apply binding (with unsolved return) 110 | becomes a new procedure 111 | - Already closure-converted 112 | - IF requires some care, as usual 113 | 114 | Result will have tons of small functions; not 115 | efficient yet, but now amenable to standard 116 | techniques since all call sites now known. 117 | So that's about it. 118 | 119 | References, credits 120 | 121 | (super stands for "supervised", not "superior") 122 | -------------------------------------------------------------------------------- /dvl/examples/richardson.dvl: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010-2011 National University of Ireland. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of DysVunctional Language. 5 | ;;; 6 | ;;; DysVunctional Language is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU Affero General Public License as 8 | ;;; published by the Free Software Foundation, either version 3 of the 9 | ;;; License, or (at your option) any later version. 10 | ;;; 11 | ;;; DysVunctional Language is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU Affero General Public License 17 | ;;; along with DysVunctional Language. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (include "streams.dvl") 21 | 22 | (define (ones) 23 | (cons 1 ones)) 24 | 25 | ; (nth-stream ones (real 4)) 26 | 27 | (define (stream-of-iterates next value) 28 | ((iterate next) value)) 29 | 30 | (define (increment x) 31 | (+ x 1)) 32 | 33 | (define integers (stream-of-iterates increment (real 0))) 34 | 35 | ; Constrast (nth-stream integers 6) 36 | ; with (nth-stream integers (real 6)) 37 | 38 | (define (map-streams1 f s1) 39 | (stream-map f s1)) 40 | 41 | (define (map-streams f s1 s2) 42 | (stream-map2 f s1 s2)) 43 | 44 | (define (refine-by-doubling s) 45 | (/ s (sqrt (+ 2 (sqrt (- 4 (* s s))))))) 46 | 47 | (define side-lengths (stream-of-iterates refine-by-doubling (real (sqrt 2)))) 48 | 49 | (define side-numbers (stream-of-iterates (lambda (n) (* 2 n)) (real 4))) 50 | 51 | (define (semi-perimeter length-of-side number-of-sides) 52 | (* (/ number-of-sides 2) length-of-side)) 53 | 54 | (define archimedian-pi-sequence 55 | (map-streams semi-perimeter side-lengths side-numbers)) 56 | 57 | ; (nth-stream archimedian-pi-sequence (real 19)) 58 | 59 | (define (make-zeno-sequence R h) 60 | (lambda () 61 | (cons (R h) 62 | (make-zeno-sequence R (/ h 2))))) 63 | 64 | (define (richardson-trick error-order) 65 | (let ((2^p (expt 2 error-order))) 66 | (lambda (Rh Rh/2) 67 | (/ (- (* 2^p Rh/2) Rh) (- 2^p 1))))) 68 | 69 | ;; This version duplicates the work of computing the stream values 70 | #; 71 | (define (accelerate-zeno-sequence seq error-order) 72 | (map-streams 73 | (richardson-trick error-order) 74 | seq 75 | (tail seq))) 76 | 77 | ;; This version therefore compiles much faster. 78 | ;; I think I would need cross-loop-iteration alias analysis to 79 | ;; recollapse the computations. 80 | (define (accelerate-zeno-sequence seq error-order) 81 | (map-streams1 (richardson-trick error-order) (stream-of-adjacent-pairs seq))) 82 | 83 | ; (nth-stream (accelerate-zeno-sequence archimedian-pi-sequence (real 2)) (real 1)) 84 | 85 | ;;; Hm. Unfortunately, I can't actually do this. The problem is that 86 | ;;; the analysis eagerly chases down the definition of the stream, but 87 | ;;; each new element is made by a closure that has a longer chain of 88 | ;;; accelerations in its environment. I suppose I should even have 89 | ;;; known that: computing each next element of the tableau requires an 90 | ;;; increasing amount of intermediate storage, so it can't be 91 | ;;; union-free. 92 | (define (make-richardson-tableau seq error-orders) 93 | (lambda () 94 | (let (((cons order rest) (force error-orders))) 95 | (cons seq (make-richardson-tableau 96 | (accelerate-zeno-sequence seq order) 97 | rest))))) 98 | 99 | (define (richardson-sequence seq error-orders) 100 | (map-streams1 head (make-richardson-tableau seq error-orders))) 101 | 102 | (define evens (stream-of-iterates (lambda (n) (+ n 2)) (real 2))) 103 | 104 | (nth-stream (richardson-sequence archimedian-pi-sequence evens) (real 0)) 105 | 106 | -------------------------------------------------------------------------------- /dvl/doc/boston-slug-talk-aug-2013/mandel-driver.js: -------------------------------------------------------------------------------- 1 | /// ---------------------------------------------------------------------- 2 | /// Copyright 2013 Alexey Radul. 3 | /// ---------------------------------------------------------------------- 4 | /// This file is part of DysVunctional Language. 5 | /// 6 | /// DysVunctional Language is free software; you can redistribute it and/or modify 7 | /// it under the terms of the GNU Affero General Public License as 8 | /// published by the Free Software Foundation, either version 3 of the 9 | /// License, or (at your option) any later version. 10 | /// 11 | /// DysVunctional Language is distributed in the hope that it will be useful, 12 | /// but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | /// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | /// GNU General Public License for more details. 15 | /// 16 | /// You should have received a copy of the GNU Affero General Public License 17 | /// along with DysVunctional Language. If not, see . 18 | /// ---------------------------------------------------------------------- 19 | 20 | var mandel = fol_program(window, "foo", new ArrayBuffer(4096)); 21 | 22 | function setPixel(imageData, x, y, r, g, b, a) { 23 | index = (x + y * imageData.width) * 4; 24 | imageData.data[index+0] = r; 25 | imageData.data[index+1] = g; 26 | imageData.data[index+2] = b; 27 | imageData.data[index+3] = a; 28 | } 29 | 30 | function dataFor(width, height) { 31 | var start = new Date(); 32 | var aliasDepth = 2; 33 | var answer = new Array(width); 34 | for (var i = 0; i < width; i++) { 35 | var x = 3*(+i)/width - 2.0; 36 | var dx = 1.0/(aliasDepth*width); 37 | var subAnswer = new Array(height); 38 | answer[i] = subAnswer; 39 | for (var j = 0; j < height; j++) { 40 | var y = 3*(+j)/height - 1.5; 41 | var dy = 1.0/(aliasDepth*height); 42 | var ct = 0; 43 | for (var ii = 0; ii < aliasDepth; ii++) { 44 | for (var jj = 0; jj < aliasDepth; jj++) { 45 | if(mandel(x+ii*dx, y+jj*dy)) {ct = ct + 1;} 46 | } 47 | } 48 | color = 240-(240*ct/(aliasDepth*aliasDepth)); 49 | answer[i][j] = color; 50 | } 51 | } 52 | var done = new Date(); 53 | // 10 flops per iteration by 400 iterations per point 54 | var flops = 10*400*width*height*aliasDepth*aliasDepth; 55 | reportTime('' + width + "x" + height, flops, done-start); 56 | return answer; 57 | } 58 | 59 | function reportTime(res, flops, time) { 60 | var row = document.createElement('tr'); 61 | var datum1 = document.createElement('td'); 62 | datum1.appendChild(document.createTextNode(res)); 63 | var datum2 = document.createElement('td'); 64 | datum2.appendChild(document.createTextNode(flops/1000000)); 65 | var datum3 = document.createElement('td'); 66 | datum3.appendChild(document.createTextNode(time)); 67 | row.appendChild(datum1); 68 | row.appendChild(datum2); 69 | row.appendChild(datum3); 70 | var table = document.getElementById('timings'); 71 | table.appendChild(row); 72 | } 73 | 74 | function scaleit(scale) { 75 | canvas = document.getElementById("it"); 76 | context = canvas.getContext("2d"); 77 | width = canvas.width; 78 | height = canvas.height; 79 | colorData = dataFor(width/scale, height/scale); 80 | imageData = context.createImageData(width, height); 81 | for (var i = 0; i < width/scale; i++) { 82 | for (var j = 0; j < height/scale; j++) { 83 | color = colorData[i][j]; 84 | for (var ii = 0; ii < scale; ii++) { 85 | for (var jj = 0; jj < scale; jj++) { 86 | setPixel(imageData, i*scale + ii, j*scale + jj, color, color, color, 255); 87 | } 88 | } 89 | } 90 | } 91 | context.putImageData(imageData, 0, 0); 92 | } 93 | 94 | function doit() { 95 | walkScales(0); 96 | } 97 | 98 | function walkScales(i) { 99 | var scales = [10,5,2,1]; 100 | scaleit(scales[i]); 101 | if (i+1 < scales.length) { 102 | window.setTimeout(walkScales, 10, i+1); 103 | } 104 | } 105 | -------------------------------------------------------------------------------- /dvl/doc/type-annotations.txt: -------------------------------------------------------------------------------- 1 | On Type Annotation for FFI and Unions for DVL 2 | Alexey Radul 3 | July 1, 2013 4 | 5 | DVL's foreign interface problem and union type problem can be solved 6 | with optional type annotations, as follows: 7 | 8 | Define a type definition construct, which allows for named products, 9 | named sums, named functions, and maybe anonymous combinations; and has 10 | appropriate primitives (ideally, one would be able to spell any 11 | abstract value this way, but much can be accomplished even without 12 | being able to describe closure pointers). You can define named types 13 | anywhere, and they are scoped. 14 | 15 | Then, additional type information can be added to any object, by 16 | syntax that accepts a type and an object, and returns an object with 17 | augmented information. One should be able to augment information in 18 | the following ways: 19 | - (Warn) I expect this object to have this type, warn me if not 20 | - (Error) This object ought to have this type, reject the program if not 21 | - (Assert) This object has this type, treat it as though it did, whether it does or no. 22 | Also, there are four possible relationships between the type specified 23 | and the type that the analysis deduces for the object: 24 | - Equality (neither broader nor narrower) 25 | - Specified type is strictly broader 26 | - Specified type is strictly narrower 27 | - Incomparable (both broader and narrower) 28 | The programmer should be able to specify actions based on any of these 29 | relationships, for a total of 12 possible kinds of declarations (some 30 | of which are presumably more useful than others). In the case of 31 | narrowing asserts, there should also be an option to insert a runtime 32 | check, or not. 33 | 34 | Now, how can this solve DVL's problems? Well, it allows introduction 35 | of arbitrary (including recursive) unions by a broader assert 36 | annotation -- any union of finite length lists will compare narrower 37 | than the recursive union type List, so this is a way to manually force 38 | the analysis to broaden to a union it would never have constructed on 39 | its own. 40 | 41 | It also allows specification of foreign interface types, by narrowing 42 | assertions about the objects that come in from the outside. Said 43 | assertions can include checks for safety or drop them for speed, on a 44 | case by case basis. 45 | 46 | Issues: 47 | 48 | 1. Imprecise specification of procedure types. Obviously, a 49 | traditional function type is a much broader type than DVL's current 50 | abstract values for functions. [In fact, it's not even obvious how to 51 | check whether a given abstract closure actually meets a given function 52 | type -- another round of abstract evaluation? This might never end, 53 | for recursive function types.] However, a traditional function type 54 | can still supply information about a closure, which could be attached 55 | to it and applied at its call sites appropriately. [In fact, function 56 | types may only be actually needed for functions that come in from the 57 | outside, because everything else might be doable by annotating the 58 | arguments and results.] 59 | 60 | Speaking of functions that come in from the outside, if any -- they 61 | produce issues of their own. In particular, if I want the compiler to 62 | respect their side effects, I may need to annotate them with monadic 63 | types, and get into that whole mess. But, maybe, I can accept pure 64 | functions from the outside using this type annotation mechanism and be 65 | happy. 66 | 67 | 2. Conditional type assertion. It seems useful to be able to 68 | conditionalize these assertions based on the deduced types of other 69 | objects in scope. For example, in the definition of iota, it may be 70 | desirable to broaden-assert the return type to be a list of unknown 71 | length; but it may also be desirable to do this only if the input is 72 | an unknown number, and let iota generate a list of known length if the 73 | number is known (and, perhaps, small). Is there a way to keep such 74 | conditions to the type level, or should they be reflected into the 75 | value level as well? Can I have a "type annotation" that says "if 76 | this object is known at analysis time, return the object #t, otherwise 77 | the object #f"? This would break monotonicity. Is it good for 78 | anything? 79 | -------------------------------------------------------------------------------- /fol/doc/type-transformations.txt: -------------------------------------------------------------------------------- 1 | Scalar Replacement of Aggregates by Local Transformation 2 | August 19, 2012 3 | Alexey Radul 4 | 5 | This is a story about the local transformations that SRA does all of 6 | in one sweep. 7 | 8 | Consider an isomorphism of datatypes. For example, in the presence 9 | of 10 | 11 | (define-type p2 (structure (x real) (y real))) 12 | 13 | we have an obvious isomorphism between 14 | 15 | (define-type p3 (structure (base p2) (z real))) 16 | 17 | and 18 | 19 | (define-type p3' (structure (x real) (y real) (z real))) 20 | 21 | Let this isomorphism be implemented by p3->p3' and p3'->p3. 22 | 23 | There is a set of local transformations that incrementally migrates a 24 | program using p3 into one that uses p3' (or back, if desired). 25 | 26 | A) You can always introduce (well-typed) identities 27 | e :: p3 -> (p3'->p3 (p3->p3' e)) 28 | e :: p3' -> (p3->p3' (p3'->p3 e)) 29 | 30 | This combines with standard transforms to change the type of a 31 | variable from p3 to p3': 32 | 33 | (let ((a e)) b) 34 | -> (let ((a (p3'->p3 (p3->p3' e)))) b) 35 | -> (let ((a' (p3->p3' e))) 36 | (let ((a (p3'->p3 a'))) 37 | b)) 38 | -> (let ((a' (p3->p3' e))) 39 | (inline a in b)) 40 | 41 | B) You can migrate isomorphims into compound syntax 42 | (p3->p3' (let bs e)) -> (let bs (p3->p3' e)) 43 | (p3->p3' (if p c a) -> (if p (p3->p3' c) (p3->p3' a)) 44 | 45 | C) You can eliminate identities 46 | (p3->p3' (p3'->p3 e)) -> e 47 | (p3'->p3 (p3->p3' e)) -> e 48 | 49 | A, B, and C combine with standard transforms to convert any 50 | interrelated cluster of variables (inside a procedure body) from one 51 | type to the other (stopping at function calls, including constructors 52 | and accessors). 53 | 54 | D) Constructors, deconstructors, and transforms obey algebraic 55 | identities (which can be deduced from the definitions of the 56 | transforms as procedures in terms of constructors and 57 | deconstructors). 58 | (p3->p3' (make-p3 e1 e2)) -> 59 | (deconstruct e1 (x y) 60 | (make-p3' x y e2)) 61 | 62 | (p3'->p3 (make-p3' e1 e2 e3)) -> 63 | (make-p3 (make-p2 e1 e2) e3) 64 | 65 | (p3-p2 (p3'->p3 e)) -> 66 | (deconstruct e (x y z) 67 | (make-p2 x y)) 68 | 69 | (p3'-x (p3->p3' e)) -> 70 | (p2-x (p3-p2 e)) 71 | 72 | E) Given any function that accepts a p3 as an argument or returns one 73 | as a value, one can always introduce a new function that accepts or 74 | returns a p3' instead. 75 | (define (f x) e) -> (define (f' x') (let ((x (p3'->p3 x'))) e)) 76 | (define (f x) e) -> (define (f' x) (p3->p3' e)) 77 | 78 | (Using A, B, C, and D the body of this new function can be rewritten 79 | in terms of p3' except in places where it itself calls functions that 80 | require p3s). 81 | 82 | E') One can rewrite any call site to a function that needed a p3 to a 83 | call site to the new function: 84 | (f x) -> (f' (p3->p3' x)) 85 | (f x) -> (p3'->p3 (f x)) 86 | 87 | F) Any type that includes a p3 member admits an obvious isomorphism 88 | to a new type that includes a p3' member in that place instead (whose 89 | own algebraic laws for D are even simpler). The pairs of transforms 90 | obey appropriate cancelation laws. 91 | 92 | By aggressive use of the above transforms (and standard things like 93 | the introduction and inlining of variables, or the deletion of 94 | non-escaping procedures that have no remaining call sites) it is 95 | possible to convert any desired region of a program to use whichever 96 | of p3 or p3' is desired. In fact, a reasonable definition of "region 97 | boundary" for this purpose is the set of places where the above 98 | transforms remain. 99 | 100 | The preceding discussion is not specific to SRA, as it applies to any 101 | type isomorphism. SRA fits into the above framework, with the 102 | restriction that the source type must be a product, and the "result 103 | type" is actually held in several variables. The local 104 | transformations go through, mutatis mutandis, except that they cannot 105 | be applied to injections into sum types because those absolutely 106 | require the injectee to fit into one variable. SRA as implemented 107 | runs these transformations to convergence (in the direction of fewer 108 | constructed product types) in one pass. 109 | --------------------------------------------------------------------------------