[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/06: Move solve-flow-equations to utils
From: |
Andy Wingo |
Subject: |
[Guile-commits] 02/06: Move solve-flow-equations to utils |
Date: |
Fri, 24 Jul 2015 15:13:39 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit bebc70c8b1f584c9f1e360ffc38094af4a4cee49
Author: Andy Wingo <address@hidden>
Date: Fri Jul 24 11:40:00 2015 +0200
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.
---
module/language/cps/slot-allocation.scm | 60 +++---------------------------
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 74e71c4..6039214 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 fa4673c..9f95e01 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))))))))
- [Guile-commits] branch master updated (4aabc20 -> ee85e29), Andy Wingo, 2015/07/24
- [Guile-commits] 01/06: Factor out compute-effects/elide-type-checks from dce.scm, Andy Wingo, 2015/07/24
- [Guile-commits] 04/06: Small expression-effects tweak, Andy Wingo, 2015/07/24
- [Guile-commits] 02/06: Move solve-flow-equations to utils,
Andy Wingo <=
- [Guile-commits] 05/06: Eliminate trampoline gotos when possible in compile-bytecode, Andy Wingo, 2015/07/24
- [Guile-commits] 03/06: Loop-invariant code motion, Andy Wingo, 2015/07/24
- [Guile-commits] 06/06: Rotate comparisons down to loop back-edges, Andy Wingo, 2015/07/24