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.

2 files changed, 24 insertions, 14 deletions

diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 6039214c8..8be36e716 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 9f95e0171..fcbda9e76 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)))))))