more conservative classoid-name clearing
[sbcl.git] / src / compiler / loop.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
9
10 ;;; **********************************************************************
11 ;;;
12 ;;; Stuff to annotate the flow graph with information about the loops in it.
13 ;;;
14 ;;; Written by Rob MacLachlan
15 (in-package "SB!C")
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))))