/[cmucl]/src/compiler/loop.lisp
ViewVC logotype

Contents of /src/compiler/loop.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Mar 19 15:19:00 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.1: +2 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Package: C -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/loop.lisp,v 1.2 2010/03/19 15:19:00 rtoy Rel $")
9 ;;; **********************************************************************
10 ;;;
11 ;;; Stuff to annotate the flow graph with information about the loops in it.
12 ;;;
13 ;;; Written by Rob MacLachlan
14 (in-package "C")
15 (intl:textdomain "cmucl")
16
17 ;;; FIND-DOMINATORS -- Internal
18 ;;;
19 ;;; Find the set of blocks that dominates each block in COMPONENT. We
20 ;;; assume that the DOMINATORS for each block is initially NIL, which
21 ;;; serves to represent the set of all blocks. If a block is not
22 ;;; reachable from an entry point, then its dominators will still be
23 ;;; NIL when we are done.
24 (defun find-dominators (component)
25 (let ((head (loop-head (component-outer-loop component)))
26 changed)
27 (let ((set (make-sset)))
28 (sset-adjoin head set)
29 (setf (block-dominators head) set))
30 (loop
31 (setq changed nil)
32 (do-blocks (block component :tail)
33 (let ((dom (block-dominators block)))
34 (when dom (sset-delete block dom))
35 (dolist (pred (block-pred block))
36 (let ((pdom (block-dominators pred)))
37 (when pdom
38 (if dom
39 (when (sset-intersection dom pdom)
40 (setq changed t))
41 (setq dom (copy-sset pdom) changed t)))))
42 (setf (block-dominators block) dom)
43 (when dom (sset-adjoin block dom))))
44 (unless changed (return)))))
45
46
47 ;;; DOMINATES-P -- Internal
48 ;;;
49 ;;; Return true if BLOCK1 dominates BLOCK2, false otherwise.
50 (defun dominates-p (block1 block2)
51 (let ((set (block-dominators block2)))
52 (if set
53 (sset-member block1 set)
54 t)))
55
56 ;;; LOOP-ANALYZE -- Interface
57 ;;;
58 ;;; Set up the LOOP structures which describe the loops in the flow
59 ;;; graph for COMPONENT. We NIL out any existing loop information,
60 ;;; and then scan through the blocks looking for blocks which are the
61 ;;; destination of a retreating edge: an edge that goes backward in
62 ;;; the DFO. We then create LOOP structures to describe the loops
63 ;;; that have those blocks as their heads. If find the head of a
64 ;;; strange loop, then we do some graph walking to find the other
65 ;;; segments in the strange loop. After we have found the loop
66 ;;; structure, we walk it to initialize the block lists.
67 (defun loop-analyze (component)
68 (let ((loop (component-outer-loop component)))
69 (do-blocks (block component :both)
70 (setf (block-loop block) nil))
71 (setf (loop-inferiors loop) ())
72 (setf (loop-blocks loop) nil)
73 (do-blocks (block component)
74 (let ((number (block-number block)))
75 (dolist (pred (block-pred block))
76 (when (<= (block-number pred) number)
77 (when (note-loop-head block component)
78 (clear-flags component)
79 (setf (block-flag block) :good)
80 (dolist (succ (block-succ block))
81 (find-strange-loop-blocks succ block))
82 (find-strange-loop-segments block component))
83 (return)))))
84 (find-loop-blocks (component-outer-loop component))))
85
86
87 ;;; FIND-LOOP-BLOCKS -- Internal
88 ;;;
89 ;;; This function initializes the block lists for LOOP and the loops
90 ;;; nested within it. We recursively descend into the loop nesting
91 ;;; and place the blocks in the appropriate loop on the way up. When
92 ;;; we are done, we scan the blocks looking for exits. An exit is
93 ;;; always a block that has a successor which doesn't have a LOOP
94 ;;; assigned yet, since the target of the exit must be in a superior
95 ;;; loop.
96 ;;;
97 ;;; We find the blocks by doing a forward walk from the head of the
98 ;;; loop and from any exits of nested loops. The walks from inferior
99 ;;; loop exits are necessary because the walks from the head terminate
100 ;;; when they encounter a block in an inferior loop.
101 (defun find-loop-blocks (loop)
102 (dolist (sub-loop (loop-inferiors loop))
103 (find-loop-blocks sub-loop))
104
105 (find-blocks-from-here (loop-head loop) loop)
106 (dolist (sub-loop (loop-inferiors loop))
107 (dolist (exit (loop-exits sub-loop))
108 (dolist (succ (block-succ exit))
109 (find-blocks-from-here succ loop))))
110
111 (collect ((exits))
112 (dolist (sub-loop (loop-inferiors loop))
113 (dolist (exit (loop-exits sub-loop))
114 (dolist (succ (block-succ exit))
115 (unless (block-loop succ)
116 (exits exit)
117 (return)))))
118
119 (do ((block (loop-blocks loop) (block-loop-next block)))
120 ((null block))
121 (dolist (succ (block-succ block))
122 (unless (block-loop succ)
123 (exits block)
124 (return))))
125 (setf (loop-exits loop) (exits))))
126
127
128 ;;; FIND-BLOCKS-FROM-HERE -- Internal
129 ;;;
130 ;;; This function does a graph walk to find the blocks directly within
131 ;;; LOOP that can be reached by a forward walk from BLOCK. If BLOCK
132 ;;; is already in a loop or is not dominated by the LOOP-HEAD, then we
133 ;;; return. Otherwise, we add the block to the BLOCKS for LOOP and
134 ;;; recurse on its successors.
135 (defun find-blocks-from-here (block loop)
136 (when (and (not (block-loop block))
137 (dominates-p (loop-head loop) block))
138 (setf (block-loop block) loop)
139 (shiftf (block-loop-next block) (loop-blocks loop) block)
140 (dolist (succ (block-succ block))
141 (find-blocks-from-here succ loop))))
142
143
144 ;;; NOTE-LOOP-HEAD -- Internal
145 ;;;
146 ;;; Create a loop structure to describe the loop headed by the block
147 ;;; HEAD. If there is one already, just return. If some retreating
148 ;;; edge into the head is from a block which isn't dominated by the
149 ;;; head, then we have the head of a strange loop segment. We return
150 ;;; true if HEAD is part of a newly discovered strange loop.
151 (defun note-loop-head (head component)
152 (let ((superior (find-superior head (component-outer-loop component))))
153 (unless (eq (loop-head superior) head)
154 (let ((result (make-loop :head head
155 :kind :natural
156 :superior superior
157 :depth (1+ (loop-depth superior))))
158 (number (block-number head)))
159 (push result (loop-inferiors superior))
160 (dolist (pred (block-pred head))
161 (when (<= (block-number pred) number)
162 (if (dominates-p head pred)
163 (push pred (loop-tail result))
164 (setf (loop-kind result) :strange))))
165 (eq (loop-kind result) :strange)))))
166
167
168 ;;; FIND-SUPERIOR -- Internal
169 ;;;
170 ;;; Find the loop which would be the superior of a loop headed by
171 ;;; HEAD. If there is already a loop with that head, then return that
172 ;;; loop.
173 (defun find-superior (head loop)
174 (if (eq (loop-head loop) head)
175 loop
176 (dolist (inferior (loop-inferiors loop) loop)
177 (when (dominates-p (loop-head inferior) head)
178 (return (find-superior head inferior))))))
179
180
181 ;;; FIND-STRANGE-LOOP-BLOCKS -- Internal
182 ;;;
183 ;;; Do a graph walk to find the blocks in the strange loop which HEAD
184 ;;; is in. BLOCK is the block we are currently at and COMPONENT is
185 ;;; the component we are in. We do a walk forward from block, using
186 ;;; only edges which are not back edges. We return true if there is a
187 ;;; path from BLOCK to HEAD, false otherwise. If the BLOCK-FLAG is
188 ;;; true then we return. We use two non-null values of FLAG to
189 ;;; indicate whether a path from the BLOCK back to HEAD was found.
190 (defun find-strange-loop-blocks (block head)
191 (let ((flag (block-flag block)))
192 (cond (flag
193 (if (eq flag :good)
194 t
195 nil))
196 (t
197 (setf (block-flag block) :bad)
198 (unless (dominates-p block head)
199 (dolist (succ (block-succ block))
200 (when (find-strange-loop-blocks succ head)
201 (setf (block-flag block) :good))))
202 (eq (block-flag block) :good)))))
203
204 ;;; FIND-STRANGE-LOOP-SEGMENTS -- Internal
205 ;;;
206 ;;; Do a graph walk to find the segments in the strange loop that has
207 ;;; BLOCK in it. We walk forward, looking only at blocks in the loop
208 ;;; (flagged as :GOOD.) Each block in the loop that has predecessors
209 ;;; outside of the loop is the head of a segment. We enter the LOOP
210 ;;; structures in COMPONENT.
211 (defun find-strange-loop-segments (block component)
212 (when (eq (block-flag block) :good)
213 (setf (block-flag block) :done)
214 (unless (every #'(lambda (x) (member (block-flag x) '(:good :done)))
215 (block-pred block))
216 (note-loop-head block component))
217 (dolist (succ (block-succ block))
218 (find-strange-loop-segments succ component))))

  ViewVC Help
Powered by ViewVC 1.1.5