Move some graph utilities from contification.scm to utils.scm

* module/language/cps2/utils.scm (compute-successors): New helper.
  (compute-reverse-post-order): Move here from contification.scm and
  rename from "sort-nodes".
  (invert-graph): New helper.
  (compute-strongly-connected-components): Move here from
  contification.scm and rename from "compute-sccs".

* module/language/cps2/contification.scm (sort-nodes, compute-sccs): Remove.

module/language/cps2/contification.scm

@@ -257,49 +257,6 @@ function set."
      (intset->intmap (lambda (label) empty-intset) (intset-add labels 0))
      (intset->intmap (lambda (label) empty-intset) labels))))
 
-(define (sort-nodes succs start)
-  "Compute a reverse post-order numbering for a depth-first walk over
-nodes reachable from the start node."
-  (let visit ((label start) (order '()) (visited empty-intset))
-    (call-with-values
-        (lambda ()
-          (intset-fold (lambda (succ order visited)
-                         (if (intset-ref visited succ)
-                             (values order visited)
-                             (visit succ order visited)))
-                       (intmap-ref succs label)
-                       order
-                       (intset-add! visited label)))
-      (lambda (order visited)
-        ;; After visiting successors, add label to the reverse post-order.
-        (values (cons label order) visited)))))
-
-(define (compute-sccs succs start)
-  "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map
-partitioning the labels into strongly connected components (SCCs)."
-  (let ((preds (intmap-fold
-                 (lambda (pred succs preds)
-                   (intset-fold
-                    (lambda (succ preds)
-                      (intmap-add preds succ pred intset-add))
-                    succs
-                    preds))
-                 succs
-                 (intmap-map (lambda (label _) empty-intset) succs))))
-    (define (visit-scc scc sccs-by-label)
-      (let visit ((label scc) (sccs-by-label sccs-by-label))
-        (if (intmap-ref sccs-by-label label (lambda (_) #f))
-            sccs-by-label
-            (intset-fold visit
-                         (intmap-ref preds label)
-                         (intmap-add sccs-by-label label scc)))))
-    (intmap-fold
-     (lambda (label scc sccs)
-       (let ((labels (intset-add empty-intset label)))
-         (intmap-add sccs scc labels intset-union)))
-     (fold visit-scc empty-intmap (sort-nodes succs start))
-     empty-intmap)))
-
 (define (tail-label conts label)
   (match (intmap-ref conts label)
     (($ $kfun src meta self tail body)
@@ -374,7 +331,9 @@ partitioning the labels into strongly connected components (SCCs)."
        ;; has no predecessors.
        ;;
        ;; id -> label...
-       ((groups) (intmap-remove (compute-sccs calls 0) 0)))
+       ((groups) (intmap-remove
+                  (compute-strongly-connected-components calls 0)
+                  0)))
     ;; todo: thread groups through contification
     (define (attempt-contification labels contified return-substs)
       (let ((returns (compute-return-labels labels tails returns

module/language/cps2/utils.scm

@@ -45,7 +45,11 @@
             ;; Flow analysis.
             compute-constant-values
             compute-function-body
+            compute-successors
+            invert-graph
             compute-predecessors
+            compute-reverse-post-order
+            compute-strongly-connected-components
             compute-idoms
             compute-dom-edges
             ))
@@ -199,6 +203,37 @@
                              (visit-cont k labels))
                             (_ labels)))))))))))
 
+(define (compute-successors conts kfun)
+  (define (visit label succs)
+    (let visit ((label kfun) (succs empty-intmap))
+      (define (propagate0)
+        (intmap-add! succs label empty-intset))
+      (define (propagate1 succ)
+        (visit succ (intmap-add! succs label (intset succ))))
+      (define (propagate2 succ0 succ1)
+        (let ((succs (intmap-add! succs label (intset succ0 succ1))))
+          (visit succ1 (visit succ0 succs))))
+      (if (intmap-ref succs label (lambda (_) #f))
+          succs
+          (match (intmap-ref conts label)
+            (($ $kargs names vars ($ $continue k src exp))
+             (match exp
+               (($ $branch kt) (propagate2 k kt))
+               (($ $prompt escape? handler) (propagate2 k handler))
+               (_ (propagate1 k))))
+            (($ $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))))))
+  (persistent-intmap (visit kfun empty-intmap)))
+
 (define* (compute-predecessors conts kfun #:key
                                (labels (compute-function-body conts kfun)))
   (define (meet cdr car)
@@ -225,6 +260,53 @@
    (intset-fold add-preds labels
                 (intset->intmap (lambda (label) '()) labels))))
 
+(define (compute-reverse-post-order succs start)
+  "Compute a reverse post-order numbering for a depth-first walk over
+nodes reachable from the start node."
+  (let visit ((label start) (order '()) (visited empty-intset))
+    (call-with-values
+        (lambda ()
+          (intset-fold (lambda (succ order visited)
+                         (if (intset-ref visited succ)
+                             (values order visited)
+                             (visit succ order visited)))
+                       (intmap-ref succs label)
+                       order
+                       (intset-add! visited label)))
+      (lambda (order visited)
+        ;; After visiting successors, add label to the reverse post-order.
+        (values (cons label order) visited)))))
+
+(define (invert-graph succs)
+  "Given a graph PRED->SUCC..., where PRED is a label and SUCC... is an
+intset of successors, return a graph SUCC->PRED...."
+  (intmap-fold (lambda (pred succs preds)
+                 (intset-fold
+                  (lambda (succ preds)
+                    (intmap-add preds succ pred intset-add))
+                  succs
+                  preds))
+               succs
+               (intmap-map (lambda (label _) empty-intset) succs)))
+
+(define (compute-strongly-connected-components succs start)
+  "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map
+partitioning the labels into strongly connected components (SCCs)."
+  (let ((preds (invert-graph succs)))
+    (define (visit-scc scc sccs-by-label)
+      (let visit ((label scc) (sccs-by-label sccs-by-label))
+        (if (intmap-ref sccs-by-label label (lambda (_) #f))
+            sccs-by-label
+            (intset-fold visit
+                         (intmap-ref preds label)
+                         (intmap-add sccs-by-label label scc)))))
+    (intmap-fold
+     (lambda (label scc sccs)
+       (let ((labels (intset-add empty-intset label)))
+         (intmap-add sccs scc labels intset-union)))
+     (fold visit-scc empty-intmap (compute-reverse-post-order succs start))
+     empty-intmap)))
+
 ;; Precondition: For each function in CONTS, the continuation names are
 ;; topologically sorted.
 (define (compute-idoms conts kfun)