From fef50ea8da1cfe4ca5e05e5b7ff0c8df4af9a5fd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 3 Jun 2015 09:53:55 +0200 Subject: [PATCH] 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 | 47 +-------------- module/language/cps2/utils.scm | 82 ++++++++++++++++++++++++++ 2 files changed, 85 insertions(+), 44 deletions(-) diff --git a/module/language/cps2/contification.scm b/module/language/cps2/contification.scm index 4e419c83a..b9944a4f1 100644 --- a/module/language/cps2/contification.scm +++ b/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 diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm index 7f8597a7c..79d37e8ce 100644 --- a/module/language/cps2/utils.scm +++ b/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)