[bpt/guile.git] / test-suite / tests / peval.test

;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
;;;; 	Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite tree-il)
  #:use-module (test-suite lib)
  #:use-module (system base compile)
  #: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))

(define peval
  ;; The partial evaluator.
  (@@ (language tree-il optimize) peval))

(define-syntax pass-if-peval
  (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 code))))
         (pmatch evaled
           (pat #t)
           (_   (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 "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 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 resolve-primitives
    ;; First order, multiple values.
    (let ((x 1) (y 2))
      (values x y))
    (apply (primitive values) (const 1) (const 2)))

  (pass-if-peval resolve-primitives
    ;; First order, multiple values truncated.
    (let ((x (values 1 'a)) (y 2))
      (values x y))
    (apply (primitive values) (const 1) (const 2)))

  (pass-if-peval resolve-primitives
    ;; First order, multiple values truncated.
    (or (values 1 2) 3)
    (const 1))

  (pass-if-peval
    ;; First order, coalesced, mutability preserved.
    (cons 0 (cons 1 (cons 2 (list 3 4 5))))
    (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 resolve-primitives
   (let ((string->chars
          (lambda (s)
            (define (char-at n)
              (string-ref s n))
            (define (len)
              (string-length s))
            (let loop ((i 0))
              (if (< i (len))
                  (cons (char-at i)
                        (loop (1+ i)))
                  '())))))
     (string->chars "yo"))
   (apply (primitive list) (const #\y) (const #\o)))

  (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
   ;; 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
   ;; 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.
    (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 () (_))
          (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)))
    (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 *)
                              (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 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.
    (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 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.
    ((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 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))
    (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)))
    (apply (primitive 1+) (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, `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 ((make-adder
                             (lambda (x) (lambda (y) (+ x y)))))
                        (cons (make-adder 1) (make-adder 2)))
                     #:to 'tree-il)))
      ((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)))))
      (and (even? 4) (odd? 7)))
    (const #t))

  (pass-if-peval
    ;; Memv with constants.
    (memv 1 '(3 2 1))
    (const '(1)))

  (pass-if-peval
    ;; Memv with non-constant list.  It could fold but doesn't
    ;; currently.
    (memv 1 (list 3 2 1))
    (apply (primitive memv)
           (const 1)
           (apply (primitive list) (const 3) (const 2) (const 1))))

  (pass-if-peval
    ;; Memv with non-constant key, constant list, test context
    (case foo
      ((3 2 1) 'a)
      (else 'b))
    (let (key) (_) ((toplevel foo))
         (if (if (apply (primitive eqv?) (lexical key _) (const 3))
                 (const #t)
                 (if (apply (primitive eqv?) (lexical key _) (const 2))
                     (const #t)
                     (apply (primitive eqv?) (lexical key _) (const 1))))
             (const a)
             (const b))))

  (pass-if-peval
    ;; Memv with non-constant key, empty list, test context.  Currently
    ;; doesn't fold entirely.
    (case foo
      (() 'a)
      (else 'b))
    (begin (toplevel foo) (const b)))

  ;;
  ;; 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 _) (lexical y _)))))

  (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))
    (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
   (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 cons) (const 1) (const (2 3))))
         (apply (primitive cons) (const 0) (lexical x _))))

  (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) (_) ((const 0))
            (begin
              (apply (toplevel frob) (lambda _ _))
              (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 ((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) (1+ y)))))
    (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 _ . _))

  (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))
      (let ((here (let ((start pos)) (lambda () start))))
        (set! pos 1) ;; Cause references to `pos' to residualize.
        (here)))
    (let (pos) (_) ((const 0))
         (let (here) (_) (_)
              (begin
                (set! (lexical pos _) (const 1))
                (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 resolve-primitives
    ;; The inliner sees through a `let'.
    ((let ((a 10)) (lambda (b) (* b 2))) 30)
    (const 60))

  (pass-if-peval
      ((lambda ()
         (define (const x) (lambda (_) x))
         (let ((v #f))
           ((const #t) v))))
    (const #t))

  (pass-if-peval
      ;; Applications of procedures with rest arguments can get inlined.
      ((lambda (x y . z)
         (list x y z))
       1 2 3 4)
    (let (z) (_) ((apply (primitive list) (const 3) (const 4)))
         (apply (primitive list) (const 1) (const 2) (lexical z _))))

  (pass-if-peval
   ;; Constant folding: cons of #nil does not make list
   (cons 1 #nil)
   (apply (primitive cons) (const 1) (const '#nil)))
  
  (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
   ;; Non-constant guards get lexical bindings.
   (dynamic-wind foo (lambda () bar) baz)
   (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
        (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
  
  (pass-if-peval
   resolve-primitives
   ;; Constant guards don't need lexical bindings.
   (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
   (dynwind
    (lambda ()
      (lambda-case
       ((() #f #f #f () ()) (toplevel foo))))
    (toplevel bar)
    (lambda ()
      (lambda-case
       ((() #f #f #f () ()) (toplevel baz))))))
  
  (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))

  ;; Handler lambda inlined
  (pass-if-peval
   resolve-primitives
   (call-with-prompt tag
                     (lambda () 1)
                     (lambda (k x) x))
   (prompt (toplevel tag)
           (const 1)
           (lambda-case
            (((k x) #f #f #f () (_ _))
             (lexical x _)))))

  ;; Handler toplevel not inlined
  (pass-if-peval
   resolve-primitives
   (call-with-prompt tag
                     (lambda () 1)
                     handler)
   (let (handler) (_) ((toplevel handler))
        (prompt (toplevel tag)
                (const 1)
                (lambda-case
                 ((() #f args #f () (_))
                  (apply (primitive @apply)
                         (lexical handler _)
                         (lexical args _)))))))

  (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, and the continuation tag stays around.  (The continue tag
   ;; stays around because although it is not referenced, recursively
   ;; visiting the loop in the continue handler manages to visit the tag
   ;; twice before aborting.  The abort doesn't unroll the recursive
   ;; reference.)
   (while #t #t)
   (let (_) (_) ((apply (primitive make-prompt-tag) . _))
        (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 _)))))

  (pass-if-peval
   resolve-primitives
   (lambda (a . rest)
     (apply (lambda (x y) (+ x y))
            a rest))
   (lambda _
     (lambda-case
      (((x y) #f #f #f () (_ _))
       _))))

  (pass-if-peval resolve-primitives
    (car '(1 2))
    (const 1))

  ;; If we bail out when inlining an identifier because it's too big,
  ;; but the identifier simply aliases some other identifier, then avoid
  ;; residualizing a reference to the leaf identifier.  The bailout is
  ;; driven by the recursive-effort-limit, which is currently 100.  We
  ;; make sure to trip it with this recursive sum thing.
  (pass-if-peval resolve-primitives
    (let ((x (let sum ((n 0) (out 0))
               (if (< n 10000)
                   (sum (1+ n) (+ out n))
                   out))))
      ((lambda (y) (list y)) x))
    (let (x) (_) (_)
         (apply (primitive list) (lexical x _))))

  ;; Here we test that a common test in a chain of ifs gets lifted.
  (pass-if-peval resolve-primitives
    (if (and (struct? x) (eq? (struct-vtable x) A))
        (foo x)
        (if (and (struct? x) (eq? (struct-vtable x) B))
            (bar x)
            (if (and (struct? x) (eq? (struct-vtable x) C))
                (baz x)
                (qux x))))
    (let (failure) (_) ((lambda _
                          (lambda-case
                           ((() #f #f #f () ())
                            (apply (toplevel qux) (toplevel x))))))
         (if (apply (primitive struct?) (toplevel x))
             (if (apply (primitive eq?)
                        (apply (primitive struct-vtable) (toplevel x))
                        (toplevel A))
                 (apply (toplevel foo) (toplevel x))
                 (if (apply (primitive eq?)
                            (apply (primitive struct-vtable) (toplevel x))
                            (toplevel B))
                     (apply (toplevel bar) (toplevel x))
                     (if (apply (primitive eq?)
                                (apply (primitive struct-vtable) (toplevel x))
                                (toplevel C))
                         (apply (toplevel baz) (toplevel x))
                         (apply (lexical failure _)))))
             (apply (lexical failure _)))))

  ;; Multiple common tests should get lifted as well.
  (pass-if-peval resolve-primitives
    (if (and (struct? x) (eq? (struct-vtable x) A) B)
        (foo x)
        (if (and (struct? x) (eq? (struct-vtable x) A) C)
            (bar x)
            (if (and (struct? x) (eq? (struct-vtable x) A) D)
                (baz x)
                (qux x))))
    (let (failure) (_) ((lambda _
                          (lambda-case
                           ((() #f #f #f () ())
                            (apply (toplevel qux) (toplevel x))))))
         (if (apply (primitive struct?) (toplevel x))
             (if (apply (primitive eq?)
                        (apply (primitive struct-vtable) (toplevel x))
                        (toplevel A))
                 (if (toplevel B)
                     (apply (toplevel foo) (toplevel x))
                     (if (toplevel C)
                         (apply (toplevel bar) (toplevel x))
                         (if (toplevel D)
                             (apply (toplevel baz) (toplevel x))
                             (apply (lexical failure _)))))
                 (apply (lexical failure _)))
             (apply (lexical failure _)))))

  (pass-if-peval resolve-primitives
    (apply (lambda (x y) (cons x y)) '(1 2))
    (apply (primitive cons) (const 1) (const 2)))

  (pass-if-peval resolve-primitives
    (apply (lambda (x y) (cons x y)) (list 1 2))
    (apply (primitive cons) (const 1) (const 2)))

  (pass-if-peval resolve-primitives
    (let ((t (make-prompt-tag)))
      (call-with-prompt t
                        (lambda () (abort-to-prompt t 1 2 3))
                        (lambda (k x y z) (list x y z))))
    (apply (primitive 'list) (const 1) (const 2) (const 3))))