mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-06-03 09:53:55 +02:00
parent ba44619672
commit fef50ea8da
2 changed files with 85 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

47
module/language/cps2/contification.scm
View file

@ -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

82
module/language/cps2/utils.scm
View file

@ -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)