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
41 (compile 'in #:from 'scheme #:to 'tree-il)
45 (let ((evaled (unparse-tree-il (peval code))))
48 (_ (pk 'peval-mismatch)
49 ((@ (ice-9 pretty-print) pretty-print)
52 ((@ (ice-9 pretty-print) pretty-print)
55 ((@ (ice-9 pretty-print) pretty-print)
61 (with-test-prefix "partial evaluation"
64 ;; First order, primitive.
65 (let ((x 1) (y 2)) (+ x y))
69 ;; First order, thunk.
71 (let ((f (lambda () (+ x y))))
76 ;; First order, let-values (requires primitive expansion for
77 ;; `call-with-values'.)
80 (lambda () (if (zero? x) (values 1 2) (values 3 4)))
86 ;; First order, multiple values.
89 (primcall values (const 1) (const 2)))
92 ;; First order, multiple values truncated.
93 (let ((x (values 1 'a)) (y 2))
95 (primcall values (const 1) (const 2)))
98 ;; First order, multiple values truncated.
103 ;; First order, coalesced, mutability preserved.
104 (cons 0 (cons 1 (cons 2 (list 3 4 5))))
106 (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
109 ;; First order, coalesced, immutability preserved.
110 (cons 0 (cons 1 (cons 2 '(3 4 5))))
111 (primcall cons (const 0)
112 (primcall cons (const 1)
113 (primcall cons (const 2)
116 ;; These two tests doesn't work any more because we changed the way we
117 ;; deal with constants -- now the algorithm will see a construction as
118 ;; being bound to the lexical, so it won't propagate it. It can't
119 ;; even propagate it in the case that it is only referenced once,
122 ;; (let ((x (cons 1 2))) (lambda () x))
124 ;; is not the same as
126 ;; (lambda () (cons 1 2))
128 ;; Perhaps if we determined that not only was it only referenced once,
129 ;; it was not closed over by a lambda, then we could propagate it, and
130 ;; re-enable these two tests.
134 ;; First order, mutability preserved.
135 (let loop ((i 3) (r '()))
138 (loop (1- i) (cons (cons i i) r))))
140 (primcall cons (const 1) (const 1))
141 (primcall cons (const 2) (const 2))
142 (primcall cons (const 3) (const 3))))
147 ;; First order, evaluated.
152 (loop (1- i) (cons i r))))
155 ;; Instead here are tests for what happens for the above cases: they
156 ;; unroll but they don't fold.
158 (let loop ((i 3) (r '()))
161 (loop (1- i) (cons (cons i i) r))))
164 (primcall cons (const 3) (const 3))))
167 (primcall cons (const 2) (const 2))
170 (primcall cons (const 1) (const 1))
179 (loop (1- i) (cons i r))))
181 ((primcall list (const 4)))
199 (let loop ((l '(1 2 3 4)) (sum 0))
202 (loop (cdr l) (+ sum (car l)))))
217 (string->chars "yo"))
218 (primcall list (const #\y) (const #\o)))
221 ;; Primitives in module-refs are resolved (the expansion of `pmatch'
222 ;; below leads to calls to (@@ (system base pmatch) car) and
223 ;; similar, which is what we want to be inlined.)
225 (use-modules (system base pmatch))
233 ;; Mutability preserved.
234 ((lambda (x y z) (list x y z)) 1 2 3)
235 (primcall list (const 1) (const 2) (const 3)))
238 ;; Don't propagate effect-free expressions that operate on mutable
244 (let (x) (_) ((primcall list (const 1)))
245 (let (y) (_) ((primcall car (lexical x _)))
247 (primcall set-car! (lexical x _) (const 0))
251 ;; Don't propagate effect-free expressions that operate on objects we
256 (let (y) (_) ((primcall car (toplevel x)))
258 (primcall set-car! (toplevel x) (const 0))
262 ;; Infinite recursion
263 ((lambda (x) (x x)) (lambda (x) (x x)))
268 (call (lexical x _) (lexical x _))))))
269 (call (lexical x _) (lexical x _))))
272 ;; First order, aliased primitive.
273 (let* ((x *) (y (x 1 2))) y)
277 ;; First order, shadowed primitive.
279 (define (+ x y) (pk x y))
285 (((x y) #f #f #f () (_ _))
286 (call (toplevel pk) (lexical x _) (lexical y _))))))
287 (call (toplevel +) (const 1) (const 2))))
290 ;; First-order, effects preserved.
295 (call (toplevel do-something!))
299 ;; First order, residual bindings removed.
302 (primcall * (const 5) (toplevel z)))
305 ;; First order, with lambda.
307 (define (bar z) (* z z))
312 (((x) #f #f #f () (_))
313 (primcall + (lexical x _) (const 9)))))))
316 ;; First order, with lambda inlined & specialized twice.
317 (let ((f (lambda (x y)
326 (primcall + ; (f 2 3)
331 (let (x) (_) ((toplevel something)) ; (f something 2)
332 ;; `something' is not const, so preserve order of
333 ;; effects with a lexical binding.
341 ;; First order, with lambda inlined & specialized 3 times.
342 (let ((f (lambda (x y) (if (> x 0) y x))))
350 (const -1) ; (f -1 0)
356 (seq (toplevel y) (const -1)) ; (f -1 y)
359 (toplevel y) ; (f 2 y)
360 (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
361 (if (primcall > (lexical x _) (const 0))
366 ;; First order, conditional.
374 (((x) #f #f #f () (_))
375 (call (toplevel display) (lexical x _))))))
378 ;; First order, recursive procedure.
379 (letrec ((fibo (lambda (n)
388 ;; Don't propagate toplevel references, as intervening expressions
389 ;; could alter their bindings.
393 (let (x) (_) ((toplevel top))
395 (call (toplevel foo))
401 (f (* (car x) (cadr x))))
408 ;; Higher order with optional argument (default value).
409 ((lambda* (f x #:optional (y 0))
410 (+ y (f (* (car x) (cadr x)))))
417 ;; Higher order with optional argument (caller-supplied value).
418 ((lambda* (f x #:optional (y 0))
419 (+ y (f (* (car x) (cadr x)))))
427 ;; Higher order with optional argument (side-effecting default
429 ((lambda* (f x #:optional (y (foo)))
430 (+ y (f (* (car x) (cadr x)))))
434 (let (y) (_) ((call (toplevel foo)))
435 (primcall + (lexical y _) (const 7))))
438 ;; Higher order with optional argument (caller-supplied value).
439 ((lambda* (f x #:optional (y (foo)))
440 (+ y (f (* (car x) (cadr x)))))
449 ((lambda (f) (f x)) (lambda (x) x))
454 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
455 (let ((fold (lambda (f g) (f (g top)))))
456 (fold 1+ (lambda (x) x)))
457 (primcall 1+ (toplevel top)))
460 ;; Procedure not inlined when residual code contains recursive calls.
461 ;; <http://debbugs.gnu.org/9542>
462 (letrec ((fold (lambda (f x3 b null? car cdr)
465 (f (car x3) (fold f (cdr x3) b null? car cdr))))))
466 (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
467 (letrec (fold) (_) (_)
468 (call (lexical fold _)
475 (((x1) #f #f #f () (_))
479 (((x2) #f #f #f () (_))
480 (primcall 1- (lexical x2 _))))))))
482 (pass-if "inlined lambdas are alpha-renamed"
483 ;; In this example, `make-adder' is inlined more than once; thus,
484 ;; they should use different gensyms for their arguments, because
485 ;; the various optimization passes assume uniquely-named variables.
488 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
489 ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
490 (pmatch (unparse-tree-il
491 (peval (expand-primitives
495 (lambda (x) (lambda (y) (+ x y)))))
496 (cons (make-adder 1) (make-adder 2)))
502 (((y) #f #f #f () (,gensym1))
505 (lexical y ,ref1)))))
508 (((y) #f #f #f () (,gensym2))
511 (lexical y ,ref2))))))
512 (and (eq? gensym1 ref1)
514 (not (eq? gensym1 gensym2))))
518 ;; Unused letrec bindings are pruned.
519 (letrec ((a (lambda () (b)))
526 ;; Unused letrec bindings are pruned.
531 (seq (call (toplevel foo!))
535 ;; Higher order, mutually recursive procedures.
536 (letrec ((even? (lambda (x)
541 (and (even? 4) (odd? 7)))
545 ;; Memv with constants.
550 ;; Memv with non-constant list. It could fold but doesn't
552 (memv 1 (list 3 2 1))
555 (primcall list (const 3) (const 2) (const 1))))
558 ;; Memv with non-constant key, constant list, test context
562 (let (key) (_) ((toplevel foo))
563 (if (if (primcall eqv? (lexical key _) (const 3))
565 (if (primcall eqv? (lexical key _) (const 2))
567 (primcall eqv? (lexical key _) (const 1))))
572 ;; Memv with non-constant key, empty list, test context.
576 (seq (toplevel foo) (const 'b)))
579 ;; Below are cases where constant propagation should bail out.
583 ;; Non-constant lexical is not propagated.
584 (let ((v (make-vector 6 #f)))
586 (vector-set! v n n)))
588 ((call (toplevel make-vector) (const 6) (const #f)))
591 (((n) #f #f #f () (_))
592 (primcall vector-set!
593 (lexical v _) (lexical n _) (lexical n _)))))))
596 ;; Mutable lexical is not propagated.
597 (let ((v (vector 1 2 3)))
601 ((primcall vector (const 1) (const 2) (const 3)))
608 ;; Lexical that is not provably pure is not inlined nor propagated.
609 (let* ((x (if (> p q) (frob!) (display 'chbouib)))
612 (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
613 (call (toplevel frob!))
614 (call (toplevel display) (const chbouib))))
615 (let (y) (_) ((primcall * (lexical x _) (const 2)))
618 (primcall + (lexical x _) (lexical y _))))))
621 ;; Non-constant arguments not propagated to lambdas.
630 ((primcall vector (const 1) (const 2) (const 3))
631 (call (toplevel make-list) (const 10))
632 (primcall list (const 1) (const 2) (const 3)))
634 (primcall vector-set!
635 (lexical x _) (const 0) (const 0))
636 (seq (primcall set-car!
637 (lexical y _) (const 0))
639 (lexical z _) (const ()))))))
642 (let ((foo top-foo) (bar top-bar))
643 (let* ((g (lambda (x y) (+ x y)))
644 (f (lambda (g x) (g x x))))
645 (+ (f g foo) (f g bar))))
646 (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
648 (primcall + (lexical foo _) (lexical foo _))
649 (primcall + (lexical bar _) (lexical bar _)))))
652 ;; Fresh objects are not turned into constants, nor are constants
653 ;; turned into fresh objects.
658 (let (x) (_) ((primcall cons (const 1) (const (2 3))))
659 (primcall cons (const 0) (lexical x _))))
666 (let (x) (_) ((const 2))
668 (set! (lexical x _) (const 3))
677 (frob f) ; may mutate `x'
679 (letrec (x) (_) ((const 0))
681 (call (toplevel frob) (lambda _ _))
686 (letrec ((f (lambda (x)
687 (set! f (lambda (_) x))
693 ;; Bindings possibly mutated.
694 (let ((x (make-foo)))
695 (frob! x) ; may mutate `x'
697 (let (x) (_) ((call (toplevel make-foo)))
699 (call (toplevel frob!) (lexical x _))
703 ;; Inlining stops at recursive calls with dynamic arguments.
705 (if (< x 0) x (loop (1- x))))
706 (letrec (loop) (_) ((lambda (_)
708 (((x) #f #f #f () (_))
710 (call (lexical loop _)
713 (call (lexical loop _) (toplevel x))))
716 ;; Recursion on the 2nd argument is fully evaluated.
718 (let loop ((x x) (y 10))
722 (let (x) (_) ((call (toplevel top)))
723 (call (toplevel foo) (lexical x _) (const 0))))
726 ;; Inlining aborted when residual code contains recursive calls.
728 ;; <http://debbugs.gnu.org/9542>
729 (let loop ((x x) (y 0))
734 (loop (1+ x) (1+ y)))))
735 (letrec (loop) (_) ((lambda (_)
737 (((x y) #f #f #f () (_ _))
739 (lexical y _) (const 0))
741 (call (lexical loop _) (toplevel x) (const 0))))
744 ;; Infinite recursion: `peval' gives up and leaves it as is.
745 (letrec ((f (lambda (x) (g (1- x))))
746 (g (lambda (x) (h (1+ x))))
747 (h (lambda (x) (f x))))
752 ;; Infinite recursion: all the arguments to `loop' are static, but
753 ;; unrolling it would lead `peval' to enter an infinite loop.
757 (letrec (loop) (_) ((lambda . _))
758 (call (lexical loop _) (const 0))))
761 ;; This test checks that the `start' binding is indeed residualized.
762 ;; See the `referenced?' procedure in peval's `prune-bindings'.
764 (let ((here (let ((start pos)) (lambda () start))))
765 (set! pos 1) ;; Cause references to `pos' to residualize.
767 (let (pos) (_) ((const 0))
770 (set! (lexical pos _) (const 1))
771 (call (lexical here _))))))
774 ;; FIXME: should this one residualize the binding?
780 ;; This is a fun one for peval to handle.
783 (letrec (a) (_) ((lexical a _))
787 ;; Another interesting recursive case.
788 (letrec ((a b) (b a))
790 (letrec (a) (_) ((lexical a _))
794 ;; Another pruning case, that `a' is residualized.
795 (letrec ((a (lambda () (a)))
801 ;; "b c a" is the current order that we get with unordered letrec,
802 ;; but it's not important to this test, so if it changes, just adapt
804 (letrec (b c a) (_ _ _)
808 (call (lexical a _)))))
811 (((x) #f #f #f () (_))
816 (call (lexical a _))))))
819 ((call (toplevel foo) (lexical b _)))
820 (call (lexical c _) (lexical d _)))))
823 ;; In this case, we can prune the bindings. `a' ends up being copied
824 ;; because it is only referenced once in the source program. Oh
826 (letrec* ((a (lambda (x) (top x)))
832 (((x) #f #f #f () (_))
833 (call (toplevel top) (lexical x _)))))
836 (((x) #f #f #f () (_))
837 (call (toplevel top) (lexical x _)))))))
840 ;; The inliner sees through a `let'.
841 ((let ((a 10)) (lambda (b) (* b 2))) 30)
846 (define (const x) (lambda (_) x))
852 ;; Applications of procedures with rest arguments can get inlined.
856 (let (z) (_) ((primcall list (const 3) (const 4)))
857 (primcall list (const 1) (const 2) (lexical z _))))
860 ;; Unmutated lists can get inlined.
861 (let ((args (list 2 3)))
862 (apply (lambda (x y z w)
865 (primcall list (const 0) (const 1) (const 2) (const 3)))
868 ;; However if the list might have been mutated, it doesn't propagate.
869 (let ((args (list 2 3)))
871 (apply (lambda (x y z w)
874 (let (args) (_) ((primcall list (const 2) (const 3)))
876 (call (toplevel foo!) (lexical args _))
880 (((x y z w) #f #f #f () (_ _ _ _))
882 (lexical x _) (lexical y _)
883 (lexical z _) (lexical w _)))))
889 ;; Here the `args' that gets built by the application of the lambda
890 ;; takes more than effort "10" to visit. Test that we fall back to
891 ;; the source expression of the operand, which is still a call to
892 ;; `list', so the inlining still happens.
893 (lambda (bv offset n)
894 (let ((x (bytevector-ieee-single-native-ref
897 (y (bytevector-ieee-single-native-ref
900 (let ((args (list x y)))
902 (lambda (bv offset x y)
903 (bytevector-ieee-single-native-set!
907 (bytevector-ieee-single-native-set!
916 (((bv offset n) #f #f #f () (_ _ _))
917 (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref
920 (lexical offset _) (const 0)))
921 (primcall bytevector-ieee-single-native-ref
924 (lexical offset _) (const 4))))
926 (primcall bytevector-ieee-single-native-set!
929 (lexical offset _) (const 0))
931 (primcall bytevector-ieee-single-native-set!
934 (lexical offset _) (const 4))
938 ;; Here we ensure that non-constant expressions are not copied.
940 (let ((args (list (foo!))))
944 ;; This toplevel ref might raise an unbound variable exception.
945 ;; The effects of `(foo!)' must be visible before this effect.
951 (let (_) (_) ((call (toplevel foo!)))
952 (let (z) (_) ((toplevel z))
958 ;; Rest args referenced more than once are not destructured.
960 (let ((args (list 'foo)))
971 ((primcall list (const foo)))
973 (primcall set-car! (lexical args _) (const bar))
977 (lexical args _))))))))
980 ;; Let-values inlining, even with consumers with rest args.
981 (call-with-values (lambda () (values 1 2))
984 (primcall list (const 1) (const 2)))
987 ;; When we can't inline let-values but can prove that the producer
988 ;; has just one value, reduce to "let" (which can then fold
990 (call-with-values (lambda () (if foo 1 2))
992 (apply values args)))
993 (if (toplevel foo) (const 1) (const 2)))
996 ;; Constant folding: cons of #nil does not make list
998 (primcall cons (const 1) (const '#nil)))
1001 ;; Constant folding: cons
1002 (begin (cons 1 2) #f)
1006 ;; Constant folding: cons
1007 (begin (cons (foo) 2) #f)
1008 (seq (call (toplevel foo)) (const #f)))
1011 ;; Constant folding: cons
1016 ;; Constant folding: car+cons
1021 ;; Constant folding: cdr+cons
1026 ;; Constant folding: car+cons, impure
1027 (car (cons 1 (bar)))
1028 (seq (call (toplevel bar)) (const 1)))
1031 ;; Constant folding: cdr+cons, impure
1032 (cdr (cons (bar) 0))
1033 (seq (call (toplevel bar)) (const 0)))
1036 ;; Constant folding: car+list
1041 ;; Constant folding: cdr+list
1043 (primcall list (const 0)))
1046 ;; Constant folding: car+list, impure
1047 (car (list 1 (bar)))
1048 (seq (call (toplevel bar)) (const 1)))
1051 ;; Constant folding: cdr+list, impure
1052 (cdr (list (bar) 0))
1053 (seq (call (toplevel bar)) (primcall list (const 0))))
1056 ;; Equality primitive: same lexical
1057 (let ((x (random))) (eq? x x))
1058 (seq (call (toplevel random)) (const #t)))
1061 ;; Equality primitive: merge lexical identities
1062 (let* ((x (random)) (y x)) (eq? x y))
1063 (seq (call (toplevel random)) (const #t)))
1066 ;; Non-constant guards get lexical bindings, invocation of winder and
1067 ;; unwinder lifted out. Unfortunately both have the generic variable
1068 ;; name "tmp", so we can't distinguish them in this test, and they
1069 ;; also collide in generic names with the single-value result from
1070 ;; the dynwind; alack.
1071 (dynamic-wind foo (lambda () bar) baz)
1072 (let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
1073 (seq (call (lexical tmp _))
1074 (let (tmp) (_) ((dynwind (lexical tmp _)
1077 (seq (call (lexical tmp _))
1078 (lexical tmp _))))))
1081 ;; Constant guards don't need lexical bindings.
1082 (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
1084 (let (tmp) (_) ((dynwind (lambda ()
1086 ((() #f #f #f () ()) (toplevel foo))))
1090 ((() #f #f #f () ()) (toplevel baz))))))
1095 ;; Dynwind bodies that return an unknown number of values need a
1097 (dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
1099 (let-values (dynwind (lambda ()
1101 ((() #f #f #f () ()) (toplevel foo))))
1102 (call (toplevel bar))
1105 ((() #f #f #f () ()) (toplevel baz)))))
1107 ((() #f vals #f () (_))
1109 (primcall @apply (primitive values) (lexical vals _))))))))
1112 ;; Prompt is removed if tag is unreferenced
1113 (let ((tag (make-prompt-tag)))
1114 (call-with-prompt tag
1116 (lambda args args)))
1120 ;; Prompt is removed if tag is unreferenced, with explicit stem
1121 (let ((tag (make-prompt-tag "foo")))
1122 (call-with-prompt tag
1124 (lambda args args)))
1127 ;; Handler lambda inlined
1129 (call-with-prompt tag
1132 (prompt (toplevel tag)
1135 (((k x) #f #f #f () (_ _))
1138 ;; Handler toplevel not inlined
1140 (call-with-prompt tag
1143 (let (handler) (_) ((toplevel handler))
1144 (prompt (toplevel tag)
1147 ((() #f args #f () (_))
1150 (lexical args _)))))))
1153 ;; `while' without `break' or `continue' has no prompts and gets its
1154 ;; condition folded. Unfortunately the outer `lp' does not yet get
1155 ;; elided, and the continuation tag stays around. (The continue tag
1156 ;; stays around because although it is not referenced, recursively
1157 ;; visiting the loop in the continue handler manages to visit the tag
1158 ;; twice before aborting. The abort doesn't unroll the recursive
1161 (let (_) (_) ((primcall make-prompt-tag . _))
1165 ((() #f #f #f () ())
1169 ((() #f #f #f () ())
1170 (call (lexical loop _))))))
1171 (call (lexical loop _)))))))
1172 (call (lexical lp _)))))
1176 (apply (lambda (x y) (+ x y))
1180 (((x y) #f #f #f () (_ _))
1187 ;; If we bail out when inlining an identifier because it's too big,
1188 ;; but the identifier simply aliases some other identifier, then avoid
1189 ;; residualizing a reference to the leaf identifier. The bailout is
1190 ;; driven by the recursive-effort-limit, which is currently 100. We
1191 ;; make sure to trip it with this recursive sum thing.
1193 (let ((x (let sum ((n 0) (out 0))
1195 (sum (1+ n) (+ out n))
1197 ((lambda (y) (list y)) x))
1199 (primcall list (lexical x _))))
1201 ;; Here we test that a common test in a chain of ifs gets lifted.
1203 (if (and (struct? x) (eq? (struct-vtable x) A))
1205 (if (and (struct? x) (eq? (struct-vtable x) B))
1207 (if (and (struct? x) (eq? (struct-vtable x) C))
1210 (let (failure) (_) ((lambda _
1212 ((() #f #f #f () ())
1213 (call (toplevel qux) (toplevel x))))))
1214 (if (primcall struct? (toplevel x))
1216 (primcall struct-vtable (toplevel x))
1218 (call (toplevel foo) (toplevel x))
1220 (primcall struct-vtable (toplevel x))
1222 (call (toplevel bar) (toplevel x))
1224 (primcall struct-vtable (toplevel x))
1226 (call (toplevel baz) (toplevel x))
1227 (call (lexical failure _)))))
1228 (call (lexical failure _)))))
1230 ;; Multiple common tests should get lifted as well.
1232 (if (and (struct? x) (eq? (struct-vtable x) A) B)
1234 (if (and (struct? x) (eq? (struct-vtable x) A) C)
1236 (if (and (struct? x) (eq? (struct-vtable x) A) D)
1239 (let (failure) (_) ((lambda _
1241 ((() #f #f #f () ())
1242 (call (toplevel qux) (toplevel x))))))
1243 (if (primcall struct? (toplevel x))
1245 (primcall struct-vtable (toplevel x))
1248 (call (toplevel foo) (toplevel x))
1250 (call (toplevel bar) (toplevel x))
1252 (call (toplevel baz) (toplevel x))
1253 (call (lexical failure _)))))
1254 (call (lexical failure _)))
1255 (call (lexical failure _)))))
1258 (apply (lambda (x y) (cons x y)) '(1 2))
1259 (primcall cons (const 1) (const 2)))
1262 (apply (lambda (x y) (cons x y)) (list 1 2))
1263 (primcall cons (const 1) (const 2)))
1266 (let ((t (make-prompt-tag)))
1268 (lambda () (abort-to-prompt t 1 2 3))
1269 (lambda (k x y z) (list x y z))))
1270 (primcall list (const 1) (const 2) (const 3)))
1273 (call-with-values foo (lambda (x) (bar x)))
1274 (let (x) (_) ((call (toplevel foo)))
1275 (call (toplevel bar) (lexical x _)))))