Add a partial evaluator for use in the compiler.

Thanks to William R. Cook for his excellent tutorial,
<http://softlang.uni-koblenz.de/dsl11/>.

* module/language/tree-il/optimize.scm (optimize!): Call `peval' unless
  the #:partial-eval? option asks otherwise.
  (peval): New procedure.

* module/language/tree-il/inline.scm: Add comment.

* module/language/tree-il/primitives.scm (*primitive-constructors*): New
  variable.
  (*effect-free-primitives*): Use it.
  (constructor-primitive?): New primitive.

* test-suite/tests/tree-il.test (assert-tree-il->glil): Extend to
  support `with-partial-evaluation', `without-partial-evaluation', and
  `with-options'.
  (peval): New binding.
  (pass-if-peval): New macro.
  ("lexical refs"): Run tests without partial evaluation.
  ("letrec"): Likewise.
  ("the or hack"): Likewise.
  ("conditional"): Likewise, for some tests.
  ("sequence"): Adjust to new generated code.
  ("partial evaluation"): New test prefix.

module/language/tree-il/inline.scm

@@ -38,6 +38,7 @@
       ((<void>)
        (make-const src #t))
 
+      ;; FIXME: This is redundant with what the partial evaluator does.
       ((<conditional> test consequent alternate)
        (record-case (boolean-value test)
          ((<const> exp)

module/language/tree-il/optimize.scm

@@ -1,6 +1,6 @@
 ;;; Tree-il optimizer
 
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011 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
@@ -23,10 +23,249 @@
   #:use-module (language tree-il primitives)
   #:use-module (language tree-il inline)
   #:use-module (language tree-il fix-letrec)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
   #:export (optimize!))
 
 (define (optimize! x env opts)
+  (let ((peval (match (memq #:partial-eval? opts)
+                 ((#:partial-eval? #f _ ...)
+                  ;; Disable partial evaluation.
+                  identity)
+                 (_ peval))))
    (inline!
     (fix-letrec!
+     (peval
       (expand-primitives!
-     (resolve-primitives! x env)))))
+       (resolve-primitives! x env)))))))
+
+(define* (peval exp #:optional (env vlist-null))
+  "Partially evaluate EXP in top-level environment ENV and return the
+resulting expression.  Since it does not handle <fix> and <let-values>,
+it should be called before `fix-letrec'."
+
+  ;; This is a simple partial evaluator.  It effectively performs
+  ;; constant folding, copy propagation, dead code elimination, and
+  ;; inlining, but not across top-level bindings---there should be a way
+  ;; to allow this (TODO).
+  ;;
+  ;; Unlike a full-blown partial evaluator, it does not emit definitions
+  ;; of specialized versions of lambdas encountered on its way.  Also,
+  ;; it's very conservative: it bails out if `set!', `prompt', etc. are
+  ;; met.
+
+  (define local-toplevel-env
+    ;; The top-level environment of the module being compiled.
+    (match exp
+      (($ <toplevel-define> _ name)
+       (vhash-consq name #t env))
+      (($ <sequence> _ exps)
+       (fold (lambda (x r)
+               (match x
+                 (($ <toplevel-define> _ name)
+                  (vhash-consq name #t r))
+                 (_ r)))
+             env
+             exps))
+      (_ env)))
+
+  (define (local-toplevel? name)
+    (vhash-assq name local-toplevel-env))
+
+  (define (apply-primitive name args)
+    ;; todo: further optimize commutative primitives
+    (catch #t
+      (lambda ()
+        (call-with-values
+            (lambda ()
+              (apply (module-ref the-scm-module name) args))
+          (lambda results
+            (values #t results))))
+      (lambda _
+        (values #f '()))))
+
+  (define (make-values src values)
+    (make-application src (make-primitive-ref src 'values)
+                      (map (cut make-const src <>) values)))
+
+  (define (const*? x)
+    (or (const? x) (lambda? x) (void? x)))
+
+  (define (pure-expression? x)
+    ;; Return true if X is pure---i.e., if it is known to have no
+    ;; effects and does not allocate new storage.  Note: <module-ref> is
+    ;; not "pure" because it loads a module as a side-effect.
+    (let loop ((x x))
+      (match x
+        (($ <void>) #t)
+        (($ <const>) #t)
+        (($ <lambda>) #t)
+        (($ <lambda-case> _ req opt rest kw inits _ body alternate)
+         (and (every loop inits) (loop body) (loop alternate)))
+        (($ <lexical-ref>) #t)
+        (($ <toplevel-ref>) #t)
+        (($ <primitive-ref>) #t)
+        (($ <conditional> _ condition subsequent alternate)
+         (and (loop condition) (loop subsequent) (loop alternate)))
+        (($ <application> _ ($ <primitive-ref> _ name) args)
+         (and (effect-free-primitive? name)
+              (not (constructor-primitive? name))
+              (every loop args)))
+        (($ <application> _ ($ <lambda> _ body) args)
+         (and (loop body) (every loop args)))
+        (($ <sequence> _ exps)
+         (every loop exps))
+        (($ <let> _ _ _ vals body)
+         (and (every loop vals) (loop body)))
+        (($ <letrec> _ _ _ _ vals body)
+         (and (every loop vals) (loop body)))
+        (_ #f))))
+
+  (catch 'match-error
+    (lambda ()
+      (let loop ((exp   exp)
+                 (env   vlist-null)  ; static environment
+                 (calls '()))        ; inlined call stack
+        (define (lookup var)
+          (and=> (vhash-assq var env) cdr))
+
+        (match exp
+          (($ <const>)
+           exp)
+          (($ <void>)
+           exp)
+          (($ <lexical-ref> _ _ gensym)
+           ;; Propagate only pure expressions.
+           (let ((val (lookup gensym)))
+             (or (and (pure-expression? val) val) exp)))
+          (($ <let> src names gensyms vals body)
+           (let* ((vals (map (cut loop <> env calls) vals))
+                  (body (loop body
+                              (fold vhash-consq env gensyms vals)
+                              calls)))
+             (if (const? body)
+                 body
+                 (let*-values (((stripped) (remove (compose const? car)
+                                                   (zip vals gensyms names)))
+                               ((vals gensyms names) (unzip3 stripped)))
+                   (if (null? stripped)
+                       body
+                       (make-let src names gensyms vals body))))))
+          (($ <letrec> src in-order? names gensyms vals body)
+           ;; Things could be done more precisely when IN-ORDER? but
+           ;; it's OK not to do it---at worst we lost an optimization
+           ;; opportunity.
+           (let* ((vals (map (cut loop <> env calls) vals))
+                  (body (loop body
+                              (fold vhash-consq env gensyms vals)
+                              calls)))
+             (if (const? body)
+                 body
+                 (make-letrec src in-order? names gensyms vals body))))
+          (($ <toplevel-ref> src (? effect-free-primitive? name))
+           (if (and (not (local-toplevel? name))
+                    (eq? (module-ref (current-module) name #f)
+                         (module-ref the-scm-module name)))
+               (make-primitive-ref src name)
+               exp))
+          (($ <toplevel-ref>)
+           ;; todo: open private local bindings.
+           exp)
+          (($ <module-ref>)
+           exp)
+          (($ <toplevel-define> src name exp)
+           (make-toplevel-define src name (loop exp env '())))
+          (($ <primitive-ref>)
+           exp)
+          (($ <conditional> src condition subsequent alternate)
+           (let ((condition (loop condition env calls)))
+             (if (const*? condition)
+                 (if (or (lambda? condition) (void? condition)
+                         (const-exp condition))
+                     (loop subsequent env calls)
+                     (loop alternate env calls))
+                 (make-conditional src condition
+                                   (loop subsequent env calls)
+                                   (loop alternate env calls)))))
+          (($ <application> src proc* args*)
+           ;; todo: augment the global env with specialized functions
+           (let* ((proc (loop proc* env calls))
+                  (args (map (cut loop <> env calls) args*))
+                  (app  (make-application src proc args)))
+             ;; If ARGS are constants and this call hasn't already been
+             ;; expanded before (to avoid infinite recursion), then
+             ;; expand it (todo: emit an infinite recursion warning.)
+             (if (and (any const*? args)
+                      (not (member (cons proc args) calls)))
+                 (match proc
+                   (($ <primitive-ref> _ (? effect-free-primitive? name))
+                    (if (every const? args)  ; only simple constants
+                        (let-values (((success? values)
+                                      (apply-primitive name
+                                                       (map const-exp args))))
+                          (if success?
+                              (match values
+                                ((value)
+                                 (make-const src value))
+                                (_
+                                 (make-values src values)))
+                              app))
+                        app))
+                   (($ <primitive-ref>)
+                    ;; An effectful primitive.
+                    app)
+                   (($ <lambda> _ _
+                       ($ <lambda-case> _ req opt #f #f inits gensyms body))
+                    ;; Simple case: no rest, no keyword arguments.
+                    ;; todo: handle the more complex cases
+                    (let ((nargs  (length args))
+                          (nreq   (length req))
+                          (nopt   (if opt (length opt) 0)))
+                      (if (and (>= nargs nreq) (<= nargs (+ nreq nopt)))
+                          (loop body
+                                (fold vhash-consq env gensyms
+                                      (append args
+                                              (drop inits
+                                                    (max 0
+                                                         (- nargs
+                                                            (+ nreq nopt))))))
+                                (cons (cons proc args) calls))
+                          app)))
+                   (($ <lambda>)
+                    app)
+                   (($ <toplevel-ref>)
+                    app))
+
+                 ;; There are no constant arguments, so don't substitute
+                 ;; lambdas---i.e., prefer (lexical f) over an inline
+                 ;; copy of `f'.
+                 (let ((proc (if (lambda? proc) proc* proc))
+                       (args (map (lambda (raw evaled)
+                                    (if (lambda? evaled)
+                                        raw
+                                        evaled))
+                                  args*
+                                  args)))
+                   (make-application src proc args)))))
+          (($ <lambda> src meta body)
+           (make-lambda src meta (loop body env calls)))
+          (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+           (make-lambda-case src req opt rest kw inits gensyms
+                             (loop body env calls)
+                             alt))
+          (($ <sequence> src exps)
+           (let ((exps (map (cut loop <> env calls) exps)))
+             (if (every pure-expression? exps)
+                 (last exps)
+                 (match (reverse exps)
+                   ;; Remove all expressions but the last one.
+                   ((keep rest ...)
+                    (let ((rest (remove pure-expression? rest)))
+                      (make-sequence src (reverse (cons keep rest))))))))))))
+    (lambda _
+      ;; We encountered something we don't handle, like `<lexical-set>',
+      ;; <abort>, or some other effecting construct, so bail out.
+      exp)))

