fix replacement of CSE with lexical-refwip-cse

* module/language/tree-il/cse.scm (cse): Fix dominator unrolling for
  lexical propagation.

* test-suite/tests/cse.test ("cse"): Add test.

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 _)))))