X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/0ea5ba9ab9e749ccb19ec12129045d0753844338..9d8a10a94c022e5fe4b58aa4b586eda514b1189f:/module/language/tree-il/cse.scm

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)