1 ;;;; This file contains the control analysis pass in the compiler. This
2 ;;;; 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.
24 ;;; Insert Block in the emission order after the block After.
25 (defun add-to-emit-order (block after)
26 (declare (type block-annotation block after))
27 (let ((next (block-annotation-next after)))
28 (setf (block-annotation-next after) block)
29 (setf (block-annotation-prev block) after)
30 (setf (block-annotation-next block) next)
31 (setf (block-annotation-prev next) block))
34 ;;; If Block looks like the head of a loop, then attempt to rotate it.
35 ;;; A block looks like a loop head if the number of some predecessor
36 ;;; is less than the block's number. Since blocks are numbered in
37 ;;; reverse DFN, this will identify loop heads in a reducible flow
40 ;;; When we find a suspected loop head, we scan back from the tail to
41 ;;; find an alternate loop head. This substitution preserves the
42 ;;; correctness of the walk, since the old head can be reached from
43 ;;; the new head. We determine the new head by scanning as far back as
44 ;;; we can find increasing block numbers. Beats me if this is in
45 ;;; general optimal, but it works in simple cases.
47 ;;; This optimization is inhibited in functions with NLX EPs, since it
48 ;;; is hard to do this without possibly messing up the special-case
49 ;;; walking from NLX EPs described in CONTROL-ANALYZE-1-FUN. We also
50 ;;; suppress rotation of loop heads which are the start of a function
51 ;;; (i.e. tail calls), as the debugger wants functions to start at the
53 (defun find-rotated-loop-head (block)
54 (declare (type cblock block))
55 (let* ((num (block-number block))
56 (env (block-environment block))
57 (pred (dolist (pred (block-pred block) nil)
58 (when (and (not (block-flag pred))
59 (eq (block-environment pred) env)
60 (< (block-number pred) num))
64 (not (environment-nlx-info env))
65 (not (eq (node-block (lambda-bind (block-home-lambda block)))
68 (current-num (block-number pred)))
71 (dolist (pred (block-pred current) (return-from DONE))
74 (when (and (not (block-flag pred))
75 (eq (block-environment pred) env)
76 (> (block-number pred) current-num))
77 (setq current pred current-num (block-number pred))
79 (assert (not (block-flag current)))
84 ;;; Do a graph walk linking blocks into the emit order as we go. We call
85 ;;; FIND-ROTATED-LOOP-HEAD to do while-loop optimization.
87 ;;; We treat blocks ending in tail local calls to other environments
88 ;;; specially. We can't walked the called function immediately, since it is in
89 ;;; a different function and we must keep the code for a function contiguous.
90 ;;; Instead, we return the function that we want to call so that it can be
91 ;;; walked as soon as possible, which is hopefully immediately.
93 ;;; If any of the recursive calls ends in a tail local call, then we return
94 ;;; the last such function, since it is the only one we can possibly drop
95 ;;; through to. (But it doesn't have to be from the last block walked, since
96 ;;; that call might not have added anything.)
98 ;;; We defer walking successors whose successor is the component tail (end
99 ;;; in an error, NLX or tail full call.) This is to discourage making error
100 ;;; code the drop-through.
101 (defun control-analyze-block (block tail block-info-constructor)
102 (declare (type cblock block) (type block-annotation tail))
103 (unless (block-flag block)
104 (let ((block (find-rotated-loop-head block)))
105 (setf (block-flag block) t)
106 (assert (and (block-component block) (not (block-delete-p block))))
107 (add-to-emit-order (or (block-info block)
108 (setf (block-info block)
109 (funcall block-info-constructor block)))
110 (block-annotation-prev tail))
112 (let ((last (block-last block)))
113 (cond ((and (combination-p last) (node-tail-p last)
114 (eq (basic-combination-kind last) :local)
115 (not (eq (node-environment last)
116 (lambda-environment (combination-lambda last)))))
117 (combination-lambda last))
119 (let ((component-tail (component-tail (block-component block)))
120 (block-succ (block-succ block))
122 (dolist (succ block-succ)
123 (unless (eq (first (block-succ succ)) component-tail)
124 (let ((res (control-analyze-block
125 succ tail block-info-constructor)))
126 (when res (setq fun res)))))
127 (dolist (succ block-succ)
128 (control-analyze-block succ tail block-info-constructor))
131 ;;; Analyze all of the NLX EPs first to ensure that code reachable only from
132 ;;; a NLX is emitted contiguously with the code reachable from the Bind. Code
133 ;;; reachable from the Bind is inserted *before* the NLX code so that the Bind
134 ;;; marks the beginning of the code for the function. If the walks from NLX
135 ;;; EPs reach the bind block, then we just move it to the beginning.
137 ;;; If the walk from the bind node encountered a tail local call, then we
138 ;;; start over again there to help the call drop through. Of course, it will
139 ;;; never get a drop-through if either function has NLX code.
140 (defun control-analyze-1-fun (fun component block-info-constructor)
141 (declare (type clambda fun) (type component component))
142 (let* ((tail-block (block-info (component-tail component)))
143 (prev-block (block-annotation-prev tail-block))
144 (bind-block (node-block (lambda-bind fun))))
145 (unless (block-flag bind-block)
146 (dolist (nlx (environment-nlx-info (lambda-environment fun)))
147 (control-analyze-block (nlx-info-target nlx) tail-block
148 block-info-constructor))
150 ((block-flag bind-block)
151 (let* ((block-note (block-info bind-block))
152 (prev (block-annotation-prev block-note))
153 (next (block-annotation-next block-note)))
154 (setf (block-annotation-prev next) prev)
155 (setf (block-annotation-next prev) next)
156 (add-to-emit-order block-note prev-block)))
158 (let ((new-fun (control-analyze-block bind-block
159 (block-annotation-next
161 block-info-constructor)))
163 (control-analyze-1-fun new-fun component
164 block-info-constructor)))))))
167 ;;; Do control analysis on Component, finding the emit order. Our only
168 ;;; cleverness here is that we walk XEP's first to increase the probability
169 ;;; that the tail call will be a drop-through.
171 ;;; When we are done, we delete blocks that weren't reached by the walk.
172 ;;; Some return blocks are made unreachable by LTN without setting
173 ;;; COMPONENT-REANALYZE. We remove all deleted blocks from the IR2-COMPONENT
174 ;;; VALUES-RECEIVERS to keep stack analysis from getting confused.
175 (defevent control-deleted-block "control analysis deleted dead block")
176 (defun control-analyze (component block-info-constructor)
177 (declare (type component component)
178 (type function block-info-constructor))
179 (let* ((head (component-head component))
180 (head-block (funcall block-info-constructor head))
181 (tail (component-tail component))
182 (tail-block (funcall block-info-constructor tail)))
183 (setf (block-info head) head-block)
184 (setf (block-info tail) tail-block)
185 (setf (block-annotation-prev tail-block) head-block)
186 (setf (block-annotation-next head-block) tail-block)
188 (clear-flags component)
190 (dolist (fun (component-lambdas component))
191 (when (external-entry-point-p fun)
192 (control-analyze-1-fun fun component block-info-constructor)))
194 (dolist (fun (component-lambdas component))
195 (control-analyze-1-fun fun component block-info-constructor))
197 (do-blocks (block component)
198 (unless (block-flag block)
199 (event control-deleted-block (continuation-next (block-start block)))
200 (delete-block block))))
202 (let ((2comp (component-info component)))
203 (when (ir2-component-p 2comp)
204 ;; If it's not an ir2-component, don't worry about it.
205 (setf (ir2-component-values-receivers 2comp)
206 (delete-if-not #'block-component
207 (ir2-component-values-receivers 2comp)))))