From: Andy Wingo <wingo@pobox.com>
Date: Thu, 26 Apr 2012 21:40:57 +0000 (+0200)
Subject: Merge remote-tracking branch 'origin/stable-2.0'
X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/9d8a10a94c022e5fe4b58aa4b586eda514b1189f?hp=0ea5ba9ab9e749ccb19ec12129045d0753844338

Merge remote-tracking branch 'origin/stable-2.0'

Conflicts:
	test-suite/tests/cse.test
---

diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 0ed4b6d32..a09b374bc 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
index a7edcbe4a..7ae472312 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -188,7 +188,7 @@
     (/ (string-length (symbol->string (struct-layout x))) 2))
 
   (define hash-bits (logcount most-positive-fixnum))
-  (define hash-depth 3)
+  (define hash-depth 4)
   (define hash-width 3)
   (define (hash-expression exp)
     (define (hash-exp exp depth)
@@ -348,29 +348,30 @@
          (expressions-equal? exp exp*))
         (_ #f)))
       
-    (define (unroll db from to)
-      (or (<= from to)
-          (match (vlist-ref db (1- from))
+    (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- from) to)))
+                  (unroll db (1+ base) (1- n))))
             ((#(exp* effects* ctx*) . h*)
              (and (effects-commute? effects effects*)
-                  (unroll db (1- from) to))))))
+                  (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)))
-             (let lp ((n 0) (db-len (vlist-length db)))
+           (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 db-len db-len*)
+                       (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*)))))))))))
+                                (lp (1+ n) (- db-len db-len*))))))))))))
 
   (define (intersection db+ db-)
     (vhash-fold-right
@@ -409,8 +410,12 @@
                                      (logior &zero-values
                                              &allocation)))
                    (has-dominating-effect? exp effects db)))
-          (log 'elide ctx (unparse-tree-il exp))
-          (values (make-void #f) 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)
diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index b2e218e3b..e698a3736 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -62,9 +62,9 @@
       ((_ all name ...)
        (with-syntax (((n ...) (iota (length #'(name ...)))))
          #'(begin
-             (define name (ash 1 (* n 2)))
+             (define-syntax name (identifier-syntax (ash 1 (* n 2))))
              ...
-             (define all (logior name ...))))))))
+             (define-syntax all (identifier-syntax (logior name ...)))))))))
 
 ;; Here we define the effects, indicating the meaning of the effect.
 ;;
@@ -121,7 +121,7 @@
   ;; subexpression (+ x y).
   &type-check)
 
-(define &no-effects 0)
+(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
@@ -130,15 +130,16 @@
 ;; cause an outer expression to include &definite-bailout in its
 ;; effects.  For that reason we have to treat it specially.
 ;;
-(define &all-effects-but-bailout
-  (logand &all-effects (lognot &definite-bailout)))
+(define-syntax &all-effects-but-bailout
+  (identifier-syntax
+   (logand &all-effects (lognot &definite-bailout))))
 
-(define (cause effect)
+(define-inlinable (cause effect)
   (ash effect 1))
 
-(define (&depends-on a)
+(define-inlinable (&depends-on a)
   (logand a &all-effects))
-(define (&causes a)
+(define-inlinable (&causes a)
   (logand a (cause &all-effects)))
 
 (define (exclude-effects effects exclude)
@@ -148,12 +149,12 @@
 (define (constant? effects)
   (zero? effects))
 
-(define (depends-on-effects? x effects)
+(define-inlinable (depends-on-effects? x effects)
   (not (zero? (logand (&depends-on x) effects))))
-(define (causes-effects? x effects)
+(define-inlinable (causes-effects? x effects)
   (not (zero? (logand (&causes x) (cause effects)))))
 
-(define (effects-commute? a b)
+(define-inlinable (effects-commute? a b)
   (and (not (causes-effects? a (&depends-on b)))
        (not (causes-effects? b (&depends-on a)))))
 
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index baac91579..c6e4fec07 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 8866b0193..11cdb49b0 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -286,7 +286,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)
@@ -296,19 +296,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)
+(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 (not (var-set? var))) #f #f)))
-
-(define (make-bound-operands vars syms sources visit)
-  (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
+                   (and source (not (var-set? var))) #f #f
+                   (and (not (var-set? var)) alias))))
+
+(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))
@@ -342,7 +350,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)
@@ -701,6 +714,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)
@@ -793,11 +811,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
@@ -823,7 +867,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))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 73d3d69e6..a44bc1acc 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -47,7 +47,7 @@
     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? number? char? nil?
 
@@ -149,6 +149,7 @@
   `(values
     eq? eqv? equal?
     = < > <= >= zero?
+    ash logand logior logxor lognot
     + * - / 1- 1+ quotient remainder modulo
     not
     pair? null? list? symbol? vector? struct? string? number? char? nil
@@ -390,6 +391,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 e433b86f3..b12ab15fa 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/tests/peval.test b/test-suite/tests/peval.test
index b10bedf1f..2bd8919f5 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -998,4 +998,18 @@
 
   (pass-if-peval
     (car '(1 2))
-    (const 1)))
+    (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 63baef981..ba76ad6e5 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -148,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)