[Guile-commits] branch master updated: CSE computes online map of constant values, uses it to fold branches

[Andy Wingo]

This is an automated email from the git hooks/post-receive script.

wingo pushed a commit to branch master
in repository guile.

The following commit(s) were added to refs/heads/master by this push:
     new 8b994be  CSE computes online map of constant values, uses it to fold 
branches
8b994be is described below

commit 8b994be59fc4d9d23d8fad546deca3dbb2d29df7
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Aug 25 23:00:57 2020 +0200

    CSE computes online map of constant values, uses it to fold branches
    
    * module/language/cps/cse.scm (intset-intersect*): New helper.  Use it
      to replace manual uses.
      (lset-unionq, meet-constants, adjoin-constant, set-constants): New
      helpers.
      (compute-consts): New function, to compute constants at each label,
      using not only definitions but flow.
      (<analysis>): Add consts to analysis.
      (elide-predecessor, prune-branch, forward-branch, compute-out-edges)
      (propagate-analysis, eliminate-common-subexpressions-in-fun): Plumb
      consts through the algorithm.
      (fold-branch): Fold an eq-constant? using the flow-determined constant
      info.  Finally allows compile-bytecode to fold to switch statements!
    * module/language/cps/optimize.scm (optimize-first-order-cps): Move
      branch chain optimization before the final CSE/DCE pass.
---
 module/language/cps/cse.scm      | 226 ++++++++++++++++++++++++++++++---------
 module/language/cps/optimize.scm |   2 +-
 2 files changed, 175 insertions(+), 53 deletions(-)

diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 1966467..efa95cd 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -35,6 +35,9 @@
   #:use-module (language cps renumber)
   #:export (eliminate-common-subexpressions))
 
+(define (intset-intersect* out out*)
+  (if out (intset-intersect out out*) out*))
+
 (define (compute-available-expressions succs kfun clobbers)
   "Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is
 an intset containing ancestor labels whose value is available at LABEL."
@@ -46,10 +49,7 @@ an intset containing ancestor labels whose value is 
available at LABEL."
                         (intset-subtract in-1 kill-1)
                         empty-intset)))
         (add intset-union)
-        (meet (lambda (in-1 in-1*)
-                (if in-1
-                    (intset-intersect in-1 in-1*)
-                    in-1*))))
+        (meet intset-intersect*))
     (let ((in (intmap-replace init kfun empty-intset))
           (out init)
           (worklist (intset kfun)))
@@ -145,14 +145,107 @@ false.  It could be that both true and false proofs are 
available."
                   (intset kfun)
                   (intmap-add empty-intmap kfun empty-intset)))
 
