[Guile-commits] 03/05: solve-flow-equations tweak

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 4792577ab8c5c6264a48cc8d6592ca7c1103c2c7
Author: Andy Wingo <address@hidden>
Date:   Mon Jul 27 13:25:38 2015 +0200

    solve-flow-equations tweak
    
    * module/language/cps/utils.scm (solve-flow-equations): Revert to take
      separate in and out maps.  Take an optional initial worklist.
    
    * module/language/cps/slot-allocation.scm: Adapt to solve-flow-equations
      change.
---
 module/language/cps/slot-allocation.scm |   16 +++++++++++++---
 module/language/cps/utils.scm           |   22 +++++++++++-----------
 2 files changed, 24 insertions(+), 14 deletions(-)

diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 6039214..8be36e7 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -276,11 +276,15 @@ body continuation in the prompt."
 the definitions that are live before and after LABEL, as intsets."
   (let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps)))
          (preds (invert-graph succs))
-         (old->new (compute-reverse-control-flow-order preds)))
+         (old->new (compute-reverse-control-flow-order preds))
+         (init (persistent-intmap (intmap-fold
+                                   (lambda (old new init)
+                                     (intmap-add! init new empty-intset))
+                                   old->new empty-intmap))))
     (call-with-values
         (lambda ()
           (solve-flow-equations (rename-graph preds old->new)
-                                empty-intset
+                                init init
                                 (rename-keys defs old->new)
                                 (rename-keys uses old->new)
                                 intset-subtract intset-union intset-union))
@@ -403,9 +407,15 @@ is an active call."
     (call-with-values
         (lambda ()
           (let ((succs (rename-graph preds old->new))
+                (init (persistent-intmap
+                       (intmap-fold
+                        (lambda (old new in)
+                          (intmap-add! in new #f))
+                        old->new empty-intmap)))
                 (kills (rename-keys kills old->new))
                 (gens (rename-keys gens old->new)))
-            (solve-flow-equations succs #f kills gens subtract add meet)))
+            (solve-flow-equations succs init init kills gens
+                                  subtract add meet)))
       (lambda (in out)
         ;; A variable is lazy if its uses reach its definition.
         (intmap-fold (lambda (label out lazy)
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index 9f95e01..fcbda9e 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -482,7 +482,8 @@ connected components in sorted order."
     (#f (values set #f))
     (i (values (intset-remove set i) i))))
 
-(define (solve-flow-equations succs init kill gen subtract add meet)
+(define* (solve-flow-equations succs in out kill gen subtract add meet
+                               #:optional (worklist (intmap-keys succs)))
   "Find a fixed point for flow equations for SUCCS, where INIT is the
 initial state at each node in SUCCS.  KILL and GEN are intmaps
 indicating the state that is killed or defined at every node, and
@@ -509,13 +510,12 @@ SUBTRACT, ADD, and MEET operates on that state."
               (lambda (in changed)
                 (values changed in out)))))))
 
-  (let ((init (intmap-map (lambda (k v) init) succs)))
-    (let run ((worklist (intmap-keys succs)) (in init) (out init))
-      (call-with-values (lambda () (intset-pop worklist))
-        (lambda (worklist popped)
-          (if popped
-              (call-with-values (lambda () (visit popped in out))
-                (lambda (changed in out)
-                  (run (intset-union worklist changed) in out)))
-              (values (persistent-intmap in)
-                      (persistent-intmap out))))))))
+  (let run ((worklist worklist) (in in) (out out))
+    (call-with-values (lambda () (intset-pop worklist))
+      (lambda (worklist popped)
+        (if popped
+            (call-with-values (lambda () (visit popped in out))
+              (lambda (changed in out)
+                (run (intset-union worklist changed) in out)))
+            (values (persistent-intmap in)
+                    (persistent-intmap out)))))))