diff options
author | Andy Wingo <wingo@pobox.com> | 2015-07-24 11:40:00 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-07-24 11:40:00 +0200 |
commit | bebc70c8b1f584c9f1e360ffc38094af4a4cee49 (patch) | |
tree | d92992b12ce32e6b65b48c48200360b1f7b7c170 | |
parent | b40fac1e983007e0b5f4312c1717858e966c0198 (diff) | |
download | guile-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.scm | 60 | ||||
-rw-r--r-- | module/language/cps/utils.scm | 46 |
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)))))))) |