1 ;;;; This file implements the stack analysis phase in the compiler. We
2 ;;;; do a graph walk to determine which unknown-values lvars are on
3 ;;;; the stack at each point in the program, and then we insert
4 ;;;; cleanup code to pop off unused values.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
17 ;;; Scan through BLOCK looking for uses of :UNKNOWN lvars that have
18 ;;; their DEST outside of the block. We do some checking to verify the
19 ;;; invariant that all pushes come after the last pop.
20 (defun find-pushed-lvars (block)
21 (let* ((2block (block-info block))
22 (popped (ir2-block-popped 2block))
24 (lvar-dest (car (last popped)))
28 (do-nodes (node lvar block)
29 (when (eq node last-pop)
33 (let ((dest (lvar-dest lvar))
34 (2lvar (lvar-info lvar)))
35 (when (and (not (eq (node-block dest) block))
37 (eq (ir2-lvar-kind 2lvar) :unknown))
38 (aver (or saw-last (not last-pop)))
41 (setf (ir2-block-pushed 2block) (pushed))))
44 ;;;; annotation graph walk
46 ;;; Add LVARs from LATE to EARLY; use EQ to check whether EARLY has
48 (defun merge-stacks (early late)
49 (declare (type list early late))
50 (cond ((null early) late)
52 ((tailp early late) late)
53 ((tailp late early) early)
55 (t (bug "Lexical unwinding of UVL stack is not implemented."))))
57 ;;; Update information on stacks of unknown-values LVARs on the
58 ;;; boundaries of BLOCK. Return true if the start stack has been
60 (defun stack-update (block)
61 (declare (type cblock block))
62 (declare (optimize (debug 3)))
63 (let* ((2block (block-info block))
64 (end (ir2-block-end-stack 2block))
66 (cleanup (block-end-cleanup block))
67 (found-similar-p nil))
68 (dolist (succ (block-succ block))
70 (when (and (< block succ)
71 (eq cleanup (block-end-cleanup succ)))
72 (setq found-similar-p t))
73 (setq new-end (merge-stacks new-end (ir2-block-start-stack (block-info succ)))))
74 (unless found-similar-p
75 (map-block-nlxes (lambda (nlx-info)
76 (let* ((nle (nlx-info-target nlx-info))
77 (nle-start-stack (ir2-block-start-stack
79 (exit-lvar (nlx-info-lvar nlx-info)))
80 (when (eq exit-lvar (car nle-start-stack))
81 (pop nle-start-stack))
82 (setq new-end (merge-stacks new-end
86 (setf (ir2-block-end-stack 2block) new-end)
87 (let ((start new-end))
88 (dolist (push (reverse (ir2-block-pushed 2block)))
89 (if (eq (car start) push)
91 (aver (not (member push start)))))
93 (dolist (pop (reverse (ir2-block-popped 2block)))
96 (cond ((equal-but-no-car-recursion start
97 (ir2-block-start-stack 2block))
100 (setf (ir2-block-start-stack 2block) start)
103 ;;; Do stack annotation for any values generators in Block that were
104 ;;; unreached by all walks (i.e. the lvar isn't live at the point that
105 ;;; it is generated.) This will only happen when the values receiver cannot be
106 ;;; reached from this particular generator (due to an unconditional control
109 ;;; What we do is push on the End-Stack all lvars in Pushed that
110 ;;; aren't already present in the End-Stack. When we find any pushed
111 ;;; lvar that isn't live, it must be the case that all lvars
112 ;;; pushed after (on top of) it aren't live.
114 ;;; If we see a pushed lvar that is the LVAR of a tail call, then we
115 ;;; ignore it, since the tail call didn't actually push anything. The
116 ;;; tail call must always the last in the block.
118 ;;; [This function also fixes End-Stack in NLEs.]
119 (defun annotate-dead-values (block)
120 (declare (type cblock block))
121 (let* ((2block (block-info block))
122 (stack (ir2-block-end-stack 2block))
123 (last (block-last block))
124 (tailp-lvar (if (node-tail-p last) (node-lvar last))))
125 (do ((pushes (ir2-block-pushed 2block) (rest pushes))
128 (let ((push (first pushes)))
129 (cond ((member push stack)
130 (aver (not popping)))
131 ((eq push tailp-lvar)
132 (aver (null (rest pushes))))
134 (push push (ir2-block-end-stack 2block))
135 (setq popping t))))))
139 ;;; For every NLE block push all LVARs that are live in its ENTRY to
140 ;;; its start stack. (We cannot pop unused LVARs on a control transfer
141 ;;; to an NLE block, so we must do it later.)
142 (defun fix-nle-block-stacks (component)
143 (declare (type component component))
144 (dolist (block (block-succ (component-head component)))
145 (let ((start-node (block-start-node block)))
146 (unless (bind-p start-node)
147 (let* ((2block (block-info block))
148 (start-stack (block-start-stack 2block))
149 (nlx-ref (ctran-next (node-next start-node)))
150 (nlx-info (constant-value (ref-leaf nlx-ref)))
151 (mess-up (cleanup-mess-up (nlx-info-cleanup nlx-info)))
152 (entry-block (node-block mess-up))
153 (entry-stack (ir2-block-start-stack (block-info entry-block)))
154 (exit-lvar (nlx-info-lvar nlx-info)))
156 (eq exit-lvar (car start-stack)))
157 (when *check-consistency*
158 (aver (not (memq exit-var entry-stack))))
159 (push exit-var entry-stack))
160 (when *check-consistency*
161 (aver (subsetp start-stack entry-stack)))
162 (setf (ir2-block-start-stack 2block) entry-stack)
163 (setf (ir2-block-end-stack 2block) entry-stack)
164 ; ANNOTATE-DEAD-VALUES will do the rest
167 ;;; This is called when we discover that the stack-top unknown-values
168 ;;; lvar at the end of BLOCK1 is different from that at the start of
169 ;;; BLOCK2 (its successor).
171 ;;; We insert a call to a funny function in a new cleanup block
172 ;;; introduced between BLOCK1 and BLOCK2. Since control analysis and
173 ;;; LTN have already run, we must do make an IR2 block, then do
174 ;;; ADD-TO-EMIT-ORDER and LTN-ANALYZE-BELATED-BLOCK on the new
175 ;;; block. The new block is inserted after BLOCK1 in the emit order.
177 ;;; If the control transfer between BLOCK1 and BLOCK2 represents a
178 ;;; tail-recursive return or a non-local exit, then the cleanup code
179 ;;; will never actually be executed. It doesn't seem to be worth the
180 ;;; risk of trying to optimize this, since this rarely happens and
181 ;;; wastes only space.
182 (defun discard-unused-values (block1 block2)
183 (declare (type cblock block1 block2))
184 (let* ((block1-stack (ir2-block-end-stack (block-info block1)))
185 (block2-stack (ir2-block-start-stack (block-info block2)))
186 (last-popped (elt block1-stack
187 (- (length block1-stack)
188 (length block2-stack)
190 (aver (tailp block2-stack block1-stack))
192 (let* ((block (insert-cleanup-code block1 block2
193 (block-start-node block2)
194 `(%pop-values ',last-popped)))
195 (2block (make-ir2-block block)))
196 (setf (block-info block) 2block)
197 (add-to-emit-order 2block (block-info block1))
198 (ltn-analyze-belated-block block)))
204 ;;; Return a list of all the blocks containing genuine uses of one of
205 ;;; the RECEIVERS. Exits are excluded, since they don't drop through
207 (defun find-values-generators (receivers)
208 (declare (list receivers))
209 (collect ((res nil adjoin))
210 (dolist (rec receivers)
211 (dolist (pop (ir2-block-popped (block-info rec)))
214 (res (node-block use))))))
217 ;;; Analyze the use of unknown-values lvars in COMPONENT, inserting
218 ;;; cleanup code to discard values that are generated but never
219 ;;; received. This phase doesn't need to be run when Values-Receivers
220 ;;; is null, i.e. there are no unknown-values lvars used across block
223 ;;; Do the backward graph walk, starting at each values receiver. We
224 ;;; ignore receivers that already have a non-null START-STACK. These
225 ;;; are nested values receivers that have already been reached on
226 ;;; another walk. We don't want to clobber that result with our null
228 (defun stack-analyze (component)
229 (declare (type component component))
230 (let* ((2comp (component-info component))
231 (receivers (ir2-component-values-receivers 2comp))
232 (generators (find-values-generators receivers)))
234 (dolist (block generators)
235 (find-pushed-lvars block))
237 (loop for did-something = nil
238 do (do-blocks-backwards (block component)
239 (when (stack-update block)
240 (setq did-something t)))
243 (when *check-consistency*
244 (dolist (block (block-succ (component-head component)))
245 (when (bind-p (block-start-node block))
246 (aver (null (ir2-block-start-stack (block-info block)))))))
248 (dolist (block generators)
249 (annotate-dead-values block))
251 (do-blocks (block component)
252 (let ((top (car (ir2-block-end-stack (block-info block)))))
253 (dolist (succ (block-succ block))
254 (when (and (block-start succ)
255 (not (eq (car (ir2-block-start-stack (block-info succ)))
257 (discard-unused-values block succ))))))