1 ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
2 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
4 ;;;; Copyright (C) 2009-2014 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 (rnrs bytevectors) ;; for the bytevector primitives
29 #:use-module (srfi srfi-13))
32 ;; The partial evaluator.
33 (@@ (language tree-il optimize) peval))
35 (define-syntax pass-if-peval
36 (syntax-rules (resolve-primitives)
39 (compile 'in #:from 'scheme #:to 'tree-il)))
40 ((_ resolve-primitives in pat)
44 (compile 'in #:from 'scheme #:to 'tree-il)
48 (let ((evaled (unparse-tree-il (peval code))))
51 (_ (pk 'peval-mismatch)
52 ((@ (ice-9 pretty-print) pretty-print)
55 ((@ (ice-9 pretty-print) pretty-print)
58 ((@ (ice-9 pretty-print) pretty-print)
64 (with-test-prefix "partial evaluation"
67 ;; First order, primitive.
68 (let ((x 1) (y 2)) (+ x y))
72 ;; First order, thunk.
74 (let ((f (lambda () (+ x y))))
78 (pass-if-peval resolve-primitives
79 ;; First order, let-values (requires primitive expansion for
80 ;; `call-with-values'.)
83 (lambda () (if (zero? x) (values 1 2) (values 3 4)))
88 (pass-if-peval resolve-primitives
89 ;; First order, multiple values.
92 (apply (primitive values) (const 1) (const 2)))
94 (pass-if-peval resolve-primitives
95 ;; First order, multiple values truncated.
96 (let ((x (values 1 'a)) (y 2))
98 (apply (primitive values) (const 1) (const 2)))
100 (pass-if-peval resolve-primitives
101 ;; First order, multiple values truncated.
106 ;; First order, coalesced, mutability preserved.
107 (cons 0 (cons 1 (cons 2 (list 3 4 5))))
108 (apply (primitive list)
109 (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
112 ;; First order, coalesced, immutability preserved.
113 (cons 0 (cons 1 (cons 2 '(3 4 5))))
114 (apply (primitive cons) (const 0)
115 (apply (primitive cons) (const 1)
116 (apply (primitive cons) (const 2)
119 ;; These two tests doesn't work any more because we changed the way we
120 ;; deal with constants -- now the algorithm will see a construction as
121 ;; being bound to the lexical, so it won't propagate it. It can't
122 ;; even propagate it in the case that it is only referenced once,
125 ;; (let ((x (cons 1 2))) (lambda () x))
127 ;; is not the same as
129 ;; (lambda () (cons 1 2))
131 ;; Perhaps if we determined that not only was it only referenced once,
132 ;; it was not closed over by a lambda, then we could propagate it, and
133 ;; re-enable these two tests.
137 ;; First order, mutability preserved.
138 (let loop ((i 3) (r '()))
141 (loop (1- i) (cons (cons i i) r))))
142 (apply (primitive list)
143 (apply (primitive cons) (const 1) (const 1))
144 (apply (primitive cons) (const 2) (const 2))
145 (apply (primitive cons) (const 3) (const 3))))
150 ;; First order, evaluated.
155 (loop (1- i) (cons i r))))
158 ;; Instead here are tests for what happens for the above cases: they
159 ;; unroll but they don't fold.
161 (let loop ((i 3) (r '()))
164 (loop (1- i) (cons (cons i i) r))))
166 ((apply (primitive list)
167 (apply (primitive cons) (const 3) (const 3))))
169 ((apply (primitive cons)
170 (apply (primitive cons) (const 2) (const 2))
172 (apply (primitive cons)
173 (apply (primitive cons) (const 1) (const 1))
182 (loop (1- i) (cons i r))))
184 ((apply (primitive list) (const 4)))
186 ((apply (primitive cons)
190 ((apply (primitive cons)
194 ((apply (primitive cons)
197 (apply (primitive car)
202 (let loop ((l '(1 2 3 4)) (sum 0))
205 (loop (cdr l) (+ sum (car l)))))
208 (pass-if-peval resolve-primitives
220 (string->chars "yo"))
221 (apply (primitive list) (const #\y) (const #\o)))
224 ;; Primitives in module-refs are resolved (the expansion of `pmatch'
225 ;; below leads to calls to (@@ (system base pmatch) car) and
226 ;; similar, which is what we want to be inlined.)
228 (use-modules (system base pmatch))
237 ;; Mutability preserved.
238 ((lambda (x y z) (list x y z)) 1 2 3)
239 (apply (primitive list) (const 1) (const 2) (const 3)))
242 ;; Don't propagate effect-free expressions that operate on mutable
248 (let (x) (_) ((apply (primitive list) (const 1)))
249 (let (y) (_) ((apply (primitive car) (lexical x _)))
251 (apply (toplevel set-car!) (lexical x _) (const 0))
255 ;; Don't propagate effect-free expressions that operate on objects we
260 (let (y) (_) ((apply (primitive car) (toplevel x)))
262 (apply (toplevel set-car!) (toplevel x) (const 0))
266 ;; Infinite recursion
267 ((lambda (x) (x x)) (lambda (x) (x x)))
272 (apply (lexical x _) (lexical x _))))))
273 (apply (lexical x _) (lexical x _))))
276 ;; First order, aliased primitive.
277 (let* ((x *) (y (x 1 2))) y)
281 ;; First order, shadowed primitive.
283 (define (+ x y) (pk x y))
289 (((x y) #f #f #f () (_ _))
290 (apply (toplevel pk) (lexical x _) (lexical y _))))))
291 (apply (toplevel +) (const 1) (const 2))))
294 ;; First-order, effects preserved.
299 (apply (toplevel do-something!))
303 ;; First order, residual bindings removed.
306 (apply (primitive *) (const 5) (toplevel z)))
309 ;; First order, with lambda.
311 (define (bar z) (* z z))
316 (((x) #f #f #f () (_))
317 (apply (primitive +) (lexical x _) (const 9)))))))
320 ;; First order, with lambda inlined & specialized twice.
321 (let ((f (lambda (x y)
330 (apply (primitive +) ; (f 2 3)
335 (let (x) (_) ((toplevel something)) ; (f something 2)
336 ;; `something' is not const, so preserve order of
337 ;; effects with a lexical binding.
345 ;; First order, with lambda inlined & specialized 3 times.
346 (let ((f (lambda (x y) (if (> x 0) y x))))
353 (const -1) ; (f -1 0)
355 (begin (toplevel y) (const -1)) ; (f -1 y)
356 (toplevel y) ; (f 2 y)
357 (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
358 (if (apply (primitive >) (lexical x _) (const 0))
363 ;; First order, conditional.
371 (((x) #f #f #f () (_))
372 (apply (toplevel display) (lexical x _))))))
375 ;; First order, recursive procedure.
376 (letrec ((fibo (lambda (n)
385 ;; Don't propagate toplevel references, as intervening expressions
386 ;; could alter their bindings.
390 (let (x) (_) ((toplevel top))
392 (apply (toplevel foo))
398 (f (* (car x) (cadr x))))
405 ;; Higher order with optional argument (default value).
406 ((lambda* (f x #:optional (y 0))
407 (+ y (f (* (car x) (cadr x)))))
414 ;; Higher order with optional argument (default uses earlier argument).
415 ;; <http://bugs.gnu.org/17634>
416 ((lambda* (f x #:optional (y (+ 3 (car x))))
417 (+ y (f (* (car x) (cadr x)))))
424 ;; Higher order with optional arguments
425 ;; (default uses earlier optional argument).
426 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
427 (+ y z (f (* (car x) (cadr x)))))
434 ;; Higher order with optional arguments (one caller-supplied value,
435 ;; one default that uses earlier optional argument).
436 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
437 (+ y z (f (* (car x) (cadr x)))))
445 ;; Higher order with optional arguments (caller-supplied values).
446 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
447 (+ y z (f (* (car x) (cadr x)))))
456 ;; Higher order with optional and rest arguments (one
457 ;; caller-supplied value, one default that uses earlier optional
459 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
461 (list r (+ y z (f (* (car x) (cadr x))))))
466 (apply (primitive list) (const ()) (const 4)))
469 ;; Higher order with optional and rest arguments
470 ;; (caller-supplied values for optionals).
471 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
473 (list r (+ y z (f (* (car x) (cadr x))))))
479 (apply (primitive list) (const ()) (const 21)))
482 ;; Higher order with optional and rest arguments
483 ;; (caller-supplied values for optionals and rest).
484 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
486 (list r (+ y z (f (* (car x) (cadr x))))))
494 (let (r) (_) ((apply (primitive list) (const 8) (const 3)))
495 (apply (primitive list) (lexical r _) (const 21))))
498 ;; Higher order with optional argument (caller-supplied value).
499 ((lambda* (f x #:optional (y 0))
500 (+ y (f (* (car x) (cadr x)))))
508 ;; Higher order with optional argument (side-effecting default
510 ((lambda* (f x #:optional (y (foo)))
511 (+ y (f (* (car x) (cadr x)))))
515 (let (y) (_) ((apply (toplevel foo)))
516 (apply (primitive +) (lexical y _) (const 7))))
519 ;; Higher order with optional argument (caller-supplied value).
520 ((lambda* (f x #:optional (y (foo)))
521 (+ y (f (* (car x) (cadr x)))))
530 ((lambda (f) (f x)) (lambda (x) x))
535 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
536 (let ((fold (lambda (f g) (f (g top)))))
537 (fold 1+ (lambda (x) x)))
538 (apply (primitive 1+) (toplevel top)))
541 ;; Procedure not inlined when residual code contains recursive calls.
542 ;; <http://debbugs.gnu.org/9542>
543 (letrec ((fold (lambda (f x3 b null? car cdr)
546 (f (car x3) (fold f (cdr x3) b null? car cdr))))))
547 (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
548 (letrec (fold) (_) (_)
549 (apply (lexical fold _)
556 (((x1) #f #f #f () (_))
560 (((x2) #f #f #f () (_))
561 (apply (primitive -) (lexical x2 _) (const 1))))))))
563 (pass-if "inlined lambdas are alpha-renamed"
564 ;; In this example, `make-adder' is inlined more than once; thus,
565 ;; they should use different gensyms for their arguments, because
566 ;; the various optimization passes assume uniquely-named variables.
569 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
570 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
571 (pmatch (unparse-tree-il
574 (lambda (x) (lambda (y) (+ x y)))))
575 (cons (make-adder 1) (make-adder 2)))
577 ((apply (primitive cons)
580 (((y) #f #f #f () (,gensym1))
583 (lexical y ,ref1)))))
586 (((y) #f #f #f () (,gensym2))
589 (lexical y ,ref2))))))
590 (and (eq? gensym1 ref1)
592 (not (eq? gensym1 gensym2))))
596 ;; Unused letrec bindings are pruned.
597 (letrec ((a (lambda () (b)))
604 ;; Unused letrec bindings are pruned.
609 (begin (apply (toplevel foo!))
613 ;; Higher order, mutually recursive procedures.
614 (letrec ((even? (lambda (x)
619 (and (even? 4) (odd? 7)))
623 ;; Memv with constants.
628 ;; Memv with non-constant list. It could fold but doesn't
630 (memv 1 (list 3 2 1))
631 (apply (primitive memv)
633 (apply (primitive list) (const 3) (const 2) (const 1))))
636 ;; Memv with non-constant key, constant list, test context
640 (let (key) (_) ((toplevel foo))
641 (if (if (apply (primitive eqv?) (lexical key _) (const 3))
643 (if (apply (primitive eqv?) (lexical key _) (const 2))
645 (apply (primitive eqv?) (lexical key _) (const 1))))
650 ;; Memv with non-constant key, empty list, test context. Currently
651 ;; doesn't fold entirely.
655 (begin (toplevel foo) (const b)))
658 ;; Below are cases where constant propagation should bail out.
662 ;; Non-constant lexical is not propagated.
663 (let ((v (make-vector 6 #f)))
665 (vector-set! v n n)))
667 ((apply (toplevel make-vector) (const 6) (const #f)))
670 (((n) #f #f #f () (_))
671 (apply (toplevel vector-set!)
672 (lexical v _) (lexical n _) (lexical n _)))))))
675 ;; Mutable lexical is not propagated.
676 (let ((v (vector 1 2 3)))
680 ((apply (primitive vector) (const 1) (const 2) (const 3)))
687 ;; Lexical that is not provably pure is not inlined nor propagated.
688 (let* ((x (if (> p q) (frob!) (display 'chbouib)))
691 (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
692 (apply (toplevel frob!))
693 (apply (toplevel display) (const chbouib))))
694 (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
696 (lexical x _) (lexical x _) (lexical y _)))))
699 ;; Non-constant arguments not propagated to lambdas.
708 ((apply (primitive vector) (const 1) (const 2) (const 3))
709 (apply (toplevel make-list) (const 10))
710 (apply (primitive list) (const 1) (const 2) (const 3)))
712 (apply (toplevel vector-set!)
713 (lexical x _) (const 0) (const 0))
714 (apply (toplevel set-car!)
715 (lexical y _) (const 0))
716 (apply (toplevel set-cdr!)
717 (lexical z _) (const ())))))
720 (let ((foo top-foo) (bar top-bar))
721 (let* ((g (lambda (x y) (+ x y)))
722 (f (lambda (g x) (g x x))))
723 (+ (f g foo) (f g bar))))
724 (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
726 (apply (primitive +) (lexical foo _) (lexical foo _))
727 (apply (primitive +) (lexical bar _) (lexical bar _)))))
730 ;; Fresh objects are not turned into constants, nor are constants
731 ;; turned into fresh objects.
736 (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
737 (apply (primitive cons) (const 0) (lexical x _))))
744 (let (x) (_) ((const 2))
746 (set! (lexical x _) (const 3))
755 (frob f) ; may mutate `x'
757 (letrec (x) (_) ((const 0))
759 (apply (toplevel frob) (lambda _ _))
764 (letrec ((f (lambda (x)
765 (set! f (lambda (_) x))
771 ;; Bindings possibly mutated.
772 (let ((x (make-foo)))
773 (frob! x) ; may mutate `x'
775 (let (x) (_) ((apply (toplevel make-foo)))
777 (apply (toplevel frob!) (lexical x _))
781 ;; Inlining stops at recursive calls with dynamic arguments.
783 (if (< x 0) x (loop (1- x))))
784 (letrec (loop) (_) ((lambda (_)
786 (((x) #f #f #f () (_))
788 (apply (lexical loop _)
789 (apply (primitive 1-)
791 (apply (lexical loop _) (toplevel x))))
794 ;; Recursion on the 2nd argument is fully evaluated.
796 (let loop ((x x) (y 10))
800 (let (x) (_) ((apply (toplevel top)))
801 (apply (toplevel foo) (lexical x _) (const 0))))
804 ;; Inlining aborted when residual code contains recursive calls.
806 ;; <http://debbugs.gnu.org/9542>
807 (let loop ((x x) (y 0))
812 (loop (1+ x) (1+ y)))))
813 (letrec (loop) (_) ((lambda (_)
815 (((x y) #f #f #f () (_ _))
816 (if (apply (primitive >)
817 (lexical y _) (const 0))
819 (apply (lexical loop _) (toplevel x) (const 0))))
822 ;; Infinite recursion: `peval' gives up and leaves it as is.
823 (letrec ((f (lambda (x) (g (1- x))))
824 (g (lambda (x) (h (1+ x))))
825 (h (lambda (x) (f x))))
830 ;; Infinite recursion: all the arguments to `loop' are static, but
831 ;; unrolling it would lead `peval' to enter an infinite loop.
835 (letrec (loop) (_) ((lambda . _))
836 (apply (lexical loop _) (const 0))))
839 ;; This test checks that the `start' binding is indeed residualized.
840 ;; See the `referenced?' procedure in peval's `prune-bindings'.
842 (let ((here (let ((start pos)) (lambda () start))))
843 (set! pos 1) ;; Cause references to `pos' to residualize.
845 (let (pos) (_) ((const 0))
848 (set! (lexical pos _) (const 1))
849 (apply (lexical here _))))))
852 ;; FIXME: should this one residualize the binding?
858 ;; This is a fun one for peval to handle.
861 (letrec (a) (_) ((lexical a _))
865 ;; Another interesting recursive case.
866 (letrec ((a b) (b a))
868 (letrec (a) (_) ((lexical a _))
872 ;; Another pruning case, that `a' is residualized.
873 (letrec ((a (lambda () (a)))
879 ;; "b c a" is the current order that we get with unordered letrec,
880 ;; but it's not important to this test, so if it changes, just adapt
882 (letrec (b c a) (_ _ _)
886 (apply (lexical a _)))))
889 (((x) #f #f #f () (_))
894 (apply (lexical a _))))))
897 ((apply (toplevel foo) (lexical b _)))
902 ;; In this case, we can prune the bindings. `a' ends up being copied
903 ;; because it is only referenced once in the source program. Oh
905 (letrec* ((a (lambda (x) (top x)))
908 (apply (toplevel foo)
911 (((x) #f #f #f () (_))
912 (apply (toplevel top) (lexical x _)))))
915 (((x) #f #f #f () (_))
916 (apply (toplevel top) (lexical x _)))))))
918 (pass-if-peval resolve-primitives
919 ;; The inliner sees through a `let'.
920 ((let ((a 10)) (lambda (b) (* b 2))) 30)
925 (define (const x) (lambda (_) x))
931 ;; Applications of procedures with rest arguments can get inlined.
935 (let (z) (_) ((apply (primitive list) (const 3) (const 4)))
936 (apply (primitive list) (const 1) (const 2) (lexical z _))))
938 (pass-if-peval resolve-primitives
939 ;; Unmutated lists can get inlined.
940 (let ((args (list 2 3)))
941 (apply (lambda (x y z w)
944 (apply (primitive list) (const 0) (const 1) (const 2) (const 3)))
946 (pass-if-peval resolve-primitives
947 ;; However if the list might have been mutated, it doesn't propagate.
948 (let ((args (list 2 3)))
950 (apply (lambda (x y z w)
953 (let (args) (_) ((apply (primitive list) (const 2) (const 3)))
955 (apply (toplevel foo!) (lexical args _))
956 (apply (primitive @apply)
959 (((x y z w) #f #f #f () (_ _ _ _))
960 (apply (primitive list)
961 (lexical x _) (lexical y _)
962 (lexical z _) (lexical w _)))))
967 (pass-if-peval resolve-primitives
968 ;; Here the `args' that gets built by the application of the lambda
969 ;; takes more than effort "10" to visit. Test that we fall back to
970 ;; the source expression of the operand, which is still a call to
971 ;; `list', so the inlining still happens.
972 (lambda (bv offset n)
973 (let ((x (bytevector-ieee-single-native-ref
976 (y (bytevector-ieee-single-native-ref
979 (let ((args (list x y)))
981 (lambda (bv offset x y)
982 (bytevector-ieee-single-native-set!
986 (bytevector-ieee-single-native-set!
995 (((bv offset n) #f #f #f () (_ _ _))
996 (let (x y) (_ _) ((apply (primitive bytevector-ieee-single-native-ref)
999 (lexical offset _) (const 0)))
1000 (apply (primitive bytevector-ieee-single-native-ref)
1002 (apply (primitive +)
1003 (lexical offset _) (const 4))))
1005 (apply (primitive bytevector-ieee-single-native-set!)
1007 (apply (primitive +)
1008 (lexical offset _) (const 0))
1010 (apply (primitive bytevector-ieee-single-native-set!)
1012 (apply (primitive +)
1013 (lexical offset _) (const 4))
1014 (lexical y _))))))))
1016 (pass-if-peval resolve-primitives
1017 ;; Here we ensure that non-constant expressions are not copied.
1019 (let ((args (list (foo!))))
1023 ;; This toplevel ref might raise an unbound variable exception.
1024 ;; The effects of `(foo!)' must be visible before this effect.
1029 ((() #f #f #f () ())
1030 (let (_) (_) ((apply (toplevel foo!)))
1031 (let (z) (_) ((toplevel z))
1032 (apply (primitive 'list)
1034 (lexical _ _))))))))
1036 (pass-if-peval resolve-primitives
1037 ;; Rest args referenced more than once are not destructured.
1039 (let ((args (list 'foo)))
1040 (set-car! args 'bar)
1048 ((() #f #f #f () ())
1050 ((apply (primitive list) (const foo)))
1052 (apply (primitive set-car!) (lexical args _) (const bar))
1053 (apply (primitive @apply)
1056 (lexical args _))))))))
1058 (pass-if-peval resolve-primitives
1059 ;; Let-values inlining, even with consumers with rest args.
1060 (call-with-values (lambda () (values 1 2))
1063 (apply (primitive list) (const 1) (const 2)))
1066 ;; Constant folding: cons of #nil does not make list
1068 (apply (primitive cons) (const 1) (const '#nil)))
1071 ;; Constant folding: cons
1072 (begin (cons 1 2) #f)
1076 ;; Constant folding: cons
1077 (begin (cons (foo) 2) #f)
1078 (begin (apply (toplevel foo)) (const #f)))
1081 ;; Constant folding: cons
1086 ;; Constant folding: car+cons
1091 ;; Constant folding: cdr+cons
1096 ;; Constant folding: car+cons, impure
1097 (car (cons 1 (bar)))
1098 (begin (apply (toplevel bar)) (const 1)))
1101 ;; Constant folding: cdr+cons, impure
1102 (cdr (cons (bar) 0))
1103 (begin (apply (toplevel bar)) (const 0)))
1106 ;; Constant folding: car+list
1111 ;; Constant folding: cdr+list
1113 (apply (primitive list) (const 0)))
1116 ;; Constant folding: car+list, impure
1117 (car (list 1 (bar)))
1118 (begin (apply (toplevel bar)) (const 1)))
1121 ;; Constant folding: cdr+list, impure
1122 (cdr (list (bar) 0))
1123 (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
1127 ;; Non-constant guards get lexical bindings.
1128 (dynamic-wind foo (lambda () bar) baz)
1129 (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
1130 (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
1134 ;; Constant guards don't need lexical bindings.
1135 (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
1139 ((() #f #f #f () ()) (toplevel foo))))
1143 ((() #f #f #f () ()) (toplevel baz))))))
1147 ;; Prompt is removed if tag is unreferenced
1148 (let ((tag (make-prompt-tag)))
1149 (call-with-prompt tag
1151 (lambda args args)))
1156 ;; Prompt is removed if tag is unreferenced, with explicit stem
1157 (let ((tag (make-prompt-tag "foo")))
1158 (call-with-prompt tag
1160 (lambda args args)))
1163 ;; Handler lambda inlined
1166 (call-with-prompt tag
1169 (prompt (toplevel tag)
1172 (((k x) #f #f #f () (_ _))
1175 ;; Handler toplevel not inlined
1178 (call-with-prompt tag
1181 (let (handler) (_) ((toplevel handler))
1182 (prompt (toplevel tag)
1185 ((() #f args #f () (_))
1186 (apply (primitive @apply)
1188 (lexical args _)))))))
1192 ;; `while' without `break' or `continue' has no prompts and gets its
1193 ;; condition folded. Unfortunately the outer `lp' does not yet get
1194 ;; elided, and the continuation tag stays around. (The continue tag
1195 ;; stays around because although it is not referenced, recursively
1196 ;; visiting the loop in the continue handler manages to visit the tag
1197 ;; twice before aborting. The abort doesn't unroll the recursive
1200 (let (_) (_) ((apply (primitive make-prompt-tag) . _))
1204 ((() #f #f #f () ())
1208 ((() #f #f #f () ())
1209 (apply (lexical loop _))))))
1210 (apply (lexical loop _)))))))
1211 (apply (lexical lp _)))))
1216 (apply (lambda (x y) (+ x y))
1220 (((x y) #f #f #f () (_ _))
1223 (pass-if-peval resolve-primitives
1227 ;; If we bail out when inlining an identifier because it's too big,
1228 ;; but the identifier simply aliases some other identifier, then avoid
1229 ;; residualizing a reference to the leaf identifier. The bailout is
1230 ;; driven by the recursive-effort-limit, which is currently 100. We
1231 ;; make sure to trip it with this recursive sum thing.
1232 (pass-if-peval resolve-primitives
1233 (let ((x (let sum ((n 0) (out 0))
1235 (sum (1+ n) (+ out n))
1237 ((lambda (y) (list y)) x))
1239 (apply (primitive list) (lexical x _))))
1241 ;; Here we test that a common test in a chain of ifs gets lifted.
1242 (pass-if-peval resolve-primitives
1243 (if (and (struct? x) (eq? (struct-vtable x) A))
1245 (if (and (struct? x) (eq? (struct-vtable x) B))
1247 (if (and (struct? x) (eq? (struct-vtable x) C))
1250 (let (failure) (_) ((lambda _
1252 ((() #f #f #f () ())
1253 (apply (toplevel qux) (toplevel x))))))
1254 (if (apply (primitive struct?) (toplevel x))
1255 (if (apply (primitive eq?)
1256 (apply (primitive struct-vtable) (toplevel x))
1258 (apply (toplevel foo) (toplevel x))
1259 (if (apply (primitive eq?)
1260 (apply (primitive struct-vtable) (toplevel x))
1262 (apply (toplevel bar) (toplevel x))
1263 (if (apply (primitive eq?)
1264 (apply (primitive struct-vtable) (toplevel x))
1266 (apply (toplevel baz) (toplevel x))
1267 (apply (lexical failure _)))))
1268 (apply (lexical failure _)))))
1270 ;; Multiple common tests should get lifted as well.
1271 (pass-if-peval resolve-primitives
1272 (if (and (struct? x) (eq? (struct-vtable x) A) B)
1274 (if (and (struct? x) (eq? (struct-vtable x) A) C)
1276 (if (and (struct? x) (eq? (struct-vtable x) A) D)
1279 (let (failure) (_) ((lambda _
1281 ((() #f #f #f () ())
1282 (apply (toplevel qux) (toplevel x))))))
1283 (if (apply (primitive struct?) (toplevel x))
1284 (if (apply (primitive eq?)
1285 (apply (primitive struct-vtable) (toplevel x))
1288 (apply (toplevel foo) (toplevel x))
1290 (apply (toplevel bar) (toplevel x))
1292 (apply (toplevel baz) (toplevel x))
1293 (apply (lexical failure _)))))
1294 (apply (lexical failure _)))
1295 (apply (lexical failure _)))))
1297 (pass-if-peval resolve-primitives
1298 (apply (lambda (x y) (cons x y)) '(1 2))
1299 (apply (primitive cons) (const 1) (const 2)))
1301 (pass-if-peval resolve-primitives
1302 (apply (lambda (x y) (cons x y)) (list 1 2))
1303 (apply (primitive cons) (const 1) (const 2)))
1305 (pass-if-peval resolve-primitives
1306 (let ((t (make-prompt-tag)))
1308 (lambda () (abort-to-prompt t 1 2 3))
1309 (lambda (k x y z) (list x y z))))
1310 (apply (primitive 'list) (const 1) (const 2) (const 3)))
1312 (pass-if-peval resolve-primitives
1313 ;; Should not inline tail list to apply if it is mutable.
1314 ;; <http://debbugs.gnu.org/15533>
1319 (let (l) (_) ((const ()))
1321 (if (apply (primitive pair?) (toplevel arg))
1322 (set! (lexical l _) (toplevel arg))
1324 (apply (primitive @apply) (toplevel f) (lexical l _))))))