1 ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
2 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
4 ;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library 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 GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-suite tree-il)
21 #:use-module (test-suite lib)
22 #:use-module (system base compile)
23 #:use-module (system base pmatch)
24 #:use-module (system base message)
25 #:use-module (language tree-il)
26 #:use-module (language tree-il primitives)
27 #:use-module (language glil)
28 #:use-module (srfi srfi-13))
31 ;; The partial evaluator.
32 (@@ (language tree-il optimize) peval))
34 (define-syntax pass-if-peval
35 (syntax-rules (resolve-primitives)
38 (compile 'in #:from 'scheme #:to 'tree-il)))
39 ((_ resolve-primitives in pat)
43 (compile 'in #:from 'scheme #:to 'tree-il)
47 (let ((evaled (unparse-tree-il (peval code))))
50 (_ (pk 'peval-mismatch)
51 ((@ (ice-9 pretty-print) pretty-print)
54 ((@ (ice-9 pretty-print) pretty-print)
57 ((@ (ice-9 pretty-print) pretty-print)
63 (with-test-prefix "partial evaluation"
66 ;; First order, primitive.
67 (let ((x 1) (y 2)) (+ x y))
71 ;; First order, thunk.
73 (let ((f (lambda () (+ x y))))
77 (pass-if-peval resolve-primitives
78 ;; First order, let-values (requires primitive expansion for
79 ;; `call-with-values'.)
82 (lambda () (if (zero? x) (values 1 2) (values 3 4)))
87 (pass-if-peval resolve-primitives
88 ;; First order, multiple values.
91 (apply (primitive values) (const 1) (const 2)))
93 (pass-if-peval resolve-primitives
94 ;; First order, multiple values truncated.
95 (let ((x (values 1 'a)) (y 2))
97 (apply (primitive values) (const 1) (const 2)))
99 (pass-if-peval resolve-primitives
100 ;; First order, multiple values truncated.
105 ;; First order, coalesced, mutability preserved.
106 (cons 0 (cons 1 (cons 2 (list 3 4 5))))
107 (apply (primitive list)
108 (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
111 ;; First order, coalesced, immutability preserved.
112 (cons 0 (cons 1 (cons 2 '(3 4 5))))
113 (apply (primitive cons) (const 0)
114 (apply (primitive cons) (const 1)
115 (apply (primitive cons) (const 2)
118 ;; These two tests doesn't work any more because we changed the way we
119 ;; deal with constants -- now the algorithm will see a construction as
120 ;; being bound to the lexical, so it won't propagate it. It can't
121 ;; even propagate it in the case that it is only referenced once,
124 ;; (let ((x (cons 1 2))) (lambda () x))
126 ;; is not the same as
128 ;; (lambda () (cons 1 2))
130 ;; Perhaps if we determined that not only was it only referenced once,
131 ;; it was not closed over by a lambda, then we could propagate it, and
132 ;; re-enable these two tests.
136 ;; First order, mutability preserved.
137 (let loop ((i 3) (r '()))
140 (loop (1- i) (cons (cons i i) r))))
141 (apply (primitive list)
142 (apply (primitive cons) (const 1) (const 1))
143 (apply (primitive cons) (const 2) (const 2))
144 (apply (primitive cons) (const 3) (const 3))))
149 ;; First order, evaluated.
154 (loop (1- i) (cons i r))))
157 ;; Instead here are tests for what happens for the above cases: they
158 ;; unroll but they don't fold.
160 (let loop ((i 3) (r '()))
163 (loop (1- i) (cons (cons i i) r))))
165 ((apply (primitive list)
166 (apply (primitive cons) (const 3) (const 3))))
168 ((apply (primitive cons)
169 (apply (primitive cons) (const 2) (const 2))
171 (apply (primitive cons)
172 (apply (primitive cons) (const 1) (const 1))
181 (loop (1- i) (cons i r))))
183 ((apply (primitive list) (const 4)))
185 ((apply (primitive cons)
189 ((apply (primitive cons)
193 ((apply (primitive cons)
196 (apply (primitive car)
201 (let loop ((l '(1 2 3 4)) (sum 0))
204 (loop (cdr l) (+ sum (car l)))))
207 (pass-if-peval resolve-primitives
219 (string->chars "yo"))
220 (apply (primitive list) (const #\y) (const #\o)))
223 ;; Primitives in module-refs are resolved (the expansion of `pmatch'
224 ;; below leads to calls to (@@ (system base pmatch) car) and
225 ;; similar, which is what we want to be inlined.)
227 (use-modules (system base pmatch))
236 ;; Mutability preserved.
237 ((lambda (x y z) (list x y z)) 1 2 3)
238 (apply (primitive list) (const 1) (const 2) (const 3)))
241 ;; Don't propagate effect-free expressions that operate on mutable
247 (let (x) (_) ((apply (primitive list) (const 1)))
248 (let (y) (_) ((apply (primitive car) (lexical x _)))
250 (apply (toplevel set-car!) (lexical x _) (const 0))
254 ;; Don't propagate effect-free expressions that operate on objects we
259 (let (y) (_) ((apply (primitive car) (toplevel x)))
261 (apply (toplevel set-car!) (toplevel x) (const 0))
265 ;; Infinite recursion
266 ((lambda (x) (x x)) (lambda (x) (x x)))
271 (apply (lexical x _) (lexical x _))))))
272 (apply (lexical x _) (lexical x _))))
275 ;; First order, aliased primitive.
276 (let* ((x *) (y (x 1 2))) y)
280 ;; First order, shadowed primitive.
282 (define (+ x y) (pk x y))
288 (((x y) #f #f #f () (_ _))
289 (apply (toplevel pk) (lexical x _) (lexical y _))))))
290 (apply (toplevel +) (const 1) (const 2))))
293 ;; First-order, effects preserved.
298 (apply (toplevel do-something!))
302 ;; First order, residual bindings removed.
305 (apply (primitive *) (const 5) (toplevel z)))
308 ;; First order, with lambda.
310 (define (bar z) (* z z))
315 (((x) #f #f #f () (_))
316 (apply (primitive +) (lexical x _) (const 9)))))))
319 ;; First order, with lambda inlined & specialized twice.
320 (let ((f (lambda (x y)
329 (apply (primitive +) ; (f 2 3)
334 (let (x) (_) ((toplevel something)) ; (f something 2)
335 ;; `something' is not const, so preserve order of
336 ;; effects with a lexical binding.
344 ;; First order, with lambda inlined & specialized 3 times.
345 (let ((f (lambda (x y) (if (> x 0) y x))))
352 (const -1) ; (f -1 0)
354 (begin (toplevel y) (const -1)) ; (f -1 y)
355 (toplevel y) ; (f 2 y)
356 (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
357 (if (apply (primitive >) (lexical x _) (const 0))
362 ;; First order, conditional.
370 (((x) #f #f #f () (_))
371 (apply (toplevel display) (lexical x _))))))
374 ;; First order, recursive procedure.
375 (letrec ((fibo (lambda (n)
384 ;; Don't propagate toplevel references, as intervening expressions
385 ;; could alter their bindings.
389 (let (x) (_) ((toplevel top))
391 (apply (toplevel foo))
397 (f (* (car x) (cadr x))))
404 ;; Higher order with optional argument (default value).
405 ((lambda* (f x #:optional (y 0))
406 (+ y (f (* (car x) (cadr x)))))
413 ;; Higher order with optional argument (caller-supplied value).
414 ((lambda* (f x #:optional (y 0))
415 (+ y (f (* (car x) (cadr x)))))
423 ;; Higher order with optional argument (side-effecting default
425 ((lambda* (f x #:optional (y (foo)))
426 (+ y (f (* (car x) (cadr x)))))
430 (let (y) (_) ((apply (toplevel foo)))
431 (apply (primitive +) (lexical y _) (const 7))))
434 ;; Higher order with optional argument (caller-supplied value).
435 ((lambda* (f x #:optional (y (foo)))
436 (+ y (f (* (car x) (cadr x)))))
445 ((lambda (f) (f x)) (lambda (x) x))
450 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
451 (let ((fold (lambda (f g) (f (g top)))))
452 (fold 1+ (lambda (x) x)))
453 (apply (primitive 1+) (toplevel top)))
456 ;; Procedure not inlined when residual code contains recursive calls.
457 ;; <http://debbugs.gnu.org/9542>
458 (letrec ((fold (lambda (f x3 b null? car cdr)
461 (f (car x3) (fold f (cdr x3) b null? car cdr))))))
462 (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
463 (letrec (fold) (_) (_)
464 (apply (lexical fold _)
471 (((x1) #f #f #f () (_))
475 (((x2) #f #f #f () (_))
476 (apply (primitive -) (lexical x2 _) (const 1))))))))
478 (pass-if "inlined lambdas are alpha-renamed"
479 ;; In this example, `make-adder' is inlined more than once; thus,
480 ;; they should use different gensyms for their arguments, because
481 ;; the various optimization passes assume uniquely-named variables.
484 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
485 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
486 (pmatch (unparse-tree-il
489 (lambda (x) (lambda (y) (+ x y)))))
490 (cons (make-adder 1) (make-adder 2)))
492 ((apply (primitive cons)
495 (((y) #f #f #f () (,gensym1))
498 (lexical y ,ref1)))))
501 (((y) #f #f #f () (,gensym2))
504 (lexical y ,ref2))))))
505 (and (eq? gensym1 ref1)
507 (not (eq? gensym1 gensym2))))
511 ;; Unused letrec bindings are pruned.
512 (letrec ((a (lambda () (b)))
519 ;; Unused letrec bindings are pruned.
524 (begin (apply (toplevel foo!))
528 ;; Higher order, mutually recursive procedures.
529 (letrec ((even? (lambda (x)
534 (and (even? 4) (odd? 7)))
538 ;; Memv with constants.
543 ;; Memv with non-constant list. It could fold but doesn't
545 (memv 1 (list 3 2 1))
546 (apply (primitive memv)
548 (apply (primitive list) (const 3) (const 2) (const 1))))
551 ;; Memv with non-constant key, constant list, test context
555 (let (key) (_) ((toplevel foo))
556 (if (if (apply (primitive eqv?) (lexical key _) (const 3))
558 (if (apply (primitive eqv?) (lexical key _) (const 2))
560 (apply (primitive eqv?) (lexical key _) (const 1))))
565 ;; Memv with non-constant key, empty list, test context. Currently
566 ;; doesn't fold entirely.
570 (begin (toplevel foo) (const b)))
573 ;; Below are cases where constant propagation should bail out.
577 ;; Non-constant lexical is not propagated.
578 (let ((v (make-vector 6 #f)))
580 (vector-set! v n n)))
582 ((apply (toplevel make-vector) (const 6) (const #f)))
585 (((n) #f #f #f () (_))
586 (apply (toplevel vector-set!)
587 (lexical v _) (lexical n _) (lexical n _)))))))
590 ;; Mutable lexical is not propagated.
591 (let ((v (vector 1 2 3)))
595 ((apply (primitive vector) (const 1) (const 2) (const 3)))
602 ;; Lexical that is not provably pure is not inlined nor propagated.
603 (let* ((x (if (> p q) (frob!) (display 'chbouib)))
606 (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
607 (apply (toplevel frob!))
608 (apply (toplevel display) (const chbouib))))
609 (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
611 (lexical x _) (lexical x _) (lexical y _)))))
614 ;; Non-constant arguments not propagated to lambdas.
623 ((apply (primitive vector) (const 1) (const 2) (const 3))
624 (apply (toplevel make-list) (const 10))
625 (apply (primitive list) (const 1) (const 2) (const 3)))
627 (apply (toplevel vector-set!)
628 (lexical x _) (const 0) (const 0))
629 (apply (toplevel set-car!)
630 (lexical y _) (const 0))
631 (apply (toplevel set-cdr!)
632 (lexical z _) (const ())))))
635 (let ((foo top-foo) (bar top-bar))
636 (let* ((g (lambda (x y) (+ x y)))
637 (f (lambda (g x) (g x x))))
638 (+ (f g foo) (f g bar))))
639 (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
641 (apply (primitive +) (lexical foo _) (lexical foo _))
642 (apply (primitive +) (lexical bar _) (lexical bar _)))))
645 ;; Fresh objects are not turned into constants, nor are constants
646 ;; turned into fresh objects.
651 (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
652 (apply (primitive cons) (const 0) (lexical x _))))
659 (let (x) (_) ((const 2))
661 (set! (lexical x _) (const 3))
670 (frob f) ; may mutate `x'
672 (letrec (x) (_) ((const 0))
674 (apply (toplevel frob) (lambda _ _))
679 (letrec ((f (lambda (x)
680 (set! f (lambda (_) x))
686 ;; Bindings possibly mutated.
687 (let ((x (make-foo)))
688 (frob! x) ; may mutate `x'
690 (let (x) (_) ((apply (toplevel make-foo)))
692 (apply (toplevel frob!) (lexical x _))
696 ;; Inlining stops at recursive calls with dynamic arguments.
698 (if (< x 0) x (loop (1- x))))
699 (letrec (loop) (_) ((lambda (_)
701 (((x) #f #f #f () (_))
703 (apply (lexical loop _)
704 (apply (primitive 1-)
706 (apply (lexical loop _) (toplevel x))))
709 ;; Recursion on the 2nd argument is fully evaluated.
711 (let loop ((x x) (y 10))
715 (let (x) (_) ((apply (toplevel top)))
716 (apply (toplevel foo) (lexical x _) (const 0))))
719 ;; Inlining aborted when residual code contains recursive calls.
721 ;; <http://debbugs.gnu.org/9542>
722 (let loop ((x x) (y 0))
727 (loop (1+ x) (1+ y)))))
728 (letrec (loop) (_) ((lambda (_)
730 (((x y) #f #f #f () (_ _))
731 (if (apply (primitive >)
732 (lexical y _) (const 0))
734 (apply (lexical loop _) (toplevel x) (const 0))))
737 ;; Infinite recursion: `peval' gives up and leaves it as is.
738 (letrec ((f (lambda (x) (g (1- x))))
739 (g (lambda (x) (h (1+ x))))
740 (h (lambda (x) (f x))))
745 ;; Infinite recursion: all the arguments to `loop' are static, but
746 ;; unrolling it would lead `peval' to enter an infinite loop.
750 (letrec (loop) (_) ((lambda . _))
751 (apply (lexical loop _) (const 0))))
754 ;; This test checks that the `start' binding is indeed residualized.
755 ;; See the `referenced?' procedure in peval's `prune-bindings'.
757 (let ((here (let ((start pos)) (lambda () start))))
758 (set! pos 1) ;; Cause references to `pos' to residualize.
760 (let (pos) (_) ((const 0))
763 (set! (lexical pos _) (const 1))
764 (apply (lexical here _))))))
767 ;; FIXME: should this one residualize the binding?
773 ;; This is a fun one for peval to handle.
776 (letrec (a) (_) ((lexical a _))
780 ;; Another interesting recursive case.
781 (letrec ((a b) (b a))
783 (letrec (a) (_) ((lexical a _))
787 ;; Another pruning case, that `a' is residualized.
788 (letrec ((a (lambda () (a)))
794 ;; "b c a" is the current order that we get with unordered letrec,
795 ;; but it's not important to this test, so if it changes, just adapt
797 (letrec (b c a) (_ _ _)
801 (apply (lexical a _)))))
804 (((x) #f #f #f () (_))
809 (apply (lexical a _))))))
812 ((apply (toplevel foo) (lexical b _)))
817 ;; In this case, we can prune the bindings. `a' ends up being copied
818 ;; because it is only referenced once in the source program. Oh
820 (letrec* ((a (lambda (x) (top x)))
823 (apply (toplevel foo)
826 (((x) #f #f #f () (_))
827 (apply (toplevel top) (lexical x _)))))
830 (((x) #f #f #f () (_))
831 (apply (toplevel top) (lexical x _)))))))
834 ;; Constant folding: cons of #nil does not make list
836 (apply (primitive cons) (const 1) (const '#nil)))
839 ;; Constant folding: cons
840 (begin (cons 1 2) #f)
844 ;; Constant folding: cons
845 (begin (cons (foo) 2) #f)
846 (begin (apply (toplevel foo)) (const #f)))
849 ;; Constant folding: cons
854 ;; Constant folding: car+cons
859 ;; Constant folding: cdr+cons
864 ;; Constant folding: car+cons, impure
866 (begin (apply (toplevel bar)) (const 1)))
869 ;; Constant folding: cdr+cons, impure
871 (begin (apply (toplevel bar)) (const 0)))
874 ;; Constant folding: car+list
879 ;; Constant folding: cdr+list
881 (apply (primitive list) (const 0)))
884 ;; Constant folding: car+list, impure
886 (begin (apply (toplevel bar)) (const 1)))
889 ;; Constant folding: cdr+list, impure
891 (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
895 ;; Non-constant guards get lexical bindings.
896 (dynamic-wind foo (lambda () bar) baz)
897 (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
898 (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
902 ;; Constant guards don't need lexical bindings.
903 (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
907 ((() #f #f #f () ()) (toplevel foo))))
911 ((() #f #f #f () ()) (toplevel baz))))))
915 ;; Prompt is removed if tag is unreferenced
916 (let ((tag (make-prompt-tag)))
917 (call-with-prompt tag
924 ;; Prompt is removed if tag is unreferenced, with explicit stem
925 (let ((tag (make-prompt-tag "foo")))
926 (call-with-prompt tag
931 ;; Handler lambda inlined
934 (call-with-prompt tag
937 (prompt (toplevel tag)
940 (((k x) #f #f #f () (_ _))
943 ;; Handler toplevel not inlined
946 (call-with-prompt tag
949 (let (handler) (_) ((toplevel handler))
950 (prompt (toplevel tag)
953 ((() #f args #f () (_))
954 (apply (primitive @apply)
956 (lexical args _)))))))
960 ;; `while' without `break' or `continue' has no prompts and gets its
961 ;; condition folded. Unfortunately the outer `lp' does not yet get
962 ;; elided, and the continuation tag stays around. (The continue tag
963 ;; stays around because although it is not referenced, recursively
964 ;; visiting the loop in the continue handler manages to visit the tag
965 ;; twice before aborting. The abort doesn't unroll the recursive
968 (let (_) (_) ((apply (primitive make-prompt-tag) . _))
977 (apply (lexical loop _))))))
978 (apply (lexical loop _)))))))
979 (apply (lexical lp _)))))
984 (apply (lambda (x y) (+ x y))
988 (((x y) #f #f #f () (_ _))
991 (pass-if-peval resolve-primitives
995 ;; If we bail out when inlining an identifier because it's too big,
996 ;; but the identifier simply aliases some other identifier, then avoid
997 ;; residualizing a reference to the leaf identifier. The bailout is
998 ;; driven by the recursive-effort-limit, which is currently 100. We
999 ;; make sure to trip it with this recursive sum thing.
1000 (pass-if-peval resolve-primitives
1001 (let ((x (let sum ((n 0) (out 0))
1003 (sum (1+ n) (+ out n))
1005 ((lambda (y) (list y)) x))
1007 (apply (primitive list) (lexical x _))))
1009 ;; Here we test that a common test in a chain of ifs gets lifted.
1010 (pass-if-peval resolve-primitives
1011 (if (and (struct? x) (eq? (struct-vtable x) A))
1013 (if (and (struct? x) (eq? (struct-vtable x) B))
1015 (if (and (struct? x) (eq? (struct-vtable x) C))
1018 (let (failure) (_) ((lambda _
1020 ((() #f #f #f () ())
1021 (apply (toplevel qux) (toplevel x))))))
1022 (if (apply (primitive struct?) (toplevel x))
1023 (if (apply (primitive eq?)
1024 (apply (primitive struct-vtable) (toplevel x))
1026 (apply (toplevel foo) (toplevel x))
1027 (if (apply (primitive eq?)
1028 (apply (primitive struct-vtable) (toplevel x))
1030 (apply (toplevel bar) (toplevel x))
1031 (if (apply (primitive eq?)
1032 (apply (primitive struct-vtable) (toplevel x))
1034 (apply (toplevel baz) (toplevel x))
1035 (apply (lexical failure _)))))
1036 (apply (lexical failure _)))))
1038 ;; Multiple common tests should get lifted as well.
1039 (pass-if-peval resolve-primitives
1040 (if (and (struct? x) (eq? (struct-vtable x) A) B)
1042 (if (and (struct? x) (eq? (struct-vtable x) A) C)
1044 (if (and (struct? x) (eq? (struct-vtable x) A) D)
1047 (let (failure) (_) ((lambda _
1049 ((() #f #f #f () ())
1050 (apply (toplevel qux) (toplevel x))))))
1051 (if (apply (primitive struct?) (toplevel x))
1052 (if (apply (primitive eq?)
1053 (apply (primitive struct-vtable) (toplevel x))
1056 (apply (toplevel foo) (toplevel x))
1058 (apply (toplevel bar) (toplevel x))
1060 (apply (toplevel baz) (toplevel x))
1061 (apply (lexical failure _)))))
1062 (apply (lexical failure _)))
1063 (apply (lexical failure _)))))
1065 (pass-if-peval resolve-primitives
1066 (apply (lambda (x y) (cons x y)) '(1 2))
1067 (apply (primitive cons) (const 1) (const 2)))
1069 (pass-if-peval resolve-primitives
1070 (apply (lambda (x y) (cons x y)) (list 1 2))
1071 (apply (primitive cons) (const 1) (const 2)))
1073 (pass-if-peval resolve-primitives
1074 (let ((t (make-prompt-tag)))
1076 (lambda () (abort-to-prompt t 1 2 3))
1077 (lambda (k x y z) (list x y z))))
1078 (apply (primitive 'list) (const 1) (const 2) (const 3))))