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 (rnrs bytevectors) ;; for the bytevector primitives
28 #:use-module (srfi srfi-13))
31 ;; The partial evaluator.
32 (@@ (language tree-il optimize) peval))
34 (define-syntax pass-if-peval
40 (compile 'in #:from 'scheme #:to 'tree-il)
44 (let ((evaled (unparse-tree-il (peval code))))
47 (_ (pk 'peval-mismatch)
48 ((@ (ice-9 pretty-print) pretty-print)
51 ((@ (ice-9 pretty-print) pretty-print)
54 ((@ (ice-9 pretty-print) pretty-print)
60 (with-test-prefix "partial evaluation"
63 ;; First order, primitive.
64 (let ((x 1) (y 2)) (+ x y))
68 ;; First order, thunk.
70 (let ((f (lambda () (+ x y))))
75 ;; First order, let-values (requires primitive expansion for
76 ;; `call-with-values'.)
79 (lambda () (if (zero? x) (values 1 2) (values 3 4)))
85 ;; First order, multiple values.
88 (primcall values (const 1) (const 2)))
91 ;; First order, multiple values truncated.
92 (let ((x (values 1 'a)) (y 2))
94 (primcall values (const 1) (const 2)))
97 ;; First order, multiple values truncated.
102 ;; First order, coalesced, mutability preserved.
103 (cons 0 (cons 1 (cons 2 (list 3 4 5))))
105 (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
108 ;; First order, coalesced, immutability preserved.
109 (cons 0 (cons 1 (cons 2 '(3 4 5))))
110 (primcall cons (const 0)
111 (primcall cons (const 1)
112 (primcall cons (const 2)
115 ;; These two tests doesn't work any more because we changed the way we
116 ;; deal with constants -- now the algorithm will see a construction as
117 ;; being bound to the lexical, so it won't propagate it. It can't
118 ;; even propagate it in the case that it is only referenced once,
121 ;; (let ((x (cons 1 2))) (lambda () x))
123 ;; is not the same as
125 ;; (lambda () (cons 1 2))
127 ;; Perhaps if we determined that not only was it only referenced once,
128 ;; it was not closed over by a lambda, then we could propagate it, and
129 ;; re-enable these two tests.
133 ;; First order, mutability preserved.
134 (let loop ((i 3) (r '()))
137 (loop (1- i) (cons (cons i i) r))))
139 (primcall cons (const 1) (const 1))
140 (primcall cons (const 2) (const 2))
141 (primcall cons (const 3) (const 3))))
146 ;; First order, evaluated.
151 (loop (1- i) (cons i r))))
154 ;; Instead here are tests for what happens for the above cases: they
155 ;; unroll but they don't fold.
157 (let loop ((i 3) (r '()))
160 (loop (1- i) (cons (cons i i) r))))
163 (primcall cons (const 3) (const 3))))
166 (primcall cons (const 2) (const 2))
169 (primcall cons (const 1) (const 1))
178 (loop (1- i) (cons i r))))
180 ((primcall list (const 4)))
198 (let loop ((l '(1 2 3 4)) (sum 0))
201 (loop (cdr l) (+ sum (car l)))))
216 (string->chars "yo"))
217 (primcall list (const #\y) (const #\o)))
220 ;; Primitives in module-refs are resolved (the expansion of `pmatch'
221 ;; below leads to calls to (@@ (system base pmatch) car) and
222 ;; similar, which is what we want to be inlined.)
224 (use-modules (system base pmatch))
232 ;; Mutability preserved.
233 ((lambda (x y z) (list x y z)) 1 2 3)
234 (primcall list (const 1) (const 2) (const 3)))
237 ;; Don't propagate effect-free expressions that operate on mutable
243 (let (x) (_) ((primcall list (const 1)))
244 (let (y) (_) ((primcall car (lexical x _)))
246 (primcall set-car! (lexical x _) (const 0))
250 ;; Don't propagate effect-free expressions that operate on objects we
255 (let (y) (_) ((primcall car (toplevel x)))
257 (primcall set-car! (toplevel x) (const 0))
261 ;; Infinite recursion
262 ((lambda (x) (x x)) (lambda (x) (x x)))
267 (call (lexical x _) (lexical x _))))))
268 (call (lexical x _) (lexical x _))))
271 ;; First order, aliased primitive.
272 (let* ((x *) (y (x 1 2))) y)
276 ;; First order, shadowed primitive.
278 (define (+ x y) (pk x y))
284 (((x y) #f #f #f () (_ _))
285 (call (toplevel pk) (lexical x _) (lexical y _))))))
286 (call (toplevel +) (const 1) (const 2))))
289 ;; First-order, effects preserved.
294 (call (toplevel do-something!))
298 ;; First order, residual bindings removed.
301 (primcall * (const 5) (toplevel z)))
304 ;; First order, with lambda.
306 (define (bar z) (* z z))
311 (((x) #f #f #f () (_))
312 (primcall + (lexical x _) (const 9)))))))
315 ;; First order, with lambda inlined & specialized twice.
316 (let ((f (lambda (x y)
325 (primcall + ; (f 2 3)
330 (let (x) (_) ((toplevel something)) ; (f something 2)
331 ;; `something' is not const, so preserve order of
332 ;; effects with a lexical binding.
340 ;; First order, with lambda inlined & specialized 3 times.
341 (let ((f (lambda (x y) (if (> x 0) y x))))
353 (const -1) ; (f -1 0)
354 (seq (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 (primcall > (lexical x _) (const 0))
362 ;; First order, conditional.
370 (((x) #f #f #f () (_))
371 (call (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 (call (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 (default uses earlier argument).
414 ;; <http://bugs.gnu.org/17634>
415 ((lambda* (f x #:optional (y (+ 3 (car x))))
416 (+ y (f (* (car x) (cadr x)))))
423 ;; Higher order with optional arguments
424 ;; (default uses earlier optional argument).
425 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
426 (+ y z (f (* (car x) (cadr x)))))
433 ;; Higher order with optional arguments (one caller-supplied value,
434 ;; one default that uses earlier optional argument).
435 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
436 (+ y z (f (* (car x) (cadr x)))))
444 ;; Higher order with optional arguments (caller-supplied values).
445 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
446 (+ y z (f (* (car x) (cadr x)))))
455 ;; Higher order with optional and rest arguments (one
456 ;; caller-supplied value, one default that uses earlier optional
458 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
460 (list r (+ y z (f (* (car x) (cadr x))))))
465 (primcall list (const ()) (const 4)))
468 ;; Higher order with optional and rest arguments
469 ;; (caller-supplied values for optionals).
470 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
472 (list r (+ y z (f (* (car x) (cadr x))))))
478 (primcall list (const ()) (const 21)))
481 ;; Higher order with optional and rest arguments
482 ;; (caller-supplied values for optionals and rest).
483 ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
485 (list r (+ y z (f (* (car x) (cadr x))))))
493 (let (r) (_) ((primcall list (const 8) (const 3)))
494 (primcall list (lexical r _) (const 21))))
497 ;; Higher order with optional argument (caller-supplied value).
498 ((lambda* (f x #:optional (y 0))
499 (+ y (f (* (car x) (cadr x)))))
507 ;; Higher order with optional argument (side-effecting default
509 ((lambda* (f x #:optional (y (foo)))
510 (+ y (f (* (car x) (cadr x)))))
514 (let (y) (_) ((call (toplevel foo)))
515 (primcall + (lexical y _) (const 7))))
518 ;; Higher order with optional argument (caller-supplied value).
519 ((lambda* (f x #:optional (y (foo)))
520 (+ y (f (* (car x) (cadr x)))))
529 ((lambda (f) (f x)) (lambda (x) x))
534 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
535 (let ((fold (lambda (f g) (f (g top)))))
536 (fold 1+ (lambda (x) x)))
537 (primcall 1+ (toplevel top)))
540 ;; Procedure not inlined when residual code contains recursive calls.
541 ;; <http://debbugs.gnu.org/9542>
542 (letrec ((fold (lambda (f x3 b null? car cdr)
545 (f (car x3) (fold f (cdr x3) b null? car cdr))))))
546 (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
547 (letrec (fold) (_) (_)
548 (call (lexical fold _)
555 (((x1) #f #f #f () (_))
559 (((x2) #f #f #f () (_))
560 (primcall 1- (lexical x2 _))))))))
562 (pass-if "inlined lambdas are alpha-renamed"
563 ;; In this example, `make-adder' is inlined more than once; thus,
564 ;; they should use different gensyms for their arguments, because
565 ;; the various optimization passes assume uniquely-named variables.
568 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
569 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
570 (pmatch (unparse-tree-il
571 (peval (expand-primitives
575 (lambda (x) (lambda (y) (+ x y)))))
576 (cons (make-adder 1) (make-adder 2)))
582 (((y) #f #f #f () (,gensym1))
585 (lexical y ,ref1)))))
588 (((y) #f #f #f () (,gensym2))
591 (lexical y ,ref2))))))
592 (and (eq? gensym1 ref1)
594 (not (eq? gensym1 gensym2))))
598 ;; Unused letrec bindings are pruned.
599 (letrec ((a (lambda () (b)))
606 ;; Unused letrec bindings are pruned.
611 (seq (call (toplevel foo!))
615 ;; Higher order, mutually recursive procedures.
616 (letrec ((even? (lambda (x)
621 (and (even? 4) (odd? 7)))
625 ;; Memv with constants.
630 ;; Memv with non-constant list. It could fold but doesn't
632 (memv 1 (list 3 2 1))
635 (primcall list (const 3) (const 2) (const 1))))
638 ;; Memv with non-constant key, constant list, test context
642 (let (key) (_) ((toplevel foo))
643 (if (if (primcall eqv? (lexical key _) (const 3))
645 (if (primcall eqv? (lexical key _) (const 2))
647 (primcall eqv? (lexical key _) (const 1))))
652 ;; Memv with non-constant key, empty list, test context.
656 (seq (toplevel foo) (const 'b)))
659 ;; Below are cases where constant propagation should bail out.
663 ;; Non-constant lexical is not propagated.
664 (let ((v (make-vector 6 #f)))
666 (vector-set! v n n)))
668 ((primcall make-vector (const 6) (const #f)))
671 (((n) #f #f #f () (_))
672 (primcall vector-set!
673 (lexical v _) (lexical n _) (lexical n _)))))))
676 ;; Mutable lexical is not propagated.
677 (let ((v (vector 1 2 3)))
681 ((primcall vector (const 1) (const 2) (const 3)))
688 ;; Lexical that is not provably pure is not inlined nor propagated.
689 (let* ((x (if (> p q) (frob!) (display 'chbouib)))
692 (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
693 (call (toplevel frob!))
694 (call (toplevel display) (const chbouib))))
695 (let (y) (_) ((primcall * (lexical x _) (const 2)))
697 (primcall + (lexical x _) (lexical x _))
701 ;; Non-constant arguments not propagated to lambdas.
710 ((primcall vector (const 1) (const 2) (const 3))
711 (call (toplevel make-list) (const 10))
712 (primcall list (const 1) (const 2) (const 3)))
714 (primcall vector-set!
715 (lexical x _) (const 0) (const 0))
716 (seq (primcall set-car!
717 (lexical y _) (const 0))
719 (lexical z _) (const ()))))))
722 (let ((foo top-foo) (bar top-bar))
723 (let* ((g (lambda (x y) (+ x y)))
724 (f (lambda (g x) (g x x))))
725 (+ (f g foo) (f g bar))))
726 (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
728 (primcall + (lexical foo _) (lexical foo _))
729 (primcall + (lexical bar _) (lexical bar _)))))
732 ;; Fresh objects are not turned into constants, nor are constants
733 ;; turned into fresh objects.
738 (let (x) (_) ((primcall cons (const 1) (const (2 3))))
739 (primcall cons (const 0) (lexical x _))))
746 (let (x) (_) ((const 2))
748 (set! (lexical x _) (const 3))
757 (frob f) ; may mutate `x'
759 (letrec (x) (_) ((const 0))
761 (call (toplevel frob) (lambda _ _))
766 (letrec ((f (lambda (x)
767 (set! f (lambda (_) x))
773 ;; Bindings possibly mutated.
774 (let ((x (make-foo)))
775 (frob! x) ; may mutate `x'
777 (let (x) (_) ((call (toplevel make-foo)))
779 (call (toplevel frob!) (lexical x _))
783 ;; Inlining stops at recursive calls with dynamic arguments.
785 (if (< x 0) x (loop (1- x))))
786 (letrec (loop) (_) ((lambda (_)
788 (((x) #f #f #f () (_))
790 (call (lexical loop _)
793 (call (lexical loop _) (toplevel x))))
796 ;; Recursion on the 2nd argument is fully evaluated.
798 (let loop ((x x) (y 10))
802 (let (x) (_) ((call (toplevel top)))
803 (call (toplevel foo) (lexical x _) (const 0))))
806 ;; Inlining aborted when residual code contains recursive calls.
808 ;; <http://debbugs.gnu.org/9542>
809 (let loop ((x x) (y 0))
814 (loop (1+ x) (1+ y)))))
815 (letrec (loop) (_) ((lambda (_)
817 (((x y) #f #f #f () (_ _))
819 (lexical y _) (const 0))
821 (call (lexical loop _) (toplevel x) (const 0))))
824 ;; Infinite recursion: `peval' gives up and leaves it as is.
825 (letrec ((f (lambda (x) (g (1- x))))
826 (g (lambda (x) (h (1+ x))))
827 (h (lambda (x) (f x))))
832 ;; Infinite recursion: all the arguments to `loop' are static, but
833 ;; unrolling it would lead `peval' to enter an infinite loop.
837 (letrec (loop) (_) ((lambda . _))
838 (call (lexical loop _) (const 0))))
841 ;; This test checks that the `start' binding is indeed residualized.
842 ;; See the `referenced?' procedure in peval's `prune-bindings'.
844 (let ((here (let ((start pos)) (lambda () start))))
845 (set! pos 1) ;; Cause references to `pos' to residualize.
847 (let (pos) (_) ((const 0))
850 (set! (lexical pos _) (const 1))
851 (call (lexical here _))))))
854 ;; FIXME: should this one residualize the binding?
860 ;; This is a fun one for peval to handle.
863 (letrec (a) (_) ((lexical a _))
867 ;; Another interesting recursive case.
868 (letrec ((a b) (b a))
870 (letrec (a) (_) ((lexical a _))
874 ;; Another pruning case, that `a' is residualized.
875 (letrec ((a (lambda () (a)))
881 ;; "b c a" is the current order that we get with unordered letrec,
882 ;; but it's not important to this test, so if it changes, just adapt
888 (call (lexical a _)))))
892 (call (lexical a _))))))
893 (call (toplevel foo) (lexical b _))))
896 ;; In this case, we can prune the bindings. `a' ends up being copied
897 ;; because it is only referenced once in the source program. Oh
899 (letrec* ((a (lambda (x) (top x)))
905 (((x) #f #f #f () (_))
906 (call (toplevel top) (lexical x _)))))
909 (((x) #f #f #f () (_))
910 (call (toplevel top) (lexical x _)))))))
913 ;; The inliner sees through a `let'.
914 ((let ((a 10)) (lambda (b) (* b 2))) 30)
919 (define (const x) (lambda (_) x))
925 ;; Applications of procedures with rest arguments can get inlined.
929 (let (z) (_) ((primcall list (const 3) (const 4)))
930 (primcall list (const 1) (const 2) (lexical z _))))
933 ;; Unmutated lists can get inlined.
934 (let ((args (list 2 3)))
935 (apply (lambda (x y z w)
938 (primcall list (const 0) (const 1) (const 2) (const 3)))
941 ;; However if the list might have been mutated, it doesn't propagate.
942 (let ((args (list 2 3)))
944 (apply (lambda (x y z w)
947 (let (args) (_) ((primcall list (const 2) (const 3)))
949 (call (toplevel foo!) (lexical args _))
953 (((x y z w) #f #f #f () (_ _ _ _))
955 (lexical x _) (lexical y _)
956 (lexical z _) (lexical w _)))))
962 ;; Here the `args' that gets built by the application of the lambda
963 ;; takes more than effort "10" to visit. Test that we fall back to
964 ;; the source expression of the operand, which is still a call to
965 ;; `list', so the inlining still happens.
966 (lambda (bv offset n)
967 (let ((x (bytevector-ieee-single-native-ref
970 (y (bytevector-ieee-single-native-ref
973 (let ((args (list x y)))
975 (lambda (bv offset x y)
976 (bytevector-ieee-single-native-set!
980 (bytevector-ieee-single-native-set!
989 (((bv offset n) #f #f #f () (_ _ _))
990 (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref
993 (lexical offset _) (const 0)))
994 (primcall bytevector-ieee-single-native-ref
997 (lexical offset _) (const 4))))
999 (primcall bytevector-ieee-single-native-set!
1002 (lexical offset _) (const 0))
1004 (primcall bytevector-ieee-single-native-set!
1007 (lexical offset _) (const 4))
1008 (lexical y _))))))))
1011 ;; Here we ensure that non-constant expressions are not copied.
1013 (let ((args (list (foo!))))
1017 ;; This toplevel ref might raise an unbound variable exception.
1018 ;; The effects of `(foo!)' must be visible before this effect.
1023 ((() #f #f #f () ())
1024 (let (_) (_) ((call (toplevel foo!)))
1025 (let (z) (_) ((toplevel z))
1028 (lexical _ _))))))))
1031 ;; Rest args referenced more than once are not destructured.
1033 (let ((args (list 'foo)))
1034 (set-car! args 'bar)
1042 ((() #f #f #f () ())
1044 ((primcall list (const foo)))
1046 (primcall set-car! (lexical args _) (const bar))
1050 (lexical args _))))))))
1053 ;; Let-values inlining, even with consumers with rest args.
1054 (call-with-values (lambda () (values 1 2))
1057 (primcall list (const 1) (const 2)))
1060 ;; When we can't inline let-values but can prove that the producer
1061 ;; has just one value, reduce to "let" (which can then fold
1063 (call-with-values (lambda () (if foo 1 2))
1065 (apply values args)))
1066 (if (toplevel foo) (const 1) (const 2)))
1069 ;; Constant folding: cons of #nil does not make list
1071 (primcall cons (const 1) (const '#nil)))
1074 ;; Constant folding: cons
1075 (begin (cons 1 2) #f)
1079 ;; Constant folding: cons
1080 (begin (cons (foo) 2) #f)
1081 (seq (call (toplevel foo)) (const #f)))
1084 ;; Constant folding: cons
1089 ;; Constant folding: car+cons
1094 ;; Constant folding: cdr+cons
1099 ;; Constant folding: car+cons, impure
1100 (car (cons 1 (bar)))
1101 (seq (call (toplevel bar)) (const 1)))
1104 ;; Constant folding: cdr+cons, impure
1105 (cdr (cons (bar) 0))
1106 (seq (call (toplevel bar)) (const 0)))
1109 ;; Constant folding: car+list
1114 ;; Constant folding: cdr+list
1116 (primcall list (const 0)))
1119 ;; Constant folding: car+list, impure
1120 (car (list 1 (bar)))
1121 (seq (call (toplevel bar)) (const 1)))
1124 ;; Constant folding: cdr+list, impure
1125 (cdr (list (bar) 0))
1126 (seq (call (toplevel bar)) (primcall list (const 0))))
1129 ;; Equality primitive: same lexical
1130 (let ((x (random))) (eq? x x))
1131 (seq (call (toplevel random)) (const #t)))
1134 ;; Equality primitive: merge lexical identities
1135 (let* ((x (random)) (y x)) (eq? x y))
1136 (seq (call (toplevel random)) (const #t)))
1139 ;; Non-constant guards get lexical bindings, invocation of winder and
1140 ;; unwinder lifted out. Unfortunately both have the generic variable
1141 ;; name "tmp", so we can't distinguish them in this test, and they
1142 ;; also collide in generic names with the single-value result from
1143 ;; the dynwind; alack.
1144 (dynamic-wind foo (lambda () bar) baz)
1145 (let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
1146 (seq (seq (if (primcall thunk? (lexical tmp _))
1147 (call (lexical tmp _))
1148 (primcall scm-error . _))
1149 (primcall wind (lexical tmp _) (lexical tmp _)))
1150 (let (tmp) (_) ((toplevel bar))
1151 (seq (seq (primcall unwind)
1152 (call (lexical tmp _)))
1153 (lexical tmp _))))))
1156 ;; Constant guards don't need lexical bindings or thunk? checks.
1157 (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
1158 (seq (seq (toplevel foo)
1162 ((() #f #f #f () ()) (toplevel foo))))
1165 ((() #f #f #f () ()) (toplevel baz))))))
1166 (let (tmp) (_) ((toplevel bar))
1167 (seq (seq (primcall unwind)
1172 ;; Dynwind bodies that return an unknown number of values need a
1174 (dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
1175 (seq (seq (toplevel foo)
1179 ((() #f #f #f () ()) (toplevel foo))))
1182 ((() #f #f #f () ()) (toplevel baz))))))
1183 (let-values (call (toplevel bar))
1185 ((() #f vals #f () (_))
1186 (seq (seq (primcall unwind)
1188 (primcall apply (primitive values) (lexical vals _))))))))
1191 ;; Prompt is removed if tag is unreferenced
1192 (let ((tag (make-prompt-tag)))
1193 (call-with-prompt tag
1195 (lambda args args)))
1199 ;; Prompt is removed if tag is unreferenced, with explicit stem
1200 (let ((tag (make-prompt-tag "foo")))
1201 (call-with-prompt tag
1203 (lambda args args)))
1206 ;; Handler lambda inlined
1208 (call-with-prompt tag
1216 (((k x) #f #f #f () (_ _))
1219 ;; Handler toplevel not inlined
1221 (call-with-prompt tag
1228 ((() #f #f #f () ())
1230 (toplevel handler)))
1233 ;; `while' without `break' or `continue' has no prompts and gets its
1234 ;; condition folded. Unfortunately the outer `lp' does not yet get
1235 ;; elided, and the continuation tag stays around. (The continue tag
1236 ;; stays around because although it is not referenced, recursively
1237 ;; visiting the loop in the continue handler manages to visit the tag
1238 ;; twice before aborting. The abort doesn't unroll the recursive
1241 (let (_) (_) ((primcall make-prompt-tag . _))
1245 ((() #f #f #f () ())
1249 ((() #f #f #f () ())
1250 (call (lexical loop _))))))
1251 (call (lexical loop _)))))))
1252 (call (lexical lp _)))))
1256 (apply (lambda (x y) (+ x y))
1260 (((x y) #f #f #f () (_ _))
1267 ;; If we bail out when inlining an identifier because it's too big,
1268 ;; but the identifier simply aliases some other identifier, then avoid
1269 ;; residualizing a reference to the leaf identifier. The bailout is
1270 ;; driven by the recursive-effort-limit, which is currently 100. We
1271 ;; make sure to trip it with this recursive sum thing.
1273 (let ((x (let sum ((n 0) (out 0))
1275 (sum (1+ n) (+ out n))
1277 ((lambda (y) (list y)) x))
1279 (primcall list (lexical x _))))
1281 ;; Here we test that a common test in a chain of ifs gets lifted.
1283 (if (and (struct? x) (eq? (struct-vtable x) A))
1285 (if (and (struct? x) (eq? (struct-vtable x) B))
1287 (if (and (struct? x) (eq? (struct-vtable x) C))
1290 (let (failure) (_) ((lambda _
1292 ((() #f #f #f () ())
1293 (call (toplevel qux) (toplevel x))))))
1294 (if (primcall struct? (toplevel x))
1296 (primcall struct-vtable (toplevel x))
1298 (call (toplevel foo) (toplevel x))
1300 (primcall struct-vtable (toplevel x))
1302 (call (toplevel bar) (toplevel x))
1304 (primcall struct-vtable (toplevel x))
1306 (call (toplevel baz) (toplevel x))
1307 (call (lexical failure _)))))
1308 (call (lexical failure _)))))
1310 ;; Multiple common tests should get lifted as well.
1312 (if (and (struct? x) (eq? (struct-vtable x) A) B)
1314 (if (and (struct? x) (eq? (struct-vtable x) A) C)
1316 (if (and (struct? x) (eq? (struct-vtable x) A) D)
1319 (let (failure) (_) ((lambda _
1321 ((() #f #f #f () ())
1322 (call (toplevel qux) (toplevel x))))))
1323 (if (primcall struct? (toplevel x))
1325 (primcall struct-vtable (toplevel x))
1328 (call (toplevel foo) (toplevel x))
1330 (call (toplevel bar) (toplevel x))
1332 (call (toplevel baz) (toplevel x))
1333 (call (lexical failure _)))))
1334 (call (lexical failure _)))
1335 (call (lexical failure _)))))
1338 (apply (lambda (x y) (cons x y)) '(1 2))
1339 (primcall cons (const 1) (const 2)))
1342 (apply (lambda (x y) (cons x y)) (list 1 2))
1343 (primcall cons (const 1) (const 2)))
1345 ;; Disable after removal of abort-in-tail-position optimization, in
1346 ;; hopes that CPS does a uniformly better job.
1349 (let ((t (make-prompt-tag)))
1351 (lambda () (abort-to-prompt t 1 2 3))
1352 (lambda (k x y z) (list x y z))))
1353 (primcall list (const 1) (const 2) (const 3)))
1356 (call-with-values foo (lambda (x) (bar x)))
1357 (let (x) (_) ((call (toplevel foo)))
1358 (call (toplevel bar) (lexical x _))))
1362 (define* (bar a #:optional (b (1+ a)))
1366 (primcall list (const 1) (const 2)))
1369 ;; Should not inline tail list to apply if it is mutable.
1370 ;; <http://debbugs.gnu.org/15533>
1375 (let (l) (_) ((const ()))
1377 (if (primcall pair? (toplevel arg))
1378 (set! (lexical l _) (toplevel arg))
1380 (primcall apply (toplevel f) (lexical l _))))))