0.7.4.20:
[sbcl.git] / src / compiler / stack.lisp
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.
5
6 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; more information.
8 ;;;;
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.
14
15 (in-package "SB!C")
16 \f
17 ;;; Scan through BLOCK looking for uses of :UNKNOWN continuations that
18 ;;; have their DEST outside of the block. We do some checking to
19 ;;; verify the invariant that all pushes come after the last pop.
20 (defun find-pushed-continuations (block)
21   (let* ((2block (block-info block))
22          (popped (ir2-block-popped 2block))
23          (last-pop (if popped
24                        (continuation-dest (car (last popped)))
25                        nil)))
26     (collect ((pushed))
27       (let ((saw-last nil))
28         (do-nodes (node cont block)
29           (when (eq node last-pop)
30             (setq saw-last t))
31
32           (let ((dest (continuation-dest cont))
33                 (2cont (continuation-info cont)))
34             (when (and dest
35                        (not (eq (node-block dest) block))
36                        2cont
37                        (eq (ir2-continuation-kind 2cont) :unknown))
38               (aver (or saw-last (not last-pop)))
39               (pushed cont)))))
40
41       (setf (ir2-block-pushed 2block) (pushed))))
42   (values))
43 \f
44 ;;;; annotation graph walk
45
46 ;;; Do a backward walk in the flow graph simulating the run-time stack
47 ;;; of unknown-values continuations and annotating the blocks with the
48 ;;; result.
49 ;;;
50 ;;; BLOCK is the block that is currently being walked and STACK is the
51 ;;; stack of unknown-values continuations in effect immediately after
52 ;;; block. We simulate the stack by popping off the unknown-values
53 ;;; generated by this block (if any) and pushing the continuations for
54 ;;; values received by this block. (The role of push and pop are
55 ;;; interchanged because we are doing a backward walk.)
56 ;;;
57 ;;; If we run into a values generator whose continuation isn't on
58 ;;; stack top, then the receiver hasn't yet been reached on any walk
59 ;;; to this use. In this case, we ignore the push for now, counting on
60 ;;; Annotate-Dead-Values to clean it up if we discover that it isn't
61 ;;; reachable at all.
62 ;;;
63 ;;; If our final stack isn't empty, then we walk all the predecessor
64 ;;; blocks that don't have all the continuations that we have on our
65 ;;; START-STACK on their END-STACK. This is our termination condition
66 ;;; for the graph walk. We put the test around the recursive call so
67 ;;; that the initial call to this function will do something even
68 ;;; though there isn't initially anything on the stack.
69 ;;;
70 ;;; We can use the tailp test, since the only time we want to bottom
71 ;;; out with a non-empty stack is when we intersect with another path
72 ;;; from the same top level call to this function that has more values
73 ;;; receivers on that path. When we bottom out in this way, we are
74 ;;; counting on DISCARD-UNUSED-VALUES doing its thing.
75 ;;;
76 ;;; When we do recurse, we check that predecessor's END-STACK is a
77 ;;; subsequence of our START-STACK. There may be extra stuff on the
78 ;;; top of our stack because the last path to the predecessor may have
79 ;;; discarded some values that we use. There may be extra stuff on the
80 ;;; bottom of our stack because this walk may be from a values
81 ;;; receiver whose lifetime encloses that of the previous walk.
82 ;;;
83 ;;; If a predecessor block is the component head, then it must be the
84 ;;; case that this is a NLX entry stub. If so, we just stop our walk,
85 ;;; since the stack at the exit point doesn't have anything to do with
86 ;;; 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)
94             (pop new-stack)
95             (aver (not (member push new-stack)))))
96
97       (dolist (pop (reverse (ir2-block-popped 2block)))
98         (push pop new-stack))
99
100       (setf (ir2-block-start-stack 2block) new-stack)
101
102       (when new-stack
103         (dolist (pred (block-pred block))
104           (if (eq pred (component-head (block-component block)))
105               (aver (find block
106                           (physenv-nlx-info (block-physenv 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                   (aver (search pred-stack new-stack))
111                   (stack-simulation-walk pred new-stack))))))))
112
113   (values))
114
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
119 ;;; transfer.)
120 ;;;
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.
125 ;;;
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))
136          (popping nil))
137         ((null pushes))
138       (let ((push (first pushes)))
139         (cond ((member push stack)
140                (aver (not popping)))
141               ((eq push tailp-cont)
142                (aver (null (rest pushes))))
143               (t
144                (push push (ir2-block-end-stack 2block))
145                (setq popping t))))))
146
147   (values))
148 \f
149 ;;; This is called when we discover that the stack-top unknown-values
150 ;;; continuation at the end of BLOCK1 is different from that at the
151 ;;; start of BLOCK2 (its successor).
152 ;;;
153 ;;; We insert a call to a funny function in a new cleanup block
154 ;;; introduced between BLOCK1 and BLOCK2. Since control analysis and
155 ;;; LTN have already run, we must do make an IR2 block, then do
156 ;;; ADD-TO-EMIT-ORDER and LTN-ANALYZE-BELATED-BLOCK on the new block.
157 ;;; The new block is inserted after BLOCK1 in the emit order.
158 ;;;
159 ;;; If the control transfer between BLOCK1 and BLOCK2 represents a
160 ;;; tail-recursive return (:DELETED IR2-continuation) or a non-local
161 ;;; exit, then the cleanup code will never actually be executed. It
162 ;;; doesn't seem to be worth the risk of trying to optimize this,
163 ;;; since this rarely happens and 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)
171                               1))))
172     (aver (tailp block2-stack block1-stack))
173
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-belated-block block)))
181
182   (values))
183 \f
184 ;;;; stack analysis
185
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
188 ;;; receiver.
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)))
194         (do-uses (use pop)
195           (unless (exit-p use)
196             (res (node-block use))))))
197     (res)))
198
199 ;;; Analyze the use of unknown-values continuations in COMPONENT,
200 ;;; inserting cleanup code to discard values that are generated but
201 ;;; never received. This phase doesn't need to be run when
202 ;;; Values-Receivers is null, i.e. there are no unknown-values
203 ;;; continuations used across block boundaries.
204 ;;;
205 ;;; Do the backward graph walk, starting at each values receiver. We
206 ;;; ignore receivers that already have a non-null START-STACK. These
207 ;;; are nested values receivers that have already been reached on
208 ;;; another walk. We don't want to clobber that result with our null
209 ;;; initial stack.
210 (defun stack-analyze (component)
211   (declare (type component component))
212   (let* ((2comp (component-info component))
213          (receivers (ir2-component-values-receivers 2comp))
214          (generators (find-values-generators receivers)))
215
216     (dolist (block generators)
217       (find-pushed-continuations block))
218
219     (dolist (block receivers)
220       (unless (ir2-block-start-stack (block-info block))
221         (stack-simulation-walk block ())))
222
223     (dolist (block generators)
224       (annotate-dead-values block))
225
226     (do-blocks (block component)
227       (let ((top (car (ir2-block-end-stack (block-info block)))))
228         (dolist (succ (block-succ block))
229           (when (and (block-start succ)
230                      (not (eq (car (ir2-block-start-stack (block-info succ)))
231                               top)))
232             (discard-unused-values block succ))))))
233
234   (values))