[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guilecommits] GNU Guile branch, master, updated. v2.1.0231gb8da548
From: 
Andy Wingo 
Subject: 
[Guilecommits] GNU Guile branch, master, updated. v2.1.0231gb8da548 
Date: 
Sat, 12 Oct 2013 14:22:54 +0000 
This is an automated email from the git hooks/postreceive 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 (deadafteruse?): Don't kill a variable
if it was defined outside the current loop.
(deadafterbranch?): 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 postdominators
* module/language/cps/dfg.scm ($block): Add pdom and pdomlevel fields,
for postdominators.
(reversepostorder, convertpredecessors): Arrange to work either
way: for dominators or for postdominators.
(analyzecontrolflow!): Compute postdominators.
(dominates?): Refactor.
(postdominates?): 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 (computedomedges)
(computejoinedges, computereduciblebackedges)
(computeirreducibledomlevels, computenodesbylevel)
(markloopbody, markirreducibleloops, identifyloops): Identify
loops. Irreducible loops are TODO.
* testsuite/tests/rtlcompilation.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.
(reversepostorder): Return a vector directly.
(convertpredecessors, computedomlevels, computeidoms):
(analyzecontrolflow!): Factor out control flow analsysis a bit
better.
(identifyloops): New helper. Currently a NOP.
(visitfun): Adapt to computedominatortree rename to
analyzecontrolflow!.

Summary of changes:
module/language/cps/dfg.scm  352 ++++++++++++++++++++++++++
testsuite/tests/rtlcompilation.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 usemapuses setusemapuses!))
(definerecordtype $block
 (%makeblock scope scopelevel preds succs idom domlevel loopheader)
+ (%makeblock scope scopelevel preds succs
+ idom domlevel
+ pdom pdomlevel
+ loopheader irreducible)
block?
(scope blockscope setblockscope!)
(scopelevel blockscopelevel setblockscopelevel!)
@@ 113,50 +116,53 @@
(succs blocksuccs setblocksuccs!)
(idom blockidom setblockidom!)
(domlevel blockdomlevel setblockdomlevel!)
 (loopheader blockloopheader setblockloopheader!))
