diff options
author | Andy Wingo <wingo@pobox.com> | 2012-04-26 22:56:45 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-04-26 22:56:45 +0200 |
commit | c46e0a8a598a16b8f68b5492a13e4032b93f21f9 (patch) | |
tree | b57374184dc4715a32393b53866263a55ebc01b7 /test-suite/tests/peval.test | |
parent | e7501d4a682cc2b430514280834dfc68b97f2be2 (diff) | |
parent | de1eb420a5a95b17e85b19c4d98c869036e9ecb0 (diff) | |
download | guile-c46e0a8a598a16b8f68b5492a13e4032b93f21f9.tar.gz |
Merge commit 'de1eb420a5a95b17e85b19c4d98c869036e9ecb0'
Conflicts:
module/language/tree-il/primitives.scm
test-suite/tests/tree-il.test
Diffstat (limited to 'test-suite/tests/peval.test')
-rw-r--r-- | test-suite/tests/peval.test | 1001 |
1 files changed, 1001 insertions, 0 deletions
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test new file mode 100644 index 000000000..310cd974e --- /dev/null +++ b/test-suite/tests/peval.test @@ -0,0 +1,1001 @@ +;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- +;;;; Andy Wingo <wingo@pobox.com> --- May 2009 +;;;; +;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite tree-il) + #:use-module (test-suite lib) + #:use-module (system base compile) + #:use-module (system base pmatch) + #:use-module (system base message) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:use-module (language glil) + #:use-module (srfi srfi-13)) + +(define peval + ;; The partial evaluator. + (@@ (language tree-il optimize) peval)) + +(define-syntax pass-if-peval + (syntax-rules (resolve-primitives) + ((_ in pat) + (pass-if-peval in pat + (expand-primitives! + (resolve-primitives! + (compile 'in #:from 'scheme #:to 'tree-il) + (current-module))))) + ((_ in pat code) + (pass-if 'in + (let ((evaled (unparse-tree-il (peval code)))) + (pmatch evaled + (pat #t) + (_ (pk 'peval-mismatch) + ((@ (ice-9 pretty-print) pretty-print) + 'in) + (newline) + ((@ (ice-9 pretty-print) pretty-print) + evaled) + (newline) + ((@ (ice-9 pretty-print) pretty-print) + 'pat) + (newline) + #f))))))) + + +(with-test-prefix "partial evaluation" + + (pass-if-peval + ;; First order, primitive. + (let ((x 1) (y 2)) (+ x y)) + (const 3)) + + (pass-if-peval + ;; First order, thunk. + (let ((x 1) (y 2)) + (let ((f (lambda () (+ x y)))) + (f))) + (const 3)) + + (pass-if-peval + ;; First order, let-values (requires primitive expansion for + ;; `call-with-values'.) + (let ((x 0)) + (call-with-values + (lambda () (if (zero? x) (values 1 2) (values 3 4))) + (lambda (a b) + (+ a b)))) + (const 3)) + + (pass-if-peval + ;; First order, multiple values. + (let ((x 1) (y 2)) + (values x y)) + (primcall values (const 1) (const 2))) + + (pass-if-peval + ;; First order, multiple values truncated. + (let ((x (values 1 'a)) (y 2)) + (values x y)) + (primcall values (const 1) (const 2))) + + (pass-if-peval + ;; First order, multiple values truncated. + (or (values 1 2) 3) + (const 1)) + + (pass-if-peval + ;; First order, coalesced, mutability preserved. + (cons 0 (cons 1 (cons 2 (list 3 4 5)))) + (primcall list + (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))) + + (pass-if-peval + ;; First order, coalesced, immutability preserved. + (cons 0 (cons 1 (cons 2 '(3 4 5)))) + (primcall cons (const 0) + (primcall cons (const 1) + (primcall cons (const 2) + (const (3 4 5)))))) + + ;; These two tests doesn't work any more because we changed the way we + ;; deal with constants -- now the algorithm will see a construction as + ;; being bound to the lexical, so it won't propagate it. It can't + ;; even propagate it in the case that it is only referenced once, + ;; because: + ;; + ;; (let ((x (cons 1 2))) (lambda () x)) + ;; + ;; is not the same as + ;; + ;; (lambda () (cons 1 2)) + ;; + ;; Perhaps if we determined that not only was it only referenced once, + ;; it was not closed over by a lambda, then we could propagate it, and + ;; re-enable these two tests. + ;; + #; + (pass-if-peval + ;; First order, mutability preserved. + (let loop ((i 3) (r '())) + (if (zero? i) + r + (loop (1- i) (cons (cons i i) r)))) + (primcall list + (primcall cons (const 1) (const 1)) + (primcall cons (const 2) (const 2)) + (primcall cons (const 3) (const 3)))) + ;; + ;; See above. + #; + (pass-if-peval + ;; First order, evaluated. + (let loop ((i 7) + (r '())) + (if (<= i 0) + (car r) + (loop (1- i) (cons i r)))) + (const 1)) + + ;; Instead here are tests for what happens for the above cases: they + ;; unroll but they don't fold. + (pass-if-peval + (let loop ((i 3) (r '())) + (if (zero? i) + r + (loop (1- i) (cons (cons i i) r)))) + (let (r) (_) + ((primcall list + (primcall cons (const 3) (const 3)))) + (let (r) (_) + ((primcall cons + (primcall cons (const 2) (const 2)) + (lexical r _))) + (primcall cons + (primcall cons (const 1) (const 1)) + (lexical r _))))) + + ;; See above. + (pass-if-peval + (let loop ((i 4) + (r '())) + (if (<= i 0) + (car r) + (loop (1- i) (cons i r)))) + (let (r) (_) + ((primcall list (const 4))) + (let (r) (_) + ((primcall cons + (const 3) + (lexical r _))) + (let (r) (_) + ((primcall cons + (const 2) + (lexical r _))) + (let (r) (_) + ((primcall cons + (const 1) + (lexical r _))) + (primcall car + (lexical r _))))))) + + ;; Static sums. + (pass-if-peval + (let loop ((l '(1 2 3 4)) (sum 0)) + (if (null? l) + sum + (loop (cdr l) (+ sum (car l))))) + (const 10)) + + (pass-if-peval + (let ((string->chars + (lambda (s) + (define (char-at n) + (string-ref s n)) + (define (len) + (string-length s)) + (let loop ((i 0)) + (if (< i (len)) + (cons (char-at i) + (loop (1+ i))) + '()))))) + (string->chars "yo")) + (primcall list (const #\y) (const #\o))) + + (pass-if-peval + ;; Primitives in module-refs are resolved (the expansion of `pmatch' + ;; below leads to calls to (@@ (system base pmatch) car) and + ;; similar, which is what we want to be inlined.) + (begin + (use-modules (system base pmatch)) + (pmatch '(a b c d) + ((a b . _) + #t))) + (seq (call . _) + (const #t))) + + (pass-if-peval + ;; Mutability preserved. + ((lambda (x y z) (list x y z)) 1 2 3) + (primcall list (const 1) (const 2) (const 3))) + + (pass-if-peval + ;; Don't propagate effect-free expressions that operate on mutable + ;; objects. + (let* ((x (list 1)) + (y (car x))) + (set-car! x 0) + y) + (let (x) (_) ((primcall list (const 1))) + (let (y) (_) ((primcall car (lexical x _))) + (seq + (primcall set-car! (lexical x _) (const 0)) + (lexical y _))))) + + (pass-if-peval + ;; Don't propagate effect-free expressions that operate on objects we + ;; don't know about. + (let ((y (car x))) + (set-car! x 0) + y) + (let (y) (_) ((primcall car (toplevel x))) + (seq + (primcall set-car! (toplevel x) (const 0)) + (lexical y _)))) + + (pass-if-peval + ;; Infinite recursion + ((lambda (x) (x x)) (lambda (x) (x x))) + (let (x) (_) + ((lambda _ + (lambda-case + (((x) _ _ _ _ _) + (call (lexical x _) (lexical x _)))))) + (call (lexical x _) (lexical x _)))) + + (pass-if-peval + ;; First order, aliased primitive. + (let* ((x *) (y (x 1 2))) y) + (const 2)) + + (pass-if-peval + ;; First order, shadowed primitive. + (begin + (define (+ x y) (pk x y)) + (+ 1 2)) + (seq + (define + + (lambda (_) + (lambda-case + (((x y) #f #f #f () (_ _)) + (call (toplevel pk) (lexical x _) (lexical y _)))))) + (call (toplevel +) (const 1) (const 2)))) + + (pass-if-peval + ;; First-order, effects preserved. + (let ((x 2)) + (do-something!) + x) + (seq + (call (toplevel do-something!)) + (const 2))) + + (pass-if-peval + ;; First order, residual bindings removed. + (let ((x 2) (y 3)) + (* (+ x y) z)) + (primcall * (const 5) (toplevel z))) + + (pass-if-peval + ;; First order, with lambda. + (define (foo x) + (define (bar z) (* z z)) + (+ x (bar 3))) + (define foo + (lambda (_) + (lambda-case + (((x) #f #f #f () (_)) + (primcall + (lexical x _) (const 9))))))) + + (pass-if-peval + ;; First order, with lambda inlined & specialized twice. + (let ((f (lambda (x y) + (+ (* x top) y))) + (x 2) + (y 3)) + (+ (* x (f x y)) + (f something x))) + (primcall + + (primcall * + (const 2) + (primcall + ; (f 2 3) + (primcall * + (const 2) + (toplevel top)) + (const 3))) + (let (x) (_) ((toplevel something)) ; (f something 2) + ;; `something' is not const, so preserve order of + ;; effects with a lexical binding. + (primcall + + (primcall * + (lexical x _) + (toplevel top)) + (const 2))))) + + (pass-if-peval + ;; First order, with lambda inlined & specialized 3 times. + (let ((f (lambda (x y) (if (> x 0) y x)))) + (+ (f -1 0) + (f 1 0) + (f -1 y) + (f 2 y) + (f z y))) + (primcall + + + (const -1) ; (f -1 0) + (primcall + + + (const 0) ; (f 1 0) + (primcall + + + (seq (toplevel y) (const -1)) ; (f -1 y) + (primcall + + + (toplevel y) ; (f 2 y) + (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y) + (if (primcall > (lexical x _) (const 0)) + (lexical y _) + (lexical x _)))))))) + + (pass-if-peval + ;; First order, conditional. + (let ((y 2)) + (lambda (x) + (if (> y 0) + (display x) + 'never-reached))) + (lambda () + (lambda-case + (((x) #f #f #f () (_)) + (call (toplevel display) (lexical x _)))))) + + (pass-if-peval + ;; First order, recursive procedure. + (letrec ((fibo (lambda (n) + (if (<= n 1) + n + (+ (fibo (- n 1)) + (fibo (- n 2))))))) + (fibo 4)) + (const 3)) + + (pass-if-peval + ;; Don't propagate toplevel references, as intervening expressions + ;; could alter their bindings. + (let ((x top)) + (foo) + x) + (let (x) (_) ((toplevel top)) + (seq + (call (toplevel foo)) + (lexical x _)))) + + (pass-if-peval + ;; Higher order. + ((lambda (f x) + (f (* (car x) (cadr x)))) + (lambda (x) + (+ x 1)) + '(2 3)) + (const 7)) + + (pass-if-peval + ;; Higher order with optional argument (default value). + ((lambda* (f x #:optional (y 0)) + (+ y (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3)) + (const 7)) + + (pass-if-peval + ;; Higher order with optional argument (caller-supplied value). + ((lambda* (f x #:optional (y 0)) + (+ y (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3) + 35) + (const 42)) + + (pass-if-peval + ;; Higher order with optional argument (side-effecting default + ;; value). + ((lambda* (f x #:optional (y (foo))) + (+ y (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3)) + (let (y) (_) ((call (toplevel foo))) + (primcall + (lexical y _) (const 7)))) + + (pass-if-peval + ;; Higher order with optional argument (caller-supplied value). + ((lambda* (f x #:optional (y (foo))) + (+ y (f (* (car x) (cadr x))))) + (lambda (x) + (+ x 1)) + '(2 3) + 35) + (const 42)) + + (pass-if-peval + ;; Higher order. + ((lambda (f) (f x)) (lambda (x) x)) + (toplevel x)) + + (pass-if-peval + ;; Bug reported at + ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>. + (let ((fold (lambda (f g) (f (g top))))) + (fold 1+ (lambda (x) x))) + (primcall 1+ (toplevel top))) + + (pass-if-peval + ;; Procedure not inlined when residual code contains recursive calls. + ;; <http://debbugs.gnu.org/9542> + (letrec ((fold (lambda (f x3 b null? car cdr) + (if (null? x3) + b + (f (car x3) (fold f (cdr x3) b null? car cdr)))))) + (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1)))) + (letrec (fold) (_) (_) + (call (lexical fold _) + (primitive *) + (toplevel x) + (const 1) + (primitive zero?) + (lambda () + (lambda-case + (((x1) #f #f #f () (_)) + (lexical x1 _)))) + (lambda () + (lambda-case + (((x2) #f #f #f () (_)) + (primcall 1- (lexical x2 _)))))))) + + (pass-if "inlined lambdas are alpha-renamed" + ;; In this example, `make-adder' is inlined more than once; thus, + ;; they should use different gensyms for their arguments, because + ;; the various optimization passes assume uniquely-named variables. + ;; + ;; Bug reported at + ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and + ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>. + (pmatch (unparse-tree-il + (peval (expand-primitives! + (resolve-primitives! + (compile + '(let ((make-adder + (lambda (x) (lambda (y) (+ x y))))) + (cons (make-adder 1) (make-adder 2))) + #:to 'tree-il) + (current-module))))) + ((primcall cons + (lambda () + (lambda-case + (((y) #f #f #f () (,gensym1)) + (primcall + + (const 1) + (lexical y ,ref1))))) + (lambda () + (lambda-case + (((y) #f #f #f () (,gensym2)) + (primcall + + (const 2) + (lexical y ,ref2)))))) + (and (eq? gensym1 ref1) + (eq? gensym2 ref2) + (not (eq? gensym1 gensym2)))) + (_ #f))) + + (pass-if-peval + ;; Unused letrec bindings are pruned. + (letrec ((a (lambda () (b))) + (b (lambda () (a))) + (c (lambda (x) x))) + (c 10)) + (const 10)) + + (pass-if-peval + ;; Unused letrec bindings are pruned. + (letrec ((a (foo!)) + (b (lambda () (a))) + (c (lambda (x) x))) + (c 10)) + (seq (call (toplevel foo!)) + (const 10))) + + (pass-if-peval + ;; Higher order, mutually recursive procedures. + (letrec ((even? (lambda (x) + (or (= 0 x) + (odd? (- x 1))))) + (odd? (lambda (x) + (not (even? x))))) + (and (even? 4) (odd? 7))) + (const #t)) + + (pass-if-peval + ;; Memv with constants. + (memv 1 '(3 2 1)) + (const '(1))) + + (pass-if-peval + ;; Memv with non-constant list. It could fold but doesn't + ;; currently. + (memv 1 (list 3 2 1)) + (primcall memv + (const 1) + (primcall list (const 3) (const 2) (const 1)))) + + (pass-if-peval + ;; Memv with non-constant key, constant list, test context + (case foo + ((3 2 1) 'a) + (else 'b)) + (let (key) (_) ((toplevel foo)) + (if (if (primcall eqv? (lexical key _) (const 3)) + (const #t) + (if (primcall eqv? (lexical key _) (const 2)) + (const #t) + (primcall eqv? (lexical key _) (const 1)))) + (const a) + (const b)))) + + (pass-if-peval + ;; Memv with non-constant key, empty list, test context. + (case foo + (() 'a) + (else 'b)) + (seq (toplevel foo) (const 'b))) + + ;; + ;; Below are cases where constant propagation should bail out. + ;; + + (pass-if-peval + ;; Non-constant lexical is not propagated. + (let ((v (make-vector 6 #f))) + (lambda (n) + (vector-set! v n n))) + (let (v) (_) + ((call (toplevel make-vector) (const 6) (const #f))) + (lambda () + (lambda-case + (((n) #f #f #f () (_)) + (primcall vector-set! + (lexical v _) (lexical n _) (lexical n _))))))) + + (pass-if-peval + ;; Mutable lexical is not propagated. + (let ((v (vector 1 2 3))) + (lambda () + v)) + (let (v) (_) + ((primcall vector (const 1) (const 2) (const 3))) + (lambda () + (lambda-case + ((() #f #f #f () ()) + (lexical v _)))))) + + (pass-if-peval + ;; Lexical that is not provably pure is not inlined nor propagated. + (let* ((x (if (> p q) (frob!) (display 'chbouib))) + (y (* x 2))) + (+ x x y)) + (let (x) (_) ((if (primcall > (toplevel p) (toplevel q)) + (call (toplevel frob!)) + (call (toplevel display) (const chbouib)))) + (let (y) (_) ((primcall * (lexical x _) (const 2))) + (primcall + + (lexical x _) + (primcall + (lexical x _) (lexical y _)))))) + + (pass-if-peval + ;; Non-constant arguments not propagated to lambdas. + ((lambda (x y z) + (vector-set! x 0 0) + (set-car! y 0) + (set-cdr! z '())) + (vector 1 2 3) + (make-list 10) + (list 1 2 3)) + (let (x y z) (_ _ _) + ((primcall vector (const 1) (const 2) (const 3)) + (call (toplevel make-list) (const 10)) + (primcall list (const 1) (const 2) (const 3))) + (seq + (primcall vector-set! + (lexical x _) (const 0) (const 0)) + (seq (primcall set-car! + (lexical y _) (const 0)) + (primcall set-cdr! + (lexical z _) (const ())))))) + + (pass-if-peval + (let ((foo top-foo) (bar top-bar)) + (let* ((g (lambda (x y) (+ x y))) + (f (lambda (g x) (g x x)))) + (+ (f g foo) (f g bar)))) + (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar)) + (primcall + + (primcall + (lexical foo _) (lexical foo _)) + (primcall + (lexical bar _) (lexical bar _))))) + + (pass-if-peval + ;; Fresh objects are not turned into constants, nor are constants + ;; turned into fresh objects. + (let* ((c '(2 3)) + (x (cons 1 c)) + (y (cons 0 x))) + y) + (let (x) (_) ((primcall cons (const 1) (const (2 3)))) + (primcall cons (const 0) (lexical x _)))) + + (pass-if-peval + ;; Bindings mutated. + (let ((x 2)) + (set! x 3) + x) + (let (x) (_) ((const 2)) + (seq + (set! (lexical x _) (const 3)) + (lexical x _)))) + + (pass-if-peval + ;; Bindings mutated. + (letrec ((x 0) + (f (lambda () + (set! x (+ 1 x)) + x))) + (frob f) ; may mutate `x' + x) + (letrec (x) (_) ((const 0)) + (seq + (call (toplevel frob) (lambda _ _)) + (lexical x _)))) + + (pass-if-peval + ;; Bindings mutated. + (letrec ((f (lambda (x) + (set! f (lambda (_) x)) + x))) + (f 2)) + (letrec _ . _)) + + (pass-if-peval + ;; Bindings possibly mutated. + (let ((x (make-foo))) + (frob! x) ; may mutate `x' + x) + (let (x) (_) ((call (toplevel make-foo))) + (seq + (call (toplevel frob!) (lexical x _)) + (lexical x _)))) + + (pass-if-peval + ;; Inlining stops at recursive calls with dynamic arguments. + (let loop ((x x)) + (if (< x 0) x (loop (1- x)))) + (letrec (loop) (_) ((lambda (_) + (lambda-case + (((x) #f #f #f () (_)) + (if _ _ + (call (lexical loop _) + (primcall 1- + (lexical x _)))))))) + (call (lexical loop _) (toplevel x)))) + + (pass-if-peval + ;; Recursion on the 2nd argument is fully evaluated. + (let ((x (top))) + (let loop ((x x) (y 10)) + (if (> y 0) + (loop x (1- y)) + (foo x y)))) + (let (x) (_) ((call (toplevel top))) + (call (toplevel foo) (lexical x _) (const 0)))) + + (pass-if-peval + ;; Inlining aborted when residual code contains recursive calls. + ;; + ;; <http://debbugs.gnu.org/9542> + (let loop ((x x) (y 0)) + (if (> y 0) + (loop (1- x) (1- y)) + (if (< x 0) + x + (loop (1+ x) (1+ y))))) + (letrec (loop) (_) ((lambda (_) + (lambda-case + (((x y) #f #f #f () (_ _)) + (if (primcall > + (lexical y _) (const 0)) + _ _))))) + (call (lexical loop _) (toplevel x) (const 0)))) + + (pass-if-peval + ;; Infinite recursion: `peval' gives up and leaves it as is. + (letrec ((f (lambda (x) (g (1- x)))) + (g (lambda (x) (h (1+ x)))) + (h (lambda (x) (f x)))) + (f 0)) + (letrec _ . _)) + + (pass-if-peval + ;; Infinite recursion: all the arguments to `loop' are static, but + ;; unrolling it would lead `peval' to enter an infinite loop. + (let loop ((x 0)) + (and (< x top) + (loop (1+ x)))) + (letrec (loop) (_) ((lambda . _)) + (call (lexical loop _) (const 0)))) + + (pass-if-peval + ;; This test checks that the `start' binding is indeed residualized. + ;; See the `referenced?' procedure in peval's `prune-bindings'. + (let ((pos 0)) + (set! pos 1) ;; Cause references to `pos' to residualize. + (let ((here (let ((start pos)) (lambda () start)))) + (here))) + (let (pos) (_) ((const 0)) + (seq + (set! (lexical pos _) (const 1)) + (let (here) (_) (_) + (call (lexical here _)))))) + + (pass-if-peval + ;; FIXME: should this one residualize the binding? + (letrec ((a a)) + 1) + (const 1)) + + (pass-if-peval + ;; This is a fun one for peval to handle. + (letrec ((a a)) + a) + (letrec (a) (_) ((lexical a _)) + (lexical a _))) + + (pass-if-peval + ;; Another interesting recursive case. + (letrec ((a b) (b a)) + a) + (letrec (a) (_) ((lexical a _)) + (lexical a _))) + + (pass-if-peval + ;; Another pruning case, that `a' is residualized. + (letrec ((a (lambda () (a))) + (b (lambda () (a))) + (c (lambda (x) x))) + (let ((d (foo b))) + (c d))) + + ;; "b c a" is the current order that we get with unordered letrec, + ;; but it's not important to this test, so if it changes, just adapt + ;; the test. + (letrec (b c a) (_ _ _) + ((lambda _ + (lambda-case + ((() #f #f #f () ()) + (call (lexical a _))))) + (lambda _ + (lambda-case + (((x) #f #f #f () (_)) + (lexical x _)))) + (lambda _ + (lambda-case + ((() #f #f #f () ()) + (call (lexical a _)))))) + (let (d) + (_) + ((call (toplevel foo) (lexical b _))) + (call (lexical c _) (lexical d _))))) + + (pass-if-peval + ;; In this case, we can prune the bindings. `a' ends up being copied + ;; because it is only referenced once in the source program. Oh + ;; well. + (letrec* ((a (lambda (x) (top x))) + (b (lambda () a))) + (foo (b) (b))) + (call (toplevel foo) + (lambda _ + (lambda-case + (((x) #f #f #f () (_)) + (call (toplevel top) (lexical x _))))) + (lambda _ + (lambda-case + (((x) #f #f #f () (_)) + (call (toplevel top) (lexical x _))))))) + + (pass-if-peval + ;; Constant folding: cons of #nil does not make list + (cons 1 #nil) + (primcall cons (const 1) (const '#nil))) + + (pass-if-peval + ;; Constant folding: cons + (begin (cons 1 2) #f) + (const #f)) + + (pass-if-peval + ;; Constant folding: cons + (begin (cons (foo) 2) #f) + (seq (call (toplevel foo)) (const #f))) + + (pass-if-peval + ;; Constant folding: cons + (if (cons 0 0) 1 2) + (const 1)) + + (pass-if-peval + ;; Constant folding: car+cons + (car (cons 1 0)) + (const 1)) + + (pass-if-peval + ;; Constant folding: cdr+cons + (cdr (cons 1 0)) + (const 0)) + + (pass-if-peval + ;; Constant folding: car+cons, impure + (car (cons 1 (bar))) + (seq (call (toplevel bar)) (const 1))) + + (pass-if-peval + ;; Constant folding: cdr+cons, impure + (cdr (cons (bar) 0)) + (seq (call (toplevel bar)) (const 0))) + + (pass-if-peval + ;; Constant folding: car+list + (car (list 1 0)) + (const 1)) + + (pass-if-peval + ;; Constant folding: cdr+list + (cdr (list 1 0)) + (primcall list (const 0))) + + (pass-if-peval + ;; Constant folding: car+list, impure + (car (list 1 (bar))) + (seq (call (toplevel bar)) (const 1))) + + (pass-if-peval + ;; Constant folding: cdr+list, impure + (cdr (list (bar) 0)) + (seq (call (toplevel bar)) (primcall list (const 0)))) + + (pass-if-peval + ;; Equality primitive: same lexical + (let ((x (random))) (eq? x x)) + (seq (call (toplevel random)) (const #t))) + + (pass-if-peval + ;; Equality primitive: merge lexical identities + (let* ((x (random)) (y x)) (eq? x y)) + (seq (call (toplevel random)) (const #t))) + + (pass-if-peval + ;; Non-constant guards get lexical bindings. + (dynamic-wind foo (lambda () bar) baz) + (let (w u) (_ _) ((toplevel foo) (toplevel baz)) + (dynwind (lexical w _) + (call (lexical w _)) + (toplevel bar) + (call (lexical u _)) + (lexical u _)))) + + (pass-if-peval + ;; Constant guards don't need lexical bindings. + (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz)) + (dynwind + (lambda () + (lambda-case + ((() #f #f #f () ()) (toplevel foo)))) + (toplevel foo) + (toplevel bar) + (toplevel baz) + (lambda () + (lambda-case + ((() #f #f #f () ()) (toplevel baz)))))) + + (pass-if-peval + ;; Prompt is removed if tag is unreferenced + (let ((tag (make-prompt-tag))) + (call-with-prompt tag + (lambda () 1) + (lambda args args))) + (const 1)) + + (pass-if-peval + ;; Prompt is removed if tag is unreferenced, with explicit stem + (let ((tag (make-prompt-tag "foo"))) + (call-with-prompt tag + (lambda () 1) + (lambda args args))) + (const 1)) + + ;; Handler lambda inlined + (pass-if-peval + (call-with-prompt tag + (lambda () 1) + (lambda (k x) x)) + (prompt (toplevel tag) + (const 1) + (lambda-case + (((k x) #f #f #f () (_ _)) + (lexical x _))))) + + ;; Handler toplevel not inlined + (pass-if-peval + (call-with-prompt tag + (lambda () 1) + handler) + (let (handler) (_) ((toplevel handler)) + (prompt (toplevel tag) + (const 1) + (lambda-case + ((() #f args #f () (_)) + (primcall @apply + (lexical handler _) + (lexical args _))))))) + + (pass-if-peval + ;; `while' without `break' or `continue' has no prompts and gets its + ;; condition folded. Unfortunately the outer `lp' does not yet get + ;; elided. + (while #t #t) + (letrec (lp) (_) + ((lambda _ + (lambda-case + ((() #f #f #f () ()) + (letrec (loop) (_) + ((lambda _ + (lambda-case + ((() #f #f #f () ()) + (call (lexical loop _)))))) + (call (lexical loop _))))))) + (call (lexical lp _)))) + + (pass-if-peval + (lambda (a . rest) + (apply (lambda (x y) (+ x y)) + a rest)) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + _)))) + + (pass-if-peval + (car '(1 2)) + (const 1))) |