[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/06: Move some graph utilities from contification.scm
From: |
Andy Wingo |
Subject: |
[Guile-commits] 02/06: Move some graph utilities from contification.scm to utils.scm |
Date: |
Wed, 03 Jun 2015 14:49:54 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit fef50ea8da1cfe4ca5e05e5b7ff0c8df4af9a5fd
Author: Andy Wingo <address@hidden>
Date: Wed Jun 3 09:53:55 2015 +0200
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 4e419c8..b9944a4 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 7f8597a..79d37e8 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)
- [Guile-commits] branch master updated (726558f -> f541ee1), Andy Wingo, 2015/06/03
- [Guile-commits] 05/06: Add setk clause to with-cps, Andy Wingo, 2015/06/03
- [Guile-commits] 01/06: Port prune-bailouts pass to CPS2, Andy Wingo, 2015/06/03
- [Guile-commits] 02/06: Move some graph utilities from contification.scm to utils.scm,
Andy Wingo <=
- [Guile-commits] 03/06: Fix some cps2 utils bugs, Andy Wingo, 2015/06/03
- [Guile-commits] 06/06: Port type-fold to CPS2, Andy Wingo, 2015/06/03
- [Guile-commits] 04/06: Port CSE to CPS2, Andy Wingo, 2015/06/03