Prepare for CSE bailout propagation

* module/language/cps/cse.scm (compute-available-expressions): Prepare
  for being able to prune joins from bailouts.  Always loop after the
  first iteration.

* module/language/cps/effects-analysis.scm: Remove &possible-bailout.
  Rename &definite-bailout to &bailout, and rename
  &all-effects-but-bailout to &unknown-effects.

module/language/cps/cse.scm

@@ -88,24 +88,40 @@ index corresponds to MIN-LABEL, and so on."
                  (out (vector-ref avail-out n))
                  (fx (vector-ref effects n)))
             ;; Intersect avail-out from predecessors into "in".
-            (match (lookup-predecessors (idx->label n) dfg)
+            (let lp ((preds (lookup-predecessors (idx->label n) dfg))
-              (() #t)
+                     (initialized? #f))
-              (preds
+              (match preds
-               (bitvector-fill! in #t)
+                (() #t)
-               (for-each (lambda (pred)
+                ((pred . preds)
-                           (let ((pred (label->idx pred)))
+                 (let ((pred (label->idx pred)))
-                             ;; Avoid intersecting back-edges and
+                   (cond
-                             ;; cross-edges on the first iteration.
+                    ((or (and first? (<= n pred))
-                             (unless (and first? (<= n pred))
+                         ;; Here it would be nice to avoid intersecting
-                               (intersect! in (vector-ref avail-out pred)))))
+                         ;; with predecessors that bail out, which might
-                         (lookup-predecessors (idx->label n) dfg))))
+                         ;; allow expressions from the other (if there's
+                         ;; only one) predecessor to propagate past the
+                         ;; join.  However that would require the tree
+                         ;; to be rewritten so that the successor is
+                         ;; correctly scoped, and gets the right
+                         ;; dominator.  Punt for now.
+
+                         ;; (bitvector-ref bailouts pred)
+                         )
+                     ;; Avoid intersecting back-edges and cross-edges on
+                     ;; the first iteration.
+                     (lp preds initialized?))
+                    (else
+                     (if initialized?
+                         (intersect! in (vector-ref avail-out pred))
+                         (bitvector-copy! in (vector-ref avail-out pred)))
+                     (lp preds #t)))))))
             (let ((new-count (bit-count #t in)))
               (unless (= prev-count new-count)
                 ;; Copy "in" to "out".
                 (bitvector-copy! out in)
                 ;; Kill expressions that don't commute.
                 (cond
-                 ((causes-all-effects? fx &all-effects-but-bailout)
+                 ((causes-all-effects? fx &unknown-effects)
                   ;; Fast-path if this expression clobbers the world.
                   (intersect! out always-avail))
                  ((effect-free? (exclude-effects fx &type-check))
@@ -129,7 +145,7 @@ index corresponds to MIN-LABEL, and so on."
                 (bitvector-set! out n #t))
               (lp (1+ n) first? (or changed? (not (= prev-count new-count)))))))
          (else
-          (if changed?
+          (if (or first? changed?)
               (lp 0 #f #f)
               avail-in)))))))
 

module/language/cps/effects-analysis.scm

@@ -49,8 +49,7 @@
             &fluid
             &fluid-environment
             &prompt
-            &definite-bailout
+            &bailout
-            &possible-bailout
             &allocation
             &car
             &cdr
@@ -64,7 +63,7 @@
 
             &no-effects
             &all-effects
-            &all-effects-but-bailout
+            &unknown-effects
 
             effects-commute?
             exclude-effects
@@ -121,10 +120,7 @@
 
     ;; Indicates that an expression definitely causes a non-local,
     ;; non-resumable exit -- a bailout.  Only used in the "changes" sense.
-    &definite-bailout
+    &bailout
-
-    ;; Indicates that an expression may cause a bailout.
-    &possible-bailout
 
     ;; Indicates that an expression may return a fresh object -- a
     ;; "causes" effect.
@@ -186,8 +182,7 @@
   (define-effects &all-effects
     &fluid
     &prompt
-    &definite-bailout
+    &bailout
-    &possible-bailout
     &allocation
     &car
     &cdr
@@ -209,16 +204,12 @@
 
 (define-syntax &no-effects (identifier-syntax 0))
 
-;; Definite bailout is an oddball effect.  Since it indicates that an
+;; An expression with unknown effects can cause any effect, except
-;; expression definitely causes bailout, it's not in the set of effects
+;; &bailout (which indicates certain bailout).
-;; of a call to an unknown procedure.  At the same time, it's also
-;; special in that a definite bailout in a subexpression doesn't always
-;; cause an outer expression to include &definite-bailout in its
-;; effects.  For that reason we have to treat it specially.
 ;;
-(define-syntax &all-effects-but-bailout
+(define-syntax &unknown-effects
   (identifier-syntax
-   (logand &all-effects (lognot &definite-bailout))))
+   (logand &all-effects (lognot &bailout))))
 
 (define-inlinable (cause effect)
   (ash effect 1))
@@ -257,8 +248,7 @@
   (begin
     (hashq-set! *primitive-effects* 'name
                 (case-lambda* ((dfg . args) effects)
-                              (_ (logior (cause &possible-bailout)
+                              (_ (cause &bailout))))
-                                         (cause &definite-bailout)))))
     ...))
 
 (define-syntax-rule (define-primitive-effects ((name . args) effects) ...)
@@ -304,9 +294,9 @@
 
 ;; Bailout.
 (define-primitive-effects
-  ((error . _) (logior (cause &definite-bailout) (cause &possible-bailout)))
+  ((error . _) (logior (cause &bailout)))
-  ((scm-error . _) (logior (cause &definite-bailout) (cause &possible-bailout)))
+  ((scm-error . _) (logior (cause &bailout)))
-  ((throw . _) (logior (cause &definite-bailout) (cause &possible-bailout))))
+  ((throw . _) (logior (cause &bailout))))
 
 ;; Pairs.
 (define-primitive-effects
@@ -457,7 +447,7 @@
   (let ((proc (hashq-ref *primitive-effects* name)))
     (if proc
         (apply proc dfg args)
-        (logior &all-effects-but-bailout (cause &all-effects-but-bailout)))))
+        (logior &unknown-effects (cause &unknown-effects)))))
 
 (define (expression-effects exp dfg)
   (match exp
@@ -468,7 +458,7 @@
     (($ $prompt)
      (cause &prompt))
     ((or ($ $call) ($ $callk))
-     (logior &all-effects-but-bailout (cause &all-effects-but-bailout)))
+     (logior &unknown-effects (cause &unknown-effects)))
     (($ $primcall name args)
      (primitive-effects dfg name args))))