guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-123-g4bd53


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-123-g4bd53c1
Date: Mon, 23 Apr 2012 22:31:22 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=4bd53c1ba39ba1c2d51ff895104f27cf4bb69e4e

The branch, stable-2.0 has been updated
       via  4bd53c1ba39ba1c2d51ff895104f27cf4bb69e4e (commit)
       via  985702f7131e11c7c13aa75db19d10525c34fecd (commit)
       via  f6a554a6aa0832432cec9c9c18b99fad56008997 (commit)
       via  299ce911f986c7f9a6a4887ca3b72e5748e126f7 (commit)
       via  73001b06f60206edfa4ae4ec6a8b5c8f65d272c2 (commit)
       via  3db8f60977e966522e3c05cc554c99382c968b55 (commit)
       via  036c366dc2fbbeeb04d8984bb0819df28d9d455f (commit)
       via  b3f25e62695315ab632d2e3a66d31bb490c82100 (commit)
       via  f7d8efc630ce45f5d82aae5b2682d261e5541d5f (commit)
       via  9068f4f52772397c5d4408f585ccdf1017869a3e (commit)
       via  f66cbb99ee096186837536885d3436bb334df34d (commit)
       via  1cd63115be7a25d0ea18aaa0e1eff5658d8db77a (commit)
       via  a36e7870c31322fd300c7478df24dbf559a0d67b (commit)
       via  da9b2b71f76644abcc2eec2cc1478379df1e9025 (commit)
       via  de1eb420a5a95b17e85b19c4d98c869036e9ecb0 (commit)
       via  5deea34d0eb3d2ec5db421eb79516e747eed5841 (commit)
      from  7e822b32d2a165a027fd1de4d59fdfae568599bf (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 4bd53c1ba39ba1c2d51ff895104f27cf4bb69e4e
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 23 21:42:40 2012 +0200

    vlist performance improvements; allocate vhash data inline
    
    * module/ice-9/vlist.scm (make-block): If we are making a hash table,
      allocate it inline with the contents.  Otherwise don't even add a
      pointer to the block.
      (block-hash-table?): New internal accessor.
      (block-ref*): Remove.  Vhash entries are no longer wrapped.
      (block-ref):
      (block-hash-table-next-offset):
      (block-hash-table-set-next-offset!):
      (block-hash-table-ref):
      (block-hash-table-set!):
      (block-hash-table-add!): Adapt to take content vector explicitly, and
      to expect the hash table inline with the contents.  Some of these
      accessors are new.  Adapt callers.
      (assert-vlist): New helper.
      (vlist-cons): Update comment.
      (vhash?): Update scheme to allocate the hash table and chain links
      inline with the contents.
      (%vhash-fold*, %vhash-assoc): Rewrite to be more performant.

commit 985702f7131e11c7c13aa75db19d10525c34fecd
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 23 17:56:28 2012 +0200

    avoid emitting degenerate aliases in peval
    
    * module/language/tree-il/peval.scm (<operand>, make-operand)
      (make-bound-operands, peval): Avoid emitting needless aliases in
      degenerate cases of let.
      (visit-operand): If we visit an operand with a fresh counter and have
      to abort, record that fact.
    
    * test-suite/tests/peval.test ("partial evaluation"): Add a test.

commit f6a554a6aa0832432cec9c9c18b99fad56008997
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 23 13:07:34 2012 +0200

    vlist-cons micro-optimizations
    
    * module/ice-9/vlist.scm (set-block-next-free!): Define this instead of
      increment-block-next-free!.
      (block-append!): Refactor to take an offset, and only append if the
      offset is the next free value, and there is space in the block.
      (block-cons): Refactor to not be a loop.  The partial evaluator would
      have to understand effects analysis in order to be able to unroll it,
      and there's at most one recursion.
    
      Recovers the performance loss resulting from the previous commit.

commit 299ce911f986c7f9a6a4887ca3b72e5748e126f7
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 23 11:43:01 2012 +0200

    slight vlist refactor
    
    * module/ice-9/vlist.scm: Use define-inlinable instead of define-inline,
      to ensure strict argument evaluation.  There is a slight performance
      penalty, but I hope subsequent hacks make it up.

commit 73001b06f60206edfa4ae4ec6a8b5c8f65d272c2
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 16 16:25:19 2012 -0700

    fix replacement of CSE with lexical-ref
    
    * module/language/tree-il/cse.scm (cse): Fix dominator unrolling for
      lexical propagation.
    
    * test-suite/tests/cse.test ("cse"): Add test.

commit 3db8f60977e966522e3c05cc554c99382c968b55
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 16 12:42:31 2012 -0700

    cse hashing tweak
    
    * module/language/tree-il/cse.scm (cse): Minor tweak to hash depth based
      on time profile of compiling peval.scm.

commit 036c366dc2fbbeeb04d8984bb0819df28d9d455f
Author: Andy Wingo <address@hidden>
Date:   Sun Apr 15 13:41:05 2012 -0700

    more inlining in effects.scm
    
    * module/language/tree-il/effects.scm (define-effects)
      (&no-effects, &all-effects-but-bailout):
      (cause, &depends-on, &causes, depends-on-effects?)
      (causes-effects?, effects-commute?): Add ham-fisted inlining.

commit b3f25e62695315ab632d2e3a66d31bb490c82100
Author: Andy Wingo <address@hidden>
Date:   Sun Apr 15 13:39:56 2012 -0700

    better primitives support for bit operations
    
    * module/language/tree-il/primitives.scm
      (*interesting-primitive-names*): Add lognot.
      (*effect-free-primitives*): Add ash, logand, logior, logxor, and
      lognot.
      (logior, logand): Define associative expanders.

commit f7d8efc630ce45f5d82aae5b2682d261e5541d5f
Author: Andy Wingo <address@hidden>
Date:   Sun Apr 15 13:00:30 2012 -0700

    disable optimizations in goops dispatch procedures
    
    * module/oop/goops/dispatch.scm: Disable peval and cse.

commit 9068f4f52772397c5d4408f585ccdf1017869a3e
Author: Andy Wingo <address@hidden>
Date:   Fri Apr 13 15:23:20 2012 -0700

    enable cse
    
    * module/language/tree-il/optimize.scm: Enable CSE unless #:cse? #f is
      passed.
    
    * test-suite/tests/tree-il.test: Disable CSE for one test.

commit f66cbb99ee096186837536885d3436bb334df34d
Author: Andy Wingo <address@hidden>
Date:   Fri Apr 13 15:23:15 2012 -0700

    new pass: cse
    
    * module/language/tree-il/cse.scm: New pass, some simple common
      subexpression elimination with effects analysis.
    
    * test-suite/tests/cse.test: New test.
    
    * test-suite/Makefile.am:
    * module/Makefile.am: Adapt.

commit 1cd63115be7a25d0ea18aaa0e1eff5658d8db77a
Author: Andy Wingo <address@hidden>
Date:   Fri Apr 13 15:13:19 2012 -0700

    minor tweaks to a peval test
    
    * test-suite/tests/peval.test: Update mutable var test to really ensure
      that the function can't inline.

commit a36e7870c31322fd300c7478df24dbf559a0d67b
Author: Andy Wingo <address@hidden>
Date:   Thu Apr 12 16:46:18 2012 -0700

    peval uses effects analysis
    
    * module/language/tree-il/peval.scm: Use effects analysis from (language
      tree-il effects) instead of our own constant-expression?.  Eagerly
      mark assigned lexicals as non-copyable.

commit da9b2b71f76644abcc2eec2cc1478379df1e9025
Author: Andy Wingo <address@hidden>
Date:   Thu Apr 12 16:25:45 2012 -0700

    add effects
    
    * module/language/tree-il/effects.scm: New module, for effects
      analysis.
    * module/Makefile.am: Adapt.

commit de1eb420a5a95b17e85b19c4d98c869036e9ecb0
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 11 11:43:00 2012 -0700

    peval tests into separate file
    
    * test-suite/tests/tree-il.test ("partial evaluation"):
    * test-suite/tests/peval.test ("partial evaluation"): Separate peval
    * tests.
    
    * test-suite/Makefile.am: Adapt.

commit 5deea34d0eb3d2ec5db421eb79516e747eed5841
Author: Andy Wingo <address@hidden>
Date:   Tue Apr 10 15:47:21 2012 -0700

    add more primitives and predicates to (language tree-il primitives)
    
    * module/language/tree-il/primitives.scm
      (*interesting-primitive-names*): Add number? and char?.  Add more
      numeric predicates.  Add character comparators.  Add throw, error, and
      scm-error.
      (*primitive-accessors*): Remove struct-vtable.  Though the vtable's
      contents may change (through redefinition), its identity does not
      change.
      (*effect-free-primitives*): Put struct-vtable, number?, and char?
      here.
      (*multiply-valued-primitives*): Instead of listing singly-valued
      primitives, list multiply-valued primitives.
      (*bailout-primitives*): New list.
      (*negatable-primitives*): New alist.
      (*bailout-primitive-table*, *multiply-valued-primitive-table*)
      (*negatable-primitive-table*): New tables.
      (singly-valued-primitive?): Adapt to
      use *multiply-valued-primitive-table*.
      (bailout-primitive?, negate-primitive): New exported procedures.

-----------------------------------------------------------------------

Summary of changes:
 module/Makefile.am                     |    2 +
 module/ice-9/vlist.scm                 |  377 +++++++------
 module/language/tree-il/cse.scm        |  605 +++++++++++++++++++
 module/language/tree-il/effects.scm    |  335 +++++++++++
 module/language/tree-il/optimize.scm   |   16 +-
 module/language/tree-il/peval.scm      |  140 +++--
 module/language/tree-il/primitives.scm |  128 +++--
 module/oop/goops/dispatch.scm          |    6 +-
 test-suite/Makefile.am                 |    2 +
 test-suite/tests/cse.test              |  259 ++++++++
 test-suite/tests/peval.test            | 1002 ++++++++++++++++++++++++++++++++
 test-suite/tests/tree-il.test          |  967 +------------------------------
 12 files changed, 2570 insertions(+), 1269 deletions(-)
 create mode 100644 module/language/tree-il/cse.scm
 create mode 100644 module/language/tree-il/effects.scm
 create mode 100644 test-suite/tests/cse.test
 create mode 100644 test-suite/tests/peval.test

diff --git a/module/Makefile.am b/module/Makefile.am
index 9c9d8ed..b033f7b 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -96,12 +96,14 @@ SCHEME_LANG_SOURCES =                                       
        \
 TREE_IL_LANG_SOURCES =                                         \
   language/tree-il/primitives.scm                              \
   language/tree-il/peval.scm                                   \
+  language/tree-il/effects.scm                                         \
   language/tree-il/fix-letrec.scm                               \
   language/tree-il/optimize.scm                                 \
   language/tree-il/canonicalize.scm                             \
   language/tree-il/analyze.scm                                 \
   language/tree-il/inline.scm                                  \
   language/tree-il/compile-glil.scm                            \
+  language/tree-il/cse.scm                                     \
   language/tree-il/debug.scm                                   \
   language/tree-il/spec.scm
 
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 0ed4b6d..a09b374 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -69,26 +69,19 @@
 (define block-growth-factor
   (make-fluid 2))
 
-(define-syntax-rule (define-inline (name formals ...) body ...)
-  ;; Work around the lack of an inliner.
-  (define-syntax name
-    (syntax-rules ()
-      ((_ formals ...)
-       (begin body ...)))))
-
-(define-inline (make-block base offset size hash-tab?)
-  ;; Return a block (and block descriptor) of SIZE elements pointing to BASE
-  ;; at OFFSET.  If HASH-TAB? is true, a "hash table" is also added.
-  ;; Note: We use `next-free' instead of `last-used' as suggested by Bagwell.
-
-  ;; XXX: We could improve locality here by having a single vector but 
currently
-  ;; the extra arithmetic outweighs the benefits (!).
-  (vector (make-vector size)
-          base offset size 0
-          (and hash-tab? (make-vector size #f))))
+(define-inlinable (make-block base offset size hash-tab?)
+  ;; Return a block (and block descriptor) of SIZE elements pointing to
+  ;; BASE at OFFSET.  If HASH-TAB? is true, we also reserve space for a
+  ;; "hash table".  Note: We use `next-free' instead of `last-used' as
+  ;; suggested by Bagwell.
+  (if hash-tab?
+      (vector (make-vector (* size 3) #f)
+              base offset size 0)
+      (vector (make-vector size)
+              base offset size 0)))
 
 (define-syntax-rule (define-block-accessor name index)
-  (define-inline (name block)
+  (define-inlinable (name block)
     (vector-ref block index)))
 
 (define-block-accessor block-content 0)
@@ -96,33 +89,51 @@
 (define-block-accessor block-offset 2)
 (define-block-accessor block-size 3)
 (define-block-accessor block-next-free 4)
-(define-block-accessor block-hash-table 5)
 
-(define-inline (increment-block-next-free! block)
-  (vector-set! block 4
-               (+ (block-next-free block) 1)))
+(define-inlinable (block-hash-table? block)
+  (< (block-size block) (vector-length (block-content block))))
 
-(define-inline (block-append! block value)
-  ;; This is not thread-safe.  To fix it, see Section 2.8 of the paper.
-  (let ((offset (block-next-free block)))
-    (increment-block-next-free! block)
-    (vector-set! (block-content block) offset value)
-    #t))
-
-(define-inline (block-ref block offset)
-  (vector-ref (block-content block) offset))
-
-(define-inline (block-ref* block offset)
-  (let ((v (block-ref block offset)))
-    (if (block-hash-table block)
-        (car v) ;; hide the vhash link
-        v)))
-
-(define-inline (block-hash-table-ref block offset)
-  (vector-ref (block-hash-table block) offset))
+(define-inlinable (set-block-next-free! block next-free)
+  (vector-set! block 4 next-free))
 
-(define-inline (block-hash-table-set! block offset value)
-  (vector-set! (block-hash-table block) offset value))
+(define-inlinable (block-append! block value offset)
+  ;; This is not thread-safe.  To fix it, see Section 2.8 of the paper.
+  (and (< offset (block-size block))
+       (= offset (block-next-free block))
+       (begin
+         (set-block-next-free! block (1+ offset))
+         (vector-set! (block-content block) offset value)
+         #t)))
+
+;; Return the item at slot OFFSET.
+(define-inlinable (block-ref content offset)
+  (vector-ref content offset))
+
+;; Return the offset of the next item in the hash bucket, after the one
+;; at OFFSET.
+(define-inlinable (block-hash-table-next-offset content size offset)
+  (vector-ref content (+ size size offset)))
+
+;; Save the offset of the next item in the hash bucket, after the one
+;; at OFFSET.
+(define-inlinable (block-hash-table-set-next-offset! content size offset
+                                                     next-offset)
+  (vector-set! content (+ size size offset) next-offset))
+
+;; Returns the index of the last entry stored in CONTENT with
+;; SIZE-modulo hash value KHASH.
+(define-inlinable (block-hash-table-ref content size khash)
+  (vector-ref content (+ size khash)))
+
+(define-inlinable (block-hash-table-set! content size khash offset)
+  (vector-set! content (+ size khash) offset))
+
+;; Add hash table information for the item recently added at OFFSET,
+;; with SIZE-modulo hash KHASH.
+(define-inlinable (block-hash-table-add! content size khash offset)
+  (block-hash-table-set-next-offset! content size offset
+                                     (block-hash-table-ref content size khash))
+  (block-hash-table-set! content size khash offset))
 
 (define block-null
   ;; The null block.
@@ -149,13 +160,10 @@
                           (lambda (vl port)
                             (cond ((vlist-null? vl)
                                    (format port "#<vlist ()>"))
-                                  ((block-hash-table (vlist-base vl))
+                                  ((vhash? vl)
                                    (format port "#<vhash ~x ~a pairs>"
                                            (object-address vl)
-                                           (vhash-fold (lambda (k v r)
-                                                         (+ 1 r))
-                                                       0
-                                                       vl)))
+                                           (vlist-length vl)))
                                   (else
                                    (format port "#<vlist ~a>"
                                            (vlist->list vl))))))
@@ -165,42 +173,61 @@
   ;; The empty vlist.
   (make-vlist block-null 0))
 
-(define-inline (block-cons item vlist hash-tab?)
-  (let loop ((base   (vlist-base vlist))
-             (offset (+ 1 (vlist-offset vlist))))
-    (if (and (< offset (block-size base))
-             (= offset (block-next-free base))
-             (block-append! base item))
-        (make-vlist base offset)
-        (let ((size (cond ((eq? base block-null) 1)
-                          ((< offset (block-size base))
-                           ;; new vlist head
-                           1)
-                          (else
-                           (* (fluid-ref block-growth-factor)
-                              (block-size base))))))
-          ;; Prepend a new block pointing to BASE.
-          (loop (make-block base (- offset 1) size hash-tab?)
-                0)))))
+;; Asserting that something is a vlist is actually a win if your next
+;; step is to call record accessors, because that causes CSE to
+;; eliminate the type checks in those accessors.
+;;
+(define-inlinable (assert-vlist val)
+  (unless (vlist? val)
+    (throw 'wrong-type-arg
+           #f
+           "Not a vlist: ~S"
+           (list val)
+           (list val))))
+
+(define-inlinable (block-cons item vlist hash-tab?)
+  (let ((base (vlist-base vlist))
+        (offset (1+ (vlist-offset vlist))))
+    (cond
+     ((block-append! base item offset)
+      ;; Fast path: We added the item directly to the block.
+      (make-vlist base offset))
+     (else
+      ;; Slow path: Allocate a new block.
+      (let* ((size (block-size base))
+             (base (make-block
+                    base
+                    (1- offset)
+                    (cond
+                     ((zero? size) 1)
+                     ((< offset size) 1) ;; new vlist head
+                     (else (* (fluid-ref block-growth-factor) size)))
+                    hash-tab?)))
+        (set-block-next-free! base 1)
+        (vector-set! (block-content base) 0 item)
+        (make-vlist base 0))))))
 
 (define (vlist-cons item vlist)
   "Return a new vlist with @var{item} as its head and @var{vlist} as its
 tail."
-  ;; Note: Calling `vlist-cons' on a vhash will not do the right thing: it
-  ;; doesn't box ITEM so that it can have the hidden "next" link used by
-  ;; vhash items, and it passes `#f' as the HASH-TAB? argument to
-  ;; `block-cons'.  However, inserting all the checks here has an important
-  ;; performance penalty, hence this choice.
+  ;; Note: Although the result of `vlist-cons' on a vhash is a valid
+  ;; vlist, it is not a valid vhash.  The new item does not get a hash
+  ;; table entry.  If we allocate a new block, the new block will not
+  ;; have a hash table.  Perhaps we can do something more sensible here,
+  ;; but this is a hot function, so there are performance impacts.
+  (assert-vlist vlist)
   (block-cons item vlist #f))
 
 (define (vlist-head vlist)
   "Return the head of @var{vlist}."
+  (assert-vlist vlist)
   (let ((base   (vlist-base vlist))
         (offset (vlist-offset vlist)))
-    (block-ref* base offset)))
+    (block-ref (block-content base) offset)))
 
 (define (vlist-tail vlist)
   "Return the tail of @var{vlist}."
+  (assert-vlist vlist)
   (let ((base   (vlist-base vlist))
         (offset (vlist-offset vlist)))
     (if (> offset 0)
@@ -210,6 +237,7 @@ tail."
 
 (define (vlist-null? vlist)
   "Return true if @var{vlist} is empty."
+  (assert-vlist vlist)
   (let ((base (vlist-base vlist)))
     (and (not (block-base base))
          (= 0 (block-size base)))))
@@ -226,6 +254,7 @@ tail."
 (define (vlist-fold proc init vlist)
   "Fold over @var{vlist}, calling @var{proc} for each element."
   ;; FIXME: Handle multiple lists.
+  (assert-vlist vlist)
   (let loop ((base   (vlist-base vlist))
              (offset (vlist-offset vlist))
              (result init))
@@ -235,19 +264,18 @@ tail."
                (done? (< next 0)))
           (loop (if done? (block-base base) base)
                 (if done? (block-offset base) next)
-                (proc (block-ref* base offset) result))))))
+                (proc (block-ref (block-content base) offset) result))))))
 
 (define (vlist-fold-right proc init vlist)
   "Fold over @var{vlist}, calling @var{proc} for each element, starting from
 the last element."
-  (define len (vlist-length vlist))
-
-  (let loop ((index  (1- len))
+  (assert-vlist vlist)
+  (let loop ((index  (1- (vlist-length vlist)))
              (result init))
     (if (< index 0)
         result
         (loop (1- index)
-              (proc (vlist-ref vlist index) result)))))
+          (proc (vlist-ref vlist index) result)))))
 
 (define (vlist-reverse vlist)
   "Return a new @var{vlist} whose content are those of @var{vlist} in reverse
@@ -267,11 +295,12 @@ order."
 
 (define (vlist-ref vlist index)
   "Return the element at index @var{index} in @var{vlist}."
+  (assert-vlist vlist)
   (let loop ((index   index)
              (base    (vlist-base vlist))
              (offset  (vlist-offset vlist)))
     (if (<= index offset)
-        (block-ref* base (- offset index))
+        (block-ref (block-content base) (- offset index))
         (loop (- index offset 1)
               (block-base base)
               (block-offset base)))))
@@ -279,6 +308,7 @@ order."
 (define (vlist-drop vlist count)
   "Return a new vlist that does not contain the @var{count} first elements of
 @var{vlist}."
+  (assert-vlist vlist)
   (let loop ((count  count)
              (base   (vlist-base vlist))
              (offset (vlist-offset vlist)))
@@ -319,6 +349,7 @@ satisfy @var{pred}."
 
 (define (vlist-length vlist)
   "Return the length of @var{vlist}."
+  (assert-vlist vlist)
   (let loop ((base (vlist-base vlist))
              (len  (vlist-offset vlist)))
     (if (eq? base block-null)
@@ -371,98 +402,94 @@ details."
 ;; associated with K1 and K2, respectively.  The resulting layout is a
 ;; follows:
 ;;
-;;     ,--------------------.
-;;     | ,-> (K1 . V1) ---. |
-;;     | |                | |
-;;     | |   (K2 . V2) <--' |
-;;     | |                  |
-;;     +-|------------------+
-;;     | |                  |
-;;     | |                  |
-;;     | `-- O <---------------H
-;;     |                    |
-;;     `--------------------'
+;;             ,--------------------.
+;;            0| ,-> (K1 . V1)      | Vlist array
+;;            1| |                  |
+;;            2| |   (K2 . V2)      |
+;;            3| |                  |
+;;        size +-|------------------+
+;;            0| |                  | Hash table
+;;            1| |                  |
+;;            2| +-- O <------------- H
+;;            3| |                  |
+;;    size * 2 +-|------------------+
+;;            0| `-> 2              | Chain links
+;;            1|                    |
+;;            2|    #f              |
+;;            3|                    |
+;;    size * 3 `--------------------'
+;;
+;; The backing store for the vhash is partitioned into three areas: the
+;; vlist part, the hash table part, and the chain links part.  In this
+;; example we have a hash H which, when indexed into the hash table
+;; part, indicates that a value with this hash can be found at offset 0
+;; in the vlist part.  The corresponding index (in this case, 0) of the
+;; chain links array holds the index of the next element in this block
+;; with this hash value, or #f if we reached the end of the chain.
 ;;
-;; The bottom part is the "hash table" part of the vhash, as returned by
-;; `block-hash-table'; the other half is the data part.  O is the offset of
-;; the first value associated with a key that hashes to H in the data part.
-;; The (K1 . V1) pair has a "hidden" link to the (K2 . V2) pair; hiding the
-;; link is handled by `block-ref'.
-
-;; This API potentially requires users to repeat which hash function and which
-;; equality predicate to use.  This can lead to unpredictable results if they
-;; are used in consistenly, e.g., between `vhash-cons' and `vhash-assoc', which
-;; is undesirable, as argued in http://savannah.gnu.org/bugs/?22159 .  OTOH, 
two
-;; arguments can be made in favor of this API:
+;; This API potentially requires users to repeat which hash function and
+;; which equality predicate to use.  This can lead to unpredictable
+;; results if they are used in consistenly, e.g., between `vhash-cons'
+;; and `vhash-assoc', which is undesirable, as argued in
+;; http://savannah.gnu.org/bugs/?22159 .  OTOH, two arguments can be
+;; made in favor of this API:
 ;;
 ;;  - It's consistent with how alists are handled in SRFI-1.
 ;;
-;;  - In practice, users will probably consistenly use either the `q', the `v',
-;;    or the plain variant (`vlist-cons' and `vlist-assoc' without any optional
-;;    argument), i.e., they will rarely explicitly pass a hash function or
-;;    equality predicate.
+;;  - In practice, users will probably consistenly use either the `q',
+;;    the `v', or the plain variant (`vlist-cons' and `vlist-assoc'
+;;    without any optional argument), i.e., they will rarely explicitly
+;;    pass a hash function or equality predicate.
 
 (define (vhash? obj)
   "Return true if @var{obj} is a hash list."
   (and (vlist? obj)
-       (let ((base (vlist-base obj)))
-         (and base
-              (vector? (block-hash-table base))))))
+       (block-hash-table? (vlist-base obj))))
 
 (define* (vhash-cons key value vhash #:optional (hash hash))
   "Return a new hash list based on @var{vhash} where @var{key} is associated
 with @var{value}.  Use @var{hash} to compute @var{key}'s hash."
-  (let* ((key+value (cons key value))
-         (entry     (cons key+value #f))
-         (vlist     (block-cons entry vhash #t))
-         (base      (vlist-base vlist))
-         (khash     (hash key (block-size base))))
-
-    (let ((o (block-hash-table-ref base khash)))
-      (if o (set-cdr! entry o)))
-
-    (block-hash-table-set! base khash
-                           (vlist-offset vlist))
-
-    vlist))
+  (assert-vlist vhash)
+  ;; We should also assert that it is a hash table.  Need to check the
+  ;; performance impacts of that.  Also, vlist-null is a valid hash
+  ;; table, which does not pass vhash?.  A bug, perhaps.
+  (let* ((vhash     (block-cons (cons key value) vhash #t))
+         (base      (vlist-base vhash))
+         (offset    (vlist-offset vhash))
+         (size      (block-size base))
+         (khash     (hash key size))
+         (content   (block-content base)))
+    (block-hash-table-add! content size khash offset)
+    vhash))
 
 (define vhash-consq (cut vhash-cons <> <> <> hashq))
 (define vhash-consv (cut vhash-cons <> <> <> hashv))
 
-(define-inline (%vhash-fold* proc init key vhash equal? hash)
+(define-inlinable (%vhash-fold* proc init key vhash equal? hash)
   ;; Fold over all the values associated with KEY in VHASH.
-  (define khash
-    (let ((size (block-size (vlist-base vhash))))
-      (and (> size 0) (hash key size))))
-
-  (let loop ((base       (vlist-base vhash))
-             (khash      khash)
-             (offset     (and khash
-                              (block-hash-table-ref (vlist-base vhash)
-                                                    khash)))
-             (max-offset (vlist-offset vhash))
-             (result     init))
-
-    (let ((answer (and offset (block-ref base offset))))
-      (cond ((and (pair? answer)
-                  (<= offset max-offset)
-                  (let ((answer-key (caar answer)))
-                    (equal? key answer-key)))
-             (let ((result      (proc (cdar answer) result))
-                   (next-offset (cdr answer)))
-               (loop base khash next-offset max-offset result)))
-            ((and (pair? answer) (cdr answer))
-             =>
-             (lambda (next-offset)
-               (loop base khash next-offset max-offset result)))
-            (else
-             (let ((next-base (block-base base)))
-               (if (and next-base (> (block-size next-base) 0))
-                   (let* ((khash  (hash key (block-size next-base)))
-                          (offset (block-hash-table-ref next-base khash)))
-                     (loop next-base khash offset (block-offset base)
-                           result))
-                   result)))))))
+  (define (visit-block base max-offset result)
+    (let* ((size (block-size base))
+           (content (block-content base))
+           (khash (hash key size)))
+      (let loop ((offset (block-hash-table-ref content size khash))
+                 (result result))
+        (if offset
+            (loop (block-hash-table-next-offset content size offset)
+                  (if (and (<= offset max-offset)
+                           (equal? key (car (block-ref content offset))))
+                      (proc (cdr (block-ref content offset)) result)
+                      result))
+            (let ((next-block (block-base base)))
+              (if (> (block-size next-block) 0)
+                  (visit-block next-block (block-offset base) result)
+                  result))))))
+
+  (assert-vlist vhash)
+  (if (> (block-size (vlist-base vhash)) 0)
+      (visit-block (vlist-base vhash)
+                   (vlist-offset vhash)
+                   init)
+      init))
 
 (define* (vhash-fold* proc init key vhash
                       #:optional (equal? equal?) (hash hash))
@@ -480,39 +507,29 @@ value of @var{result} for the first call to @var{proc}."
   "Same as @code{vhash-fold*}, but using @code{hashv} and @code{eqv?}."
   (%vhash-fold* proc init key vhash eqv? hashv))
 
-(define-inline (%vhash-assoc key vhash equal? hash)
+(define-inlinable (%vhash-assoc key vhash equal? hash)
   ;; A specialization of `vhash-fold*' that stops when the first value
   ;; associated with KEY is found or when the end-of-list is reached.  Inline 
to
   ;; make sure `vhash-assq' gets to use the `eq?' instruction instead of 
calling
   ;; the `eq?'  subr.
-  (define khash
-    (let ((size (block-size (vlist-base vhash))))
-      (and (> size 0) (hash key size))))
-
-  (let loop ((base       (vlist-base vhash))
-             (khash      khash)
-             (offset     (and khash
-                              (block-hash-table-ref (vlist-base vhash)
-                                                    khash)))
-             (max-offset (vlist-offset vhash)))
-    (let ((answer (and offset (block-ref base offset))))
-      (cond ((and (pair? answer)
-                  (<= offset max-offset)
-                  (let ((answer-key (caar answer)))
-                    (equal? key answer-key)))
-             (car answer))
-            ((and (pair? answer) (cdr answer))
-             =>
-             (lambda (next-offset)
-               (loop base khash next-offset max-offset)))
-            (else
-             (let ((next-base (block-base base)))
-               (and next-base
-                    (> (block-size next-base) 0)
-                    (let* ((khash  (hash key (block-size next-base)))
-                           (offset (block-hash-table-ref next-base khash)))
-                      (loop next-base khash offset
-                            (block-offset base))))))))))
+  (define (visit-block base max-offset)
+    (let* ((size (block-size base))
+           (content (block-content base))
+           (khash (hash key size)))
+      (let loop ((offset (block-hash-table-ref content size khash)))
+        (if offset
+            (if (and (<= offset max-offset)
+                     (equal? key (car (block-ref content offset))))
+                (block-ref content offset)
+                (loop (block-hash-table-next-offset content size offset)))
+            (let ((next-block (block-base base)))
+              (and (> (block-size next-block) 0)
+                   (visit-block next-block (block-offset base))))))))
+
+  (assert-vlist vhash)
+  (and (> (block-size (vlist-base vhash)) 0)
+       (visit-block (vlist-base vhash)
+                    (vlist-offset vhash))))
 
 (define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
   "Return the first key/value pair from @var{vhash} whose key is equal to
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
new file mode 100644
index 0000000..f55c481
--- /dev/null
+++ b/module/language/tree-il/cse.scm
@@ -0,0 +1,605 @@
+;;; Common Subexpression Elimination (CSE) on Tree-IL
+
+;; Copyright (C) 2011, 2012 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 (language tree-il cse)
+  #:use-module (language tree-il)
+  #:use-module (language tree-il primitives)
+  #:use-module (language tree-il effects)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:export (cse))
+
+;;;
+;;; This pass eliminates common subexpressions in Tree-IL.  It works
+;;; best locally -- within a function -- so it is meant to be run after
+;;; partial evaluation, which usually inlines functions and so opens up
+;;; a bigger space for CSE to work.
+;;;
+;;; The algorithm traverses the tree of expressions, returning two
+;;; values: the newly rebuilt tree, and a "database".  The database is
+;;; the set of expressions that will have been evaluated as part of
+;;; evaluating an expression.  For example, in:
+;;;
+;;;   (1- (+ (if a b c) (* x y)))
+;;;
+;;; We can say that when it comes time to evaluate (1- <>), that the
+;;; subexpressions +, x, y, and (* x y) must have been evaluated in
+;;; values context.  We know that a was evaluated in test context, but
+;;; we don't know if it was true or false.
+;;;
+;;; The expressions in the database /dominate/ any subsequent
+;;; expression: FOO dominates BAR if evaluation of BAR implies that any
+;;; effects associated with FOO have already occured.
+;;;
+;;; When adding expressions to the database, we record the context in
+;;; which they are evaluated.  We treat expressions in test context
+;;; specially: the presence of such an expression indicates that the
+;;; expression is true.  In this way we can elide duplicate predicates.
+;;;
+;;; Duplicate predicates are not common in code that users write, but
+;;; can occur quite frequently in macro-generated code.
+;;;
+;;; For example:
+;;;
+;;;   (and (foo? x) (foo-bar x))
+;;;   => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;          (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;              (struct-ref x 1)
+;;;              (throw 'not-a-foo))
+;;;          #f))
+;;;   => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;          (struct-ref x 1)
+;;;          #f)
+;;;
+;;; A conditional bailout in effect context also has the effect of
+;;; adding predicates to the database:
+;;;
+;;;   (begin (foo-bar x) (foo-baz x))
+;;;   => (begin
+;;;        (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;            (struct-ref x 1)
+;;;            (throw 'not-a-foo))
+;;;        (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;            (struct-ref x 2)
+;;;            (throw 'not-a-foo)))
+;;;   => (begin
+;;;        (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;            (struct-ref x 1)
+;;;            (throw 'not-a-foo))
+;;;        (struct-ref x 2))
+;;;
+;;; When removing code, we have to ensure that the semantics of the
+;;; source program and the residual program are the same.  It's easy to
+;;; ensure that they have the same value, because those manipulations
+;;; are just algebraic, but the tricky thing is to ensure that the
+;;; expressions exhibit the same ordering of effects.  For that, we use
+;;; the effects analysis of (language tree-il effects).  We only
+;;; eliminate code if the duplicate code commutes with all of the
+;;; dominators on the path from the duplicate to the original.
+;;;
+;;; The implementation uses vhashes as the fundamental data structure.
+;;; This can be seen as a form of global value numbering.  This
+;;; algorithm currently spends most of its time in vhash-assoc.  I'm not
+;;; sure whether that is due to our bad hash function in Guile 2.0, an
+;;; inefficiency in vhashes, or what.  Overall though the complexity
+;;; should be linear, or N log N -- whatever vhash-assoc's complexity
+;;; is.  Walking the dominators is nonlinear, but that only happens when
+;;; we've actually found a common subexpression so that should be OK.
+;;;
+
+;; Logging helpers, as in peval.
+;;
+(define-syntax *logging* (identifier-syntax #f))
+;; (define %logging #f)
+;; (define-syntax *logging* (identifier-syntax %logging))
+(define-syntax log
+  (syntax-rules (quote)
+    ((log 'event arg ...)
+     (if (and *logging*
+              (or (eq? *logging* #t)
+                  (memq 'event *logging*)))
+         (log* 'event arg ...)))))
+(define (log* event . args)
+  (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print))
+                        'pretty-print)))
+    (pp `(log ,event . ,args))
+    (newline)
+    (values)))
+
+;; A pre-pass on the source program to determine the set of assigned
+;; lexicals.
+;;
+(define* (build-assigned-var-table exp #:optional (table vlist-null))
+  (tree-il-fold
+   (lambda (exp res)
+     res)
+   (lambda (exp res)
+     (match exp
+       (($ <lexical-set> src name gensym exp)
+        (vhash-consq gensym #t res))
+       (_ res)))
+   (lambda (exp res) res)
+   table exp))
+
+(define (boolean-valued-primitive? primitive)
+  (or (negate-primitive primitive)
+      (eq? primitive 'not)
+      (let ((chars (symbol->string primitive)))
+        (eqv? (string-ref chars (1- (string-length chars)))
+              #\?))))
+
+(define (boolean-valued-expression? x ctx)
+  (match x
+    (($ <application> _
+        ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t)
+    (($ <const> _ (? boolean?)) #t)
+    (_ (eq? ctx 'test))))
+
+(define* (cse exp)
+  "Eliminate common subexpressions in EXP."
+
+  (define assigned-lexical?
+    (let ((table (build-assigned-var-table exp)))
+      (lambda (sym)
+        (vhash-assq sym table))))
+
+  (define compute-effects
+    (make-effects-analyzer assigned-lexical?))
+
+  (define (negate exp ctx)
+    (match exp
+      (($ <const> src x)
+       (make-const src (not x)))
+      (($ <void> src)
+       (make-const src #f))
+      (($ <conditional> src test consequent alternate)
+       (make-conditional src test (negate consequent ctx) (negate alternate 
ctx)))
+      (($ <application> _ ($ <primitive-ref> _ 'not)
+          ((and x (? (cut boolean-valued-expression? <> ctx)))))
+       x)
+      (($ <application> src
+          ($ <primitive-ref> _ (and pred (? negate-primitive)))
+          args)
+       (make-application src
+                         (make-primitive-ref #f (negate-primitive pred))
+                         args))
+      (_
+       (make-application #f (make-primitive-ref #f 'not) (list exp)))))
+
+  
+  (define (bailout? exp)
+    (causes-effects? (compute-effects exp) &definite-bailout))
+
+  (define (struct-nfields x)
+    (/ (string-length (symbol->string (struct-layout x))) 2))
+
+  (define hash-bits (logcount most-positive-fixnum))
+  (define hash-depth 4)
+  (define hash-width 3)
+  (define (hash-expression exp)
+    (define (hash-exp exp depth)
+      (define (rotate x bits)
+        (logior (ash x (- bits))
+                (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
+      (define (mix h1 h2)
+        (logxor h1 (rotate h2 8)))
+      (define (hash-struct s)
+        (let ((len (struct-nfields s))
+              (h (hashq (struct-vtable s) most-positive-fixnum)))
+          (if (zero? depth)
+              h
+              (let lp ((i (max (- len hash-width) 1)) (h h))
+                (if (< i len)
+                    (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
+                    h)))))
+      (define (hash-list l)
+        (let ((h (hashq 'list most-positive-fixnum)))
+          (if (zero? depth)
+              h
+              (let lp ((l l) (width 0) (h h))
+                (if (< width hash-width)
+                    (lp (cdr l) (1+ width)
+                        (mix (hash-exp (car l) (1+ depth)) h))
+                    h)))))
+      (cond
+       ((struct? exp) (hash-struct exp))
+       ((list? exp) (hash-list exp))
+       (else (hash exp most-positive-fixnum))))
+    (hash-exp exp 0))
+
+  (define (expressions-equal? a b)
+    (cond
+     ((struct? a)
+      (and (struct? b)
+           (eq? (struct-vtable a) (struct-vtable b))
+           ;; Assume that all structs are tree-il, so we skip over the
+           ;; src slot.
+           (let lp ((n (1- (struct-nfields a))))
+             (or (zero? n)
+                 (and (expressions-equal? (struct-ref a n) (struct-ref b n))
+                      (lp (1- n)))))))
+     ((pair? a)
+      (and (pair? b)
+           (expressions-equal? (car a) (car b))
+           (expressions-equal? (cdr a) (cdr b))))
+     (else
+      (equal? a b))))
+
+  (define (hasher n)
+    (lambda (x size) (modulo n size)))
+
+  (define (add-to-db exp effects ctx db)
+    (let ((v (vector exp effects ctx))
+          (h (hash-expression exp)))
+      (vhash-cons v h db (hasher h))))
+
+  (define (control-flow-boundary db)
+    (let ((h (hashq 'lambda most-positive-fixnum)))
+      (vhash-cons 'lambda h db (hasher h))))
+
+  (define (find-dominating-expression exp effects ctx db)
+    (define (entry-matches? v1 v2)
+      (match (if (vector? v1) v1 v2)
+        (#(exp* effects* ctx*)
+         (and (expressions-equal? exp exp*)
+              (or (not ctx) (eq? ctx* ctx))))
+        (_ #f)))
+      
+    (let ((len (vlist-length db))
+          (h (hash-expression exp)))
+      (and (vhash-assoc #t db entry-matches? (hasher h))
+           (let lp ((n 0))
+             (and (< n len)
+                  (match (vlist-ref db n)
+                    (('lambda . h*)
+                     ;; We assume that lambdas can escape and thus be
+                     ;; called from anywhere.  Thus code inside a lambda
+                     ;; only has a dominating expression if it does not
+                     ;; depend on any effects.
+                     (and (not (depends-on-effects? effects &all-effects))
+                          (lp (1+ n))))
+                    ((#(exp* effects* ctx*) . h*)
+                     (log 'walk (unparse-tree-il exp) effects
+                          (unparse-tree-il exp*) effects* ctx*)
+                     (or (and (= h h*)
+                              (or (not ctx) (eq? ctx ctx*))
+                              (expressions-equal? exp exp*))
+                         (and (effects-commute? effects effects*)
+                              (lp (1+ n)))))))))))
+
+  ;; Return #t if EXP is dominated by an instance of itself.  In that
+  ;; case, we can exclude *type-check* effects, because the first
+  ;; expression already caused them if needed.
+  (define (has-dominating-effect? exp effects db)
+    (or (constant? effects)
+        (and
+         (effect-free?
+          (exclude-effects effects
+                           (logior &zero-values
+                                   &allocation
+                                   &type-check)))
+         (find-dominating-expression exp effects #f db))))
+
+  (define (find-dominating-test exp effects db)
+    (and
+     (effect-free?
+      (exclude-effects effects (logior &allocation
+                                       &type-check)))
+     (match exp
+       (($ <const> src val)
+        (if (boolean? val)
+            exp
+            (make-const src (not (not val)))))
+       ;; For (not FOO), try to prove FOO, then negate the result.
+       (($ <application> src ($ <primitive-ref> _ 'not) (exp*))
+        (match (find-dominating-test exp* effects db)
+          (($ <const> _ val)
+           (log 'inferring exp (not val))
+           (make-const src (not val)))
+          (_
+           #f)))
+       (_
+        (cond
+         ((find-dominating-expression exp effects #f db)
+          ;; We have an EXP fact, so we infer #t.
+          (log 'inferring exp #t)
+          (make-const (tree-il-src exp) #t))
+         ((find-dominating-expression (negate exp 'test) effects #f db)
+          ;; We have a (not EXP) fact, so we infer #f.
+          (log 'inferring exp #f)
+          (make-const (tree-il-src exp) #f))
+         (else
+          ;; Otherwise we don't know.
+          #f))))))
+
+  (define (add-to-env exp name sym db env)
+    (let* ((v (vector exp name sym (vlist-length db)))
+           (h (hash-expression exp)))
+      (vhash-cons v h env (hasher h))))
+
+  (define (augment-env env names syms exps db)
+    (if (null? names)
+        env
+        (let ((name (car names)) (sym (car syms)) (exp (car exps)))
+          (augment-env (if (or (assigned-lexical? sym)
+                               (lexical-ref? exp))
+                           env
+                           (add-to-env exp name sym db env))
+                       (cdr names) (cdr syms) (cdr exps) db))))
+
+  (define (find-dominating-lexical exp effects env db)
+    (define (entry-matches? v1 v2)
+      (match (if (vector? v1) v1 v2)
+        (#(exp* name sym db)
+         (expressions-equal? exp exp*))
+        (_ #f)))
+      
+    (define (unroll db base n)
+      (or (zero? n)
+          (match (vlist-ref db base)
+            (('lambda . h*)
+             ;; See note in find-dominating-expression.
+             (and (not (depends-on-effects? effects &all-effects))
+                  (unroll db (1+ base) (1- n))))
+            ((#(exp* effects* ctx*) . h*)
+             (and (effects-commute? effects effects*)
+                  (unroll db (1+ base) (1- n)))))))
+
+    (let ((h (hash-expression exp)))
+      (and (effect-free? (exclude-effects effects &type-check))
+           (vhash-assoc exp env entry-matches? (hasher h))
+           (let ((env-len (vlist-length env))
+                 (db-len (vlist-length db)))
+             (let lp ((n 0) (m 0))
+               (and (< n env-len)
+                    (match (vlist-ref env n)
+                      ((#(exp* name sym db-len*) . h*)
+                       (and (unroll db m (- db-len db-len*))
+                            (if (and (= h h*) (expressions-equal? exp* exp))
+                                (make-lexical-ref (tree-il-src exp) name sym)
+                                (lp (1+ n) (- db-len db-len*))))))))))))
+
+  (define (intersection db+ db-)
+    (vhash-fold-right
+     (lambda (k h out)
+       (if (vhash-assoc k db- equal? (hasher h))
+           (vhash-cons k h out (hasher h))
+           out))
+     vlist-null
+     db+))
+
+  (define (concat db1 db2)
+    (vhash-fold-right (lambda (k h tail)
+                        (vhash-cons k h tail (hasher h)))
+                      db2 db1))
+
+  (let visit ((exp   exp)
+              (db vlist-null) ; dominating expressions: #(exp effects ctx) -> 
hash
+              (env vlist-null) ; named expressions: #(exp name sym db) -> hash
+              (ctx 'values)) ; test, effect, value, or values
+    
+    (define (parallel-visit exps db env ctx)
+      (let lp ((in exps) (out '()) (db* vlist-null))
+        (if (pair? in)
+            (call-with-values (lambda () (visit (car in) db env ctx))
+              (lambda (x db**)
+                (lp (cdr in) (cons x out) (concat db** db*))))
+            (values (reverse out) db*))))
+
+    (define (return exp db*)
+      (let ((effects (compute-effects exp)))
+        (cond
+         ((and (eq? ctx 'effect)
+               (not (lambda-case? exp))
+               (or (effect-free?
+                    (exclude-effects effects
+                                     (logior &zero-values
+                                             &allocation)))
+                   (has-dominating-effect? exp effects db)))
+          (cond
+           ((void? exp)
+            (values exp db*))
+           (else
+            (log 'elide ctx (unparse-tree-il exp))
+            (values (make-void #f) db*))))
+         ((and (boolean-valued-expression? exp ctx)
+               (find-dominating-test exp effects db))
+          => (lambda (exp)
+               (log 'propagate-test ctx (unparse-tree-il exp))
+               (values exp db*)))
+         ((and (eq? ctx 'value)
+               (find-dominating-lexical exp effects env db))
+          => (lambda (exp)
+               (log 'propagate-value ctx (unparse-tree-il exp))
+               (values exp db*)))
+         ((and (constant? effects) (memq ctx '(value values)))
+          ;; Adds nothing to the db.
+          (values exp db*))
+         (else
+          (log 'return ctx effects (unparse-tree-il exp) db*)
+          (values exp
+                  (add-to-db exp effects ctx db*))))))
+
+    (log 'visit ctx (unparse-tree-il exp) db env)
+
+    (match exp
+      (($ <const>)
+       (return exp vlist-null))
+      (($ <void>)
+       (return exp vlist-null))
+      (($ <lexical-ref> _ _ gensym)
+       (return exp vlist-null))
+      (($ <lexical-set> src name gensym exp)
+       (let*-values (((exp db*) (visit exp db env 'value)))
+         (return (make-lexical-set src name gensym exp)
+                 db*)))
+      (($ <let> src names gensyms vals body)
+       (let*-values (((vals db*) (parallel-visit vals db env 'value))
+                     ((body db**) (visit body (concat db* db)
+                                         (augment-env env names gensyms vals 
db)
+                                         ctx)))
+         (return (make-let src names gensyms vals body)
+                 (concat db** db*))))
+      (($ <letrec> src in-order? names gensyms vals body)
+       (let*-values (((vals db*) (parallel-visit vals db env 'value))
+                     ((body db**) (visit body (concat db* db)
+                                         (augment-env env names gensyms vals 
db)
+                                         ctx)))
+         (return (make-letrec src in-order? names gensyms vals body)
+                 (concat db** db*))))
+      (($ <fix> src names gensyms vals body)
+       (let*-values (((vals db*) (parallel-visit vals db env 'value))
+                     ((body db**) (visit body (concat db* db) env ctx)))
+         (return (make-fix src names gensyms vals body)
+                 (concat db** db*))))
+      (($ <let-values> src producer consumer)
+       (let*-values (((producer db*) (visit producer db env 'values))
+                     ((consumer db**) (visit consumer (concat db* db) env 
ctx)))
+         (return (make-let-values src producer consumer)
+                 (concat db** db*))))
+      (($ <dynwind> src winder body unwinder)
+       (let*-values (((pre db*) (visit winder db env 'value))
+                     ((body db**) (visit body (concat db* db) env ctx))
+                     ((post db***) (visit unwinder db env 'value)))
+         (return (make-dynwind src pre body post)
+                 (concat db* (concat db** db***)))))
+      (($ <dynlet> src fluids vals body)
+       (let*-values (((fluids db*) (parallel-visit fluids db env 'value))
+                     ((vals db**) (parallel-visit vals db env 'value))
+                     ((body db***) (visit body (concat db** (concat db* db))
+                                          env ctx)))
+         (return (make-dynlet src fluids vals body)
+                 (concat db*** (concat db** db*)))))
+      (($ <dynref> src fluid)
+       (let*-values (((fluid db*) (visit fluid db env 'value)))
+         (return (make-dynref src fluid)
+                 db*)))
+      (($ <dynset> src fluid exp)
+       (let*-values (((fluid db*) (visit fluid db env 'value))
+                     ((exp db**) (visit exp db env 'value)))
+         (return (make-dynset src fluid exp)
+                 (concat db** db*))))
+      (($ <toplevel-ref>)
+       (return exp vlist-null))
+      (($ <module-ref>)
+       (return exp vlist-null))
+      (($ <module-set> src mod name public? exp)
+       (let*-values (((exp db*) (visit exp db env 'value)))
+         (return (make-module-set src mod name public? exp)
+                 db*)))
+      (($ <toplevel-define> src name exp)
+       (let*-values (((exp db*) (visit exp db env 'value)))
+         (return (make-toplevel-define src name exp)
+                 db*)))
+      (($ <toplevel-set> src name exp)
+       (let*-values (((exp db*) (visit exp db env 'value)))
+         (return (make-toplevel-set src name exp)
+                 db*)))
+      (($ <primitive-ref>)
+       (return exp vlist-null))
+      (($ <conditional> src test consequent alternate)
+       (let*-values
+           (((test db+) (visit test db env 'test))
+            ((converse db-) (visit (negate test 'test) db env 'test))
+            ((consequent db++) (visit consequent (concat db+ db) env ctx))
+            ((alternate db--) (visit alternate (concat db- db) env ctx)))
+         (match (make-conditional src test consequent alternate)
+           (($ <conditional> _ ($ <const> _ exp))
+            (if exp
+                (return consequent (concat db++ db+))
+                (return alternate (concat db-- db-))))
+           ;; (if FOO A A) => (begin FOO A)
+           (($ <conditional> src _
+               ($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
+            (visit (make-sequence #f (list test (make-const #f a)))
+                   db env ctx))
+           ;; (if FOO #t #f) => FOO for boolean-valued FOO.
+           (($ <conditional> src
+               (? (cut boolean-valued-expression? <> ctx))
+               ($ <const> _ #t) ($ <const> _ #f))
+            (return test db+))
+           ;; (if FOO #f #t) => (not FOO)
+           (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t))
+            (visit (negate test ctx) db env ctx))
+
+           ;; Allow "and"-like conditions to accumulate in test context.
+           ((and c ($ <conditional> _ _ _ ($ <const> _ #f)))
+            (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null)))
+           ((and c ($ <conditional> _ _ ($ <const> _ #f) _))
+            (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null)))
+
+           ;; Conditional bailouts turn expressions into predicates.
+           ((and c ($ <conditional> _ _ _ (? bailout?)))
+            (return c (concat db++ db+)))
+           ((and c ($ <conditional> _ _ (? bailout?) _))
+            (return c (concat db-- db-)))
+
+           (c
+            (return c (intersection (concat db++ db+) (concat db-- db-)))))))
+      (($ <application> src proc args)
+       (let*-values (((proc db*) (visit proc db env 'value))
+                     ((args db**) (parallel-visit args db env 'value)))
+         (return (make-application src proc args)
+                 (concat db** db*))))
+      (($ <lambda> src meta body)
+       (let*-values (((body _) (visit body (control-flow-boundary db)
+                                      env 'values)))
+         (return (make-lambda src meta body)
+                 vlist-null)))
+      (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+       (let*-values (((inits _) (parallel-visit inits db env 'value))
+                     ((body db*) (visit body db env ctx))
+                     ((alt _) (if alt
+                                  (visit alt db env ctx)
+                                  (values #f #f))))
+         (return (make-lambda-case src req opt rest kw inits gensyms body alt)
+                 (if alt vlist-null db*))))
+      (($ <sequence> src exps)
+       (let lp ((in exps) (out '()) (db* vlist-null))
+         (match in
+           ((last)
+            (let*-values (((last db**) (visit last (concat db* db) env ctx)))
+              (if (null? out)
+                  (return last (concat db** db*))
+                  (return (make-sequence src (reverse (cons last out)))
+                          (concat db** db*)))))
+           ((head . rest)
+            (let*-values (((head db**) (visit head (concat db* db) env 
'effect)))
+              (cond
+               ((sequence? head)
+                (lp (append (sequence-exps head) rest) out db*))
+               ((void? head)
+                (lp rest out db*))
+               (else
+                (lp rest (cons head out) (concat db** db*)))))))))
+      (($ <prompt> src tag body handler)
+       (let*-values (((tag db*) (visit tag db env 'value))
+                     ((body _) (visit body (concat db* db) env ctx))
+                     ((handler _) (visit handler (concat db* db) env ctx)))
+         (return (make-prompt src tag body handler)
+                 db*)))
+      (($ <abort> src tag args tail)
+       (let*-values (((tag db*) (visit tag db env 'value))
+                     ((args db**) (parallel-visit args db env 'value))
+                     ((tail db***) (visit tail db env 'value)))
+         (return (make-abort src tag args tail)
+                 (concat db* (concat db** db***))))))))
diff --git a/module/language/tree-il/effects.scm 
b/module/language/tree-il/effects.scm
new file mode 100644
index 0000000..67bb8b7
--- /dev/null
+++ b/module/language/tree-il/effects.scm
@@ -0,0 +1,335 @@
+;;; Effects analysis on Tree-IL
+
+;; Copyright (C) 2011, 2012 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 (language tree-il effects)
+  #:use-module (language tree-il)
+  #:use-module (language tree-il primitives)
+  #:use-module (ice-9 match)
+  #:export (make-effects-analyzer
+            &mutable-lexical
+            &toplevel
+            &fluid
+            &definite-bailout
+            &possible-bailout
+            &zero-values
+            &allocation
+            &mutable-data
+            &type-check
+            &all-effects
+            effects-commute?
+            exclude-effects
+            effect-free?
+            constant?
+            depends-on-effects?
+            causes-effects?))
+
+;;;
+;;; Hey, it's some effects analysis!  If you invoke
+;;; `make-effects-analyzer', you get a procedure that computes the set
+;;; of effects that an expression depends on and causes.  This
+;;; information is useful when writing algorithms that move code around,
+;;; while preserving the semantics of an input program.
+;;;
+;;; The effects set is represented by a bitfield, as a fixnum.  The set
+;;; of possible effects is modelled rather coarsely.  For example, a
+;;; toplevel reference to FOO is modelled as depending on the &toplevel
+;;; effect, and causing a &type-check effect.  If any intervening code
+;;; sets any toplevel variable, that will block motion of FOO.
+;;;
+;;; For each effect, two bits are reserved: one to indicate that an
+;;; expression depends on the effect, and the other to indicate that an
+;;; expression causes the effect.
+;;;
+
+(define-syntax define-effects
+  (lambda (x)
+    (syntax-case x ()
+      ((_ all name ...)
+       (with-syntax (((n ...) (iota (length #'(name ...)))))
+         #'(begin
+             (define-syntax name (identifier-syntax (ash 1 (* n 2))))
+             ...
+             (define-syntax all (identifier-syntax (logior name ...)))))))))
+
+;; Here we define the effects, indicating the meaning of the effect.
+;;
+;; Effects that are described in a "depends on" sense can also be used
+;; in the "causes" sense.
+;;
+;; Effects that are described as causing an effect are not usually used
+;; in a "depends-on" sense.  Although the "depends-on" sense is used
+;; when checking for the existence of the "causes" effect, the effects
+;; analyzer will not associate the "depends-on" sense of these effects
+;; with any expression.
+;;
+(define-effects &all-effects
+  ;; Indicates that an expression depends on the value of a mutable
+  ;; lexical variable.
+  &mutable-lexical
+
+  ;; Indicates that an expression depends on the value of a toplevel
+  ;; variable.
+  &toplevel
+
+  ;; Indicates that an expression depends on the value of a fluid
+  ;; variable.
+  &fluid
+
+  ;; Indicates that an expression definitely causes a non-local,
+  ;; non-resumable exit -- a bailout.  Only used in the "changes" sense.
+  &definite-bailout
+
+  ;; Indicates that an expression may cause a bailout.
+  &possible-bailout
+
+  ;; Indicates than an expression may return zero values -- a "causes"
+  ;; effect.
+  &zero-values
+
+  ;; Indicates that an expression may return a fresh object -- a
+  ;; "causes" effect.
+  &allocation
+
+  ;; Indicates that an expression depends on the value of a mutable data
+  ;; structure.
+  &mutable-data
+
+  ;; Indicates that an expression may cause a type check.  A type check,
+  ;; for the purposes of this analysis, is the possibility of throwing
+  ;; an exception the first time an expression is evaluated.  If the
+  ;; expression did not cause an exception to be thrown, users can
+  ;; assume that evaluating the expression again will not cause an
+  ;; exception to be thrown.
+  ;;
+  ;; For example, (+ x y) might throw if X or Y are not numbers.  But if
+  ;; it doesn't throw, it should be safe to elide a dominated, common
+  ;; subexpression (+ x y).
+  &type-check)
+
+(define-syntax &no-effects (identifier-syntax 0))
+
+;; Definite bailout is an oddball effect.  Since it indicates that an
+;; expression definitely causes bailout, it's not in the set of effects
+;; of a call to an unknown procedure.  At the same time, it's also
+;; special in that a definite bailout in a subexpression doesn't always
+;; cause an outer expression to include &definite-bailout in its
+;; effects.  For that reason we have to treat it specially.
+;;
+(define-syntax &all-effects-but-bailout
+  (identifier-syntax
+   (logand &all-effects (lognot &definite-bailout))))
+
+(define-inlinable (cause effect)
+  (ash effect 1))
+
+(define-inlinable (&depends-on a)
+  (logand a &all-effects))
+(define-inlinable (&causes a)
+  (logand a (cause &all-effects)))
+
+(define (exclude-effects effects exclude)
+  (logand effects (lognot (cause exclude))))
+(define (effect-free? effects)
+  (zero? (&causes effects)))
+(define (constant? effects)
+  (zero? effects))
+
+(define-inlinable (depends-on-effects? x effects)
+  (not (zero? (logand (&depends-on x) effects))))
+(define-inlinable (causes-effects? x effects)
+  (not (zero? (logand (&causes x) (cause effects)))))
+
+(define-inlinable (effects-commute? a b)
+  (and (not (causes-effects? a (&depends-on b)))
+       (not (causes-effects? b (&depends-on a)))))
+
+(define (make-effects-analyzer assigned-lexical?)
+  "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
+of an expression."
+
+  (define compute-effects
+    (let ((cache (make-hash-table)))
+      (lambda (exp)
+        (or (hashq-ref cache exp)
+            (let ((effects (visit exp)))
+              (hashq-set! cache exp effects)
+              effects)))))
+
+  (define (accumulate-effects exps)
+    (let lp ((exps exps) (out &no-effects))
+      (if (null? exps)
+          out
+          (lp (cdr exps) (logior out (compute-effects (car exps)))))))
+
+  (define (visit exp)
+    (match exp
+      (($ <const>)
+       &no-effects)
+      (($ <void>)
+       &no-effects)
+      (($ <lexical-ref> _ _ gensym)
+       (if (assigned-lexical? gensym)
+           &mutable-lexical
+           &no-effects))
+      (($ <lexical-set> _ name gensym exp)
+       (logior (cause &mutable-lexical)
+               (compute-effects exp)))
+      (($ <let> _ names gensyms vals body)
+       (logior (if (or-map assigned-lexical? gensyms)
+                   (cause &allocation)
+                   &no-effects)
+               (accumulate-effects vals)
+               (compute-effects body)))
+      (($ <letrec> _ in-order? names gensyms vals body)
+       (logior (if (or-map assigned-lexical? gensyms)
+                   (cause &allocation)
+                   &no-effects)
+               (accumulate-effects vals)
+               (compute-effects body)))
+      (($ <fix> _ names gensyms vals body)
+       (logior (if (or-map assigned-lexical? gensyms)
+                   (cause &allocation)
+                   &no-effects)
+               (accumulate-effects vals)
+               (compute-effects body)))
+      (($ <let-values> _ producer consumer)
+       (logior (compute-effects producer)
+               (compute-effects consumer)
+               (cause &type-check)))
+      (($ <dynwind> _ winder body unwinder)
+       (logior (compute-effects winder)
+               (compute-effects body)
+               (compute-effects unwinder)))
+      (($ <dynlet> _ fluids vals body)
+       (logior (accumulate-effects fluids)
+               (accumulate-effects vals)
+               (cause &type-check)
+               (cause &fluid)
+               (compute-effects body)))
+      (($ <dynref> _ fluid)
+       (logior (compute-effects fluid)
+               (cause &type-check)
+               &fluid))
+      (($ <dynset> _ fluid exp)
+       (logior (compute-effects fluid)
+               (compute-effects exp)
+               (cause &type-check)
+               (cause &fluid)))
+      (($ <toplevel-ref>)
+       (logior &toplevel
+               (cause &type-check)))
+      (($ <module-ref>)
+       (logior &toplevel
+               (cause &type-check)))
+      (($ <module-set> _ mod name public? exp)
+       (logior (cause &toplevel)
+               (cause &type-check)
+               (compute-effects exp)))
+      (($ <toplevel-define> _ name exp)
+       (logior (cause &toplevel)
+               (compute-effects exp)))
+      (($ <toplevel-set> _ name exp)
+       (logior (cause &toplevel)
+               (compute-effects exp)))
+      (($ <primitive-ref>)
+       &no-effects)
+      (($ <conditional> _ test consequent alternate)
+       (let ((tfx (compute-effects test))
+             (cfx (compute-effects consequent))
+             (afx (compute-effects alternate)))
+         (if (causes-effects? (logior tfx (logand afx cfx))
+                              &definite-bailout)
+             (logior tfx cfx afx)
+             (exclude-effects (logior tfx cfx afx)
+                              &definite-bailout))))
+
+      ;; Zero values.
+      (($ <application> _ ($ <primitive-ref> _ 'values) ())
+       (cause &zero-values))
+
+      ;; Effect-free primitives.
+      (($ <application> _
+          ($ <primitive-ref> _ (and name
+                                    (? effect+exception-free-primitive?)))
+          args)
+       (logior (accumulate-effects args)
+               (if (constructor-primitive? name)
+                   (cause &allocation)
+                   &no-effects)))
+      (($ <application> _
+          ($ <primitive-ref> _ (and name
+                                    (? effect-free-primitive?)))
+          args)
+       (logior (accumulate-effects args)
+               (cause &type-check)
+               (if (constructor-primitive? name)
+                   (cause &allocation)
+                   (if (accessor-primitive? name)
+                       &mutable-data
+                       &no-effects))))
+      
+      ;; Lambda applications might throw wrong-number-of-args.
+      (($ <application> _ ($ <lambda> _ _ body) args)
+       (logior (compute-effects body)
+               (accumulate-effects args)
+               (cause &type-check)))
+        
+      ;; Bailout primitives.
+      (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
+          args)
+       (logior (accumulate-effects args)
+               (cause &definite-bailout)
+               (cause &possible-bailout)))
+
+      ;; A call to an unknown procedure can do anything.
+      (($ <application> _ proc args)
+       (logior &all-effects-but-bailout
+               (cause &all-effects-but-bailout)))
+
+      (($ <lambda> _ meta body)
+       &no-effects)
+      (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
+       (logior (exclude-effects (accumulate-effects inits)
+                                &definite-bailout)
+               (if (or-map assigned-lexical? gensyms)
+                   (cause &allocation)
+                   &no-effects)
+               (compute-effects body)
+               (if alt (compute-effects alt) &no-effects)))
+
+      (($ <sequence> _ exps)
+       (let lp ((exps exps) (effects &no-effects))
+         (match exps
+           ((tail)
+            (logior (compute-effects tail)
+                    ;; Returning zero values to a for-effect continuation is
+                    ;; not observable.
+                    (exclude-effects effects (cause &zero-values))))
+           ((head . tail)
+            (lp tail (logior (compute-effects head) effects))))))
+
+      (($ <prompt> _ tag body handler)
+       (logior (compute-effects tag)
+               (compute-effects body)
+               (compute-effects handler)))
+
+      (($ <abort> _ tag args tail)
+       (logior &all-effects-but-bailout
+               (cause &all-effects-but-bailout)))))
+
+  compute-effects)
diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index baac915..c6e4fec 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -1,6 +1,6 @@
 ;;; Tree-il optimizer
 
-;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011, 2012 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
@@ -22,6 +22,7 @@
   #:use-module (language tree-il)
   #:use-module (language tree-il primitives)
   #:use-module (language tree-il peval)
+  #:use-module (language tree-il cse)
   #:use-module (language tree-il fix-letrec)
   #:use-module (language tree-il debug)
   #:use-module (ice-9 match)
@@ -32,8 +33,15 @@
                  ((#:partial-eval? #f _ ...)
                   ;; Disable partial evaluation.
                   (lambda (x e) x))
-                 (_ peval))))
+                 (_ peval)))
+        (cse (match (memq #:cse? opts)
+               ((#:cse? #f _ ...)
+                ;; Disable CSE.
+                (lambda (x) x))
+               (_ cse))))
     (fix-letrec!
      (verify-tree-il
-      (peval (expand-primitives! (resolve-primitives! x env))
-             env)))))
+      (cse
+       (verify-tree-il
+        (peval (expand-primitives! (resolve-primitives! x env))
+               env)))))))
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 7f8575e..3b22b68 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -19,6 +19,7 @@
 (define-module (language tree-il peval)
   #:use-module (language tree-il)
   #:use-module (language tree-il primitives)
+  #:use-module (language tree-il effects)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
@@ -288,7 +289,7 @@
 ;; 
 (define-record-type <operand>
   (%make-operand var sym visit source visit-count residualize?
-                 copyable? residual-value constant-value)
+                 copyable? residual-value constant-value alias-value)
   operand?
   (var operand-var)
   (sym operand-sym)
@@ -298,18 +299,27 @@
   (residualize? operand-residualize? set-operand-residualize?!)
   (copyable? operand-copyable? set-operand-copyable?!)
   (residual-value operand-residual-value %set-operand-residual-value!)
-  (constant-value operand-constant-value set-operand-constant-value!))
+  (constant-value operand-constant-value set-operand-constant-value!)
+  (alias-value operand-alias-value set-operand-alias-value!))
 
-(define* (make-operand var sym #:optional source visit)
-  ;; Bind SYM to VAR, with value SOURCE.  Bound operands are considered
-  ;; copyable until we prove otherwise.  If we have a source expression,
-  ;; truncate it to one value.  Copy propagation does not work on
-  ;; multiply-valued expressions.
+(define* (make-operand var sym #:optional source visit alias)
+  ;; Bind SYM to VAR, with value SOURCE.  Unassigned bound operands are
+  ;; considered copyable until we prove otherwise.  If we have a source
+  ;; expression, truncate it to one value.  Copy propagation does not
+  ;; work on multiply-valued expressions.
   (let ((source (and=> source truncate-values)))
-    (%make-operand var sym visit source 0 #f (and source #t) #f #f)))
+    (%make-operand var sym visit source 0 #f
+                   (and source (not (var-set? var))) #f #f
+                   (and (not (var-set? var)) alias))))
 
-(define (make-bound-operands vars syms sources visit)
-  (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
+(define* (make-bound-operands vars syms sources visit #:optional aliases)
+  (if aliases
+      (map (lambda (name sym source alias)
+             (make-operand name sym source visit alias))
+           vars syms sources aliases)
+      (map (lambda (name sym source)
+             (make-operand name sym source visit #f))
+           vars syms sources)))
 
 (define (make-unbound-operands vars syms)
   (map make-operand vars syms))
@@ -343,7 +353,12 @@
                 (if (or counter (and (not effort-limit) (not size-limit)))
                     ((%operand-visit op) (operand-source op) counter ctx)
                     (let/ec k
-                      (define (abort) (k #f))
+                      (define (abort)
+                        ;; If we abort when visiting the value in a
+                        ;; fresh context, we won't succeed in any future
+                        ;; attempt, so don't try to copy it again.
+                        (set-operand-copyable?! op #f)
+                        (k #f))
                       ((%operand-visit op)
                        (operand-source op) 
                        (make-top-counter effort-limit size-limit abort op)
@@ -566,51 +581,15 @@ top-level bindings from ENV and return the resulting 
expression."
               (and tail
                    (make-sequence src (append head (list tail)))))))))))
 
+  (define compute-effects
+    (make-effects-analyzer assigned-lexical?))
+
   (define (constant-expression? x)
     ;; Return true if X is constant, for the purposes of copying or
     ;; elision---i.e., if it is known to have no effects, does not
     ;; allocate storage for a mutable object, and does not access
     ;; mutable data (like `car' or toplevel references).
-    (let loop ((x x))
-      (match x
-        (($ <void>) #t)
-        (($ <const>) #t)
-        (($ <lambda>) #t)
-        (($ <lambda-case> _ req opt rest kw inits syms body alternate)
-         (and (not (any assigned-lexical? syms))
-              (every loop inits) (loop body)
-              (or (not alternate) (loop alternate))))
-        (($ <lexical-ref> _ _ gensym)
-         (not (assigned-lexical? gensym)))
-        (($ <primitive-ref>) #t)
-        (($ <conditional> _ condition subsequent alternate)
-         (and (loop condition) (loop subsequent) (loop alternate)))
-        (($ <application> _ ($ <primitive-ref> _ 'values) exps)
-         (and (not (null? exps))
-              (every loop exps)))
-        (($ <application> _ ($ <primitive-ref> _ name) args)
-         (and (effect-free-primitive? name)
-              (not (constructor-primitive? name))
-              (not (accessor-primitive? name))
-              (types-check? name args)
-              (every loop args)))
-        (($ <application> _ ($ <lambda> _ _ body) args)
-         (and (loop body) (every loop args)))
-        (($ <sequence> _ exps)
-         (every loop exps))
-        (($ <let> _ _ syms vals body)
-         (and (not (any assigned-lexical? syms))
-              (every loop vals) (loop body)))
-        (($ <letrec> _ _ _ syms vals body)
-         (and (not (any assigned-lexical? syms))
-              (every loop vals) (loop body)))
-        (($ <fix> _ _ _ vals body)
-         (and (every loop vals) (loop body)))
-        (($ <let-values> _ exp body)
-         (and (loop exp) (loop body)))
-        (($ <prompt> _ tag body handler)
-         (and (loop tag) (loop body) (loop handler)))
-        (_ #f))))
+    (constant? (compute-effects x)))
 
   (define (prune-bindings ops in-order? body counter ctx build-result)
     ;; This helper handles both `let' and `letrec'/`fix'.  In the latter
@@ -746,6 +725,11 @@ top-level bindings from ENV and return the resulting 
expression."
           ((eq? ctx 'effect)
            (log 'lexical-for-effect gensym)
            (make-void #f))
+          ((operand-alias-value op)
+           ;; This is an unassigned operand that simply aliases some
+           ;; other operand.  Recurse to avoid residualizing the leaf
+           ;; binding.
+           => for-tail)
           ((eq? ctx 'call)
            ;; Don't propagate copies if we are residualizing a call.
            (log 'residualize-lexical-call gensym op)
@@ -838,11 +822,37 @@ top-level bindings from ENV and return the resulting 
expression."
                (set-operand-residualize?! op #t)
                (make-lexical-set src name (operand-sym op) (for-value exp))))))
       (($ <let> src names gensyms vals body)
+       (define (compute-alias exp)
+         ;; It's very common for macros to introduce something like:
+         ;;
+         ;;   ((lambda (x y) ...) x-exp y-exp)
+         ;;
+         ;; In that case you might end up trying to inline something like:
+         ;;
+         ;;   (let ((x x-exp) (y y-exp)) ...)
+         ;;
+         ;; But if x-exp is itself a lexical-ref that aliases some much
+         ;; larger expression, perhaps it will fail to inline due to
+         ;; size.  However we don't want to introduce a useless alias
+         ;; (in this case, x).  So if the RHS of a let expression is a
+         ;; lexical-ref, we record that expression.  If we end up having
+         ;; to residualize X, then instead we residualize X-EXP, as long
+         ;; as it isn't assigned.
+         ;;
+         (match exp
+           (($ <lexical-ref> _ _ sym)
+            (let ((op (lookup sym)))
+              (and (not (var-set? (operand-var op)))
+                   (or (operand-alias-value op)
+                       exp))))
+           (_ #f)))
+
        (let* ((vars (map lookup-var gensyms))
               (new (fresh-gensyms vars))
               (ops (make-bound-operands vars new vals
                                         (lambda (exp counter ctx)
-                                          (loop exp env counter ctx))))
+                                          (loop exp env counter ctx))
+                                        (map compute-alias vals)))
               (env (fold extend-env env gensyms ops))
               (body (loop body env counter ctx)))
          (cond
@@ -868,7 +878,9 @@ top-level bindings from ENV and return the resulting 
expression."
       (($ <letrec> src in-order? names gensyms vals body)
        ;; Note the difference from the `let' case: here we use letrec*
        ;; so that the `visit' procedure for the new operands closes over
-       ;; an environment that includes the operands.
+       ;; an environment that includes the operands.  Also we don't try
+       ;; to elide aliases, because we can't sensibly reduce something
+       ;; like (letrec ((a b) (b a)) a).
        (letrec* ((visit (lambda (exp counter ctx)
                           (loop exp env* counter ctx)))
                  (vars (map lookup-var gensyms))
@@ -985,14 +997,20 @@ top-level bindings from ENV and return the resulting 
expression."
          ((test) (make-const #f #t))
          (else exp)))
       (($ <conditional> src condition subsequent alternate)
-       (let ((condition (for-test condition)))
-         (if (const? condition)
-             (if (const-exp condition)
-                 (for-tail subsequent)
-                 (for-tail alternate))
-             (make-conditional src condition
-                               (for-tail subsequent)
-                               (for-tail alternate)))))
+       (match (for-test condition)
+         (($ <const> _ val)
+          (if val
+              (for-tail subsequent)
+              (for-tail alternate)))
+         ;; Swap the arms of (if (not FOO) A B), to simplify.
+         (($ <application> _ ($ <primitive-ref> _ 'not) (c))
+          (make-conditional src c
+                            (for-tail alternate)
+                            (for-tail subsequent)))
+         (c
+          (make-conditional src c
+                            (for-tail subsequent)
+                            (for-tail alternate)))))
       (($ <application> src
           ($ <primitive-ref> _ '@call-with-values)
           (producer
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 2039faa..dba31bd 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -29,8 +29,11 @@
             expand-primitives!
             effect-free-primitive? effect+exception-free-primitive?
             constructor-primitive? accessor-primitive?
-            singly-valued-primitive?))
+            singly-valued-primitive? bailout-primitive?
+            negate-primitive))
 
+;; When adding to this, be sure to update *multiply-valued-primitives*
+;; if appropriate.
 (define *interesting-primitive-names* 
   '(apply @apply
     call-with-values @call-with-values
@@ -43,9 +46,14 @@
     memq memv
     = < > <= >= zero?
     + * - / 1- 1+ quotient remainder modulo
-    ash logand logior logxor
+    ash logand logior logxor lognot
     not
-    pair? null? list? symbol? vector? string? struct?
+    pair? null? list? symbol? vector? string? struct? number? char?
+
+    complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+
+    char<? char<=? char>=? char>?
+
     acons cons cons*
 
     list vector
@@ -69,6 +77,8 @@
     @prompt call-with-prompt @abort abort-to-prompt
     make-prompt-tag
 
+    throw error scm-error
+
     string-length string-ref string-set!
 
     struct-vtable make-struct struct-ref struct-set!
@@ -122,7 +132,7 @@
   '(vector-ref
     car cdr
     memq memv
-    struct-vtable struct-ref
+    struct-ref
     string-ref
     bytevector-u8-ref bytevector-s8-ref
     bytevector-u16-ref bytevector-u16-native-ref
@@ -138,9 +148,13 @@
   `(values
     eq? eqv? equal?
     = < > <= >= zero?
+    ash logand logior logxor lognot
     + * - / 1- 1+ quotient remainder modulo
     not
-    pair? null? list? symbol? vector? struct? string?
+    pair? null? list? symbol? vector? struct? string? number? char?
+    complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+    char<? char<=? char>=? char>?
+    struct-vtable
     string-length
     ;; These all should get expanded out by expand-primitives!.
     caar cadr cdar cddr
@@ -156,59 +170,38 @@
   '(values
     eq? eqv? equal?
     not
-    pair? null? list? symbol? vector? struct? string?
+    pair? null? list? symbol? vector? struct? string? number? char?
     acons cons cons* list vector))
 
-;; Primitives that only return one value.
-(define *singly-valued-primitives* 
-  '(eq? eqv? equal?
-    memq memv
-    = < > <= >= zero?
-    + * - / 1- 1+ quotient remainder modulo
-    ash logand logior logxor
-    not
-    pair? null? list? symbol? vector? acons cons cons*
-    list vector
-    car cdr
-    set-car! set-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 vector-set!
-    variable-ref variable-set!
-    variable-bound?
-    fluid-ref fluid-set!
-    make-prompt-tag
-    struct? struct-vtable make-struct struct-ref struct-set!
-    string-length string-ref string-set!
-    bytevector-u8-ref bytevector-u8-set!
-    bytevector-s8-ref bytevector-s8-set!
-    u8vector-ref u8vector-set! s8vector-ref s8vector-set!
-    bytevector-u16-ref bytevector-u16-set!
-    bytevector-u16-native-ref bytevector-u16-native-set!
-    bytevector-s16-ref bytevector-s16-set!
-    bytevector-s16-native-ref bytevector-s16-native-set!
-    u16vector-ref u16vector-set! s16vector-ref s16vector-set!
-    bytevector-u32-ref bytevector-u32-set!
-    bytevector-u32-native-ref bytevector-u32-native-set!
-    bytevector-s32-ref bytevector-s32-set!
-    bytevector-s32-native-ref bytevector-s32-native-set!
-    u32vector-ref u32vector-set! s32vector-ref s32vector-set!
-    bytevector-u64-ref bytevector-u64-set!
-    bytevector-u64-native-ref bytevector-u64-native-set!
-    bytevector-s64-ref bytevector-s64-set!
-    bytevector-s64-native-ref bytevector-s64-native-set!
-    u64vector-ref u64vector-set! s64vector-ref s64vector-set!
-    bytevector-ieee-single-ref bytevector-ieee-single-set!
-    bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
-    bytevector-ieee-double-ref bytevector-ieee-double-set!
-    bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
-    f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+;; Primitives that don't always return one value.
+(define *multiply-valued-primitives* 
+  '(apply @apply
+    call-with-values @call-with-values
+    call-with-current-continuation @call-with-current-continuation
+    call/cc
+    dynamic-wind
+    @dynamic-wind
+    values
+    @prompt call-with-prompt @abort abort-to-prompt))
+
+;; Procedures that cause a nonlocal, non-resumable abort.
+(define *bailout-primitives*
+  '(throw error scm-error))
+
+;; Negatable predicates.
+(define *negatable-primitives*
+  '((even? . odd?)
+    (exact? . inexact?)
+    (< . >=)
+    (> . <=)
+    (char<? . char>=?)
+    (char>? . char<=?)))
 
 (define *effect-free-primitive-table* (make-hash-table))
 (define *effect+exceptions-free-primitive-table* (make-hash-table))
-(define *singly-valued-primitive-table* (make-hash-table))
+(define *multiply-valued-primitive-table* (make-hash-table))
+(define *bailout-primitive-table* (make-hash-table))
+(define *negatable-primitive-table* (make-hash-table))
 
 (for-each (lambda (x)
             (hashq-set! *effect-free-primitive-table* x #t))
@@ -217,8 +210,15 @@
             (hashq-set! *effect+exceptions-free-primitive-table* x #t))
           *effect+exception-free-primitives*)
 (for-each (lambda (x) 
-            (hashq-set! *singly-valued-primitive-table* x #t))
-          *singly-valued-primitives*)
+            (hashq-set! *multiply-valued-primitive-table* x #t))
+          *multiply-valued-primitives*)
+(for-each (lambda (x)
+            (hashq-set! *bailout-primitive-table* x #t))
+          *bailout-primitives*)
+(for-each (lambda (x)
+            (hashq-set! *negatable-primitive-table* (car x) (cdr x))
+            (hashq-set! *negatable-primitive-table* (cdr x) (car x)))
+          *negatable-primitives*)
 
 (define (constructor-primitive? prim)
   (memq prim *primitive-constructors*))
@@ -229,7 +229,11 @@
 (define (effect+exception-free-primitive? prim)
   (hashq-ref *effect+exceptions-free-primitive-table* prim))
 (define (singly-valued-primitive? prim)
-  (hashq-ref *singly-valued-primitive-table* prim))
+  (not (hashq-ref *multiply-valued-primitive-table* prim)))
+(define (bailout-primitive? prim)
+  (hashq-ref *bailout-primitive-table* prim))
+(define (negate-primitive prim)
+  (hashq-ref *negatable-primitive-table* prim))
 
 (define (resolve-primitives! x mod)
   (post-order!
@@ -361,6 +365,18 @@
   (x) (/ 1 x)
   (x y z . rest) (/ x (* y z . rest)))
   
+(define-primitive-expander logior
+  () 0
+  (x) (logior x 0)
+  (x y) (logior x y)
+  (x y z . rest) (logior x (logior y z . rest)))
+
+(define-primitive-expander logand
+  () -1
+  (x) (logand x -1)
+  (x y) (logand x y)
+  (x y z . rest) (logand x (logand y z . rest)))
+
 (define-primitive-expander caar (x) (car (car x)))
 (define-primitive-expander cadr (x) (car (cdr x)))
 (define-primitive-expander cdar (x) (cdr (car x)))
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index e433b86..b12ab15 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -1,4 +1,4 @@
-;;;;   Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009 Free Software 
Foundation, Inc.
+;;;;   Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012 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
@@ -178,7 +178,9 @@
                      '())
                  (acons gf gf-sym '()))))
   (define (comp exp vals)
-    (let ((p ((@ (system base compile) compile) exp #:env *dispatch-module*)))
+    (let ((p ((@ (system base compile) compile) exp
+              #:env *dispatch-module*
+              #:opts '(#:partial-eval? #f #:cse? #f))))
       (apply p vals)))
   
   ;; kick it.
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index c87af17..168e799 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -39,6 +39,7 @@ SCM_TESTS = tests/00-initial-env.test         \
            tests/control.test                  \
            tests/continuations.test            \
            tests/coverage.test                 \
+           tests/cse.test                      \
            tests/curried-definitions.test      \
            tests/ecmascript.test               \
            tests/elisp.test                    \
@@ -75,6 +76,7 @@ SCM_TESTS = tests/00-initial-env.test         \
            tests/optargs.test                  \
            tests/options.test                  \
            tests/parameters.test               \
+           tests/peval.test                    \
            tests/print.test                    \
            tests/procprop.test                 \
            tests/procs.test                    \
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
new file mode 100644
index 0000000..a6308d5
--- /dev/null
+++ b/test-suite/tests/cse.test
@@ -0,0 +1,259 @@
+;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
+;;;; Andy Wingo <address@hidden> --- May 2009
+;;;;
+;;;;   Copyright (C) 2009, 2010, 2011, 2012 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 tree-il cse)
+  #:use-module (language tree-il peval)
+  #:use-module (language glil)
+  #:use-module (srfi srfi-13))
+
+(define-syntax pass-if-cse
+  (syntax-rules ()
+    ((_ in pat)
+     (pass-if 'in
+       (let ((evaled (unparse-tree-il
+                      (cse
+                       (peval
+                        (expand-primitives!
+                         (resolve-primitives!
+                          (compile 'in #:from 'scheme #:to 'tree-il)
+                          (current-module))))))))
+         (pmatch evaled
+           (pat #t)
+           (_   (pk 'cse-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 "cse"
+
+  ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is
+  ;; boolean-valued.
+  (pass-if-cse
+   (lambda (x y)
+      (and (eq? x y)
+           (eq? x y)))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (apply (primitive eq?) (lexical x _) (lexical y _))))))
+
+  ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
+  (pass-if-cse
+   (lambda (x y)
+      (if (eq? x y) #f #t))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (apply (primitive not)
+              (apply (primitive eq?) (lexical x _) (lexical y _)))))))
+
+  ;; (if TEST (not TEST) #f)
+  ;; => (if TEST #f #f)
+  ;; => (begin TEST #f)
+  ;; => #f
+  (pass-if-cse
+    (lambda (x y)
+      (and (eq? x y) (not (eq? x y))))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (const #f)))))
+
+  ;; (if TEST #f TEST) => (if TEST #f #f) => ...
+  (pass-if-cse
+   (lambda (x y)
+      (if (eq? x y) #f (eq? x y)))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (const #f)))))
+
+  ;; The same, but side-effecting primitives do not propagate.
+  (pass-if-cse
+   (lambda (x y)
+      (and (set-car! x y) (not (set-car! x y))))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (if (apply (primitive set-car!)
+                  (lexical x _)
+                  (lexical y _))
+           (apply (primitive not)
+                  (apply (primitive set-car!)
+                         (lexical x _)
+                         (lexical y _)))
+           (const #f))))))
+
+  ;; Primitives that access mutable memory can propagate, as long as
+  ;; there is no intervening mutation.
+  (pass-if-cse
+    (lambda (x y)
+      (and (string-ref x y)
+           (begin
+             (string-ref x y)
+             (not (string-ref x y)))))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (begin
+         (apply (primitive string-ref)
+                (lexical x _)
+                (lexical y _))
+         (const #f))))))
+
+  ;; However, expressions with dependencies on effects do not propagate
+  ;; through a lambda.
+  (pass-if-cse
+    (lambda (x y)
+      (and (string-ref x y)
+           (lambda ()
+             (and (string-ref x y) #t))))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (if (apply (primitive string-ref)
+                  (lexical x _)
+                  (lexical y _))
+           (lambda _
+             (lambda-case
+              ((() #f #f #f () ())
+               (if (apply (primitive string-ref)
+                          (lexical x _)
+                          (lexical y _))
+                   (const #t)
+                   (const #f)))))
+           (const #f))))))
+
+  ;; A mutation stops the propagation.
+  (pass-if-cse
+    (lambda (x y)
+      (and (string-ref x y)
+           (begin
+             (string-set! x #\!)
+             (not (string-ref x y)))))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (if (apply (primitive string-ref)
+                  (lexical x _)
+                  (lexical y _))
+           (begin
+             (apply (primitive string-set!)
+                    (lexical x _)
+                    (const #\!))
+             (apply (primitive not)
+                    (apply (primitive string-ref)
+                           (lexical x _)
+                           (lexical y _))))
+           (const #f))))))
+
+  ;; Predicates are only added to the database if they are in a
+  ;; predicate context.
+  (pass-if-cse
+    (lambda (x y)
+      (begin (eq? x y) (eq? x y)))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (apply (primitive eq?) (lexical x _) (lexical y _))))))
+
+  ;; Conditional bailouts do cause primitives to be added to the DB.
+  (pass-if-cse
+    (lambda (x y)
+      (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (begin
+         (if (apply (primitive eq?)
+                    (lexical x _) (lexical y _))
+             (void)
+             (apply (primitive 'throw) (const 'foo)))
+         (const #t))))))
+
+  ;; A chain of tests in a conditional bailout add data to the DB
+  ;; correctly.
+  (pass-if-cse
+    (lambda (x y)
+      (begin
+        (unless (and (struct? x) (eq? (struct-vtable x) x-vtable))
+          (throw 'foo))
+        (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
+            (struct-ref x y)
+            (throw 'bar))))
+    (lambda _
+     (lambda-case
+      (((x y) #f #f #f () (_ _))
+       (begin
+         (if (if (apply (primitive struct?) (lexical x _))
+                 (apply (primitive eq?)
+                        (apply (primitive struct-vtable)
+                               (lexical x _))
+                        (toplevel x-vtable))
+                 (const #f))
+             (void)
+             (apply (primitive 'throw) (const 'foo)))
+         (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
+
+  ;; Strict argument evaluation also adds info to the DB.
+  (pass-if-cse
+    (lambda (x)
+      ((lambda (z)
+         (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
+                  (struct-ref x 2)
+                  (throw 'bar))))
+       (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
+           (struct-ref x 1)
+           (throw 'foo))))
+    
+    (lambda _
+      (lambda-case
+       (((x) #f #f #f () (_))
+        (let (z) (_) ((if (if (apply (primitive struct?) (lexical x _))
+                              (apply (primitive eq?)
+                                     (apply (primitive struct-vtable)
+                                            (lexical x _))
+                                     (toplevel x-vtable))
+                              (const #f))
+                          (apply (primitive struct-ref) (lexical x _) (const 
1))
+                          (apply (primitive 'throw) (const 'foo))))
+             (apply (primitive +) (lexical z _)
+                    (apply (primitive struct-ref) (lexical x _) (const 
2))))))))
+
+  ;; Replacing named expressions with lexicals.
+  (pass-if-cse
+   (let ((x (car y)))
+     (cons x (car y)))
+   (let (x) (_) ((apply (primitive car) (toplevel y)))
+        (apply (primitive cons) (lexical x _) (lexical x _)))))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
new file mode 100644
index 0000000..987b06c
--- /dev/null
+++ b/test-suite/tests/peval.test
@@ -0,0 +1,1002 @@
+;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
+;;;; Andy Wingo <address@hidden> --- May 2009
+;;;;
+;;;;   Copyright (C) 2009, 2010, 2011, 2012 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)))))))
+
+
+(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
+   ;; 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.
+   (while #t #t)
+   (letrec (lp) (_)
+           ((lambda _
+              (lambda-case
+               ((() #f #f #f () ())
+                (letrec (loop) (_)
+                        ((lambda _
+                           (lambda-case
+                            ((() #f #f #f () ())
+                             (apply (lexical loop _))))))
+                        (apply (lexical loop _)))))))
+           (apply (lexical lp _))))
+
+  (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 _)))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 0f0e553..2b07e62 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -69,38 +69,6 @@
          (pat (guard guard-exp) #t)
          (_ #f))))))
 
-(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)))))))
-
 
 (with-test-prefix "tree-il->scheme"
   (pass-if-tree-il->scheme
@@ -180,7 +148,7 @@
             (lexical #t #f ref 0) (call return 1)
             (unbind)))
 
-  (assert-tree-il->glil without-partial-evaluation
+  (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
    (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)
@@ -657,939 +625,6 @@
               #:opts '(#:partial-eval? #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))
-      (set! pos 1) ;; Cause references to `pos' to residualize.
-      (let ((here (let ((start pos)) (lambda () start))))
-        (here)))
-    (let (pos) (_) ((const 0))
-         (begin
-           (set! (lexical pos _) (const 1))
-           (let (here) (_) (_)
-                (apply (lexical here _))))))
-  
-  (pass-if-peval
-   ;; FIXME: should this one residualize the binding?
-   (letrec ((a a))
-     1)
-   (const 1))
-
-  (pass-if-peval
-   ;; This is a fun one for peval to handle.
-   (letrec ((a a))
-     a)
-   (letrec (a) (_) ((lexical a _))
-           (lexical a _)))
-
-  (pass-if-peval
-   ;; Another interesting recursive case.
-   (letrec ((a b) (b a))
-     a)
-   (letrec (a) (_) ((lexical a _))
-           (lexical a _)))
-
-  (pass-if-peval
-   ;; Another pruning case, that `a' is residualized.
-   (letrec ((a (lambda () (a)))
-            (b (lambda () (a)))
-            (c (lambda (x) x)))
-     (let ((d (foo b)))
-       (c d)))
-
-   ;; "b c a" is the current order that we get with unordered letrec,
-   ;; but it's not important to this test, so if it changes, just adapt
-   ;; the test.
-   (letrec (b c a) (_ _ _)
-     ((lambda _
-        (lambda-case
-         ((() #f #f #f () ())
-          (apply (lexical a _)))))
-      (lambda _
-        (lambda-case
-         (((x) #f #f #f () (_))
-          (lexical x _))))
-      (lambda _
-        (lambda-case
-         ((() #f #f #f () ())
-          (apply (lexical a _))))))
-     (let (d)
-       (_)
-       ((apply (toplevel foo) (lexical b _)))
-       (apply (lexical c _)
-              (lexical d _)))))
-
-  (pass-if-peval
-   ;; In this case, we can prune the bindings.  `a' ends up being copied
-   ;; because it is only referenced once in the source program.  Oh
-   ;; well.
-   (letrec* ((a (lambda (x) (top x)))
-             (b (lambda () a)))
-     (foo (b) (b)))
-   (apply (toplevel foo)
-          (lambda _
-            (lambda-case
-             (((x) #f #f #f () (_))
-              (apply (toplevel top) (lexical x _)))))
-          (lambda _
-            (lambda-case
-             (((x) #f #f #f () (_))
-              (apply (toplevel top) (lexical x _)))))))
-  
-  (pass-if-peval
-   ;; Constant folding: cons 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.
-   (while #t #t)
-   (letrec (lp) (_)
-           ((lambda _
-              (lambda-case
-               ((() #f #f #f () ())
-                (letrec (loop) (_)
-                        ((lambda _
-                           (lambda-case
-                            ((() #f #f #f () ())
-                             (apply (lexical loop _))))))
-                        (apply (lexical loop _)))))))
-           (apply (lexical lp _))))
-
-  (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
-   ((@ (guile) car) '(1 2))
-   (const 1))
-
-  (pass-if-peval resolve-primitives
-   ((@@ (guile) car) '(1 2))
-   (const 1)))
-
-
-
 (with-test-prefix "tree-il-fold"
 
   (pass-if "empty tree"


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]