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 ;;; Do a backward walk in the flow graph simulating the run-time stack
47 ;;; of unknown-values lvars and annotating the blocks with the result.
49 ;;; BLOCK is the block that is currently being walked and STACK is the
50 ;;; stack of unknown-values lvars in effect immediately after
51 ;;; block. We simulate the stack by popping off the unknown-values
52 ;;; generated by this block (if any) and pushing the lvars for
53 ;;; values received by this block. (The role of push and pop are
54 ;;; interchanged because we are doing a backward walk.)
56 ;;; If we run into a values generator whose lvar isn't on
57 ;;; stack top, then the receiver hasn't yet been reached on any walk
58 ;;; to this use. In this case, we ignore the push for now, counting on
59 ;;; Annotate-Dead-Values to clean it up if we discover that it isn't
62 ;;; If our final stack isn't empty, then we walk all the predecessor
63 ;;; blocks that don't have all the lvars that we have on our
64 ;;; START-STACK on their END-STACK. This is our termination condition
65 ;;; for the graph walk. We put the test around the recursive call so
66 ;;; that the initial call to this function will do something even
67 ;;; though there isn't initially anything on the stack.
69 ;;; We can use the tailp test, since the only time we want to bottom
70 ;;; out with a non-empty stack is when we intersect with another path
71 ;;; from the same top level call to this function that has more values
72 ;;; receivers on that path. When we bottom out in this way, we are
73 ;;; counting on DISCARD-UNUSED-VALUES doing its thing.
75 ;;; When we do recurse, we check that predecessor's END-STACK is a
76 ;;; subsequence of our START-STACK. There may be extra stuff on the
77 ;;; top of our stack because the last path to the predecessor may have
78 ;;; discarded some values that we use. There may be extra stuff on the
79 ;;; bottom of our stack because this walk may be from a values
80 ;;; receiver whose lifetime encloses that of the previous walk.
82 ;;; If a predecessor block is the component head, then it must be the
83 ;;; case that this is a NLX entry stub. If so, we just stop our walk,
84 ;;; since the stack at the exit point doesn't have anything to do with
86 (defun stack-simulation-walk (block stack
)
87 (declare (type cblock block
) (list stack
))
88 (let ((2block (block-info block
)))
89 (setf (ir2-block-end-stack 2block
) stack
)
90 (let ((new-stack stack
))
91 (dolist (push (reverse (ir2-block-pushed 2block
)))
92 (if (eq (car new-stack
) push
)
94 (aver (not (member push new-stack
)))))
96 (dolist (pop (reverse (ir2-block-popped 2block
)))
99 (setf (ir2-block-start-stack 2block
) new-stack
)
102 (dolist (pred (block-pred block
))
103 (if (eq pred
(component-head (block-component block
)))
105 (physenv-nlx-info (block-physenv block
))
106 :key
#'nlx-info-target
))
107 (let ((pred-stack (ir2-block-end-stack (block-info pred
))))
108 (unless (tailp new-stack pred-stack
)
109 (aver (search pred-stack new-stack
))
110 (stack-simulation-walk pred new-stack
))))))))
114 ;;; Do stack annotation for any values generators in Block that were
115 ;;; unreached by all walks (i.e. the lvar isn't live at the point that
116 ;;; it is generated.) This will only happen when the values receiver cannot be
117 ;;; reached from this particular generator (due to an unconditional control
120 ;;; What we do is push on the End-Stack all lvars in Pushed that
121 ;;; aren't already present in the End-Stack. When we find any pushed
122 ;;; lvar that isn't live, it must be the case that all lvars
123 ;;; pushed after (on top of) it aren't live.
125 ;;; If we see a pushed lvar that is the LVAR of a tail call, then we
126 ;;; ignore it, since the tail call didn't actually push anything. The
127 ;;; tail call must always the last in the block.
128 (defun annotate-dead-values (block)
129 (declare (type cblock block
))
130 (let* ((2block (block-info block
))
131 (stack (ir2-block-end-stack 2block
))
132 (last (block-last block
))
133 (tailp-lvar (if (node-tail-p last
) (node-lvar last
))))
134 (do ((pushes (ir2-block-pushed 2block
) (rest pushes
))
137 (let ((push (first pushes
)))
138 (cond ((member push stack
)
139 (aver (not popping
)))
140 ((eq push tailp-lvar
)
141 (aver (null (rest pushes
))))
143 (push push
(ir2-block-end-stack 2block
))
144 (setq popping t
))))))
148 ;;; This is called when we discover that the stack-top unknown-values
149 ;;; lvar at the end of BLOCK1 is different from that at the start of
150 ;;; BLOCK2 (its successor).
152 ;;; We insert a call to a funny function in a new cleanup block
153 ;;; introduced between BLOCK1 and BLOCK2. Since control analysis and
154 ;;; LTN have already run, we must do make an IR2 block, then do
155 ;;; ADD-TO-EMIT-ORDER and LTN-ANALYZE-BELATED-BLOCK on the new
156 ;;; block. The new block is inserted after BLOCK1 in the emit order.
158 ;;; If the control transfer between BLOCK1 and BLOCK2 represents a
159 ;;; tail-recursive return or a non-local exit, then the cleanup code
160 ;;; will never actually be executed. It doesn't seem to be worth the
161 ;;; risk of trying to optimize this, since this rarely happens and
162 ;;; wastes only space.
163 (defun discard-unused-values (block1 block2
)
164 (declare (type cblock block1 block2
))
165 (let* ((block1-stack (ir2-block-end-stack (block-info block1
)))
166 (block2-stack (ir2-block-start-stack (block-info block2
)))
167 (last-popped (elt block1-stack
168 (- (length block1-stack
)
169 (length block2-stack
)
171 (aver (tailp block2-stack block1-stack
))
173 (let* ((block (insert-cleanup-code block1 block2
174 (block-start-node block2
)
175 `(%pop-values
',last-popped
)))
176 (2block (make-ir2-block block
)))
177 (setf (block-info block
) 2block
)
178 (add-to-emit-order 2block
(block-info block1
))
179 (ltn-analyze-belated-block block
)))
185 ;;; Return a list of all the blocks containing genuine uses of one of
186 ;;; the RECEIVERS. Exits are excluded, since they don't drop through
188 (defun find-values-generators (receivers)
189 (declare (list receivers
))
190 (collect ((res nil adjoin
))
191 (dolist (rec receivers
)
192 (dolist (pop (ir2-block-popped (block-info rec
)))
195 (res (node-block use
))))))
198 ;;; Analyze the use of unknown-values lvars in COMPONENT, inserting
199 ;;; cleanup code to discard values that are generated but never
200 ;;; received. This phase doesn't need to be run when Values-Receivers
201 ;;; is null, i.e. there are no unknown-values lvars used across block
204 ;;; Do the backward graph walk, starting at each values receiver. We
205 ;;; ignore receivers that already have a non-null START-STACK. These
206 ;;; are nested values receivers that have already been reached on
207 ;;; another walk. We don't want to clobber that result with our null
209 (defun stack-analyze (component)
210 (declare (type component component
))
211 (let* ((2comp (component-info component
))
212 (receivers (ir2-component-values-receivers 2comp
))
213 (generators (find-values-generators receivers
)))
215 (dolist (block generators
)
216 (find-pushed-lvars block
))
218 (dolist (block receivers
)
219 (unless (ir2-block-start-stack (block-info block
))
220 (stack-simulation-walk block
())))
222 (dolist (block generators
)
223 (annotate-dead-values block
))
225 (do-blocks (block component
)
226 (let ((top (car (ir2-block-end-stack (block-info block
)))))
227 (dolist (succ (block-succ block
))
228 (when (and (block-start succ
)
229 (not (eq (car (ir2-block-start-stack (block-info succ
)))
231 (discard-unused-values block succ
))))))