-(with-test-prefix "partial evaluation"
-
- (pass-if-peval
- ;; First order, primitive.
- (let ((x 1) (y 2)) (+ x y))
- (const 3))
-
- (pass-if-peval
- ;; First order, thunk.
- (let ((x 1) (y 2))
- (let ((f (lambda () (+ x y))))
- (f)))
- (const 3))
-
- (pass-if-peval
- ;; First order, coalesced.
- (cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (const (0 1 2 3 4 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))))
-
- (pass-if-peval
- ;; Don't propagate effect-free expressions that operate on mutable
- ;; objects.
- (let* ((x (list 1))
- (y (car x)))
- (set-car! x 0)
- y)
- (let (x) (_) ((apply (primitive list) (const 1)))
- (let (y) (_) ((apply (primitive car) (lexical x _)))
- (begin
- (apply (toplevel set-car!) (lexical x _) (const 0))
- (lexical y _)))))
-
- (pass-if-peval
- ;; Don't propagate effect-free expressions that operate on objects we
- ;; don't know about.
- (let ((y (car x)))
- (set-car! x 0)
- y)
- (let (y) (_) ((apply (primitive car) (toplevel x)))
- (begin
- (apply (toplevel set-car!) (toplevel x) (const 0))
- (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)))
-
- (pass-if-peval
- ;; First order, aliased primitive.
- (let* ((x *) (y (x 1 2))) y)
- (const 2))
-
- (pass-if-peval
- ;; First order, shadowed primitive.
- (begin
- (define (+ x y) (pk x y))
- (+ 1 2))
- (begin
- (define +
- (lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (toplevel pk) (lexical x _) (lexical y _))))))
- (apply (toplevel +) (const 1) (const 2))))
-
- (pass-if-peval
- ;; First-order, effects preserved.
- (let ((x 2))
- (do-something!)
- x)
- (begin
- (apply (toplevel do-something!))
- (const 2)))
-
- (pass-if-peval
- ;; First order, residual bindings removed.
- (let ((x 2) (y 3))
- (* (+ x y) z))
- (apply (primitive *) (const 5) (toplevel z)))
-
- (pass-if-peval
- ;; First order, with lambda.
- (define (foo x)
- (define (bar z) (* z z))
- (+ x (bar 3)))
- (define foo
- (lambda (_)
- (lambda-case
- (((x) #f #f #f () (_))
- (letrec* (bar) (_) ((lambda (_) . _))
- (apply (primitive +) (lexical x _) (const 9))))))))
-
- (pass-if-peval
- ;; First order, with lambda inlined & specialized twice.
- (let ((f (lambda (x y)
- (+ (* x top) y)))
- (x 2)
- (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 *)
- (toplevel something)
- (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)))))
-
- (pass-if-peval
- ;; First order, conditional.
- (let ((y 2))
- (lambda (x)
- (if (> y 0)
- (display x)
- 'never-reached)))
- (lambda ()
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel display) (lexical x _))))))
-
- (pass-if-peval
- ;; First order, recursive procedure.
- (letrec ((fibo (lambda (n)
- (if (<= n 1)
- n
- (+ (fibo (- n 1))
- (fibo (- n 2)))))))
- (fibo 7))
- (const 13))
-
- (pass-if-peval
- ;; Higher order.
- ((lambda (f x)
- (f (* (car x) (cadr x))))
- (lambda (x)
- (+ x 1))
- '(2 3))
- (const 7))
-
- (pass-if-peval
- ;; Higher order with optional argument (default value).
- ((lambda* (f x #:optional (y 0))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3))
- (const 7))
-
- (pass-if-peval
- ;; Higher order with optional argument (caller-supplied value).
- ((lambda* (f x #:optional (y 0))
- (+ 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)))
-
- (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)))))
-
- (pass-if-peval
- ;; Procedure not inlined when residual code contains recursive calls.
- ;; <http://debbugs.gnu.org/9542>
- (letrec ((fold (lambda (f x3 b null? car cdr)
- (if (null? x3)
- b
- (f (car x3) (fold f (cdr x3) b null? car cdr))))))
- (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
- (letrec (fold) (_) (_)
- (apply (lexical fold _)
- (primitive *)
- (toplevel x)
- (const 1)
- (primitive zero?)
- (lambda ()
- (lambda-case
- (((x1) #f #f #f () (_))
- (lexical x1 _))))
- (lambda ()
- (lambda-case
- (((x2) #f #f #f () (_))
- (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.
- ;;
- ;; 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))
- #: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)
- (not (eq? gensym1 gensym2))))
- (_ #f)))
-
- (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))))))
- (and (even? 4) (odd? 7)))
- (const #t))
-
- ;;
- ;; Below are cases where constant propagation should bail out.
- ;;
-
- (pass-if-peval
- ;; Non-constant lexical is not propagated.
- (let ((v (make-vector 6 #f)))
- (lambda (n)
- (vector-set! v n n)))
- (let (v) (_)
- ((apply (toplevel make-vector) (const 6) (const #f)))
- (lambda ()
- (lambda-case
- (((n) #f #f #f () (_))
- (apply (toplevel vector-set!)
- (lexical v _) (lexical n _) (lexical n _)))))))
-
- (pass-if-peval
- ;; Mutable lexical is not propagated.
- (let ((v (vector 1 2 3)))
- (lambda ()
- v))
- (let (v) (_)
- ((apply (primitive vector) (const 1) (const 2) (const 3)))
- (lambda ()
- (lambda-case
- ((() #f #f #f () ())
- (lexical v _))))))
-
- (pass-if-peval
- ;; Lexical that is not provably pure is not inlined nor propagated.
- (let* ((x (if (> p q) (frob!) (display 'chbouib)))
- (y (* x 2)))
- (+ x x y))
- (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
- (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))))))
-
- (pass-if-peval
- ;; Non-constant arguments not propagated to lambdas.
- ((lambda (x y z)
- (vector-set! x 0 0)
- (set-car! y 0)
- (set-cdr! z '()))
- (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))))))
-
- (pass-if-peval
- ;; Fresh objects are not turned into constants.
- (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 _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (let ((x 2))
- (set! x 3)
- x)
- (let (x) (_) ((const 2))
- (begin
- (set! (lexical x _) (const 3))
- (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (letrec ((x 0)
- (f (lambda ()
- (set! x (+ 1 x))
- x)))
- (frob f) ; may mutate `x'
- x)
- (letrec (x f) (_ _) ((const 0) _)
- (begin
- (apply (toplevel frob) (lexical f _))
- (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (letrec ((f (lambda (x)
- (set! f (lambda (_) x))
- x)))
- (f 2))
- (letrec _ . _))
-
- (pass-if-peval
- ;; Bindings possibly mutated.
- (let ((x (make-foo)))
- (frob! x) ; may mutate `x'
- x)
- (let (x) (_) ((apply (toplevel make-foo)))
- (begin
- (apply (toplevel frob!) (lexical x _))
- (lexical x _))))
-
- (pass-if-peval
- ;; Inlining stops at recursive calls with dynamic arguments.
- (let loop ((x x))
- (if (< x 0) x (loop (1- x))))
- (letrec (loop) (_) ((lambda (_)
- (lambda-case
- (((x) #f #f #f () (_))
- (if _ _
- (apply (lexical loop _)
- (apply (primitive 1-)
- (lexical x _))))))))
- (apply (lexical loop _) (toplevel x))))
-
- (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))))
-
- (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)))))
- (letrec (loop) (_) ((lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (if (apply (primitive >)
- (lexical y _) (const 0))
- _ _)))))
- (apply (lexical loop _) (toplevel x) (const 0))))
-
- (pass-if-peval
- ;; Infinite recursion: `peval' gives up and leaves it as is.
- (letrec ((f (lambda (x) (g (1- x))))
- (g (lambda (x) (h (1+ x))))
- (h (lambda (x) (f x))))
- (f 0))
- (letrec _ . _)))