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, 2013 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 (caller-supplied value).
415 ((lambda* (f x #:optional (y 0))
416 (+ y (f (* (car x) (cadr x)))))
424 ;; Higher order with optional argument (side-effecting default
426 ((lambda* (f x #:optional (y (foo)))
427 (+ y (f (* (car x) (cadr x)))))
431 (let (y) (_) ((apply (toplevel foo)))
432 (apply (primitive +) (lexical y _) (const 7))))
435 ;; Higher order with optional argument (caller-supplied value).
436 ((lambda* (f x #:optional (y (foo)))
437 (+ y (f (* (car x) (cadr x)))))
446 ((lambda (f) (f x)) (lambda (x) x))
451 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
452 (let ((fold (lambda (f g) (f (g top)))))
453 (fold 1+ (lambda (x) x)))
454 (apply (primitive 1+) (toplevel top)))
457 ;; Procedure not inlined when residual code contains recursive calls.
458 ;; <http://debbugs.gnu.org/9542>
459 (letrec ((fold (lambda (f x3 b null? car cdr)
462 (f (car x3) (fold f (cdr x3) b null? car cdr))))))
463 (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
464 (letrec (fold) (_) (_)
465 (apply (lexical fold _)
472 (((x1) #f #f #f () (_))
476 (((x2) #f #f #f () (_))
477 (apply (primitive -) (lexical x2 _) (const 1))))))))
479 (pass-if "inlined lambdas are alpha-renamed"
480 ;; In this example, `make-adder' is inlined more than once; thus,
481 ;; they should use different gensyms for their arguments, because
482 ;; the various optimization passes assume uniquely-named variables.
485 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
486 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
487 (pmatch (unparse-tree-il
490 (lambda (x) (lambda (y) (+ x y)))))
491 (cons (make-adder 1) (make-adder 2)))
493 ((apply (primitive cons)
496 (((y) #f #f #f () (,gensym1))
499 (lexical y ,ref1)))))
502 (((y) #f #f #f () (,gensym2))
505 (lexical y ,ref2))))))
506 (and (eq? gensym1 ref1)
508 (not (eq? gensym1 gensym2))))
512 ;; Unused letrec bindings are pruned.
513 (letrec ((a (lambda () (b)))
520 ;; Unused letrec bindings are pruned.
525 (begin (apply (toplevel foo!))
529 ;; Higher order, mutually recursive procedures.
530 (letrec ((even? (lambda (x)
535 (and (even? 4) (odd? 7)))
539 ;; Memv with constants.
544 ;; Memv with non-constant list. It could fold but doesn't
546 (memv 1 (list 3 2 1))
547 (apply (primitive memv)
549 (apply (primitive list) (const 3) (const 2) (const 1))))
552 ;; Memv with non-constant key, constant list, test context
556 (let (key) (_) ((toplevel foo))
557 (if (if (apply (primitive eqv?) (lexical key _) (const 3))
559 (if (apply (primitive eqv?) (lexical key _) (const 2))
561 (apply (primitive eqv?) (lexical key _) (const 1))))
566 ;; Memv with non-constant key, empty list, test context. Currently
567 ;; doesn't fold entirely.
571 (begin (toplevel foo) (const b)))
574 ;; Below are cases where constant propagation should bail out.
578 ;; Non-constant lexical is not propagated.
579 (let ((v (make-vector 6 #f)))
581 (vector-set! v n n)))
583 ((apply (toplevel make-vector) (const 6) (const #f)))
586 (((n) #f #f #f () (_))
587 (apply (toplevel vector-set!)
588 (lexical v _) (lexical n _) (lexical n _)))))))
591 ;; Mutable lexical is not propagated.
592 (let ((v (vector 1 2 3)))
596 ((apply (primitive vector) (const 1) (const 2) (const 3)))
603 ;; Lexical that is not provably pure is not inlined nor propagated.
604 (let* ((x (if (> p q) (frob!) (display 'chbouib)))
607 (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
608 (apply (toplevel frob!))
609 (apply (toplevel display) (const chbouib))))
610 (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
612 (lexical x _) (lexical x _) (lexical y _)))))
615 ;; Non-constant arguments not propagated to lambdas.
624 ((apply (primitive vector) (const 1) (const 2) (const 3))
625 (apply (toplevel make-list) (const 10))
626 (apply (primitive list) (const 1) (const 2) (const 3)))
628 (apply (toplevel vector-set!)
629 (lexical x _) (const 0) (const 0))
630 (apply (toplevel set-car!)
631 (lexical y _) (const 0))
632 (apply (toplevel set-cdr!)
633 (lexical z _) (const ())))))
636 (let ((foo top-foo) (bar top-bar))
637 (let* ((g (lambda (x y) (+ x y)))
638 (f (lambda (g x) (g x x))))
639 (+ (f g foo) (f g bar))))
640 (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
642 (apply (primitive +) (lexical foo _) (lexical foo _))
643 (apply (primitive +) (lexical bar _) (lexical bar _)))))
646 ;; Fresh objects are not turned into constants, nor are constants
647 ;; turned into fresh objects.
652 (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
653 (apply (primitive cons) (const 0) (lexical x _))))
660 (let (x) (_) ((const 2))
662 (set! (lexical x _) (const 3))
671 (frob f) ; may mutate `x'
673 (letrec (x) (_) ((const 0))
675 (apply (toplevel frob) (lambda _ _))
680 (letrec ((f (lambda (x)
681 (set! f (lambda (_) x))
687 ;; Bindings possibly mutated.
688 (let ((x (make-foo)))
689 (frob! x) ; may mutate `x'
691 (let (x) (_) ((apply (toplevel make-foo)))
693 (apply (toplevel frob!) (lexical x _))
697 ;; Inlining stops at recursive calls with dynamic arguments.
699 (if (< x 0) x (loop (1- x))))
700 (letrec (loop) (_) ((lambda (_)
702 (((x) #f #f #f () (_))
704 (apply (lexical loop _)
705 (apply (primitive 1-)
707 (apply (lexical loop _) (toplevel x))))
710 ;; Recursion on the 2nd argument is fully evaluated.
712 (let loop ((x x) (y 10))
716 (let (x) (_) ((apply (toplevel top)))
717 (apply (toplevel foo) (lexical x _) (const 0))))
720 ;; Inlining aborted when residual code contains recursive calls.
722 ;; <http://debbugs.gnu.org/9542>
723 (let loop ((x x) (y 0))
728 (loop (1+ x) (1+ y)))))
729 (letrec (loop) (_) ((lambda (_)
731 (((x y) #f #f #f () (_ _))
732 (if (apply (primitive >)
733 (lexical y _) (const 0))
735 (apply (lexical loop _) (toplevel x) (const 0))))
738 ;; Infinite recursion: `peval' gives up and leaves it as is.
739 (letrec ((f (lambda (x) (g (1- x))))
740 (g (lambda (x) (h (1+ x))))
741 (h (lambda (x) (f x))))
746 ;; Infinite recursion: all the arguments to `loop' are static, but
747 ;; unrolling it would lead `peval' to enter an infinite loop.
751 (letrec (loop) (_) ((lambda . _))
752 (apply (lexical loop _) (const 0))))
755 ;; This test checks that the `start' binding is indeed residualized.
756 ;; See the `referenced?' procedure in peval's `prune-bindings'.
758 (let ((here (let ((start pos)) (lambda () start))))
759 (set! pos 1) ;; Cause references to `pos' to residualize.
761 (let (pos) (_) ((const 0))
764 (set! (lexical pos _) (const 1))
765 (apply (lexical here _))))))
768 ;; FIXME: should this one residualize the binding?
774 ;; This is a fun one for peval to handle.
777 (letrec (a) (_) ((lexical a _))
781 ;; Another interesting recursive case.
782 (letrec ((a b) (b a))
784 (letrec (a) (_) ((lexical a _))
788 ;; Another pruning case, that `a' is residualized.
789 (letrec ((a (lambda () (a)))
795 ;; "b c a" is the current order that we get with unordered letrec,
796 ;; but it's not important to this test, so if it changes, just adapt
798 (letrec (b c a) (_ _ _)
802 (apply (lexical a _)))))
805 (((x) #f #f #f () (_))
810 (apply (lexical a _))))))
813 ((apply (toplevel foo) (lexical b _)))
818 ;; In this case, we can prune the bindings. `a' ends up being copied
819 ;; because it is only referenced once in the source program. Oh
821 (letrec* ((a (lambda (x) (top x)))
824 (apply (toplevel foo)
827 (((x) #f #f #f () (_))
828 (apply (toplevel top) (lexical x _)))))
831 (((x) #f #f #f () (_))
832 (apply (toplevel top) (lexical x _)))))))
834 (pass-if-peval resolve-primitives
835 ;; The inliner sees through a `let'.
836 ((let ((a 10)) (lambda (b) (* b 2))) 30)
841 (define (const x) (lambda (_) x))
847 ;; Applications of procedures with rest arguments can get inlined.
851 (let (z) (_) ((apply (primitive list) (const 3) (const 4)))
852 (apply (primitive list) (const 1) (const 2) (lexical z _))))
854 (pass-if-peval resolve-primitives
855 ;; Unmutated lists can get inlined.
856 (let ((args (list 2 3)))
857 (apply (lambda (x y z w)
860 (apply (primitive list) (const 0) (const 1) (const 2) (const 3)))
862 (pass-if-peval resolve-primitives
863 ;; However if the list might have been mutated, it doesn't propagate.
864 (let ((args (list 2 3)))
866 (apply (lambda (x y z w)
869 (let (args) (_) ((apply (primitive list) (const 2) (const 3)))
871 (apply (toplevel foo!) (lexical args _))
872 (apply (primitive @apply)
875 (((x y z w) #f #f #f () (_ _ _ _))
876 (apply (primitive list)
877 (lexical x _) (lexical y _)
878 (lexical z _) (lexical w _)))))
883 (pass-if-peval resolve-primitives
884 ;; Here the `args' that gets built by the application of the lambda
885 ;; takes more than effort "10" to visit. Test that we fall back to
886 ;; the source expression of the operand, which is still a call to
887 ;; `list', so the inlining still happens.
888 (lambda (bv offset n)
889 (let ((x (bytevector-ieee-single-native-ref
892 (y (bytevector-ieee-single-native-ref
895 (let ((args (list x y)))
897 (lambda (bv offset x y)
898 (bytevector-ieee-single-native-set!
902 (bytevector-ieee-single-native-set!
911 (((bv offset n) #f #f #f () (_ _ _))
912 (let (x y) (_ _) ((apply (primitive bytevector-ieee-single-native-ref)
915 (lexical offset _) (const 0)))
916 (apply (primitive bytevector-ieee-single-native-ref)
919 (lexical offset _) (const 4))))
921 (apply (primitive bytevector-ieee-single-native-set!)
924 (lexical offset _) (const 0))
926 (apply (primitive bytevector-ieee-single-native-set!)
929 (lexical offset _) (const 4))
932 (pass-if-peval resolve-primitives
933 ;; Here we ensure that non-constant expressions are not copied.
935 (let ((args (list (foo!))))
939 ;; This toplevel ref might raise an unbound variable exception.
940 ;; The effects of `(foo!)' must be visible before this effect.
946 (let (_) (_) ((apply (toplevel foo!)))
947 (let (z) (_) ((toplevel z))
948 (apply (primitive 'list)
952 (pass-if-peval resolve-primitives
953 ;; Rest args referenced more than once are not destructured.
955 (let ((args (list 'foo)))
966 ((apply (primitive list) (const foo)))
968 (apply (primitive set-car!) (lexical args _) (const bar))
969 (apply (primitive @apply)
972 (lexical args _))))))))
974 (pass-if-peval resolve-primitives
975 ;; Let-values inlining, even with consumers with rest args.
976 (call-with-values (lambda () (values 1 2))
979 (apply (primitive list) (const 1) (const 2)))
982 ;; Constant folding: cons of #nil does not make list
984 (apply (primitive cons) (const 1) (const '#nil)))
987 ;; Constant folding: cons
988 (begin (cons 1 2) #f)
992 ;; Constant folding: cons
993 (begin (cons (foo) 2) #f)
994 (begin (apply (toplevel foo)) (const #f)))
997 ;; Constant folding: cons
1002 ;; Constant folding: car+cons
1007 ;; Constant folding: cdr+cons
1012 ;; Constant folding: car+cons, impure
1013 (car (cons 1 (bar)))
1014 (begin (apply (toplevel bar)) (const 1)))
1017 ;; Constant folding: cdr+cons, impure
1018 (cdr (cons (bar) 0))
1019 (begin (apply (toplevel bar)) (const 0)))
1022 ;; Constant folding: car+list
1027 ;; Constant folding: cdr+list
1029 (apply (primitive list) (const 0)))
1032 ;; Constant folding: car+list, impure
1033 (car (list 1 (bar)))
1034 (begin (apply (toplevel bar)) (const 1)))
1037 ;; Constant folding: cdr+list, impure
1038 (cdr (list (bar) 0))
1039 (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
1043 ;; Non-constant guards get lexical bindings.
1044 (dynamic-wind foo (lambda () bar) baz)
1045 (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
1046 (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
1050 ;; Constant guards don't need lexical bindings.
1051 (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
1055 ((() #f #f #f () ()) (toplevel foo))))
1059 ((() #f #f #f () ()) (toplevel baz))))))
1063 ;; Prompt is removed if tag is unreferenced
1064 (let ((tag (make-prompt-tag)))
1065 (call-with-prompt tag
1067 (lambda args args)))
1072 ;; Prompt is removed if tag is unreferenced, with explicit stem
1073 (let ((tag (make-prompt-tag "foo")))
1074 (call-with-prompt tag
1076 (lambda args args)))
1079 ;; Handler lambda inlined
1082 (call-with-prompt tag
1085 (prompt (toplevel tag)
1088 (((k x) #f #f #f () (_ _))
1091 ;; Handler toplevel not inlined
1094 (call-with-prompt tag
1097 (let (handler) (_) ((toplevel handler))
1098 (prompt (toplevel tag)
1101 ((() #f args #f () (_))
1102 (apply (primitive @apply)
1104 (lexical args _)))))))
1108 ;; `while' without `break' or `continue' has no prompts and gets its
1109 ;; condition folded. Unfortunately the outer `lp' does not yet get
1110 ;; elided, and the continuation tag stays around. (The continue tag
1111 ;; stays around because although it is not referenced, recursively
1112 ;; visiting the loop in the continue handler manages to visit the tag
1113 ;; twice before aborting. The abort doesn't unroll the recursive
1116 (let (_) (_) ((apply (primitive make-prompt-tag) . _))
1120 ((() #f #f #f () ())
1124 ((() #f #f #f () ())
1125 (apply (lexical loop _))))))
1126 (apply (lexical loop _)))))))
1127 (apply (lexical lp _)))))
1132 (apply (lambda (x y) (+ x y))
1136 (((x y) #f #f #f () (_ _))
1139 (pass-if-peval resolve-primitives
1143 ;; If we bail out when inlining an identifier because it's too big,
1144 ;; but the identifier simply aliases some other identifier, then avoid
1145 ;; residualizing a reference to the leaf identifier. The bailout is
1146 ;; driven by the recursive-effort-limit, which is currently 100. We
1147 ;; make sure to trip it with this recursive sum thing.
1148 (pass-if-peval resolve-primitives
1149 (let ((x (let sum ((n 0) (out 0))
1151 (sum (1+ n) (+ out n))
1153 ((lambda (y) (list y)) x))
1155 (apply (primitive list) (lexical x _))))
1157 ;; Here we test that a common test in a chain of ifs gets lifted.
1158 (pass-if-peval resolve-primitives
1159 (if (and (struct? x) (eq? (struct-vtable x) A))
1161 (if (and (struct? x) (eq? (struct-vtable x) B))
1163 (if (and (struct? x) (eq? (struct-vtable x) C))
1166 (let (failure) (_) ((lambda _
1168 ((() #f #f #f () ())
1169 (apply (toplevel qux) (toplevel x))))))
1170 (if (apply (primitive struct?) (toplevel x))
1171 (if (apply (primitive eq?)
1172 (apply (primitive struct-vtable) (toplevel x))
1174 (apply (toplevel foo) (toplevel x))
1175 (if (apply (primitive eq?)
1176 (apply (primitive struct-vtable) (toplevel x))
1178 (apply (toplevel bar) (toplevel x))
1179 (if (apply (primitive eq?)
1180 (apply (primitive struct-vtable) (toplevel x))
1182 (apply (toplevel baz) (toplevel x))
1183 (apply (lexical failure _)))))
1184 (apply (lexical failure _)))))
1186 ;; Multiple common tests should get lifted as well.
1187 (pass-if-peval resolve-primitives
1188 (if (and (struct? x) (eq? (struct-vtable x) A) B)
1190 (if (and (struct? x) (eq? (struct-vtable x) A) C)
1192 (if (and (struct? x) (eq? (struct-vtable x) A) D)
1195 (let (failure) (_) ((lambda _
1197 ((() #f #f #f () ())
1198 (apply (toplevel qux) (toplevel x))))))
1199 (if (apply (primitive struct?) (toplevel x))
1200 (if (apply (primitive eq?)
1201 (apply (primitive struct-vtable) (toplevel x))
1204 (apply (toplevel foo) (toplevel x))
1206 (apply (toplevel bar) (toplevel x))
1208 (apply (toplevel baz) (toplevel x))
1209 (apply (lexical failure _)))))
1210 (apply (lexical failure _)))
1211 (apply (lexical failure _)))))
1213 (pass-if-peval resolve-primitives
1214 (apply (lambda (x y) (cons x y)) '(1 2))
1215 (apply (primitive cons) (const 1) (const 2)))
1217 (pass-if-peval resolve-primitives
1218 (apply (lambda (x y) (cons x y)) (list 1 2))
1219 (apply (primitive cons) (const 1) (const 2)))
1221 (pass-if-peval resolve-primitives
1222 (let ((t (make-prompt-tag)))
1224 (lambda () (abort-to-prompt t 1 2 3))
1225 (lambda (k x y z) (list x y z))))
1226 (apply (primitive 'list) (const 1) (const 2) (const 3)))
1228 (pass-if-peval resolve-primitives
1229 ;; Should not inline tail list to apply if it is mutable.
1230 ;; <http://debbugs.gnu.org/15533>
1235 (let (l) (_) ((const ()))
1237 (if (apply (primitive pair?) (toplevel arg))
1238 (set! (lexical l _) (toplevel arg))
1240 (apply (primitive @apply) (toplevel f) (lexical l _))))))