From dc1ee62046c130c6b26a96ca862663406ecbc7b1 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 15 May 2012 17:20:01 +0200
Subject: [PATCH] CSE in tail position

* module/language/tree-il/cse.scm (singly-valued-expression?, cse):
  Allow CSE to propagate lexicals to tail positions, if the expression
  is singly-valued.
---
 module/language/tree-il/cse.scm | 17 ++++++++++++++++-
 1 file changed, 16 insertions(+), 1 deletion(-)

diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index a3b4a9d23..5ba590637 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -154,6 +154,21 @@
     (($ <const> _ (? boolean?)) #t)
     (_ (eq? ctx 'test))))
 
+(define (singly-valued-expression? x ctx)
+  (match x
+    (($ <const>) #t)
+    (($ <lexical-ref>) #t)
+    (($ <void>) #t)
+    (($ <lexical-ref>) #t)
+    (($ <primitive-ref>) #t)
+    (($ <module-ref>) #t)
+    (($ <toplevel-ref>) #t)
+    (($ <application> _
+        ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
+    (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+    (($ <lambda>) #t)
+    (_ (eq? ctx 'value))))
+
 (define* (cse exp)
   "Eliminate common subexpressions in EXP."
 
@@ -371,7 +386,7 @@
           => (lambda (exp)
                (log 'propagate-test ctx (unparse-tree-il exp))
                (values exp db*)))
-         ((and (eq? ctx 'value)
+         ((and (singly-valued-expression? exp ctx)
                (find-dominating-lexical exp effects env db))
           => (lambda (exp)
                (log 'propagate-value ctx (unparse-tree-il exp))