From fc283c92cbdb31942f033541b52376fd1bade3f2 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 27 Sep 2011 23:20:49 +0200
Subject: [PATCH] don't propagate pure primcalls that might not type-check

* module/language/tree-il/optimize.scm (types-check?): New helper, to
  determine if a primcall will apply without throwing an exception.
  (peval): constant-expression? returns #f for expressions that don't
  types-check?.  Effect-free primitives that type-check are void.
---
 module/language/tree-il/optimize.scm | 17 ++++++++++++++++-
 test-suite/tests/tree-il.test        |  5 +++--
 2 files changed, 19 insertions(+), 3 deletions(-)

diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index e9317efd1..369c2e44f 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -296,6 +296,16 @@ references to the new symbols."
     (transfer! current c effort-limit size-limit)
     c))
 
+(define (types-check? primitive-name args)
+  (case primitive-name
+    ((values) #t)
+    ((not pair? null? list? symbol? vector? struct?)
+     (= (length args) 1))
+    ((eq? eqv? equal?)
+     (= (length args) 2))
+    ;; FIXME: add more cases?
+    (else #f)))
+
 (define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
                 #:key
                 (operator-size-limit 40)
@@ -472,6 +482,7 @@ it does not handle <fix> and <let-values>, it should be called before
         (($ <application> _ ($ <primitive-ref> _ name) args)
          (and (effect-free-primitive? name)
               (not (constructor-primitive? name))
+              (types-check? name args)
               (every loop args)))
         (($ <application> _ ($ <lambda> _ _ body) args)
          (and (loop body) (every loop args)))
@@ -818,7 +829,11 @@ it does not handle <fix> and <let-values>, it should be called before
                            (make-values src (map (cut make-const src <>)
                                                  values))))
                         (make-application src proc args)))
-                  (make-application src proc args))))
+                  (cond
+                   ((and (eq? ctx 'effect) (types-check? name args))
+                    (make-void #f))
+                   (else
+                    (make-application src proc args))))))
            (($ <lambda> _ _
                ($ <lambda-case> _ req opt #f #f inits gensyms body #f))
             ;; Simple case: no rest, no keyword arguments.
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index cd3314307..d98700aed 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1085,8 +1085,9 @@
     (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
                       (apply (toplevel frob!))
                       (apply (toplevel display) (const chbouib))))
-         (apply (primitive +) (lexical x _) (lexical x _)
-                (apply (primitive *) (lexical x _) (const 2)))))
+         (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
+              (apply (primitive +)
+                     (lexical x _) (lexical x _) (lexical y _)))))
 
   (pass-if-peval
     ;; Non-constant arguments not propagated to lambdas.