+(define (lset-unionq old new)
+  (lset-union eq? old new))
+(define (meet-constants out out*)
+  (if out (intmap-intersect out out* lset-unionq) out*))
+(define (adjoin-constant in k v)
+  (intmap-add in k (list v) lset-unionq))
+
+(define (set-constants consts k in)
+  (intmap-add consts k in (lambda (old new) new)))
+
+(define (compute-consts conts kfun)
+  "Compute a map of var to a list of constant values known to be bound
+to variables at each label in CONTS.  If a var isn't present in the map
+for a label, it isn't known to be constant at that label."
+  (define (propagate consts succ out)
+    (let* ((in (intmap-ref consts succ (lambda (_) #f)))
+           (in* (meet-constants in out)))
+      (if (eq? in in*)
+          (values '() consts)
+          (values (list succ) (set-constants consts succ in*)))))
+
+  (define (visit-cont label consts)
+    (let ((in (intmap-ref consts label)))
+      (define (propagate0)
+        (values '() consts))
+      (define (propagate1 succ)
+        (propagate consts succ in))
+      (define (propagate2 succ0 succ1)
+        (let*-values (((changed0 consts) (propagate consts succ0 in))
+                      ((changed1 consts) (propagate consts succ1 in)))
+          (values (append changed0 changed1) consts)))
+      (define (propagate-branch succ0 succ1)
+        (let*-values (((changed0 consts)
+                       (propagate consts succ0
+                                  (intset-add in (false-idx label))))
+                      ((changed1 consts)
+                       (propagate consts succ1
+                                  (intset-add in (true-idx label)))))
+          (values (append changed0 changed1) consts)))
+      (define (propagate* succs)
+        (fold2 (lambda (succ changed consts)
+                 (call-with-values (lambda () (propagate consts succ in))
+                   (lambda (changed* consts)
+                     (values (append changed* changed) consts))))
+               succs '() consts))
+      (define (get-def k)
+        (match (intmap-ref conts k)
+          (($ $kargs (_) (v)) v)))
+      (define (propagate-constant consts k v c)
+        (propagate consts k (adjoin-constant in v c)))
+
+      (match (intmap-ref conts label)
+        (($ $kargs names vars term)
+         (match term
+           (($ $continue k src ($ $const c))
+            (propagate-constant consts k (get-def k) c))
+           (($ $continue k)
+            (propagate1 k))
+           (($ $branch kf kt src 'eq-constant? c (v))
+            (let*-values (((changed0 consts) (propagate1 kf))
+                          ((changed1 consts)
+                           (propagate-constant consts kt v c)))
+              (values (append changed0 changed1) consts)))
+           (($ $branch kf kt)  (propagate2 kf kt))
+           (($ $switch kf kt* src v)
+            (let-values (((changed consts) (propagate1 kf)))
+              (let lp ((i 0) (kt* kt*) (changed changed) (consts consts))
+                (match kt*
+                  (() (values changed consts))
+                  ((k . kt*)
+                   (call-with-values (lambda ()
+                                       (propagate-constant consts k v i))
+                     (lambda (changed* consts)
+                       (lp (1+ i) kt* (append changed* changed) consts))))))))
+           (($ $prompt k kh)   (propagate2 k kh))
+           (($ $throw)         (propagate0))))
+        (($ $kreceive arity k)
+         (propagate1 k))
+        (($ $kfun src meta self tail clause)
+         (if clause
+             (propagate1 clause)
+             (propagate0)))
+        (($ $kclause arity kbody kalt)
+         (if kalt
+             (propagate2 kbody kalt)
+             (propagate1 kbody)))
+        (($ $ktail) (propagate0)))))
+
+  (worklist-fold* visit-cont
+                  (intset kfun)
+                  (intmap-add empty-intmap kfun empty-intmap)))
+
 (define-record-type <analysis>
-  (make-analysis effects clobbers preds avail truthy-labels)
+  (make-analysis effects clobbers preds avail truthy-labels consts)
   analysis?
   (effects analysis-effects)
   (clobbers analysis-clobbers)
   (preds analysis-preds)
   (avail analysis-avail)
-  (truthy-labels analysis-truthy-labels))
+  (truthy-labels analysis-truthy-labels)
+  (consts analysis-consts))
 
 ;; When we determine that we can replace an expression with
 ;; already-bound variables, we change the expression to a $values.  At
@@ -198,7 +291,7 @@ false.  It could be that both true and false proofs are 
available."
 
 (define (elide-predecessor label pred out analysis)
   (match analysis
-    (($ <analysis> effects clobbers preds avail truthy-labels)
+    (($ <analysis> effects clobbers preds avail truthy-labels consts)
      (let ((pred-preds (intmap-ref preds pred)))
        (and
         ;; Don't elide predecessors that are the targets of back-edges.
@@ -217,39 +310,43 @@ false.  It could be that both true and false proofs are 
available."
                         (intmap-add (intmap-add preds label pred intset-remove)
                                     label pred-preds intset-union)
                         avail
-                        truthy-labels)))))))
+                        truthy-labels
+                        consts)))))))
 
 (define (prune-branch analysis pred succ)
   (match analysis
-    (($ <analysis> effects clobbers preds avail truthy-labels)
+    (($ <analysis> effects clobbers preds avail truthy-labels consts)
      (make-analysis effects
                     clobbers
                     (intmap-add preds succ pred intset-remove)
                     avail
-                    truthy-labels))))
+                    truthy-labels
+                    consts))))
 
 (define (forward-branch analysis pred old-succ new-succ)
   (match analysis
-    (($ <analysis> effects clobbers preds avail truthy-labels)
+    (($ <analysis> effects clobbers preds avail truthy-labels consts)
      (make-analysis effects
                     clobbers
                     (let ((preds (intmap-add preds old-succ pred
                                              intset-remove)))
                       (intmap-add preds new-succ pred intset-add))
                     avail
-                    truthy-labels))))
+                    truthy-labels
+                    consts))))
 
 (define (prune-successors analysis pred succs)
   (intset-fold (lambda (succ analysis)
                  (prune-branch analysis pred succ))
                succs analysis))
 
