From 9068f4f52772397c5d4408f585ccdf1017869a3e Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 13 Apr 2012 15:23:20 -0700
Subject: [PATCH 01/10] 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.
---
 module/language/tree-il/optimize.scm | 16 ++++++++++++----
 test-suite/tests/tree-il.test        |  2 +-
 2 files changed, 13 insertions(+), 5 deletions(-)

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/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 2d0784ed8..2b07e62d5 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)

From f7d8efc630ce45f5d82aae5b2682d261e5541d5f Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 15 Apr 2012 13:00:30 -0700
Subject: [PATCH 02/10] disable optimizations in goops dispatch procedures

* module/oop/goops/dispatch.scm: Disable peval and cse.
---
 module/oop/goops/dispatch.scm | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

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.

From b3f25e62695315ab632d2e3a66d31bb490c82100 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 15 Apr 2012 13:39:56 -0700
Subject: [PATCH 03/10] 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.
---
 module/language/tree-il/primitives.scm | 15 ++++++++++++++-
 1 file changed, 14 insertions(+), 1 deletion(-)

diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 704f7c294..dba31bdc8 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -46,7 +46,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?
 
@@ -148,6 +148,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?
@@ -364,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)))

From 036c366dc2fbbeeb04d8984bb0819df28d9d455f Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 15 Apr 2012 13:41:05 -0700
Subject: [PATCH 04/10] 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.
---
 module/language/tree-il/effects.scm | 23 ++++++++++++-----------
 1 file changed, 12 insertions(+), 11 deletions(-)

diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index 36436a77c..67bb8b71e 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)))))
 

From 3db8f60977e966522e3c05cc554c99382c968b55 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Mon, 16 Apr 2012 12:42:31 -0700
Subject: [PATCH 05/10] cse hashing tweak

* module/language/tree-il/cse.scm (cse): Minor tweak to hash depth based
  on time profile of compiling peval.scm.
---
 module/language/tree-il/cse.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 3d8a7f8f4..117f5666f 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -193,7 +193,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)

From 73001b06f60206edfa4ae4ec6a8b5c8f65d272c2 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Mon, 16 Apr 2012 16:25:19 -0700
Subject: [PATCH 06/10] 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.
---
 module/language/tree-il/cse.scm | 27 ++++++++++++++++-----------
 test-suite/tests/cse.test       |  9 ++++++++-
 2 files changed, 24 insertions(+), 12 deletions(-)

diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 117f5666f..f55c48127 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -353,29 +353,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
@@ -414,8 +415,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/test-suite/tests/cse.test b/test-suite/tests/cse.test
index 7195a4dd6..a6308d530 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -249,4 +249,11 @@
                           (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)))))))))
+                    (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 _)))))

From 299ce911f986c7f9a6a4887ca3b72e5748e126f7 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Mon, 23 Apr 2012 11:43:01 +0200
Subject: [PATCH 07/10] 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.
---
 module/ice-9/vlist.scm | 29 +++++++++++------------------
 1 file changed, 11 insertions(+), 18 deletions(-)

diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 0ed4b6d32..55082f321 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -69,14 +69,7 @@
 (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?)
