0.7.8.28:
[sbcl.git] / src / compiler / control.lisp
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.
4 ;;;;
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.
9
10 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; more information.
12 ;;;;
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.
18
19 (in-package "SB!C")
20
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))
29   (values))
30
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
35 ;;; graph.
36 ;;;
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.
43 ;;;
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
49 ;;; start.
50 (defun find-rotated-loop-head (block)
51   (declare (type cblock block))
52   (let* ((num (block-number block))
53          (env (block-physenv block))
54          (pred (dolist (pred (block-pred block) nil)
55                  (when (and (not (block-flag pred))
56                             (eq (block-physenv pred) env)
57                             (< (block-number pred) num))
58                    (return pred)))))
59     (cond
60      ((and pred
61            (not (physenv-nlx-info env))
62            (not (eq (lambda-block (block-home-lambda block)) block)))
63       (let ((current pred)
64             (current-num (block-number pred)))
65         (block DONE
66           (loop
67             (dolist (pred (block-pred current) (return-from DONE))
68               (when (eq pred block)
69                 (return-from DONE))
70               (when (and (not (block-flag pred))
71                          (eq (block-physenv pred) env)
72                          (> (block-number pred) current-num))
73                 (setq current pred   current-num (block-number pred))
74                 (return)))))
75         (aver (not (block-flag current)))
76         current))
77      (t
78       block))))
79
80 ;;; Do a graph walk linking blocks into the emit order as we go. We
81 ;;; call FIND-ROTATED-LOOP-HEAD to do while-loop optimization.
82 ;;;
83 ;;; We treat blocks ending in tail local calls to other environments
84 ;;; specially. We can't walked the called function immediately, since
85 ;;; it is in a different function and we must keep the code for a
86 ;;; function contiguous. Instead, we return the function that we want
87 ;;; to call so that it can be walked as soon as possible, which is
88 ;;; hopefully immediately.
89 ;;;
90 ;;; If any of the recursive calls ends in a tail local call, then we
91 ;;; return the last such function, since it is the only one we can
92 ;;; possibly drop through to. (But it doesn't have to be from the last
93 ;;; block walked, since that call might not have added anything.)
94 ;;;
95 ;;; We defer walking successors whose successor is the component tail
96 ;;; (end in an error, NLX or tail full call.) This is to discourage
97 ;;; making error code the drop-through.
98 (defun control-analyze-block (block tail block-info-constructor)
99   (declare (type cblock block) (type block-annotation tail))
100   (unless (block-flag block)
101     (let ((block (find-rotated-loop-head block)))
102       (setf (block-flag block) t)
103       (aver (and (block-component block) (not (block-delete-p block))))
104       (add-to-emit-order (or (block-info block)
105                              (setf (block-info block)
106                                    (funcall block-info-constructor block)))
107                          (block-annotation-prev tail))
108
109       (let ((last (block-last block)))
110         (cond ((and (combination-p last) (node-tail-p last)
111                     (eq (basic-combination-kind last) :local)
112                     (not (eq (node-physenv last)
113                              (lambda-physenv (combination-lambda last)))))
114                (combination-lambda last))
115               (t
116                (let ((component-tail (component-tail (block-component block)))
117                      (block-succ (block-succ block))
118                      (fun nil))
119                  (dolist (succ block-succ)
120                    (unless (eq (first (block-succ succ)) component-tail)
121                      (let ((res (control-analyze-block
122                                  succ tail block-info-constructor)))
123                        (when res (setq fun res)))))
124                  (dolist (succ block-succ)
125                    (control-analyze-block succ tail block-info-constructor))
126                  fun)))))))
127
128 ;;; Analyze all of the NLX EPs first to ensure that code reachable
129 ;;; only from a NLX is emitted contiguously with the code reachable
130 ;;; from the BIND. Code reachable from the BIND is inserted *before*
131 ;;; the NLX code so that the BIND marks the beginning of the code for
132 ;;; the function. If the walks from NLX EPs reach the BIND block, then
133 ;;; we just move it to the beginning.
134 ;;;
135 ;;; If the walk from the BIND node encountered a tail local call, then
136 ;;; we start over again there to help the call drop through. Of
137 ;;; course, it will never get a drop-through if either function has
138 ;;; NLX code.
139 (defun control-analyze-1-fun (fun component block-info-constructor)
140   (declare (type clambda fun) (type component component))
141   (let* ((tail-block (block-info (component-tail component)))
142          (prev-block (block-annotation-prev tail-block))
143          (bind-block (node-block (lambda-bind fun))))
144     (unless (block-flag bind-block)
145       (dolist (nlx (physenv-nlx-info (lambda-physenv fun)))
146         (control-analyze-block (nlx-info-target nlx) tail-block
147                                block-info-constructor))
148       (cond
149        ((block-flag bind-block)
150         (let* ((block-note (block-info bind-block))
151                (prev (block-annotation-prev block-note))
152                (next (block-annotation-next block-note)))
153           (setf (block-annotation-prev next) prev)
154           (setf (block-annotation-next prev) next)
155           (add-to-emit-order block-note prev-block)))
156        (t
157         (let ((new-fun (control-analyze-block bind-block
158                                               (block-annotation-next
159                                                prev-block)
160                                               block-info-constructor)))
161           (when new-fun
162             (control-analyze-1-fun new-fun component
163                                    block-info-constructor)))))))
164   (values))
165
166 ;;; Do control analysis on COMPONENT, finding the emit order. Our only
167 ;;; cleverness here is that we walk XEP's first to increase the
168 ;;; probability that the tail call will be a drop-through.
169 ;;;
170 ;;; When we are done, we delete blocks that weren't reached by the
171 ;;; walk. Some return blocks are made unreachable by LTN without
172 ;;; setting COMPONENT-REANALYZE. We remove all deleted blocks from the
173 ;;; IR2-COMPONENT VALUES-RECEIVERS to keep stack analysis from getting
174 ;;; 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)
187
188     (clear-flags component)
189
190     (dolist (fun (component-lambdas component))
191       (when (xep-p fun)
192         (control-analyze-1-fun fun component block-info-constructor)))
193
194     (dolist (fun (component-lambdas component))
195       (control-analyze-1-fun fun component block-info-constructor))
196
197     (do-blocks (block component)
198       (unless (block-flag block)
199         (event control-deleted-block (continuation-next (block-start block)))
200         (delete-block block))))
201
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)))))
208
209   (values))