#:use-module (system base pmatch)
#:use-module (system base message)
#:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
#:use-module (language glil)
#:use-module (srfi srfi-13))
(@@ (language tree-il optimize) peval))
(define-syntax pass-if-peval
- (syntax-rules ()
+ (syntax-rules (resolve-primitives)
((_ in pat)
+ (pass-if-peval in pat
+ (compile 'in #:from 'scheme #:to 'tree-il)))
+ ((_ resolve-primitives in pat)
+ (pass-if-peval in pat
+ (expand-primitives!
+ (resolve-primitives!
+ (compile 'in #:from 'scheme #:to 'tree-il)
+ (current-module)))))
+ ((_ in pat code)
(pass-if 'in
- (let ((evaled (unparse-tree-il
- (peval (compile 'in #:from 'scheme #:to 'tree-il)))))
+ (let ((evaled (unparse-tree-il (peval code))))
(pmatch evaled
(pat #t)
- (_ (pk 'peval-mismatch evaled) #f)))))))
+ (_ (pk 'peval-mismatch)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'in)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ evaled)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'pat)
+ (newline)
+ #f)))))))
\f
(with-test-prefix "tree-il->scheme"
(f)))
(const 3))
+ (pass-if-peval resolve-primitives
+ ;; First order, let-values (requires primitive expansion for
+ ;; `call-with-values'.)
+ (let ((x 0))
+ (call-with-values
+ (lambda () (if (zero? x) (values 1 2) (values 3 4)))
+ (lambda (a b)
+ (+ a b))))
+ (const 3))
+
(pass-if-peval
- ;; First order, coalesced.
+ ;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (const (0 1 2 3 4 5)))
+ (apply (primitive list)
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
- ;; First order, coalesced, mutability preserved.
- (define mutable
- (cons 0 (cons 1 (cons 2 (list 3 4 5)))))
- (define mutable
- ;; This must not be a constant.
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))))
-
- (pass-if-peval
- ;; First order, mutability preserved.
- (define mutable
- (let loop ((i 3) (r '()))
- (if (zero? i)
- r
- (loop (1- i) (cons (cons i i) r)))))
- (define mutable
- (apply (primitive list)
- (apply (primitive cons) (const 1) (const 1))
- (apply (primitive cons) (const 2) (const 2))
- (apply (primitive cons) (const 3) (const 3)))))
-
- (pass-if-peval
- ;; Mutability preserved.
- (define mutable
- ((lambda (x y z) (list x y z)) 1 2 3))
- (define mutable
- (apply (primitive list) (const 1) (const 2) (const 3))))
+ ;; First order, coalesced, mutability preserved.
+ (cons 0 (cons 1 (cons 2 (list 3 4 5))))
+ ;; This must not be a constant.
+ (apply (primitive list)
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+
+ (pass-if-peval
+ ;; First order, coalesced, immutability preserved.
+ (cons 0 (cons 1 (cons 2 '(3 4 5))))
+ (apply (primitive cons) (const 0)
+ (apply (primitive cons) (const 1)
+ (apply (primitive cons) (const 2)
+ (const (3 4 5))))))
+
+ ;; These two tests doesn't work any more because we changed the way we
+ ;; deal with constants -- now the algorithm will see a construction as
+ ;; being bound to the lexical, so it won't propagate it. It can't
+ ;; even propagate it in the case that it is only referenced once,
+ ;; because:
+ ;;
+ ;; (let ((x (cons 1 2))) (lambda () x))
+ ;;
+ ;; is not the same as
+ ;;
+ ;; (lambda () (cons 1 2))
+ ;;
+ ;; Perhaps if we determined that not only was it only referenced once,
+ ;; it was not closed over by a lambda, then we could propagate it, and
+ ;; re-enable these two tests.
+ ;;
+ #;
+ (pass-if-peval
+ ;; First order, mutability preserved.
+ (let loop ((i 3) (r '()))
+ (if (zero? i)
+ r
+ (loop (1- i) (cons (cons i i) r))))
+ (apply (primitive list)
+ (apply (primitive cons) (const 1) (const 1))
+ (apply (primitive cons) (const 2) (const 2))
+ (apply (primitive cons) (const 3) (const 3))))
+ ;;
+ ;; See above.
+ #;
+ (pass-if-peval
+ ;; First order, evaluated.
+ (let loop ((i 7)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r))))
+ (const 1))
+
+ ;; Instead here are tests for what happens for the above cases: they
+ ;; unroll but they don't fold.
+ (pass-if-peval
+ (let loop ((i 3) (r '()))
+ (if (zero? i)
+ r
+ (loop (1- i) (cons (cons i i) r))))
+ (let (r) (_)
+ ((apply (primitive list)
+ (apply (primitive cons) (const 3) (const 3))))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (apply (primitive cons) (const 2) (const 2))
+ (lexical r _)))
+ (apply (primitive cons)
+ (apply (primitive cons) (const 1) (const 1))
+ (lexical r _)))))
+
+ ;; See above.
+ (pass-if-peval
+ (let loop ((i 4)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r))))
+ (let (r) (_)
+ ((apply (primitive list) (const 4)))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (const 3)
+ (lexical r _)))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (const 2)
+ (lexical r _)))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (const 1)
+ (lexical r _)))
+ (apply (primitive car)
+ (lexical r _)))))))
+
+ ;; Static sums.
+ (pass-if-peval
+ (let loop ((l '(1 2 3 4)) (sum 0))
+ (if (null? l)
+ sum
+ (loop (cdr l) (+ sum (car l)))))
+ (const 10))
+
+ (pass-if-peval
+ ;; Primitives in module-refs are resolved (the expansion of `pmatch'
+ ;; below leads to calls to (@@ (system base pmatch) car) and
+ ;; similar, which is what we want to be inlined.)
+ (begin
+ (use-modules (system base pmatch))
+ (pmatch '(a b c d)
+ ((a b . _)
+ #t)))
+ (begin
+ (apply . _)
+ (const #t)))
+
+ (pass-if-peval
+ ;; Mutability preserved.
+ ((lambda (x y z) (list x y z)) 1 2 3)
+ (apply (primitive list) (const 1) (const 2) (const 3)))
(pass-if-peval
;; Don't propagate effect-free expressions that operate on mutable
(lexical y _))))
(pass-if-peval
- ;; First order, evaluated.
- (define one
- (let loop ((i 7)
- (r '()))
- (if (<= i 0)
- (car r)
- (loop (1- i) (cons i r)))))
- (define one (const 1)))
+ ;; Infinite recursion
+ ((lambda (x) (x x)) (lambda (x) (x x)))
+ (let (x) (_)
+ ((lambda _
+ (lambda-case
+ (((x) _ _ _ _ _)
+ (apply (lexical x _) (lexical x _))))))
+ (apply (lexical x _) (lexical x _))))
(pass-if-peval
;; First order, aliased primitive.
(lambda (_)
(lambda-case
(((x) #f #f #f () (_))
- (letrec* (bar) (_) ((lambda (_) . _))
- (apply (primitive +) (lexical x _) (const 9))))))))
+ (apply (primitive +) (lexical x _) (const 9)))))))
(pass-if-peval
;; First order, with lambda inlined & specialized twice.
(y 3))
(+ (* x (f x y))
(f something x)))
- (let (f) (_) ((lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (primitive +)
- (apply (primitive *)
- (lexical x _)
- (toplevel top))
- (lexical y _))))))
- (apply (primitive +)
- (apply (primitive *)
- (const 2)
- (apply (primitive +) ; (f 2 3)
- (apply (primitive *)
- (const 2)
- (toplevel top))
- (const 3)))
- (apply (primitive +) ; (f something 2)
+ (apply (primitive +)
+ (apply (primitive *)
+ (const 2)
+ (apply (primitive +) ; (f 2 3)
+ (apply (primitive *)
+ (const 2)
+ (toplevel top))
+ (const 3)))
+ (let (x) (_) ((toplevel something)) ; (f something 2)
+ ;; `something' is not const, so preserve order of
+ ;; effects with a lexical binding.
+ (apply (primitive +)
(apply (primitive *)
- (toplevel something)
+ (lexical x _)
(toplevel top))
(const 2)))))
-
+
(pass-if-peval
- ;; First order, with lambda inlined & specialized 3 times.
- (let ((f (lambda (x y) (if (> x 0) y x))))
- (+ (f -1 x) (f 2 y) (f z y)))
- (let (f) (_)
- ((lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (if (apply (primitive >) (lexical x _) (const 0))
- (lexical y _)
- (lexical x _))))))
- (apply (primitive +)
- (const -1) ; (f -1 x)
- (toplevel y) ; (f 2 y)
- (apply (lexical f _) ; (f z y)
- (toplevel z) (toplevel y)))))
+ ;; First order, with lambda inlined & specialized 3 times.
+ (let ((f (lambda (x y) (if (> x 0) y x))))
+ (+ (f -1 0)
+ (f 1 0)
+ (f -1 y)
+ (f 2 y)
+ (f z y)))
+ (apply (primitive +)
+ (const -1) ; (f -1 0)
+ (const 0) ; (f 1 0)
+ (begin (toplevel y) (const -1)) ; (f -1 y)
+ (toplevel y) ; (f 2 y)
+ (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
+ (if (apply (primitive >) (lexical x _) (const 0))
+ (lexical y _)
+ (lexical x _)))))
(pass-if-peval
;; First order, conditional.
n
(+ (fibo (- n 1))
(fibo (- n 2)))))))
- (fibo 7))
- (const 13))
+ (fibo 4))
+ (const 3))
+
+ (pass-if-peval
+ ;; Don't propagate toplevel references, as intervening expressions
+ ;; could alter their bindings.
+ (let ((x top))
+ (foo)
+ x)
+ (let (x) (_) ((toplevel top))
+ (begin
+ (apply (toplevel foo))
+ (lexical x _))))
(pass-if-peval
;; Higher order.
35)
(const 42))
+ (pass-if-peval
+ ;; Higher order with optional argument (side-effecting default
+ ;; value).
+ ((lambda* (f x #:optional (y (foo)))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (let (y) (_) ((apply (toplevel foo)))
+ (apply (primitive +) (lexical y _) (const 7))))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (caller-supplied value).
+ ((lambda* (f x #:optional (y (foo)))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ 35)
+ (const 42))
+
(pass-if-peval
;; Higher order.
((lambda (f) (f x)) (lambda (x) x))
- (apply (lambda ()
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (toplevel x)))
+ (toplevel x))
(pass-if-peval
;; Bug reported at
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
(let ((fold (lambda (f g) (f (g top)))))
(fold 1+ (lambda (x) x)))
- (let (fold) (_) (_)
- (apply (primitive 1+)
- (apply (lambda ()
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (toplevel top)))))
-
+ (apply (primitive 1+) (toplevel top)))
+
(pass-if-peval
;; Procedure not inlined when residual code contains recursive calls.
;; <http://debbugs.gnu.org/9542>
(apply (primitive -) (lexical x2 _) (const 1))))))))
(pass-if "inlined lambdas are alpha-renamed"
- ;; In this example, the two anonymous lambdas are inlined more than
- ;; once; thus, they should use different gensyms for their
- ;; arguments, because the variable allocation process assumes
- ;; globally unique gensyms.
+ ;; In this example, `make-adder' is inlined more than once; thus,
+ ;; they should use different gensyms for their arguments, because
+ ;; the various optimization passes assume uniquely-named variables.
;;
;; Bug reported at
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
(pmatch (unparse-tree-il
(peval (compile
- '(let ((f (lambda (g x)
- (+ (g x) (g (+ x 1))))))
- (f (lambda (x0) (* x0 x0)) y))
+ '(let ((make-adder
+ (lambda (x) (lambda (y) (+ x y)))))
+ (cons (make-adder 1) (make-adder 2)))
#:to 'tree-il)))
- ((let (f) (_)
- ((lambda ((name . f))
- (lambda-case
- (((g x) #f #f #f () (_ _))
- (apply (primitive +)
- (apply (lexical g _) (lexical x _))
- (apply (lexical g _)
- (apply (primitive +)
- (lexical x _) (const 1))))))))
- (apply (primitive +)
- (apply (lambda ()
- (lambda-case
- (((x0) #f #f #f () (,gensym1))
- (apply (primitive *)
- (lexical x0 ,ref1a)
- (lexical x0 ,ref1b)))))
- (toplevel y))
- (apply (lambda ()
- (lambda-case
- (((x0) #f #f #f () (,gensym2))
- (apply (primitive *)
- (lexical x0 ,ref2a)
- (lexical x0 ,ref2b)))))
- (apply (primitive +)
- (toplevel y) (const 1)))))
- (and (eq? gensym1 ref1a)
- (eq? gensym1 ref1b)
- (eq? gensym2 ref2a)
- (eq? gensym2 ref2b)
+ ((apply (primitive cons)
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym1))
+ (apply (primitive +)
+ (const 1)
+ (lexical y ,ref1)))))
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym2))
+ (apply (primitive +)
+ (const 2)
+ (lexical y ,ref2))))))
+ (and (eq? gensym1 ref1)
+ (eq? gensym2 ref2)
(not (eq? gensym1 gensym2))))
(_ #f)))
+ (pass-if-peval
+ ;; Unused letrec bindings are pruned.
+ (letrec ((a (lambda () (b)))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (c 10))
+ (const 10))
+
+ (pass-if-peval
+ ;; Unused letrec bindings are pruned.
+ (letrec ((a (foo!))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (c 10))
+ (begin (apply (toplevel foo!))
+ (const 10)))
+
(pass-if-peval
;; Higher order, mutually recursive procedures.
(letrec ((even? (lambda (x)
(or (= 0 x)
(odd? (- x 1)))))
(odd? (lambda (x)
- (not (even? (- x 1))))))
+ (not (even? x)))))
(and (even? 4) (odd? 7)))
(const #t))
(apply (toplevel frob!))
(apply (toplevel display) (const chbouib))))
(let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
- (apply (primitive +) (lexical x _) (lexical x _)
- (apply (primitive *) (lexical x _) (const 2))))))
+ (apply (primitive +)
+ (lexical x _) (lexical x _) (lexical y _)))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
(vector 1 2 3)
(make-list 10)
(list 1 2 3))
- (apply (lambda ()
- (lambda-case
- (((x y z) #f #f #f () (_ _ _))
- (begin
- (apply (toplevel vector-set!)
- (lexical x _) (const 0) (const 0))
- (apply (toplevel set-car!)
- (lexical y _) (const 0))
- (apply (toplevel set-cdr!)
- (lexical z _) (const ()))))))
- (apply (primitive vector) (const 1) (const 2) (const 3))
- (apply (toplevel make-list) (const 10))
- (apply (primitive list) (const 1) (const 2) (const 3))))
-
- (pass-if-peval
- ;; Procedure only called with dynamic args is not inlined.
- (let* ((g (lambda (x y) (+ x y)))
- (f (lambda (g x) (g x x))))
- (+ (f g foo) (f g bar)))
- (let (g) (_)
- ((lambda _ ; g
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (primitive +) (lexical x _) (lexical y _))))))
- (let (f) (_)
- ((lambda _ ; f
- (lambda-case
- (((g x) #f #f #f () (_ _))
- (apply (lexical g _) (lexical x _) (lexical x _))))))
- (apply (primitive +)
- (apply (lexical g _) (toplevel foo) (toplevel foo))
- (apply (lexical g _) (toplevel bar) (toplevel bar))))))
+ (let (x y z) (_ _ _)
+ ((apply (primitive vector) (const 1) (const 2) (const 3))
+ (apply (toplevel make-list) (const 10))
+ (apply (primitive list) (const 1) (const 2) (const 3)))
+ (begin
+ (apply (toplevel vector-set!)
+ (lexical x _) (const 0) (const 0))
+ (apply (toplevel set-car!)
+ (lexical y _) (const 0))
+ (apply (toplevel set-cdr!)
+ (lexical z _) (const ())))))
(pass-if-peval
- ;; Fresh objects are not turned into constants.
+ (let ((foo top-foo) (bar top-bar))
+ (let* ((g (lambda (x y) (+ x y)))
+ (f (lambda (g x) (g x x))))
+ (+ (f g foo) (f g bar))))
+ (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
+ (apply (primitive +)
+ (apply (primitive +) (lexical foo _) (lexical foo _))
+ (apply (primitive +) (lexical bar _) (lexical bar _)))))
+
+ (pass-if-peval
+ ;; Fresh objects are not turned into constants, nor are constants
+ ;; turned into fresh objects.
(let* ((c '(2 3))
(x (cons 1 c))
(y (cons 0 x)))
y)
- (let (x) (_) ((apply (primitive list) (const 1) (const 2) (const 3)))
- (let (y) (_) ((apply (primitive cons) (const 0) (lexical x _)))
- (lexical y _))))
+ (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
+ (apply (primitive cons) (const 0) (lexical x _))))
(pass-if-peval
;; Bindings mutated.
x)))
(frob f) ; may mutate `x'
x)
- (letrec (x f) (_ _) ((const 0) _)
+ (letrec (x) (_) ((const 0))
(begin
- (apply (toplevel frob) (lexical f _))
- (lexical x _))))
+ (apply (toplevel frob) (lambda _ _))
+ (lexical x _))))
(pass-if-peval
;; Bindings mutated.
(pass-if-peval
;; Recursion on the 2nd argument is fully evaluated.
- (let loop ((x x) (y 10))
- (if (> y 0)
- (loop x (1- y))
- (foo x y)))
- (letrec (loop) (_) (_)
- (apply (toplevel foo) (toplevel x) (const 0))))
+ (let ((x (top)))
+ (let loop ((x x) (y 10))
+ (if (> y 0)
+ (loop x (1- y))
+ (foo x y))))
+ (let (x) (_) ((apply (toplevel top)))
+ (apply (toplevel foo) (lexical x _) (const 0))))
(pass-if-peval
;; Inlining aborted when residual code contains recursive calls.
+ ;;
;; <http://debbugs.gnu.org/9542>
(let loop ((x x) (y 0))
(if (> y 0)
- (loop (1+ x) (1+ y))
- (if (< x 0) x (loop (1- x)))))
+ (loop (1- x) (1- y))
+ (if (< x 0)
+ x
+ (loop (1+ x) (1+ y)))))
(letrec (loop) (_) ((lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
(g (lambda (x) (h (1+ x))))
(h (lambda (x) (f x))))
(f 0))
- (letrec _ . _)))
+ (letrec _ . _))
+
+ (pass-if-peval
+ ;; Infinite recursion: all the arguments to `loop' are static, but
+ ;; unrolling it would lead `peval' to enter an infinite loop.
+ (let loop ((x 0))
+ (and (< x top)
+ (loop (1+ x))))
+ (letrec (loop) (_) ((lambda . _))
+ (apply (lexical loop _) (const 0))))
+
+ (pass-if-peval
+ ;; This test checks that the `start' binding is indeed residualized.
+ ;; See the `referenced?' procedure in peval's `prune-bindings'.
+ (let ((pos 0))
+ (set! pos 1) ;; Cause references to `pos' to residualize.
+ (let ((here (let ((start pos)) (lambda () start))))
+ (here)))
+ (let (pos) (_) ((const 0))
+ (begin
+ (set! (lexical pos _) (const 1))
+ (let (here) (_) (_)
+ (apply (lexical here _))))))
+
+ (pass-if-peval
+ ;; FIXME: should this one residualize the binding?
+ (letrec ((a a))
+ 1)
+ (const 1))
+
+ (pass-if-peval
+ ;; This is a fun one for peval to handle.
+ (letrec ((a a))
+ a)
+ (letrec (a) (_) ((lexical a _))
+ (lexical a _)))
+
+ (pass-if-peval
+ ;; Another interesting recursive case.
+ (letrec ((a b) (b a))
+ a)
+ (letrec (a) (_) ((lexical a _))
+ (lexical a _)))
+
+ (pass-if-peval
+ ;; Another pruning case, that `a' is residualized.
+ (letrec ((a (lambda () (a)))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (let ((d (foo b)))
+ (c d)))
+
+ ;; "b c a" is the current order that we get with unordered letrec,
+ ;; but it's not important to this test, so if it changes, just adapt
+ ;; the test.
+ (letrec (b c a) (_ _ _)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (lexical a _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (lexical x _))))
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (lexical a _))))))
+ (let (d)
+ (_)
+ ((apply (toplevel foo) (lexical b _)))
+ (apply (lexical c _)
+ (lexical d _)))))
+
+ (pass-if-peval
+ ;; In this case, we can prune the bindings. `a' ends up being copied
+ ;; because it is only referenced once in the source program. Oh
+ ;; well.
+ (letrec* ((a (lambda (x) (top x)))
+ (b (lambda () a)))
+ (foo (b) (b)))
+ (apply (toplevel foo)
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (apply (toplevel top) (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (apply (toplevel top) (lexical x _)))))))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (begin (cons 1 2) #f)
+ (const #f))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (begin (cons (foo) 2) #f)
+ (begin (apply (toplevel foo)) (const #f)))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (if (cons 0 0) 1 2)
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: car+cons
+ (car (cons 1 0))
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+cons
+ (cdr (cons 1 0))
+ (const 0))
+
+ (pass-if-peval
+ ;; Constant folding: car+cons, impure
+ (car (cons 1 (bar)))
+ (begin (apply (toplevel bar)) (const 1)))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+cons, impure
+ (cdr (cons (bar) 0))
+ (begin (apply (toplevel bar)) (const 0)))
+
+ (pass-if-peval
+ ;; Constant folding: car+list
+ (car (list 1 0))
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+list
+ (cdr (list 1 0))
+ (apply (primitive list) (const 0)))
+
+ (pass-if-peval
+ ;; Constant folding: car+list, impure
+ (car (list 1 (bar)))
+ (begin (apply (toplevel bar)) (const 1)))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+list, impure
+ (cdr (list (bar) 0))
+ (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
+
+ (pass-if-peval
+ resolve-primitives
+ ;; Prompt is removed if tag is unreferenced
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda args args)))
+ (const 1))
+
+ (pass-if-peval
+ resolve-primitives
+ ;; Prompt is removed if tag is unreferenced, with explicit stem
+ (let ((tag (make-prompt-tag "foo")))
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda args args)))
+ (const 1))
+
+ (pass-if-peval
+ resolve-primitives
+ ;; `while' without `break' or `continue' has no prompts and gets its
+ ;; condition folded. Unfortunately the outer `lp' does not yet get
+ ;; elided.
+ (while #t #t)
+ (letrec (lp) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (letrec (loop) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (lexical loop _))))))
+ (apply (lexical loop _)))))))
+ (apply (lexical lp _)))))
+
\f
(with-test-prefix "tree-il-fold"
HCoop / bpt / guile.git / blobdiff