module/language/tree-il/primitives.scm

@@ -27,7 +27,8 @@
   #:use-module (srfi srfi-16)
   #:export (resolve-primitives! add-interesting-primitive!
             expand-primitives!
-            effect-free-primitive? effect+exception-free-primitive?))
+            effect-free-primitive? effect+exception-free-primitive?
+            constructor-primitive?))
 
 (define *interesting-primitive-names* 
   '(apply @apply
@@ -106,21 +107,24 @@
 
 (for-each add-interesting-primitive! *interesting-primitive-names*)
 
+(define *primitive-constructors*
+  ;; Primitives that return a fresh object.
+  '(acons cons cons* list vector make-struct make-struct/no-tail))
+
 (define *effect-free-primitives*
-  '(values
+  `(values
     eq? eqv? equal?
     = < > <= >= zero?
     + * - / 1- 1+ quotient remainder modulo
     not
-    pair? null? list? symbol? vector? acons cons cons*
+    pair? null? list? symbol? vector?
-    list vector
     car cdr
     caar cadr cdar cddr
     caaar caadr cadar caddr cdaar cdadr cddar cdddr
     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
     vector-ref
-    struct? struct-vtable make-struct make-struct/no-tail struct-ref
+    struct? struct-vtable struct-ref
     bytevector-u8-ref bytevector-s8-ref
     bytevector-u16-ref bytevector-u16-native-ref
     bytevector-s16-ref bytevector-s16-native-ref
@@ -129,7 +133,8 @@
     bytevector-u64-ref bytevector-u64-native-ref
     bytevector-s64-ref bytevector-s64-native-ref
     bytevector-ieee-single-ref bytevector-ieee-single-native-ref
-    bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+    bytevector-ieee-double-ref bytevector-ieee-double-native-ref
+    ,@*primitive-constructors*))
 
 ;; Like *effect-free-primitives* above, but further restricted in that they
 ;; cannot raise exceptions.
@@ -151,6 +156,8 @@
             (hashq-set! *effect+exceptions-free-primitive-table* x #t))
           *effect+exception-free-primitives*)
 
+(define (constructor-primitive? prim)
+  (memq prim *primitive-constructors*))
 (define (effect-free-primitive? prim)
   (hashq-ref *effect-free-primitive-table* prim))
 (define (effect+exception-free-primitive? prim)
@@ -246,6 +253,8 @@
 (define-primitive-expander zero? (x)
   (= x 0))
 
+;; FIXME: All the code that uses `const?' is redundant with `peval'.
+
 (define-primitive-expander +
   () 0
   (x) (values x)

test-suite/tests/tree-il.test

@@ -44,16 +44,27 @@
                         'out))))))
 
 (define-syntax assert-tree-il->glil
-  (syntax-rules ()
+  (syntax-rules (with-partial-evaluation without-partial-evaluation
-    ((_ in pat test ...)
+                 with-options)
+    ((_ with-partial-evaluation in pat test ...)
+     (assert-tree-il->glil with-options (#:partial-eval? #t)
+                           in pat test ...))
+    ((_ without-partial-evaluation in pat test ...)
+     (assert-tree-il->glil with-options (#:partial-eval? #f)
+                           in pat test ...))
+    ((_ with-options opts in pat test ...)
      (let ((exp 'in))
        (pass-if 'in
          (let ((glil (unparse-glil
                       (compile (strip-source (parse-tree-il exp))
-                               #:from 'tree-il #:to 'glil))))
+                               #:from 'tree-il #:to 'glil
+                               #:opts 'opts))))
            (pmatch glil
              (pat (guard test ...) #t)
-             (else #f))))))))
+             (else #f))))))
+    ((_ in pat test ...)
+     (assert-tree-il->glil with-partial-evaluation
+                           in pat test ...))))
 
 (define-syntax pass-if-tree-il->scheme
   (syntax-rules ()
@@ -66,6 +77,21 @@
          (pat (guard guard-exp) #t)
          (_ #f))))))
 
+(define peval
+  ;; The partial evaluator.
+  (@@ (language tree-il optimize) peval))
+
+(define-syntax pass-if-peval
+  (syntax-rules ()
+    ((_ in pat)
+     (pass-if 'in
+       (let ((evaled (unparse-tree-il
+                      (peval (compile 'in #:from 'scheme #:to 'tree-il)))))
+         (pmatch evaled
+           (pat #t)
+           (_   (pk 'peval-mismatch evaled) #f)))))))
+
+
 (with-test-prefix "tree-il->scheme"
   (pass-if-tree-il->scheme
    (case-lambda ((a) a) ((b c) (list b c)))
@@ -108,7 +134,7 @@
             (label ,l2) (const 2) (call return 1))
    (eq? l1 l2))
 
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
             (label ,l3) (label ,l4) (const #f) (call return 1))
@@ -137,21 +163,21 @@
             (call return 1))))
 
 (with-test-prefix "lexical refs"
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (let (x) (y) ((const 1)) (lexical x y))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (lexical #t #f ref 0) (call return 1)
             (unbind)))
 
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (const #f) (call return 1)
             (unbind)))
 
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
@@ -270,7 +296,7 @@
             (toplevel ref bar)
             (call return 1)))
 
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (begin (toplevel bar) (const #f))
    (program () (std-prelude 0 0 #f) (label _)
             (toplevel ref bar) (call drop 1)
@@ -332,13 +358,14 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
+   ;; This gets simplified by `peval'.
    (apply (primitive null?) (const 2))
    (program () (std-prelude 0 0 #f) (label _)
-            (const 2) (call null? 1) (call return 1))))
+            (const #f) (call return 1))))
 
 (with-test-prefix "letrec"
   ;; simple bindings -> let
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (letrec (x y) (x1 y1) ((const 10) (const 20))
            (apply (toplevel foo) (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 2 #f) (label _)
@@ -351,7 +378,7 @@
             (unbind)))
 
   ;; complex bindings -> box and set! within let
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
            (apply (primitive +) (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 4 #f) (label _)
@@ -367,7 +394,7 @@
             (call add 2) (call return 1) (unbind)))
   
   ;; complex bindings in letrec* -> box and set! in order
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
             (apply (primitive +) (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 2 #f) (label _)
@@ -383,7 +410,7 @@
             (call add 2) (call return 1) (unbind)))
 
   ;; simple bindings in letrec* -> equivalent to letrec
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (letrec* (x y) (xx yy) ((const 1) (const 2))
             (lexical y yy))
    (program () (std-prelude 0 1 #f) (label _)
@@ -487,9 +514,10 @@
             (const #t) (call return 1)))
 
   (assert-tree-il->glil
+   ;; This gets simplified by `peval'.
    (apply (primitive null?) (begin (const #f) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
-            (const 2) (call null? 1) (call return 1))))
+            (const #f) (call return 1))))
 
 (with-test-prefix "values"
   (assert-tree-il->glil
@@ -514,7 +542,7 @@
 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 ;; and could be tightened in any case
 (with-test-prefix "the or hack"
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (let (x) (y) ((const 1))
         (if (lexical x y)
             (lexical x y)
@@ -532,7 +560,7 @@
    (eq? l1 l2))
 
   ;; second bound var is unreferenced
-  (assert-tree-il->glil
+  (assert-tree-il->glil without-partial-evaluation
    (let (x) (y) ((const 1))
         (if (lexical x y)
             (lexical x y)
@@ -586,6 +614,253 @@
             (toplevel ref bar) (call call/cc 1)
             (call tail-call 1))))
 
+
+(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, 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, 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
+    ;; 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
+    ;; Procedure only called with non-constant 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
+    ;; 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
+    ;; 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 _ . _)))
+
 
 (with-test-prefix "tree-il-fold"