fix bugs in effects analysis of "effect+exception-free-primitives"

* module/language/tree-il/effects.scm (make-effects-analyzer): Be more
  precise regarding the effects of the so-called
  effect+exception-free-primitives: now we check their arities.

* test-suite/tests/cse.test ("cse"): Add a test that we don't
  elide (cons 1 2 3) in effect context.

diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index 656b262..4610f7f 100644 (file)
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -264,13 +264,34 @@ of an expression."
 
           ;; Effect-free primitives.
           (($ <application> _
-              ($ <primitive-ref> _ (and name
-                                        (? effect+exception-free-primitive?)))
+              ($ <primitive-ref> _ (or 'values 'eq? 'eqv? 'equal?))
               args)
-           (logior (accumulate-effects args)
-                   (if (constructor-primitive? name)
-                       (cause &allocation)
-                       &no-effects)))
+           (accumulate-effects args))
+
+          (($ <application> _
+              ($ <primitive-ref> _ (or 'not 'pair? 'null? 'list? 'symbol?
+                                       'vector? 'struct? 'string? 'number?
+                                       'char?))
+              (arg))
+           (compute-effects arg))
+
+          ;; Primitives that allocate memory.
+          (($ <application> _ ($ <primitive-ref> _ 'cons) (x y))
+           (logior (compute-effects x) (compute-effects y)
+                   &allocation))
+
+          (($ <application> _ ($ <primitive-ref> _ (or 'list 'vector)) args)
+           (logior (accumulate-effects args) &allocation))
+
+          (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ())
+           &allocation)
+
+          (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) (arg))
+           (logior (compute-effects arg) &allocation))
+
+          ;; Primitives that are normally effect-free, but which might
+          ;; cause type checks, allocate memory, or access mutable
+          ;; memory.  FIXME: expand, to be more precise.
           (($ <application> _
               ($ <primitive-ref> _ (and name
                                         (? effect-free-primitive?)))

diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index d01d318..523635f 100644 (file)
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -286,4 +286,10 @@
      (apply (primitive car) (toplevel x))
      (if (apply (primitive car) (toplevel x))
          (const one)
-         (const two)))))
+         (const two))))
+
+  (pass-if-cse
+   (begin (cons 1 2 3) 4)
+   (begin
+     (apply (primitive cons) (const 1) (const 2) (const 3))
+     (const 4))))