summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-07-24 11:40:00 +0200
committerAndy Wingo <wingo@pobox.com>2015-07-24 11:40:00 +0200
commitbebc70c8b1f584c9f1e360ffc38094af4a4cee49 (patch)
treed92992b12ce32e6b65b48c48200360b1f7b7c170
parentb40fac1e983007e0b5f4312c1717858e966c0198 (diff)
downloadguile-bebc70c8b1f584c9f1e360ffc38094af4a4cee49.tar.gz
Move solve-flow-equations to utils
* module/language/cps/slot-allocation.scm (compute-lazy-vars): (compute-live-variables): Adapt to solve-flow-equations interface change. * module/language/cps/utils.scm (solve-flow-equations): Move here. Use an init value instead of an init map.
-rw-r--r--module/language/cps/slot-allocation.scm60
-rw-r--r--module/language/cps/utils.scm46
2 files changed, 51 insertions, 55 deletions
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 74e71c487..6039214c8 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -128,48 +128,6 @@
(define (lookup-nlocals k allocation)
(intmap-ref (allocation-frame-sizes allocation) k))
-(define (intset-pop set)
- (match (intset-next set)
- (#f (values set #f))
- (i (values (intset-remove set i) i))))
-
-(define (solve-flow-equations succs in out kill gen subtract add meet)
- "Find a fixed point for flow equations for SUCCS, where IN and OUT are
-the initial conditions as intmaps with one key for every node in SUCCS.
-KILL and GEN are intmaps indicating the state that is killed or defined
-at every node, and SUBTRACT, ADD, and MEET operates on that state."
- (define (visit label in out)
- (let* ((in-1 (intmap-ref in label))
- (kill-1 (intmap-ref kill label))
- (gen-1 (intmap-ref gen label))
- (out-1 (intmap-ref out label))
- (out-1* (add (subtract in-1 kill-1) gen-1)))
- (if (eq? out-1 out-1*)
- (values empty-intset in out)
- (let ((out (intmap-replace! out label out-1*)))
- (call-with-values
- (lambda ()
- (intset-fold (lambda (succ in changed)
- (let* ((in-1 (intmap-ref in succ))
- (in-1* (meet in-1 out-1*)))
- (if (eq? in-1 in-1*)
- (values in changed)
- (values (intmap-replace! in succ in-1*)
- (intset-add changed succ)))))
- (intmap-ref succs label) in empty-intset))
- (lambda (in changed)
- (values changed in out)))))))
-
- (let run ((worklist (intmap-keys succs)) (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)))))))
-
(define-syntax-rule (persistent-intmap2 exp)
(call-with-values (lambda () exp)
(lambda (a b)
@@ -321,14 +279,11 @@ the definitions that are live before and after LABEL, as intsets."
(old->new (compute-reverse-control-flow-order preds)))
(call-with-values
(lambda ()
- (let ((init (rename-keys
- (intmap-map (lambda (k v) empty-intset) preds)
- old->new)))
- (solve-flow-equations (rename-graph preds old->new)
- init init
- (rename-keys defs old->new)
- (rename-keys uses old->new)
- intset-subtract intset-union intset-union)))
+ (solve-flow-equations (rename-graph preds old->new)
+ empty-intset
+ (rename-keys defs old->new)
+ (rename-keys uses old->new)
+ intset-subtract intset-union intset-union))
(lambda (in out)
;; As a reverse control-flow problem, the values flowing into a
;; node are actually the live values after the node executes.
@@ -448,12 +403,9 @@ is an active call."
(call-with-values
(lambda ()
(let ((succs (rename-graph preds old->new))
- (in (rename-keys (intmap-map (lambda (k v) #f) preds) old->new))
- (out (rename-keys (intmap-map (lambda (k v) #f) preds) old->new))
- ;(out (rename-keys gens old->new))
(kills (rename-keys kills old->new))
(gens (rename-keys gens old->new)))
- (solve-flow-equations succs in out kills gens subtract add meet)))
+ (solve-flow-equations succs #f 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 fa4673c4e..9f95e0171 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -57,6 +57,7 @@
compute-sorted-strongly-connected-components
compute-idoms
compute-dom-edges
+ solve-flow-equations
))
(define label-counter (make-parameter #f))
@@ -233,7 +234,7 @@ disjoint, an error will be signalled."
(visit-cont k labels))
(_ labels)))))))))))
-(define (compute-reachable-functions conts kfun)
+(define* (compute-reachable-functions conts #:optional (kfun 0))
"Compute a mapping LABEL->LABEL..., where each key is a reachable
$kfun and each associated value is the body of the function, as an
intset."
@@ -475,3 +476,46 @@ connected components in sorted order."
(else (intmap-add! doms idom label snoc)))))
idoms
empty-intmap)))
+
+(define (intset-pop set)
+ (match (intset-next set)
+ (#f (values set #f))
+ (i (values (intset-remove set i) i))))
+
+(define (solve-flow-equations succs init kill gen subtract add meet)
+ "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
+SUBTRACT, ADD, and MEET operates on that state."
+ (define (visit label in out)
+ (let* ((in-1 (intmap-ref in label))
+ (kill-1 (intmap-ref kill label))
+ (gen-1 (intmap-ref gen label))
+ (out-1 (intmap-ref out label))
+ (out-1* (add (subtract in-1 kill-1) gen-1)))
+ (if (eq? out-1 out-1*)
+ (values empty-intset in out)
+ (let ((out (intmap-replace! out label out-1*)))
+ (call-with-values
+ (lambda ()
+ (intset-fold (lambda (succ in changed)
+ (let* ((in-1 (intmap-ref in succ))
+ (in-1* (meet in-1 out-1*)))
+ (if (eq? in-1 in-1*)
+ (values in changed)
+ (values (intmap-replace! in succ in-1*)
+ (intset-add changed succ)))))
+ (intmap-ref succs label) in empty-intset))
+ (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))))))))