peval uses effects analysis

* module/language/tree-il/peval.scm: Use effects analysis from (language
  tree-il effects) instead of our own constant-expression?.  Eagerly
  mark assigned lexicals as non-copyable.

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 7f8575e..f10f24e 100644 (file)
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -19,6 +19,7 @@
 (define-module (language tree-il peval)
   #:use-module (language tree-il)
   #:use-module (language tree-il primitives)
+  #:use-module (language tree-il effects)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
@@ -301,12 +302,13 @@
   (constant-value operand-constant-value set-operand-constant-value!))
 
 (define* (make-operand var sym #:optional source visit)
-  ;; Bind SYM to VAR, with value SOURCE.  Bound operands are considered
-  ;; copyable until we prove otherwise.  If we have a source expression,
-  ;; truncate it to one value.  Copy propagation does not work on
-  ;; multiply-valued expressions.
+  ;; Bind SYM to VAR, with value SOURCE.  Unassigned bound operands are
+  ;; considered copyable until we prove otherwise.  If we have a source
+  ;; expression, truncate it to one value.  Copy propagation does not
+  ;; work on multiply-valued expressions.
   (let ((source (and=> source truncate-values)))
-    (%make-operand var sym visit source 0 #f (and source #t) #f #f)))
+    (%make-operand var sym visit source 0 #f
+                   (and source (not (var-set? var))) #f #f)))
 
 (define (make-bound-operands vars syms sources visit)
   (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
@@ -566,51 +568,15 @@ top-level bindings from ENV and return the resulting expression."
               (and tail
                    (make-sequence src (append head (list tail)))))))))))
 
+  (define compute-effects
+    (make-effects-analyzer assigned-lexical?))
+
   (define (constant-expression? x)
     ;; Return true if X is constant, for the purposes of copying or
     ;; elision---i.e., if it is known to have no effects, does not
     ;; allocate storage for a mutable object, and does not access
     ;; mutable data (like `car' or toplevel references).
-    (let loop ((x x))
-      (match x
-        (($ <void>) #t)
-        (($ <const>) #t)
-        (($ <lambda>) #t)
-        (($ <lambda-case> _ req opt rest kw inits syms body alternate)
-         (and (not (any assigned-lexical? syms))
-              (every loop inits) (loop body)
-              (or (not alternate) (loop alternate))))
-        (($ <lexical-ref> _ _ gensym)
-         (not (assigned-lexical? gensym)))
-        (($ <primitive-ref>) #t)
-        (($ <conditional> _ condition subsequent alternate)
-         (and (loop condition) (loop subsequent) (loop alternate)))
-        (($ <application> _ ($ <primitive-ref> _ 'values) exps)
-         (and (not (null? exps))
-              (every loop exps)))
-        (($ <application> _ ($ <primitive-ref> _ name) args)
-         (and (effect-free-primitive? name)
-              (not (constructor-primitive? name))
-              (not (accessor-primitive? name))
-              (types-check? name args)
-              (every loop args)))
-        (($ <application> _ ($ <lambda> _ _ body) args)
-         (and (loop body) (every loop args)))
-        (($ <sequence> _ exps)
-         (every loop exps))
-        (($ <let> _ _ syms vals body)
-         (and (not (any assigned-lexical? syms))
-              (every loop vals) (loop body)))
-        (($ <letrec> _ _ _ syms vals body)
-         (and (not (any assigned-lexical? syms))
-              (every loop vals) (loop body)))
-        (($ <fix> _ _ _ vals body)
-         (and (every loop vals) (loop body)))
-        (($ <let-values> _ exp body)
-         (and (loop exp) (loop body)))
-        (($ <prompt> _ tag body handler)
-         (and (loop tag) (loop body) (loop handler)))
-        (_ #f))))
+    (constant? (compute-effects x)))
 
   (define (prune-bindings ops in-order? body counter ctx build-result)
     ;; This helper handles both `let' and `letrec'/`fix'.  In the latter
@@ -985,14 +951,20 @@ top-level bindings from ENV and return the resulting expression."
          ((test) (make-const #f #t))
          (else exp)))
       (($ <conditional> src condition subsequent alternate)
-       (let ((condition (for-test condition)))
-         (if (const? condition)
-             (if (const-exp condition)
-                 (for-tail subsequent)
-                 (for-tail alternate))
-             (make-conditional src condition
-                               (for-tail subsequent)
-                               (for-tail alternate)))))
+       (match (for-test condition)
+         (($ <const> _ val)
+          (if val
+              (for-tail subsequent)
+              (for-tail alternate)))
+         ;; Swap the arms of (if (not FOO) A B), to simplify.
+         (($ <application> _ ($ <primitive-ref> _ 'not) (c))
+          (make-conditional src c
+                            (for-tail alternate)
+                            (for-tail subsequent)))
+         (c
+          (make-conditional src c
+                            (for-tail subsequent)
+                            (for-tail alternate)))))
       (($ <application> src
           ($ <primitive-ref> _ '@call-with-values)
           (producer