+
+ (pdom blockpdom setblockpdom!)
+ (pdomlevel blockpdomlevel setblockpdomlevel!)
+
+ ;; The loop header of this block, if this block is part of a reducible
+ ;; loop. Otherwise #f.
+ (loopheader blockloopheader setblockloopheader!)
+
+ ;; Some sort of marker that this block is part of an irreducible
+ ;; (multientry) loop. Otherwise #f.
+ (irreducible blockirreducible setblockirreducible!))
(define (makeblock scope scopelevel)
 (%makeblock scope scopelevel '() '() #f #f #f))
+ (%makeblock scope scopelevel '() '() #f #f #f #f #f #f))
(define (reversepostorder k0 blocks)
+(define (reversepostorder k0 blocks accessor)
(let ((order '())
(visited? (makehashtable)))
(let visit ((k k0))
(hashqset! visited? k #t)
 (match (lookupblock k blocks)
 ((and block ($ $block _ _ preds succs))
 (foreach (lambda (k)
 (unless (hashqref visited? k)
 (visit k)))
 succs)
 (set! order (cons k order)))))
 order))

(defineinlinable (foreach/enumerate f l)
 (fold (lambda (x n) (f x n) (1+ n)) 0 l))

(define (convertpredecessors order blocks)
 (let* ((len (length order))
 (mapping (makehashtable))
 (predsvec (makevector len #f)))
 (foreach/enumerate
 (cut hashqset! mapping <> <>)
 order)
 (foreach/enumerate
 (lambda (k n)
 (match (lookupblock k blocks)
 (($ $block _ _ preds)
+ (foreach (lambda (k)
+ (unless (hashqref visited? k)
+ (visit k)))
+ (accessor (lookupblock k blocks)))
+ (set! order (cons k order)))
+ (list>vector order)))
+
+(define (convertpredecessors order blocks accessor)
+ (let* ((mapping (makehashtable))
+ (predsvec (makevector (vectorlength order) #f)))
+ (let lp ((n 0))
+ (when (< n (vectorlength order))
+ (hashqset! mapping (vectorref order n) n)
+ (lp (1+ n))))
+ (let lp ((n 0))
+ (when (< n (vectorlength order))
+ (let ((preds (accessor (lookupblock (vectorref order n) blocks))))
(vectorset! predsvec n
;; It's possible for a predecessor to not be in
;; the mapping, if the predecessor is not
;; reachable from the entry node.
 (filtermap (cut hashqref mapping <>) preds)))))
 order)
+ (filtermap (cut hashqref mapping <>) preds))
+ (lp (1+ n)))))
predsvec))
(define (finishidoms order idoms blocks)
 (let ((order (list>vector order))
 (domlevels (makevector (vectorlength idoms) #f)))
+(define (computedomlevels idoms)
+ (let ((domlevels (makevector (vectorlength idoms) #f)))
(define (computedomlevel n)
(or (vectorref domlevels n)
(let ((domlevel (1+ (computedomlevel (vectorref idoms n)))))
@@ 164,18 +170,13 @@
domlevel)))
(vectorset! domlevels 0 0)
(let lp ((n 0))
 (when (< n (vectorlength order))
 (let* ((k (vectorref order n))
 (idom (vectorref idoms n))
 (b (lookupblock k blocks)))
 (setblockidom! b (vectorref order idom))
 (setblockdomlevel! b (computedomlevel n))
 (lp (1+ n)))))))
+ (when (< n (vectorlength idoms))
+ (computedomlevel n)
+ (lp (1+ n))))
+ domlevels))
(define (computedominatortree k blocks)
 (let* ((order (reversepostorder k blocks))
 (preds (convertpredecessors order blocks))
 (idoms (makevector (vectorlength preds) 0)))
+(define (computeidoms preds)
+ (let ((idoms (makevector (vectorlength preds) 0)))
(define (commonidom d0 d1)
;; We exploit the fact that a reverse postorder 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)))))
+
+(defineinlinable (vectorpush! vec idx val)
+ (let ((v vec) (i idx))
+ (vectorset! v i (cons val (vectorref 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 (computedomedges idoms)
+ (let ((doms (makevector (vectorlength idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vectorlength idoms))
+ (let ((idom (vectorref idoms n)))
+ (vectorpush! 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 (computejoinedges preds idoms)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vectorref idoms n2)))))
+ (let ((joins (makevector (vectorlength idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vectorlength preds))
+ (foreach (lambda (pred)
+ (unless (dominates? pred n)
+ (vectorpush! joins pred n)))
+ (vectorref 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 (computereduciblebackedges joins idoms)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vectorref idoms n2)))))
+ (let ((backedges (makevector (vectorlength idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vectorlength joins))
+ (foreach (lambda (succ)
+ (when (dominates? succ n)
+ (vectorpush! backedges succ n)))
+ (vectorref joins n))
+ (lp (1+ n))))
+ backedges))
+
+;; 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 (computeirreducibledomlevels doms joins idoms domlevels)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vectorref idoms n2)))))
+ (let ((preorder (makevector (vectorlength doms) #f))
+ (lastpreorder (makevector (vectorlength doms) #f))
+ (res 0)
+ (count 0))
+ ;; Is MAYBEPARENT an ancestor of N on the depthfirst spanning tree
+ ;; computed from the DJ graph? See Havlak 1997, "Nesting of
+ ;; Reducible and Irreducible Loops".
+ (define (ancestor? a b)
+ (let ((w (vectorref preorder a))
+ (v (vectorref preorder b)))
+ (and (<= w v)
+ (<= v (vectorref lastpreorder w)))))
+ ;; Compute depthfirst spanning tree of DJ graph.
+ (define (recurse n)
+ (unless (vectorref preorder n)
+ (visit n)))
+ (define (visit n)
+ ;; Preorder visitation index.
+ (vectorset! preorder n count)
+ (set! count (1+ count))
+ (foreach recurse (vectorref doms n))
+ (foreach recurse (vectorref joins n))
+ ;; Preorder visitation index of last descendant.
+ (vectorset! lastpreorder (vectorref preorder n) (1 count)))
+
+ (visit 0)
+
+ (let lp ((n 0))
+ (when (< n (vectorlength joins))
+ (foreach (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 (vectorref domlevels
succ))))))
+ (vectorref joins n))
+ (lp (1+ n))))
+
+ res))
+
+(define (computenodesbylevel domlevels)
+ (let* ((maxlevel (let lp ((n 0) (maxlevel 0))
+ (if (< n (vectorlength domlevels))
+ (lp (1+ n) (max (vectorref domlevels n) maxlevel))
+ maxlevel)))
+ (nodesbylevel (makevector (1+ maxlevel) '())))
+ (let lp ((n (1 (vectorlength domlevels))))
+ (when (>= n 0)
+ (vectorpush! nodesbylevel (vectorref domlevels n) n)
+ (lp (1 n))))
+ nodesbylevel))
+
+;; Collect all predecessors to the backnodes 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 (markloopbody header backnodes preds idoms loopheaders)
+ (define (strictlydominates? n1 n2)
+ (and (< n1 n2)
+ (let ((idom (vectorref idoms n2)))
+ (or (= n1 idom)
+ (strictlydominates? n1 idom)))))
+ (define (visit node)
+ (when (strictlydominates? header node)
+ (cond
+ ((vectorref loopheaders node) => visit)
(else
 (finishidoms order idoms blocks))))))
+ (vectorset! loopheaders node header)
+ (foreach visit (vectorref preds node))))))
+ (foreach visit backnodes))
+
+(define (markirreducibleloops level idoms domlevels loopheaders)
+ ;; FIXME: Identify stronglyconnected components that are >= LEVEL in
+ ;; the dominator tree, and somehow mark them as irreducible.
+ (warn 'irreducibleloopsatlevel level))
+
+;; "Identifying Loops Using DJ Graphs" by Sreedhar, Gao, and Lee, ACAPS
+;; Technical Memo 98, 1995.
+(define (identifyloops preds idoms domlevels)
+ (let* ((doms (computedomedges idoms))
+ (joins (computejoinedges preds idoms))
+ (backedges (computereduciblebackedges joins idoms))
+ (irreduciblelevels
+ (computeirreducibledomlevels doms joins idoms domlevels))
+ (loopheaders (makevector (vectorlength preds) #f))
+ (nodesbylevel (computenodesbylevel domlevels)))
+ (let lp ((level (1 (vectorlength nodesbylevel))))
+ (when (>= level 0)
+ (foreach (lambda (n)
+ (let ((edges (vectorref backedges n)))
+ (unless (null? edges)
+ (markloopbody n edges preds idoms loopheaders))))
+ (vectorref nodesbylevel level))
+ (when (logbit? level irreduciblelevels)
+ (markirreducibleloops level idoms domlevels loopheaders))
+ (lp (1 level))))
+ loopheaders))
+
+(define (analyzecontrolflow! kentry kexit blocks)
+ ;; First go forward in the graph, computing dominators and loop
+ ;; information.
+ (let* ((order (reversepostorder kentry blocks blocksuccs))
+ (preds (convertpredecessors order blocks blockpreds))
+ (idoms (computeidoms preds))
+ (domlevels (computedomlevels idoms))
+ (loopheaders (identifyloops preds idoms domlevels)))
+ (let lp ((n 0))
+ (when (< n (vectorlength order))
+ (let* ((k (vectorref order n))
+ (idom (vectorref idoms n))
+ (domlevel (vectorref domlevels n))
+ (loopheader (vectorref loopheaders n))
+ (b (lookupblock k blocks)))
+ (setblockidom! b (vectorref order idom))
+ (setblockdomlevel! b domlevel)
+ (setblockloopheader! b (and loopheader
+ (vectorref order loopheader)))
+ (lp (1+ n))))))
+ ;; Then go backwards, computing postdominators.
+ (let* ((order (reversepostorder kexit blocks blockpreds))
+ (preds (convertpredecessors order blocks blocksuccs))
+ (idoms (computeidoms preds))
+ (domlevels (computedomlevels idoms)))
+ (let lp ((n 0))
+ (when (< n (vectorlength order))
+ (let* ((k (vectorref order n))
+ (pdom (vectorref idoms n))
+ (pdomlevel (vectorref domlevels n))
+ (b (lookupblock k blocks)))
+ (setblockpdom! b (vectorref order pdom))
+ (setblockpdomlevel! b pdomlevel)
+ (lp (1+ n)))))))
(define (visitfun fun conts blocks usemaps global?)
(define (adddef! sym defk)
@@ 324,7 +518,7 @@
(visit body kbody)))
clauses)
 (computedominatortree kentry blocks))))
+ (analyzecontrolflow! kentry ktail blocks))))
(define* (computedfg fun #:key (global? #t))
(let* ((conts (makehashtable))
@@ 487,14 +681,25 @@
;; Does k1 dominate k2?
(define (dominates? k1 k2 blocks)
 (match (lookupblock k1 blocks)
 (($ $block _ _ _ _ k1idom k1domlevel)
 (match (lookupblock k2 blocks)
 (($ $block _ _ _ _ k2idom k2domlevel)
 (cond
 ((> k1domlevel k2domlevel) #f)
 ((< k1domlevel k2domlevel) (dominates? k1 k2idom blocks))
 ((= k1domlevel k2domlevel) (eqv? k1 k2))))))))
+ (let ((b1 (lookupblock k1 blocks))
+ (b2 (lookupblock k2 blocks)))
+ (let ((k1level (blockdomlevel b1))
+ (k2level (blockdomlevel b2)))
+ (cond
+ ((> k1level k2level) #f)
+ ((< k1level k2level) (dominates? k1 (blockidom b2) blocks))
+ ((= k1level k2level) (eqv? k1 k2))))))
+
+;; Does k1 postdominate k2?
+(define (postdominates? k1 k2 blocks)
+ (let ((b1 (lookupblock k1 blocks))
+ (b2 (lookupblock k2 blocks)))
+ (let ((k1level (blockpdomlevel b1))
+ (k2level (blockpdomlevel b2)))
+ (cond
+ ((> k1level k2level) #f)
+ ((< k1level k2level) (postdominates? k1 (blockpdom b2) blocks))
+ ((= k1level k2level) (eqv? k1 k2))))))
(define (deadafterdef? sym dfg)
(match dfg
@@ 503,17 +708,22 @@
(($ $usemap sym def uses)
(null? uses))))))
+(define (lookuploopheader k blocks)
+ (blockloopheader (lookupblock k blocks)))
+
(define (deadafteruse? sym usek dfg)
(match dfg
(($ $dfg conts blocks usemaps)
(match (lookupusemap sym usemaps)
(($ $usemap 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
 ;; postdominates all uses.
 (andmap (cut dominates? <> usek 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 postdominate all
+ ;; uses.
+ (and (eqv? (lookuploopheader usek blocks)
+ (lookuploopheader def blocks))
+ (andmap (cut dominates? <> usek blocks) uses)))))))
;; A continuation is a "branch" if all of its predecessors are $kif
;; continuations.
@@ 541,16 +751,20 @@
(($ $dfg conts blocks usemaps)
(match (lookupusemap sym usemaps)
(($ $usemap sym def uses)
 (andmap
 (lambda (usek)
 ;; 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 (ormap (cut dominates? <> usek blocks)
 otherbranches)
 (not (dominates? branch usek blocks))
 (dominates? usek branch blocks)))
 uses))))))
+ ;; As in deadafteruse?, we don't kill the variable if it was
+ ;; defined outside the current loop.
+ (and (eqv? (lookuploopheader branch blocks)
+ (lookuploopheader def blocks))
+ (andmap
+ (lambda (usek)
+ ;; 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 (ormap (cut dominates? <> usek blocks)
+ otherbranches)
+ (not (dominates? branch usek blocks))
+ (dominates? usek branch blocks)))
+ uses)))))))
(define (lookupboundsyms k dfg)
(match dfg
diff git a/testsuite/tests/rtlcompilation.test
b/testsuite/tests/rtlcompilation.test
index ef4ab8d..d5cd81a 100644
 a/testsuite/tests/rtlcompilation.test
+++ b/testsuite/tests/rtlcompilation.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?.
+ (passifequal '#t
+ ((runrtl '(lambda (x doeven?)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (if doeven? (even? x) (odd? x))))
+ '(1 2 3 4)
+ #t)))
(withtestprefix "caselambda"
(passifequal "simple"
hooks/postreceive

GNU Guile
[Prev in Thread] 
Current Thread 
[Next in Thread] 
 [Guilecommits] GNU Guile branch, master, updated. v2.1.0231gb8da548,
Andy Wingo <=