1 ;;;; This file contains the control analysis pass in the compiler.
2 ;;;; This pass determines the order in which the IR2 blocks are to be
3 ;;;; emitted, attempting to minimize the associated branching costs.
5 ;;;; At this point, we commit to generating IR2 (and ultimately
6 ;;;; assembler) for reachable blocks. Before this phase there might be
7 ;;;; blocks that are unreachable but still appear in the DFO, due in
8 ;;;; inadequate optimization, etc.
10 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; more information.
13 ;;;; This software is derived from the CMU CL system, which was
14 ;;;; written at Carnegie Mellon University and released into the
15 ;;;; public domain. The software is in the public domain and is
16 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
17 ;;;; files for more information.
21 ;;; Insert BLOCK in the emission order after the block AFTER.
22 (defun add-to-emit-order (block after
)
23 (declare (type block-annotation block after
))
24 (let ((next (block-annotation-next after
)))
25 (setf (block-annotation-next after
) block
)
26 (setf (block-annotation-prev block
) after
)
27 (setf (block-annotation-next block
) next
)
28 (setf (block-annotation-prev next
) block
))
31 ;;; If BLOCK looks like the head of a loop, then attempt to rotate it.
32 ;;; A block looks like a loop head if the number of some predecessor
33 ;;; is less than the block's number. Since blocks are numbered in
34 ;;; reverse DFN, this will identify loop heads in a reducible flow
37 ;;; When we find a suspected loop head, we scan back from the tail to
38 ;;; find an alternate loop head. This substitution preserves the
39 ;;; correctness of the walk, since the old head can be reached from
40 ;;; the new head. We determine the new head by scanning as far back as
41 ;;; we can find increasing block numbers. Beats me if this is in
42 ;;; general optimal, but it works in simple cases.
44 ;;; This optimization is inhibited in functions with NLX EPs, since it
45 ;;; is hard to do this without possibly messing up the special-case
46 ;;; walking from NLX EPs described in CONTROL-ANALYZE-1-FUN. We also
47 ;;; suppress rotation of loop heads which are the start of a function
48 ;;; (i.e. tail calls), as the debugger wants functions to start at the
51 ;;; The rotation also is not done if the back edge identified in the
52 ;;; first step originates from a block that has more than one successor.
53 ;;; This matches loops that have their terminating condition tested at
54 ;;; the end, for which the original block order already minimizes the
55 ;;; number of branches: the back edge starts at a conditional branch at
56 ;;; the loop's tail and no other branches are needed. We used not to
57 ;;; test for this situation, rotating these loops, too, resulting in
58 ;;; machine code that looked like this
61 ;;; conditionally branch to L2 if the loop should terminate
64 ;;; which is ugly, and larger and often slower than what is generated
65 ;;; when not rotating these loops.
66 (defun find-rotated-loop-head (block)
67 (declare (type cblock block
))
68 (let* ((num (block-number block
))
69 (env (block-physenv block
))
70 (pred (dolist (pred (block-pred block
) nil
)
71 (when (and (not (block-flag pred
))
72 (eq (block-physenv pred
) env
)
73 (< (block-number pred
) num
))
77 (not (physenv-nlx-info env
))
78 (not (eq (lambda-block (block-home-lambda block
)) block
))
79 (null (cdr (block-succ pred
))))
81 (current-num (block-number pred
)))
84 (dolist (pred (block-pred current
) (return-from DONE
))
87 (when (and (not (block-flag pred
))
88 (eq (block-physenv pred
) env
)
89 (> (block-number pred
) current-num
))
90 (setq current pred current-num
(block-number pred
))
92 (aver (not (block-flag current
)))
97 ;;; Do a graph walk linking blocks into the emit order as we go. We
98 ;;; call FIND-ROTATED-LOOP-HEAD to do while-loop optimization.
100 ;;; We treat blocks ending in tail local calls to other environments
101 ;;; specially. We can't walked the called function immediately, since
102 ;;; it is in a different function and we must keep the code for a
103 ;;; function contiguous. Instead, we return the function that we want
104 ;;; to call so that it can be walked as soon as possible, which is
105 ;;; hopefully immediately.
107 ;;; If any of the recursive calls ends in a tail local call, then we
108 ;;; return the last such function, since it is the only one we can
109 ;;; possibly drop through to. (But it doesn't have to be from the last
110 ;;; block walked, since that call might not have added anything.)
112 ;;; We defer walking successors whose successor is the component tail
113 ;;; (end in an error, NLX or tail full call.) This is to discourage
114 ;;; making error code the drop-through.
115 (defun control-analyze-block (block tail block-info-constructor
)
116 (declare (type cblock block
)
117 (type block-annotation tail
)
118 (type function block-info-constructor
))
119 (unless (block-flag block
)
120 (let ((block (find-rotated-loop-head block
)))
121 (setf (block-flag block
) t
)
122 (aver (and (block-component block
) (not (block-delete-p block
))))
123 (add-to-emit-order (or (block-info block
)
124 (setf (block-info block
)
125 (funcall block-info-constructor block
)))
126 (block-annotation-prev tail
))
128 (let ((last (block-last block
)))
129 (cond ((and (combination-p last
) (node-tail-p last
)
130 (eq (basic-combination-kind last
) :local
)
131 (not (eq (node-physenv last
)
132 (lambda-physenv (combination-lambda last
)))))
133 (combination-lambda last
))
135 (let ((component-tail (component-tail (block-component block
)))
136 (block-succ (block-succ block
))
138 (dolist (succ block-succ
)
139 (unless (eq (first (block-succ succ
)) component-tail
)
140 (let ((res (control-analyze-block
141 succ tail block-info-constructor
)))
142 (when res
(setq fun res
)))))
143 (dolist (succ block-succ
)
144 (control-analyze-block succ tail block-info-constructor
))
147 ;;; Analyze all of the NLX EPs first to ensure that code reachable
148 ;;; only from a NLX is emitted contiguously with the code reachable
149 ;;; from the BIND. Code reachable from the BIND is inserted *before*
150 ;;; the NLX code so that the BIND marks the beginning of the code for
151 ;;; the function. If the walks from NLX EPs reach the BIND block, then
152 ;;; we just move it to the beginning.
154 ;;; If the walk from the BIND node encountered a tail local call, then
155 ;;; we start over again there to help the call drop through. Of
156 ;;; course, it will never get a drop-through if either function has
158 (defun control-analyze-1-fun (fun component block-info-constructor
)
159 (declare (type clambda fun
)
160 (type component component
)
161 (type function block-info-constructor
))
162 (let* ((tail-block (block-info (component-tail component
)))
163 (prev-block (block-annotation-prev tail-block
))
164 (bind-block (node-block (lambda-bind fun
))))
165 (unless (block-flag bind-block
)
166 (dolist (nlx (physenv-nlx-info (lambda-physenv fun
)))
167 (control-analyze-block (nlx-info-target nlx
) tail-block
168 block-info-constructor
))
170 ((block-flag bind-block
)
171 (let* ((block-note (block-info bind-block
))
172 (prev (block-annotation-prev block-note
))
173 (next (block-annotation-next block-note
)))
174 (setf (block-annotation-prev next
) prev
)
175 (setf (block-annotation-next prev
) next
)
176 (add-to-emit-order block-note prev-block
)))
178 (let ((new-fun (control-analyze-block bind-block
179 (block-annotation-next
181 block-info-constructor
)))
183 (control-analyze-1-fun new-fun component
184 block-info-constructor
)))))))
187 ;;; Do control analysis on COMPONENT, finding the emit order. Our only
188 ;;; cleverness here is that we walk XEP's first to increase the
189 ;;; probability that the tail call will be a drop-through.
191 ;;; When we are done, we delete blocks that weren't reached by the
192 ;;; walk. Some return blocks are made unreachable by LTN without
193 ;;; setting COMPONENT-REANALYZE. We remove all deleted blocks from the
194 ;;; IR2-COMPONENT VALUES-RECEIVERS to keep stack analysis from getting
196 (defevent control-deleted-block
"control analysis deleted dead block")
197 (defun control-analyze (component block-info-constructor
)
198 (declare (type component component
)
199 (type function block-info-constructor
))
200 (let* ((head (component-head component
))
201 (head-block (funcall block-info-constructor head
))
202 (tail (component-tail component
))
203 (tail-block (funcall block-info-constructor tail
)))
204 (setf (block-info head
) head-block
)
205 (setf (block-info tail
) tail-block
)
206 (setf (block-annotation-prev tail-block
) head-block
)
207 (setf (block-annotation-next head-block
) tail-block
)
209 (clear-flags component
)
211 (dolist (fun (component-lambdas component
))
213 (control-analyze-1-fun fun component block-info-constructor
)))
215 (dolist (fun (component-lambdas component
))
216 (control-analyze-1-fun fun component block-info-constructor
))
218 (do-blocks (block component
)
219 (unless (block-flag block
)
220 (event control-deleted-block
(block-start-node block
))
221 (delete-block block
))))
223 (let ((2comp (component-info component
)))
224 (when (ir2-component-p 2comp
)
225 ;; If it's not an IR2-COMPONENT, don't worry about it.
226 (setf (ir2-component-values-receivers 2comp
)
227 (delete-if-not #'block-component
228 (ir2-component-values-receivers 2comp
)))))