1 ;;;; This file implements the stack analysis phase in the compiler. We
2 ;;;; do a graph walk to determine which unknown-values continuations
3 ;;;; are on 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.
20 ;;; Scan through Block looking for uses of :Unknown continuations that have
21 ;;; their Dest outside of the block. We do some checking to verify the
22 ;;; invariant that all pushes come after the last pop.
23 (defun find-pushed-continuations (block)
24 (let* ((2block (block-info block))
25 (popped (ir2-block-popped 2block))
27 (continuation-dest (car (last popped)))
31 (do-nodes (node cont block)
32 (when (eq node last-pop)
35 (let ((dest (continuation-dest cont))
36 (2cont (continuation-info cont)))
38 (not (eq (node-block dest) block))
40 (eq (ir2-continuation-kind 2cont) :unknown))
41 (assert (or saw-last (not last-pop)))
44 (setf (ir2-block-pushed 2block) (pushed))))
47 ;;;; annotation graph walk
49 ;;; Do a backward walk in the flow graph simulating the run-time stack of
50 ;;; unknown-values continuations and annotating the blocks with the result.
52 ;;; Block is the block that is currently being walked and Stack is the stack
53 ;;; of unknown-values continuations in effect immediately after block. We
54 ;;; simulate the stack by popping off the unknown-values generated by this
55 ;;; block (if any) and pushing the continuations for values received by this
56 ;;; block. (The role of push and pop are interchanged because we are doing a
59 ;;; If we run into a values generator whose continuation isn't on stack top,
60 ;;; then the receiver hasn't yet been reached on any walk to this use. In this
61 ;;; case, we ignore the push for now, counting on Annotate-Dead-Values to clean
62 ;;; it up if we discover that it isn't reachable at all.
64 ;;; If our final stack isn't empty, then we walk all the predecessor blocks
65 ;;; that don't have all the continuations that we have on our Start-Stack on
66 ;;; their End-Stack. This is our termination condition for the graph walk. We
67 ;;; put the test around the recursive call so that the initial call to this
68 ;;; function will do something even though there isn't initially anything on
71 ;;; We can use the tailp test, since the only time we want to bottom out
72 ;;; with a non-empty stack is when we intersect with another path from the same
73 ;;; top-level call to this function that has more values receivers on that
74 ;;; path. When we bottom out in this way, we are counting on
75 ;;; DISCARD-UNUSED-VALUES doing its thing.
77 ;;; When we do recurse, we check that predecessor's END-STACK is a
78 ;;; subsequence of our START-STACK. There may be extra stuff on the top
79 ;;; of our stack because the last path to the predecessor may have discarded
80 ;;; some values that we use. There may be extra stuff on the bottom of our
81 ;;; stack because this walk may be from a values receiver whose lifetime
82 ;;; encloses that of the previous walk.
84 ;;; If a predecessor block is the component head, then it must be the case
85 ;;; that this is a NLX entry stub. If so, we just stop our walk, since the
86 ;;; stack at the exit point doesn't have anything to do with our stack.
87 (defun stack-simulation-walk (block stack)
88 (declare (type cblock block) (list stack))
89 (let ((2block (block-info block)))
90 (setf (ir2-block-end-stack 2block) stack)
91 (let ((new-stack stack))
92 (dolist (push (reverse (ir2-block-pushed 2block)))
93 (if (eq (car new-stack) push)
95 (assert (not (member push new-stack)))))
97 (dolist (pop (reverse (ir2-block-popped 2block)))
100 (setf (ir2-block-start-stack 2block) new-stack)
103 (dolist (pred (block-pred block))
104 (if (eq pred (component-head (block-component block)))
106 (environment-nlx-info (block-environment block))
107 :key #'nlx-info-target))
108 (let ((pred-stack (ir2-block-end-stack (block-info pred))))
109 (unless (tailp new-stack pred-stack)
110 (assert (search pred-stack new-stack))
111 (stack-simulation-walk pred new-stack))))))))
115 ;;; Do stack annotation for any values generators in Block that were
116 ;;; unreached by all walks (i.e. the continuation isn't live at the point that
117 ;;; it is generated.) This will only happen when the values receiver cannot be
118 ;;; reached from this particular generator (due to an unconditional control
121 ;;; What we do is push on the End-Stack all continuations in Pushed that
122 ;;; aren't already present in the End-Stack. When we find any pushed
123 ;;; continuation that isn't live, it must be the case that all continuations
124 ;;; pushed after (on top of) it aren't live.
126 ;;; If we see a pushed continuation that is the CONT of a tail call, then we
127 ;;; ignore it, since the tail call didn't actually push anything. The tail
128 ;;; call must always the last in the block.
129 (defun annotate-dead-values (block)
130 (declare (type cblock block))
131 (let* ((2block (block-info block))
132 (stack (ir2-block-end-stack 2block))
133 (last (block-last block))
134 (tailp-cont (if (node-tail-p last) (node-cont last))))
135 (do ((pushes (ir2-block-pushed 2block) (rest pushes))
138 (let ((push (first pushes)))
139 (cond ((member push stack)
140 (assert (not popping)))
141 ((eq push tailp-cont)
142 (assert (null (rest pushes))))
144 (push push (ir2-block-end-stack 2block))
145 (setq popping t))))))
149 ;;; Called when we discover that the stack-top unknown-values continuation
150 ;;; at the end of Block1 is different from that at the start of Block2 (its
153 ;;; We insert a call to a funny function in a new cleanup block introduced
154 ;;; between Block1 and Block2. Since control analysis and LTN have already
155 ;;; run, we must do make an IR2 block, then do ADD-TO-EMIT-ORDER and
156 ;;; LTN-ANALYZE-BLOCK on the new block. The new block is inserted after Block1
157 ;;; in the emit order.
159 ;;; If the control transfer between Block1 and Block2 represents a
160 ;;; tail-recursive return (:Deleted IR2-continuation) or a non-local exit, then
161 ;;; the cleanup code will never actually be executed. It doesn't seem to be
162 ;;; worth the risk of trying to optimize this, since this rarely happens and
163 ;;; wastes only space.
164 (defun discard-unused-values (block1 block2)
165 (declare (type cblock block1 block2))
166 (let* ((block1-stack (ir2-block-end-stack (block-info block1)))
167 (block2-stack (ir2-block-start-stack (block-info block2)))
168 (last-popped (elt block1-stack
169 (- (length block1-stack)
170 (length block2-stack)
172 (assert (tailp block2-stack block1-stack))
174 (let* ((block (insert-cleanup-code block1 block2
175 (continuation-next (block-start block2))
176 `(%pop-values ',last-popped)))
177 (2block (make-ir2-block block)))
178 (setf (block-info block) 2block)
179 (add-to-emit-order 2block (block-info block1))
180 (ltn-analyze-block block)))
186 ;;; Return a list of all the blocks containing genuine uses of one of the
187 ;;; Receivers. Exits are excluded, since they don't drop through to the
189 (defun find-values-generators (receivers)
190 (declare (list receivers))
191 (collect ((res nil adjoin))
192 (dolist (rec receivers)
193 (dolist (pop (ir2-block-popped (block-info rec)))
196 (res (node-block use))))))
199 ;;; Analyze the use of unknown-values continuations in Component, inserting
200 ;;; cleanup code to discard values that are generated but never received. This
201 ;;; phase doesn't need to be run when Values-Receivers is null, i.e. there are
202 ;;; no unknown-values continuations used across block boundaries.
204 ;;; Do the backward graph walk, starting at each values receiver. We ignore
205 ;;; receivers that already have a non-null Start-Stack. These are nested
206 ;;; values receivers that have already been reached on another walk. We don't
207 ;;; want to clobber that result with our null initial stack.
208 (defun stack-analyze (component)
209 (declare (type component component))
210 (let* ((2comp (component-info component))
211 (receivers (ir2-component-values-receivers 2comp))
212 (generators (find-values-generators receivers)))
214 (dolist (block generators)
215 (find-pushed-continuations block))
217 (dolist (block receivers)
218 (unless (ir2-block-start-stack (block-info block))
219 (stack-simulation-walk block ())))
221 (dolist (block generators)
222 (annotate-dead-values block))
224 (do-blocks (block component)
225 (let ((top (car (ir2-block-end-stack (block-info block)))))
226 (dolist (succ (block-succ block))
227 (when (and (block-start succ)
228 (not (eq (car (ir2-block-start-stack (block-info succ)))
230 (discard-unused-values block succ))))))