guile/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-2014, 2017, 2020, 2022-2023 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 fix-letrec)
  #:use-module (language tree-il peval)
  #:use-module (language tree-il primitives)
  #:use-module (rnrs bytevectors) ;; for the bytevector primitives
  #:use-module (srfi srfi-13))

(define-syntax pass-if-peval
  (syntax-rules ()
    ((_ in pat)
     (pass-if-peval in pat
                    (fix-letrec
                     (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)))))))


(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, 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, multiple values.
    (let ((x 1) (y 2))
      (values x y))
    (primcall values (const 1) (const 2)))

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

  (pass-if-peval
    ;; 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))))
    (primcall 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))))
    (primcall cons (const 0)
              (primcall cons (const 1)
                        (primcall 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))))
   (primcall list
             (primcall cons (const 1) (const 1))
             (primcall cons (const 2) (const 2))
             (primcall 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) (_)
        ((primcall list
                   (primcall cons (const 3) (const 3))))
        (let (r) (_)
             ((primcall cons
                        (primcall cons (const 2) (const 2))
                        (lexical r _)))
             (primcall cons
                       (primcall 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) (_)
        ((primcall list (const 4)))
        (let (r) (_)
             ((primcall cons
                        (const 3)
                        (lexical r _)))
             (let (r) (_)
                  ((primcall cons
                             (const 2)
                             (lexical r _)))
                  (let (r) (_)
                       ((primcall cons
                                  (const 1)
                                  (lexical r _)))
                       (primcall 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
   (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"))
   (primcall 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)))
    (seq (call . _)
         (const #t)))

  (pass-if-peval
   ;; Mutability preserved.
   ((lambda (x y z) (list x y z)) 1 2 3)
   (primcall 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) (_) ((primcall list (const 1)))
        (let (y) (_) ((primcall car (lexical x _)))
             (seq
               (primcall 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) (_) ((primcall car (toplevel x)))
        (seq
          (primcall 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) _ _ _ _ _)
             (call (lexical x _) (lexical x _))))))
        (call (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))
    (seq
      (define +
        (lambda (_)
          (lambda-case
           (((x y) #f #f #f () (_ _))
            (call (toplevel pk) (lexical x _) (lexical y _))))))
      (call (toplevel +) (const 1) (const 2))))

  (pass-if-peval
    ;; First-order, effects preserved.
    (let ((x 2))
      (do-something!)
      x)
    (seq
      (call (toplevel do-something!))
      (const 2)))

  (pass-if-peval
    ;; First order, residual bindings removed.
    (let ((x 2) (y 3))
      (* (+ x y) z))
    (primcall * (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 () (_))
          (primcall + (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)))
    (primcall +
              (primcall *
                        (const 2)
                        (primcall +     ; (f 2 3)
                                  (primcall *
                                            (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.
                   (primcall +
                             (primcall *
                                       (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)))
   (primcall
    +
    (primcall
     +
     (primcall
      +
      (const -1)                      ; (f -1 0)
      (seq (toplevel y) (const -1)))  ; (f -1 y)
     (toplevel y))                    ; (f 2 y)
    (let (x y) (_ _) ((toplevel z) (toplevel y))  ; (f z y)
         (if (primcall > (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 () (_))
        (call (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))
        (seq
          (call (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 (default uses earlier argument).
    ;; <http://bugs.gnu.org/17634>
    ((lambda* (f x #:optional (y (+ 3 (car x))))
       (+ y (f (* (car x) (cadr x)))))
     (lambda (x)
       (+ x 1))
     '(2 3))
    (const 12))

  (pass-if-peval
    ;; Higher order with optional arguments
    ;; (default uses earlier optional argument).
    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
       (+ y z (f (* (car x) (cadr x)))))
     (lambda (x)
       (+ x 1))
     '(2 3))
    (const 20))

  (pass-if-peval
    ;; Higher order with optional arguments (one caller-supplied value,
    ;; one default that uses earlier optional argument).
    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
       (+ y z (f (* (car x) (cadr x)))))
     (lambda (x)
       (+ x 1))
     '(2 3)
     -3)
    (const 4))

  (pass-if-peval
    ;; Higher order with optional arguments (caller-supplied values).
    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
       (+ y z (f (* (car x) (cadr x)))))
     (lambda (x)
       (+ x 1))
     '(2 3)
     -3
     17)
    (const 21))

  (pass-if-peval
    ;; Higher order with optional and rest arguments (one
    ;; caller-supplied value, one default that uses earlier optional
    ;; argument).
    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
                 #:rest r)
       (list r (+ y z (f (* (car x) (cadr x))))))
     (lambda (x)
       (+ x 1))
     '(2 3)
     -3)
    (primcall list (const ()) (const 4)))

  (pass-if-peval
    ;; Higher order with optional and rest arguments
    ;; (caller-supplied values for optionals).
    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
                 #:rest r)
       (list r (+ y z (f (* (car x) (cadr x))))))
     (lambda (x)
       (+ x 1))
     '(2 3)
     -3
     17)
    (primcall list (const ()) (const 21)))

  (pass-if-peval
    ;; Higher order with optional and rest arguments
    ;; (caller-supplied values for optionals and rest).
    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
                 #:rest r)
       (list r (+ y z (f (* (car x) (cadr x))))))
     (lambda (x)
       (+ x 1))
     '(2 3)
     -3
     17
     8
     3)
    (let (r) (_) ((primcall list (const 8) (const 3)))
         (primcall list (lexical r _) (const 21))))

  (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) (_) ((call (toplevel foo)))
         (primcall + (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)))
    (primcall + (toplevel top) (const 1)))
  
  (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))))
    (fix (fold) (_) (_)
            (call (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 () (_))
                       (primcall - (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 (expand-primitives
                     (resolve-primitives
                      (compile
                       '(let ((make-adder
                               (lambda (x) (lambda (y) (+ x y)))))
                          (cons (make-adder 1) (make-adder 2)))
                       #:to 'tree-il)
                      (current-module)))))
      ((primcall cons
                 (lambda ()
                   (lambda-case
                    (((y) #f #f #f () (,gensym1))
                     (primcall +
                               (const 1)
                               (lexical y ,ref1)))))
                 (lambda ()
                   (lambda-case
                    (((y) #f #f #f () (,gensym2))
                     (primcall +
                               (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))
   (seq (call (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))
    (primcall memv
              (const 1)
              (primcall 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 (primcall eq? (lexical key _) (const 3))
                 (const #t)
                 (if (primcall eq? (lexical key _) (const 2))
                     (const #t)
                     (primcall eq? (lexical key _) (const 1))))
             (const a)
             (const b))))

  (pass-if-peval
    ;; Memv with non-constant key, empty list, test context.
    (case foo
      (() 'a)
      (else 'b))
    (seq (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) (_)
         ((primcall make-vector (const 6) (const #f)))
         (lambda ()
           (lambda-case
            (((n) #f #f #f () (_))
             (primcall 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) (_)
         ((primcall 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 (primcall > (toplevel p) (toplevel q))
                      (call (toplevel frob!))
                      (call (toplevel display) (const chbouib))))
         (let (y) (_) ((primcall * (lexical x _) (const 2)))
              (primcall +
                        (primcall + (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) (_ _ _)
         ((primcall vector (const 1) (const 2) (const 3))
          (call (toplevel make-list) (const 10))
          (primcall list (const 1) (const 2) (const 3)))
         (seq
           (primcall vector-set!
                     (lexical x _) (const 0) (const 0))
           (seq (primcall set-car!
                          (lexical y _) (const 0))
                (primcall 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))
        (primcall +
                  (primcall + (lexical foo _) (lexical foo _))
                  (primcall + (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) (_) ((primcall cons (const 1) (const (2 3))))
         (primcall cons (const 0) (lexical x _))))

  (pass-if-peval
    ;; Bindings mutated.
    (let ((x 2))
      (set! x 3)
      x)
    (let (x) (_) ((const 2))
         (seq
           (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)
    (let (x) (_) ((const 0))
         (seq
          (call (toplevel frob) (lambda _ _))
          (lexical x _))))

  (pass-if-peval
    ;; Bindings mutated.
    (letrec ((f (lambda (x)
                  (set! f (lambda (_) x))
                  x)))
      (f 2))
    (let (f) (_) ((void)) (seq _ (call . _))))

  (pass-if-peval
    ;; Bindings possibly mutated.
    (let ((x (make-foo)))
      (frob! x) ; may mutate `x'
      x)
    (let (x) (_) ((call (toplevel make-foo)))
         (seq
           (call (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))))
    (fix (loop) (_) ((lambda (_)
                       (lambda-case
                        (((x) #f #f #f () (_))
                         (if _ _
                             (call (lexical loop _)
                                   (primcall - (lexical x _)
                                             (const 1))))))))
         (call (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) (_) ((call (toplevel top)))
         (call (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)))))
    (fix (loop) (_) ((lambda (_)
                       (lambda-case
                        (((x y) #f #f #f () (_ _))
                         (if (primcall >
                                       (lexical y _) (const 0))
                             _ _)))))
         (call (lexical loop _) (toplevel x) (const 0))))

  (pass-if-peval
    ;; Infinite recursion: `peval' can inline some but eventually gives up.
    (letrec ((f (lambda (x) (g (1- x))))
             (g (lambda (x) (h (1+ x))))
             (h (lambda (x) (f x))))
      (f 0))
    (fix (f) (_) (_) (call . _)))

  (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))))
    (fix (loop) (_) ((lambda . _))
         (call (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) (_) (_)
              (seq
               (set! (lexical pos _) (const 1))
               (call (lexical here _))))))

  (pass-if-peval
   ;; FIXME: Signal an error?
   (letrec ((a a))
     1)
   (let (a) (_) ((void)) (seq (set! . _) (const 1))))

  (pass-if-peval
   ;; This is a fun one for peval to handle.
   (letrec ((a a))
     a)
   (let (a) (_) ((void)) (seq (set! . _) (lexical a _))))

  (pass-if-peval
   ;; Another interesting recursive case.
   (letrec ((a b) (b a))
     a)
   (let (a b) (_ _) ((void) (void))
        (seq (set! . _) (seq (set! . _) (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.
   (fix (a) (_)
        ((lambda _
           (lambda-case
            ((() #f #f #f () ())
             (call (lexical a _))))))
        (fix (b) (_)
             ((lambda _
                (lambda-case
                 ((() #f #f #f () ())
                  (call (lexical a _))))))
             (call (toplevel foo) (lexical b _)))))

  (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)))
   (call (toplevel foo)
         (lambda _
           (lambda-case
            (((x) #f #f #f () (_))
             (call (toplevel top) (lexical x _)))))
         (lambda _
           (lambda-case
            (((x) #f #f #f () (_))
             (call (toplevel top) (lexical x _)))))))
  
  (pass-if-peval
    ;; 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) (_) ((primcall list (const 3) (const 4)))
         (primcall list (const 1) (const 2) (lexical z _))))

  (pass-if-peval
    ;; Unmutated lists can get inlined.
    (let ((args (list 2 3)))
      (apply (lambda (x y z w)
               (list x y z w))
             0 1 args))
    (primcall list (const 0) (const 1) (const 2) (const 3)))

  (pass-if-peval
    ;; However if the list might have been mutated, it doesn't propagate.
    (let ((args (list 2 3)))
      (foo! args)
      (apply (lambda (x y z w)
               (list x y z w))
             0 1 args))
    (let (args) (_) ((primcall list (const 2) (const 3)))
         (seq
          (call (toplevel foo!) (lexical args _))
          (primcall apply
                    (lambda ()
                      (lambda-case
                       (((x y z w) #f #f #f () (_ _ _ _))
                        (primcall list
                                  (lexical x _) (lexical y _)
                                  (lexical z _) (lexical w _)))))
                    (const 0)
                    (const 1)
                    (lexical args _)))))

  (pass-if-peval
    ;; Here the `args' that gets built by the application of the lambda
    ;; takes more than effort "10" to visit.  Test that we fall back to
    ;; the source expression of the operand, which is still a call to
    ;; `list', so the inlining still happens.
    (lambda (bv offset n)
      (let ((x (bytevector-ieee-single-native-ref
                bv
                (+ offset 0)))
            (y (bytevector-ieee-single-native-ref
                bv
                (+ offset 4))))
        (let ((args (list x y)))
          (apply
           (lambda (bv offset x y)
             (bytevector-ieee-single-native-set!
              bv
              (+ offset 0)
              x)
             (bytevector-ieee-single-native-set!
              bv
              (+ offset 4)
              y))
           bv
           offset
           args))))
    (lambda ()
      (lambda-case
       (((bv offset n) #f #f #f () (_ _ _))
        (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref
                                    (lexical bv _)
                                    (primcall +
                                              (lexical offset _) (const 0)))
                          (primcall bytevector-ieee-single-native-ref
                                    (lexical bv _)
                                    (primcall +
                                              (lexical offset _) (const 4))))
             (seq
              (primcall bytevector-ieee-single-native-set!
                        (lexical bv _)
                        (primcall +
                                  (lexical offset _) (const 0))
                        (lexical x _))
              (primcall bytevector-ieee-single-native-set!
                        (lexical bv _)
                        (primcall +
                                  (lexical offset _) (const 4))
                        (lexical y _))))))))

  (pass-if-peval
    ;; Here we ensure that non-constant expressions are not copied.
    (lambda ()
      (let ((args (list (foo!))))
        (apply
         (lambda (z x)
           (list z x))
         ;; This toplevel ref might raise an unbound variable exception.
         ;; The effects of `(foo!)' must be visible before this effect.
         z
         args)))
    (lambda ()
      (lambda-case
       ((() #f #f #f () ())
        (let (_) (_) ((call (toplevel foo!)))
             (let (z) (_) ((toplevel z))
                  (primcall 'list
                            (lexical z _)
                            (lexical _ _))))))))

  (pass-if-peval
    ;; Rest args referenced more than once are not destructured.
    (lambda ()
      (let ((args (list 'foo)))
        (set-car! args 'bar)
        (apply
         (lambda (z x)
           (list z x))
         z
         args)))
    (lambda ()
      (lambda-case
       ((() #f #f #f () ())
        (let (args) (_)
             ((primcall list (const foo)))
             (seq
              (primcall set-car! (lexical args _) (const bar))
              (primcall apply
                        (lambda . _)
                        (toplevel z)
                        (lexical args _))))))))

  (pass-if-peval
    ;; Let-values inlining, even with consumers with rest args.
    (call-with-values (lambda () (values 1 2))
      (lambda args
        (apply list args)))
    (primcall list (const 1) (const 2)))

  (pass-if-peval
    ;; When we can't inline let-values but can prove that the producer
    ;; has just one value, reduce to "let" (which can then fold
    ;; further).
    (call-with-values (lambda () (if foo 1 2))
      (lambda args
        (apply values args)))
    (if (toplevel foo) (const 1) (const 2)))

  (pass-if-peval
   ;; Constant folding: cons of #nil does not make list
   (cons 1 #nil)
   (primcall 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)
   (seq (call (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)))
   (seq (call (toplevel bar)) (const 1)))
  
  (pass-if-peval
   ;; Constant folding: cdr+cons, impure
   (cdr (cons (bar) 0))
   (seq (call (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))
   (primcall list (const 0)))
  
  (pass-if-peval
   ;; Constant folding: car+list, impure
   (car (list 1 (bar)))
   (seq (call (toplevel bar)) (const 1)))
  
  (pass-if-peval
   ;; Constant folding: cdr+list, impure
   (cdr (list (bar) 0))
   (seq (call (toplevel bar)) (primcall list (const 0))))

  (pass-if-peval
   ;; Equality primitive: same lexical
   (let ((x (random))) (eq? x x))
   (seq (call (toplevel random)) (const #t)))

  (pass-if-peval
   ;; Equality primitive: merge lexical identities
   (let* ((x (random)) (y x)) (eq? x y))
   (seq (call (toplevel random)) (const #t)))
  
  (pass-if-peval
   ;; Non-constant guards get lexical bindings, invocation of winder and
   ;; unwinder lifted out.  Unfortunately both have the generic variable
   ;; name "tmp", so we can't distinguish them in this test, and they
   ;; also collide in generic names with the single-value result from
   ;; the dynwind; alack.
   (dynamic-wind foo (lambda () bar) baz)
   (let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
        (seq (seq (if (primcall thunk? (lexical tmp _))
                      (call (lexical tmp _))
                      (primcall throw . _))
                  (primcall wind (lexical tmp _) (lexical tmp _)))
             (let (tmp) (_) ((toplevel bar))
                  (seq (seq (primcall unwind)
                            (call (lexical tmp _)))
                       (lexical tmp _))))))
  
  (pass-if-peval
   ;; Constant guards don't need lexical bindings or thunk? checks.
   (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
   (seq (seq (toplevel foo)
             (primcall wind
                       (lambda ()
                         (lambda-case
                          ((() #f #f #f () ()) (toplevel foo))))
                       (lambda ()
                         (lambda-case
                          ((() #f #f #f () ()) (toplevel baz))))))
        (let (tmp) (_) ((toplevel bar))
             (seq (seq (primcall unwind)
                       (toplevel baz))
                  (lexical tmp _)))))
  
  (pass-if-peval
   ;; Dynwind bodies that return an unknown number of values need a
   ;; let-values.
   (dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
   (seq (seq (toplevel foo)
             (primcall wind
                       (lambda ()
                         (lambda-case
                          ((() #f #f #f () ()) (toplevel foo))))
                       (lambda ()
                         (lambda-case
                          ((() #f #f #f () ()) (toplevel baz))))))
        (let-values (call (toplevel bar))
          (lambda-case
           ((() #f vals #f () (_))
            (seq (seq (primcall unwind)
                      (toplevel baz))
                 (primcall apply (primitive values) (lexical vals _))))))))
  
  (pass-if-peval
   ;; 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
   ;; 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
   (call-with-prompt tag
                     (lambda () 1)
                     (lambda (k x) x))
   (prompt #t
           (toplevel tag)
           (const 1)
           (lambda _
             (lambda-case
              (((k x) #f #f #f () (_ _))
               (lexical x _))))))

  ;; Handler toplevel not inlined
  (pass-if-peval
      (call-with-prompt tag
                        (lambda () 1)
                        handler)
    (let (handler) (_) ((toplevel handler))
         (if (primcall procedure? (lexical handler _))
             (prompt #f
                     (toplevel tag)
                     (lambda _
                       (lambda-case
                        ((() #f #f #f () ())
                         (const 1))))
                     (lambda _
                       (lambda-case
                        ((() #f args #f () (_))
                         (primcall apply
                                   (lexical handler _)
                                   (lexical args _))))))
             (primcall throw . _))))

  (pass-if-peval
   ;; `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 (_) (_) ((primcall make-prompt-tag . _))
        (fix (lp) (_)
             ((lambda _
                (lambda-case
                 ((() #f #f #f () ())
                  (fix (loop) (_)
                       ((lambda _
                          (lambda-case
                           ((() #f #f #f () ())
                            (call (lexical loop _))))))
                       (call (lexical loop _)))))))
             (call (lexical lp _)))))

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

  (pass-if-peval
    (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
    (let ((x (let sum ((n 0) (out 0))
               (if (< n 10000)
                   (sum (1+ n) (+ out n))
                   out))))
      ((lambda (y) (list y)) x))
    (let (x) (_) (_)
         (primcall list (lexical x _))))

  ;; Here we test that a common test in a chain of ifs gets lifted.
  (pass-if-peval
    (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 () ())
                            (call (toplevel qux) (toplevel x))))))
         (if (primcall struct? (toplevel x))
             (if (primcall eq?
                           (primcall struct-vtable (toplevel x))
                           (toplevel A))
                 (call (toplevel foo) (toplevel x))
                 (if (primcall eq?
                               (primcall struct-vtable (toplevel x))
                               (toplevel B))
                     (call (toplevel bar) (toplevel x))
                     (if (primcall eq?
                                   (primcall struct-vtable (toplevel x))
                                   (toplevel C))
                         (call (toplevel baz) (toplevel x))
                         (call (lexical failure _)))))
             (call (lexical failure _)))))

  ;; Multiple common tests should get lifted as well.
  (pass-if-peval
    (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 () ())
                            (call (toplevel qux) (toplevel x))))))
         (if (primcall struct? (toplevel x))
             (if (primcall eq?
                           (primcall struct-vtable (toplevel x))
                           (toplevel A))
                 (if (toplevel B)
                     (call (toplevel foo) (toplevel x))
                     (if (toplevel C)
                         (call (toplevel bar) (toplevel x))
                         (if (toplevel D)
                             (call (toplevel baz) (toplevel x))
                             (call (lexical failure _)))))
                 (call (lexical failure _)))
             (call (lexical failure _)))))

  (pass-if-peval
    (apply (lambda (x y) (cons x y)) '(1 2))
    (primcall cons (const 1) (const 2)))

  (pass-if-peval
    (apply (lambda (x y) (cons x y)) (list 1 2))
    (primcall cons (const 1) (const 2)))

  (pass-if-peval
    (apply = (list 0 0 0))
    (const #t))

  (pass-if-peval
    (apply char<? (list #\a #\b #\c))
    (const #t))

  ;; Disable after removal of abort-in-tail-position optimization, in
  ;; hopes that CPS does a uniformly better job.
  #;
  (pass-if-peval
    (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))))
    (primcall list (const 1) (const 2) (const 3)))

  (pass-if-peval
      (call-with-values foo (lambda (x) (bar x)))
    (let-values (call (toplevel foo))
      (lambda-case
       (((x) #f #f #f () (_))
        (call (toplevel bar) (lexical x _))))))

  (pass-if-peval
      (eq? '(a b) '(a b))
    (const #t))

  (pass-if-peval
      (eqv? '(a b) '(a b))
    (const #t))

  (pass-if-peval
      ((lambda (foo)
         (define* (bar a #:optional (b (1+ a)))
           (list a b))
         (bar 1))
       1)
    (primcall list (const 1) (const 2)))

  (pass-if-peval
      ;; Should not inline tail list to apply if it is mutable.
      ;; <http://debbugs.gnu.org/15533>
      (let ((l '()))
        (if (pair? arg)
            (set! l arg))
        (apply f l))
      (let (l) (_) ((const ()))
         (seq
           (if (primcall pair? (toplevel arg))
               (set! (lexical l _) (toplevel arg))
               (void))
           (primcall apply (toplevel f) (lexical l _)))))

  (pass-if-peval
      (lambda (f x)
        (let lp ((x x))
          (let ((x* (f x)))
            (if (eq? x x*) x* (lp x*)))))
    (lambda ()
      (lambda-case
       (((f x) #f #f #f () (_ _))
        (fix (lp)
             (_)
             ((lambda ((name . lp))
                (lambda-case
                 (((x) #f #f #f () (_))
                  (let (x*)
                    (_)
                    ((call (lexical f _) (lexical x _)))
                    (if (primcall
                         eq?
                         (lexical x _)
                         (lexical x* _))
                        (lexical x* _)
                        (call (lexical lp _)
                              (lexical x* _))))))))
             (call (lexical lp _)
                   (lexical x _)))))))

  (pass-if-peval
      (lambda ()
        (define (add1 n) (+ 1 n))
        (add1 1 2))
    (lambda ()
      (lambda-case
       ((() #f #f #f () ())
        (fix (add1)
             (_)
             ((lambda ((name . add1))
                (lambda-case
                 (((n) #f #f #f () (_))
                  (primcall + (const 1) (lexical n _))))))
             (call (lexical add1 _)
                   (const 1)
                   (const 2)))))))

  (pass-if-peval (make-vector 123 x)
    (primcall make-vector (const 123) (toplevel x)))

  (pass-if-peval (make-vector)
    ;; This used to trigger an infinite loop between
    ;; 'resolve-primitives' and 'expand-primcall':
    ;; <https://bugs.gnu.org/60522>.
    (primcall make-vector)))

(with-test-prefix "eqv?"
  (pass-if-peval (eqv? x #f)
    (primcall eq? (toplevel x) (const #f)))

  (pass-if-peval (eqv? x '())
    (primcall eq? (toplevel x) (const ())))

  (pass-if-peval (eqv? x #t)
    (primcall eq? (toplevel x) (const #t)))

  (pass-if-peval (eqv? x 'sym)
    (primcall eq? (toplevel x) (const sym)))

  (pass-if-peval (eqv? x 42)
    (primcall eq? (toplevel x) (const 42)))

  (pass-if-peval (eqv? x #\a)
    (primcall eq? (toplevel x) (const #\a)))

  (pass-if-peval (eqv? x 42.0)
    (primcall eqv? (toplevel x) (const '42.0)))

  (pass-if-peval (eqv? x #nil)
    (primcall eq? (toplevel x) (const #nil)))

  (pass-if-peval (eqv? x '(a . b))
    (primcall eq? (toplevel x) (const (a . b)))))

(with-test-prefix "equal?"
  (pass-if-peval (equal? x #f)
    (primcall eq? (toplevel x) (const #f)))

  (pass-if-peval (equal? x '())
    (primcall eq? (toplevel x) (const ())))

  (pass-if-peval (equal? x #t)
    (primcall eq? (toplevel x) (const #t)))

  (pass-if-peval (equal? x 'sym)
    (primcall eq? (toplevel x) (const sym)))

  (pass-if-peval (equal? x 42)
    (primcall eq? (toplevel x) (const 42)))

  (pass-if-peval (equal? x #\a)
    (primcall eq? (toplevel x) (const #\a)))

  (pass-if-peval (equal? x 42.0)
    (primcall eqv? (toplevel x) (const '42.0)))

  (pass-if-peval (equal? x #nil)
    (primcall eq? (toplevel x) (const #nil)))

  (pass-if-peval (equal? x '(a . b))
    (primcall equal? (toplevel x) (const (a . b)))))