+(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, a "hash table" is also added.
   ;; Note: We use `next-free' instead of `last-used' as suggested by Bagwell.
@@ -88,7 +81,7 @@
           (and hash-tab? (make-vector size #f))))
 
 (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)
@@ -98,30 +91,30 @@
 (define-block-accessor block-next-free 4)
 (define-block-accessor block-hash-table 5)
 
-(define-inline (increment-block-next-free! block)
+(define-inlinable (increment-block-next-free! block)
   (vector-set! block 4
                (+ (block-next-free block) 1)))
 
-(define-inline (block-append! block value)
+(define-inlinable (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)
+(define-inlinable (block-ref block offset)
   (vector-ref (block-content block) offset))
 
-(define-inline (block-ref* block offset)
+(define-inlinable (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)
+(define-inlinable (block-hash-table-ref block offset)
   (vector-ref (block-hash-table block) offset))
 
-(define-inline (block-hash-table-set! block offset value)
+(define-inlinable (block-hash-table-set! block offset value)
   (vector-set! (block-hash-table block) offset value))
 
 (define block-null
@@ -165,7 +158,7 @@
   ;; The empty vlist.
   (make-vlist block-null 0))
 
-(define-inline (block-cons item vlist hash-tab?)
+(define-inlinable (block-cons item vlist hash-tab?)
   (let loop ((base   (vlist-base vlist))
              (offset (+ 1 (vlist-offset vlist))))
     (if (and (< offset (block-size base))
@@ -429,7 +422,7 @@ with @var{value}.  Use @var{hash} to compute @var{key}'s hash."
 (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))))
@@ -480,7 +473,7 @@ 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

From f6a554a6aa0832432cec9c9c18b99fad56008997 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Mon, 23 Apr 2012 13:07:34 +0200
Subject: [PATCH 08/10] 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.
---
 module/ice-9/vlist.scm | 55 ++++++++++++++++++++++++------------------
 1 file changed, 31 insertions(+), 24 deletions(-)

diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 55082f321..22ef285f3 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -91,16 +91,17 @@
 (define-block-accessor block-next-free 4)
 (define-block-accessor block-hash-table 5)
 
-(define-inlinable (increment-block-next-free! block)
-  (vector-set! block 4
-               (+ (block-next-free block) 1)))
+(define-inlinable (set-block-next-free! block next-free)
+  (vector-set! block 4 next-free))
 
-(define-inlinable (block-append! block value)
+(define-inlinable (block-append! block value offset)
   ;; 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))
+  (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)))
 
 (define-inlinable (block-ref block offset)
   (vector-ref (block-content block) offset))
@@ -159,22 +160,28 @@
   (make-vlist block-null 0))
 
 (define-inlinable (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)))))
+  (unless (vlist? vlist)
+    (error "Expected a vlist:" vlist))
+  (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

From 985702f7131e11c7c13aa75db19d10525c34fecd Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Mon, 23 Apr 2012 17:56:28 +0200
Subject: [PATCH 09/10] 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.
---
 module/language/tree-il/peval.scm | 64 ++++++++++++++++++++++++++-----
 test-suite/tests/peval.test       | 16 +++++++-
 2 files changed, 70 insertions(+), 10 deletions(-)

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index f10f24ed2..3b22b68cb 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -289,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)
@@ -299,19 +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)
+(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)))
+                   (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))
@@ -345,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)
@@ -712,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)
@@ -804,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
@@ -834,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))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 5305dea72..987b06cca 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -985,4 +985,18 @@
 
   (pass-if-peval resolve-primitives
     (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 _)))))

From 4bd53c1ba39ba1c2d51ff895104f27cf4bb69e4e Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Mon, 23 Apr 2012 21:42:40 +0200
Subject: [PATCH 10/10] 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.
---
 module/ice-9/vlist.scm | 297 ++++++++++++++++++++++-------------------
 1 file changed, 157 insertions(+), 140 deletions(-)

diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 22ef285f3..a09b374bc 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -70,15 +70,15 @@
   (make-fluid 2))
 
 (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, 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))))
+  ;; 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-inlinable (name block)
@@ -89,7 +89,9 @@
 (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-inlinable (block-hash-table? block)
+  (< (block-size block) (vector-length (block-content block))))
 
 (define-inlinable (set-block-next-free! block next-free)
   (vector-set! block 4 next-free))
@@ -103,20 +105,35 @@
          (vector-set! (block-content block) offset value)
          #t)))
 
-(define-inlinable (block-ref block offset)
-  (vector-ref (block-content block) offset))
+;; Return the item at slot OFFSET.
+(define-inlinable (block-ref content offset)
+  (vector-ref content offset))
 
-(define-inlinable (block-ref* block offset)
-  (let ((v (block-ref block offset)))
-    (if (block-hash-table block)
-        (car v) ;; hide the vhash link
-        v)))
+;; 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)))
 
-(define-inlinable (block-hash-table-ref block offset)
-  (vector-ref (block-hash-table block) 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))
 
-(define-inlinable (block-hash-table-set! block offset value)
-  (vector-set! (block-hash-table block) offset value))
+;; 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.
@@ -143,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))))))
@@ -159,9 +173,19 @@
   ;; The empty vlist.
   (make-vlist block-null 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?)
-  (unless (vlist? vlist)
-    (error "Expected a vlist:" vlist))
   (let ((base (vlist-base vlist))
         (offset (1+ (vlist-offset vlist))))
     (cond
@@ -186,21 +210,24 @@
 (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 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:
+;; 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.
+;;
+;; 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-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))))
+  (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))))))
 
-  (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)))))))
+  (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))
@@ -485,34 +512,24 @@ value of @var{result} for the first call to @var{proc}."
   ;; 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))))
+  (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))))))))
 
-  (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))))))))))
+  (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