-(define (compute-avail-and-bool-edge analysis pred succ out)
+(define (compute-out-edges analysis pred succ out)
   (match analysis
-    (($ <analysis> effects clobbers preds avail truthy-labels)
-     (let ((avail (intmap-ref avail pred))
-           (kill  (intmap-ref clobbers pred))
-           (bool  (intmap-ref truthy-labels pred)))
+    (($ <analysis> effects clobbers preds avail truthy-labels consts)
+     (let ((avail  (intmap-ref avail pred))
+           (kill   (intmap-ref clobbers pred))
+           (bool   (intmap-ref truthy-labels pred))
+           (consts (intmap-ref consts pred)))
        (values (intset-add (intset-subtract avail kill) pred)
                (match (and (< pred succ) (intmap-ref out pred))
                  (($ $kargs _ _ ($ $branch kf kt))
@@ -257,28 +354,34 @@ false.  It could be that both true and false proofs are 
available."
                     (if (eqv? k succ) (intset-add bool idx) bool))
                   (maybe-add (maybe-add bool kf (false-idx pred))
                              kt (true-idx pred)))
-                 (_ bool)))))))
+                 (_ bool))
+               (match (and (< pred succ) (intmap-ref out pred))
+                 (($ $kargs _ _ ($ $branch kf kt src 'eq-constant? c (v)))
+                  (if (eqv? kt succ)
+                      (adjoin-constant consts v c)
+                      consts))
+                 (_ consts)))))))
 
 (define (propagate-analysis analysis label out)
   (match analysis
-    (($ <analysis> effects clobbers preds avail truthy-labels)
+    (($ <analysis> effects clobbers preds avail truthy-labels consts)
      (call-with-values
          (lambda ()
            (intset-fold
-            (lambda (pred avail-in bool-in)
+            (lambda (pred avail-in bool-in consts-in)
               (call-with-values
                   (lambda ()
-                    (compute-avail-and-bool-edge analysis pred label out))
-                (lambda (avail-in* bool-in*)
-                  (values (if avail-in
-                              (intset-intersect avail-in avail-in*)
-                              avail-in*)
-                          (intset-union bool-in bool-in*)))))
-            (intmap-ref preds label) #f empty-intset))
-       (lambda (avail-in bool-in)
+                    (compute-out-edges analysis pred label out))
+                (lambda (avail-in* bool-in* consts-in*)
+                  (values (intset-intersect* avail-in avail-in*)
+                          (intset-union bool-in bool-in*)
+                          (meet-constants consts-in consts-in*)))))
+            (intmap-ref preds label) #f empty-intset #f))
+       (lambda (avail-in bool-in consts-in)
          (make-analysis effects clobbers preds
                         (intmap-replace avail label avail-in)
-                        (intmap-replace truthy-labels label bool-in)))))))
+                        (intmap-replace truthy-labels label bool-in)
+                        (intmap-replace consts label consts-in)))))))
 
 (define (term-successors term)
   (define (list->intset ls)
@@ -316,18 +419,33 @@ false.  It could be that both true and false proofs are 
available."
     (equiv (intmap-select equiv avail))))
 
 ;; return #(taken not-taken), or #f if can't decide.
