[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-231-gb8da548
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-231-gb8da548 |
|
Date: |
Sat, 12 Oct 2013 14:22:54 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b8da548fba6979c02d2fe59e08265c0faf32d3e7
The branch, master has been updated
via b8da548fba6979c02d2fe59e08265c0faf32d3e7 (commit)
via 0e2446d4db77baf9117d21bb68f75a26aeb3c7ee (commit)
via 96b8027cc412ed431785a4c7ed643da2777f3263 (commit)
via 366eb4d764cc575eb48015b4e68fefc88b22706b (commit)
from 238ef4cf4413e407d1d61e379b690310f7383605 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit b8da548fba6979c02d2fe59e08265c0faf32d3e7
Author: Andy Wingo <address@hidden>
Date: Sat Oct 12 16:22:45 2013 +0200
RTL slot allocation: Don't kill variables that flow into loops
* module/language/cps/dfg.scm (dead-after-use?): Don't kill a variable
if it was defined outside the current loop.
(dead-after-branch?): Likewise, but I don't think this helper is
correct yet :/
commit 0e2446d4db77baf9117d21bb68f75a26aeb3c7ee
Author: Andy Wingo <address@hidden>
Date: Sat Oct 12 16:11:36 2013 +0200
Compute post-dominators
* module/language/cps/dfg.scm ($block): Add pdom and pdom-level fields,
for post-dominators.
(reverse-post-order, convert-predecessors): Arrange to work either
way: for dominators or for post-dominators.
(analyze-control-flow!): Compute post-dominators.
(dominates?): Refactor.
(post-dominates?): New helper.
commit 96b8027cc412ed431785a4c7ed643da2777f3263
Author: Andy Wingo <address@hidden>
Date: Sat Oct 12 15:19:01 2013 +0200
Identify loops
* module/language/cps/dfg.scm (compute-dom-edges)
(compute-join-edges, compute-reducible-back-edges)
(compute-irreducible-dom-levels, compute-nodes-by-level)
(mark-loop-body, mark-irreducible-loops, identify-loops): Identify
loops. Irreducible loops are TODO.
* test-suite/tests/rtl-compilation.test ("contification"): Add an
irreducible loop test.
commit 366eb4d764cc575eb48015b4e68fefc88b22706b
Author: Andy Wingo <address@hidden>
Date: Sat Oct 12 12:48:08 2013 +0200
DFG refactorings
* module/language/cps/dfg.scm ($block): Add "irreducible" field, format
TBD.
(reverse-post-order): Return a vector directly.
(convert-predecessors, compute-dom-levels, compute-idoms):
(analyze-control-flow!): Factor out control flow analsysis a bit
better.
(identify-loops): New helper. Currently a NOP.
(visit-fun): Adapt to compute-dominator-tree rename to
analyze-control-flow!.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps/dfg.scm | 352 ++++++++++++++++++++++++++-------
test-suite/tests/rtl-compilation.test | 13 ++-
2 files changed, 295 insertions(+), 70 deletions(-)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index fe5c245..af79466 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -105,7 +105,10 @@
(uses use-map-uses set-use-map-uses!))
(define-record-type $block
- (%make-block scope scope-level preds succs idom dom-level loop-header)
+ (%make-block scope scope-level preds succs
+ idom dom-level
+ pdom pdom-level
+ loop-header irreducible)
block?
(scope block-scope set-block-scope!)
(scope-level block-scope-level set-block-scope-level!)
@@ -113,50 +116,53 @@
(succs block-succs set-block-succs!)
(idom block-idom set-block-idom!)
(dom-level block-dom-level set-block-dom-level!)
- (loop-header block-loop-header set-block-loop-header!))
+
+ (pdom block-pdom set-block-pdom!)
+ (pdom-level block-pdom-level set-block-pdom-level!)
+
+ ;; The loop header of this block, if this block is part of a reducible
+ ;; loop. Otherwise #f.
+ (loop-header block-loop-header set-block-loop-header!)
+
+ ;; Some sort of marker that this block is part of an irreducible
+ ;; (multi-entry) loop. Otherwise #f.
+ (irreducible block-irreducible set-block-irreducible!))
(define (make-block scope scope-level)
- (%make-block scope scope-level '() '() #f #f #f))
+ (%make-block scope scope-level '() '() #f #f #f #f #f #f))
-(define (reverse-post-order k0 blocks)
+(define (reverse-post-order k0 blocks accessor)
(let ((order '())
(visited? (make-hash-table)))
(let visit ((k k0))
(hashq-set! visited? k #t)
- (match (lookup-block k blocks)
- ((and block ($ $block _ _ preds succs))
- (for-each (lambda (k)
- (unless (hashq-ref visited? k)
- (visit k)))
- succs)
- (set! order (cons k order)))))
- order))
-
-(define-inlinable (for-each/enumerate f l)
- (fold (lambda (x n) (f x n) (1+ n)) 0 l))
-
-(define (convert-predecessors order blocks)
- (let* ((len (length order))
- (mapping (make-hash-table))
- (preds-vec (make-vector len #f)))
- (for-each/enumerate
- (cut hashq-set! mapping <> <>)
- order)
- (for-each/enumerate
- (lambda (k n)
- (match (lookup-block k blocks)
- (($ $block _ _ preds)
+ (for-each (lambda (k)
+ (unless (hashq-ref visited? k)
+ (visit k)))
+ (accessor (lookup-block k blocks)))
+ (set! order (cons k order)))
+ (list->vector order)))
+
+(define (convert-predecessors order blocks accessor)
+ (let* ((mapping (make-hash-table))
+ (preds-vec (make-vector (vector-length order) #f)))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (hashq-set! mapping (vector-ref order n) n)
+ (lp (1+ n))))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (let ((preds (accessor (lookup-block (vector-ref order n) blocks))))
(vector-set! preds-vec n
;; It's possible for a predecessor to not be in
;; the mapping, if the predecessor is not
;; reachable from the entry node.
- (filter-map (cut hashq-ref mapping <>) preds)))))
- order)
+ (filter-map (cut hashq-ref mapping <>) preds))
+ (lp (1+ n)))))
preds-vec))
-(define (finish-idoms order idoms blocks)
- (let ((order (list->vector order))
- (dom-levels (make-vector (vector-length idoms) #f)))
+(define (compute-dom-levels idoms)
+ (let ((dom-levels (make-vector (vector-length idoms) #f)))
(define (compute-dom-level n)
(or (vector-ref dom-levels n)
(let ((dom-level (1+ (compute-dom-level (vector-ref idoms n)))))
@@ -164,18 +170,13 @@
dom-level)))
(vector-set! dom-levels 0 0)
(let lp ((n 0))
- (when (< n (vector-length order))
- (let* ((k (vector-ref order n))
- (idom (vector-ref idoms n))
- (b (lookup-block k blocks)))
- (set-block-idom! b (vector-ref order idom))
- (set-block-dom-level! b (compute-dom-level n))
- (lp (1+ n)))))))
+ (when (< n (vector-length idoms))
+ (compute-dom-level n)
+ (lp (1+ n))))
+ dom-levels))
-(define (compute-dominator-tree k blocks)
- (let* ((order (reverse-post-order k blocks))
- (preds (convert-predecessors order blocks))
- (idoms (make-vector (vector-length preds) 0)))
+(define (compute-idoms preds)
+ (let ((idoms (make-vector (vector-length preds) 0)))
(define (common-idom d0 d1)
;; We exploit the fact that a reverse post-order is a topological
;; sort, and so the idom of a node is always numerically less than
@@ -210,8 +211,201 @@
(iterate (1+ n) #t)))))
(changed?
(iterate 0 #f))
+ (else idoms)))))
+
+(define-inlinable (vector-push! vec idx val)
+ (let ((v vec) (i idx))
+ (vector-set! v i (cons val (vector-ref v i)))))
+
+;; Compute a vector containing, for each node, a list of the nodes that
+;; it immediately dominates. These are the "D" edges in the DJ tree.
+(define (compute-dom-edges idoms)
+ (let ((doms (make-vector (vector-length idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vector-length idoms))
+ (let ((idom (vector-ref idoms n)))
+ (vector-push! doms idom n))
+ (lp (1+ n))))
+ doms))
+
+;; Compute a vector containing, for each node, a list of the successors
+;; of that node that are not dominated by that node. These are the "J"
+;; edges in the DJ tree.
+(define (compute-join-edges preds idoms)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vector-ref idoms n2)))))
+ (let ((joins (make-vector (vector-length idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vector-length preds))
+ (for-each (lambda (pred)
+ (unless (dominates? pred n)
+ (vector-push! joins pred n)))
+ (vector-ref preds n))
+ (lp (1+ n))))
+ joins))
+
+;; Compute a vector containing, for each node, a list of the back edges
+;; to that node. If a node is not the entry of a reducible loop, that
+;; list is empty.
+(define (compute-reducible-back-edges joins idoms)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vector-ref idoms n2)))))
+ (let ((back-edges (make-vector (vector-length idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vector-length joins))
+ (for-each (lambda (succ)
+ (when (dominates? succ n)
+ (vector-push! back-edges succ n)))
+ (vector-ref joins n))
+ (lp (1+ n))))
+ back-edges))
+
+;; Compute the levels in the dominator tree at which there are
+;; irreducible loops, as an integer. If a bit N is set in the integer,
+;; that indicates that at level N in the dominator tree, there is at
+;; least one irreducible loop.
+(define (compute-irreducible-dom-levels doms joins idoms dom-levels)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vector-ref idoms n2)))))
+ (let ((pre-order (make-vector (vector-length doms) #f))
+ (last-pre-order (make-vector (vector-length doms) #f))
+ (res 0)
+ (count 0))
+ ;; Is MAYBE-PARENT an ancestor of N on the depth-first spanning tree
+ ;; computed from the DJ graph? See Havlak 1997, "Nesting of
+ ;; Reducible and Irreducible Loops".
+ (define (ancestor? a b)
+ (let ((w (vector-ref pre-order a))
+ (v (vector-ref pre-order b)))
+ (and (<= w v)
+ (<= v (vector-ref last-pre-order w)))))
+ ;; Compute depth-first spanning tree of DJ graph.
+ (define (recurse n)
+ (unless (vector-ref pre-order n)
+ (visit n)))
+ (define (visit n)
+ ;; Pre-order visitation index.
+ (vector-set! pre-order n count)
+ (set! count (1+ count))
+ (for-each recurse (vector-ref doms n))
+ (for-each recurse (vector-ref joins n))
+ ;; Pre-order visitation index of last descendant.
+ (vector-set! last-pre-order (vector-ref pre-order n) (1- count)))
+
+ (visit 0)
+
+ (let lp ((n 0))
+ (when (< n (vector-length joins))
+ (for-each (lambda (succ)
+ ;; If this join edge is not a loop back edge but it
+ ;; does go to an ancestor on the DFST of the DJ
+ ;; graph, then we have an irreducible loop.
+ (when (and (not (dominates? succ n))
+ (ancestor? succ n))
+ (set! res (logior (ash 1 (vector-ref dom-levels
succ))))))
+ (vector-ref joins n))
+ (lp (1+ n))))
+
+ res))
+
+(define (compute-nodes-by-level dom-levels)
+ (let* ((max-level (let lp ((n 0) (max-level 0))
+ (if (< n (vector-length dom-levels))
+ (lp (1+ n) (max (vector-ref dom-levels n) max-level))
+ max-level)))
+ (nodes-by-level (make-vector (1+ max-level) '())))
+ (let lp ((n (1- (vector-length dom-levels))))
+ (when (>= n 0)
+ (vector-push! nodes-by-level (vector-ref dom-levels n) n)
+ (lp (1- n))))
+ nodes-by-level))
+
+;; Collect all predecessors to the back-nodes that are strictly
+;; dominated by the loop header, and mark them as belonging to the loop.
+;; If they already have a loop header, that means they are either in a
+;; nested loop, or they have already been visited already.
+(define (mark-loop-body header back-nodes preds idoms loop-headers)
+ (define (strictly-dominates? n1 n2)
+ (and (< n1 n2)
+ (let ((idom (vector-ref idoms n2)))
+ (or (= n1 idom)
+ (strictly-dominates? n1 idom)))))
+ (define (visit node)
+ (when (strictly-dominates? header node)
+ (cond
+ ((vector-ref loop-headers node) => visit)
(else
- (finish-idoms order idoms blocks))))))
+ (vector-set! loop-headers node header)
+ (for-each visit (vector-ref preds node))))))
+ (for-each visit back-nodes))
+
+(define (mark-irreducible-loops level idoms dom-levels loop-headers)
+ ;; FIXME: Identify strongly-connected components that are >= LEVEL in
+ ;; the dominator tree, and somehow mark them as irreducible.
+ (warn 'irreducible-loops-at-level level))
+
+;; "Identifying Loops Using DJ Graphs" by Sreedhar, Gao, and Lee, ACAPS
+;; Technical Memo 98, 1995.
+(define (identify-loops preds idoms dom-levels)
+ (let* ((doms (compute-dom-edges idoms))
+ (joins (compute-join-edges preds idoms))
+ (back-edges (compute-reducible-back-edges joins idoms))
+ (irreducible-levels
+ (compute-irreducible-dom-levels doms joins idoms dom-levels))
+ (loop-headers (make-vector (vector-length preds) #f))
+ (nodes-by-level (compute-nodes-by-level dom-levels)))
+ (let lp ((level (1- (vector-length nodes-by-level))))
+ (when (>= level 0)
+ (for-each (lambda (n)
+ (let ((edges (vector-ref back-edges n)))
+ (unless (null? edges)
+ (mark-loop-body n edges preds idoms loop-headers))))
+ (vector-ref nodes-by-level level))
+ (when (logbit? level irreducible-levels)
+ (mark-irreducible-loops level idoms dom-levels loop-headers))
+ (lp (1- level))))
+ loop-headers))
+
+(define (analyze-control-flow! kentry kexit blocks)
+ ;; First go forward in the graph, computing dominators and loop
+ ;; information.
+ (let* ((order (reverse-post-order kentry blocks block-succs))
+ (preds (convert-predecessors order blocks block-preds))
+ (idoms (compute-idoms preds))
+ (dom-levels (compute-dom-levels idoms))
+ (loop-headers (identify-loops preds idoms dom-levels)))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (let* ((k (vector-ref order n))
+ (idom (vector-ref idoms n))
+ (dom-level (vector-ref dom-levels n))
+ (loop-header (vector-ref loop-headers n))
+ (b (lookup-block k blocks)))
+ (set-block-idom! b (vector-ref order idom))
+ (set-block-dom-level! b dom-level)
+ (set-block-loop-header! b (and loop-header
+ (vector-ref order loop-header)))
+ (lp (1+ n))))))
+ ;; Then go backwards, computing post-dominators.
+ (let* ((order (reverse-post-order kexit blocks block-preds))
+ (preds (convert-predecessors order blocks block-succs))
+ (idoms (compute-idoms preds))
+ (dom-levels (compute-dom-levels idoms)))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (let* ((k (vector-ref order n))
+ (pdom (vector-ref idoms n))
+ (pdom-level (vector-ref dom-levels n))
+ (b (lookup-block k blocks)))
+ (set-block-pdom! b (vector-ref order pdom))
+ (set-block-pdom-level! b pdom-level)
+ (lp (1+ n)))))))
(define (visit-fun fun conts blocks use-maps global?)
(define (add-def! sym def-k)
@@ -324,7 +518,7 @@
(visit body kbody)))
clauses)
- (compute-dominator-tree kentry blocks))))
+ (analyze-control-flow! kentry ktail blocks))))
(define* (compute-dfg fun #:key (global? #t))
(let* ((conts (make-hash-table))
@@ -487,14 +681,25 @@
;; Does k1 dominate k2?
(define (dominates? k1 k2 blocks)
- (match (lookup-block k1 blocks)
- (($ $block _ _ _ _ k1-idom k1-dom-level)
- (match (lookup-block k2 blocks)
- (($ $block _ _ _ _ k2-idom k2-dom-level)
- (cond
- ((> k1-dom-level k2-dom-level) #f)
- ((< k1-dom-level k2-dom-level) (dominates? k1 k2-idom blocks))
- ((= k1-dom-level k2-dom-level) (eqv? k1 k2))))))))
+ (let ((b1 (lookup-block k1 blocks))
+ (b2 (lookup-block k2 blocks)))
+ (let ((k1-level (block-dom-level b1))
+ (k2-level (block-dom-level b2)))
+ (cond
+ ((> k1-level k2-level) #f)
+ ((< k1-level k2-level) (dominates? k1 (block-idom b2) blocks))
+ ((= k1-level k2-level) (eqv? k1 k2))))))
+
+;; Does k1 post-dominate k2?
+(define (post-dominates? k1 k2 blocks)
+ (let ((b1 (lookup-block k1 blocks))
+ (b2 (lookup-block k2 blocks)))
+ (let ((k1-level (block-pdom-level b1))
+ (k2-level (block-pdom-level b2)))
+ (cond
+ ((> k1-level k2-level) #f)
+ ((< k1-level k2-level) (post-dominates? k1 (block-pdom b2) blocks))
+ ((= k1-level k2-level) (eqv? k1 k2))))))
(define (dead-after-def? sym dfg)
(match dfg
@@ -503,17 +708,22 @@
(($ $use-map sym def uses)
(null? uses))))))
+(define (lookup-loop-header k blocks)
+ (block-loop-header (lookup-block k blocks)))
+
(define (dead-after-use? sym use-k dfg)
(match dfg
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
- ;; If all other uses dominate this use, it is now dead. There
- ;; are other ways for it to be dead, but this is an
- ;; approximation. A better check would be if the successor
- ;; post-dominates all uses.
- (and-map (cut dominates? <> use-k blocks)
- uses))))))
+ ;; If all other uses dominate this use, and the variable was not
+ ;; defined outside the current loop, it is now dead. There are
+ ;; other ways for it to be dead, but this is an approximation.
+ ;; A better check would be if all successors post-dominate all
+ ;; uses.
+ (and (eqv? (lookup-loop-header use-k blocks)
+ (lookup-loop-header def blocks))
+ (and-map (cut dominates? <> use-k blocks) uses)))))))
;; A continuation is a "branch" if all of its predecessors are $kif
;; continuations.
@@ -541,16 +751,20 @@
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
- (and-map
- (lambda (use-k)
- ;; A symbol is dead after a branch if at least one of the
- ;; other branches dominates a use of the symbol, and all
- ;; other uses of the symbol dominate the test.
- (if (or-map (cut dominates? <> use-k blocks)
- other-branches)
- (not (dominates? branch use-k blocks))
- (dominates? use-k branch blocks)))
- uses))))))
+ ;; As in dead-after-use?, we don't kill the variable if it was
+ ;; defined outside the current loop.
+ (and (eqv? (lookup-loop-header branch blocks)
+ (lookup-loop-header def blocks))
+ (and-map
+ (lambda (use-k)
+ ;; A symbol is dead after a branch if at least one of the
+ ;; other branches dominates a use of the symbol, and all
+ ;; other uses of the symbol dominate the test.
+ (if (or-map (cut dominates? <> use-k blocks)
+ other-branches)
+ (not (dominates? branch use-k blocks))
+ (dominates? use-k branch blocks)))
+ uses)))))))
(define (lookup-bound-syms k dfg)
(match dfg
diff --git a/test-suite/tests/rtl-compilation.test
b/test-suite/tests/rtl-compilation.test
index ef4ab8d..d5cd81a 100644
--- a/test-suite/tests/rtl-compilation.test
+++ b/test-suite/tests/rtl-compilation.test
@@ -167,7 +167,18 @@
(define (odd? x)
(if (null? x) #f (even? (cdr x))))
(list (even? x))))
- '(1 2 3 4))))
+ '(1 2 3 4)))
+
+ ;; An irreducible loop between even? and odd?.
+ (pass-if-equal '#t
+ ((run-rtl '(lambda (x do-even?)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (if do-even? (even? x) (odd? x))))
+ '(1 2 3 4)
+ #t)))
(with-test-prefix "case-lambda"
(pass-if-equal "simple"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-231-gb8da548,
Andy Wingo <=