-(define (fold-branch table key kf kt avail bool)
-  (let ((equiv (lookup-equivalent-expressions table key avail)))
-    (let lp ((candidate (intmap-prev equiv)))
-      (match candidate
-        (#f #f)
-        (_ (let ((t (intset-ref bool (true-idx candidate)))
-                 (f (intset-ref bool (false-idx candidate))))
-             (if (eqv? t f)
-                 (lp (intmap-prev equiv (1- candidate)))
-                 (if t
-                     (vector kt kf)
-                     (vector kf kt)))))))))
+(define (fold-branch table key kf kt avail bool consts)
+  (define (fold-constant-comparison)
+    (match key
+      (('eq-constant? c v)
+       (match (intmap-ref consts v (lambda (v) #f))
+         (#f   #f)
+         ((c') (if (eq? c c')
+                   (vector kt kf)
+                   (vector kf kt)))
+         (c*   (if (memq c c*)
+                   #f
+                   (vector kf kt)))))
+      (_ #f)))
+  (define (fold-redundant-branch)
+    (let ((equiv (lookup-equivalent-expressions table key avail)))
+      (let lp ((candidate (intmap-prev equiv)))
+        (match candidate
+          (#f #f)
+          (_ (let ((t (intset-ref bool (true-idx candidate)))
+                   (f (intset-ref bool (false-idx candidate))))
+               (if (eqv? t f)
+                   (lp (intmap-prev equiv (1- candidate)))
+                   (if t
+                       (vector kt kf)
+                       (vector kf kt)))))))))
+  (or (fold-constant-comparison)
+      (fold-redundant-branch)))
 
 (define (eliminate-common-subexpressions-in-fun kfun conts out substs)
   (define equivalent-expressions (make-equivalent-expression-table))
@@ -453,7 +571,7 @@ false.  It could be that both true and false proofs are 
available."
       (#f (residualize))
       (key
        (match analysis
-         (($ <analysis> effects clobbers preds avail truthy-labels)
+         (($ <analysis> effects clobbers preds avail truthy-labels consts)
           (match (lookup-equivalent-expressions equivalent-expressions
                                                 key (intmap-ref avail label))
             ((? (lambda (x) (eq? x empty-intmap)))
@@ -468,10 +586,10 @@ false.  It could be that both true and false proofs are 
available."
       (values out analysis))
      (else
       (call-with-values (lambda ()
-                          (compute-avail-and-bool-edge analysis pred label 
out))
-        (lambda (pred-avail pred-bool)
+                          (compute-out-edges analysis pred label out))
+        (lambda (pred-avail pred-bool pred-consts)
           (match (fold-branch equivalent-expressions key kf kt
-                              pred-avail pred-bool)
+                              pred-avail pred-bool pred-consts)
             (#(taken not-taken)
              (values (intmap-replace!
                       out pred
@@ -488,7 +606,7 @@ false.  It could be that both true and false proofs are 
available."
       (($ $branch kf kt)
        (let ((key (compute-branch-key term)))
          (match analysis
-           (($ <analysis> effects clobbers preds avail truthy-labels)
+           (($ <analysis> effects clobbers preds avail truthy-labels consts)
             (call-with-values
                 (lambda ()
                   (intset-fold
@@ -505,11 +623,13 @@ false.  It could be that both true and false proofs are 
available."
     (match term
       (($ $branch kf kt src)
        (match analysis
-         (($ <analysis> effects clobbers preds avail truthy-labels)
+         (($ <analysis> effects clobbers preds avail truthy-labels consts)
           (let ((key (compute-branch-key term))
                 (avail (intmap-ref avail label))
-                (bool (intmap-ref truthy-labels label)))
-            (match (fold-branch equivalent-expressions key kf kt avail bool)
+                (bool (intmap-ref truthy-labels label))
+                (consts (intmap-ref consts label)))
+            (match (fold-branch equivalent-expressions key kf kt avail bool
+                                consts)
               (#(taken not-taken)
                (values (build-term ($continue taken src ($values ())))
                        (prune-branch analysis label not-taken)))
@@ -556,7 +676,7 @@ false.  It could be that both true and false proofs are 
available."
        (define (visit-term-normally)
          (visit-term label names vars term out substs analysis))
        (match analysis
-         (($ <analysis> effects clobbers preds avail truthy-labels)
+         (($ <analysis> effects clobbers preds avail truthy-labels consts)
           (let ((preds (intmap-ref preds label)))
             (cond
              ((eq? preds empty-intset)
@@ -616,11 +736,13 @@ false.  It could be that both true and false proofs are 
available."
          (succs (compute-successors conts kfun))
          (preds (invert-graph succs))
          (avail (compute-available-expressions succs kfun clobbers))
-         (truthy-labels (compute-truthy-expressions conts kfun)))
+         (truthy-labels (compute-truthy-expressions conts kfun))
+         (consts (compute-consts conts kfun)))
     (call-with-values
         (lambda ()
           (intmap-fold visit-label conts out substs
-                       (make-analysis effects clobbers preds avail 
truthy-labels)))
+                       (make-analysis effects clobbers preds avail 
truthy-labels
+                                      consts)))
       (lambda (out substs analysis)
         (values out substs)))))
 
diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index 1a2305e..3829be6 100644
--- a/module/language/cps/optimize.scm
+++ b/module/language/cps/optimize.scm
@@ -106,9 +106,9 @@
   (specialize-numbers #:specialize-numbers?)
   (hoist-loop-invariant-code #:licm?)
   (specialize-primcalls #:specialize-primcalls?)
+  (optimize-branch-chains #:optimize-branch-chains?)
   (eliminate-common-subexpressions #:cse?)
   (eliminate-dead-code #:eliminate-dead-code?)
-  (optimize-branch-chains #:optimize-branch-chains?)
   ;; Running simplify here enables rotate-loops to do a better job.
   (simplify #:simplify?)
   (rotate-loops #:rotate-loops?)