Initial revision
[sbcl.git] / src / compiler / envanal.lisp
1 ;;;; This file implements the environment analysis phase for the
2 ;;;; compiler. This phase annotates IR1 with a hierarchy environment
3 ;;;; structures, determining the environment that each Lambda
4 ;;;; allocates its variables and finding what values are closed over
5 ;;;; by each environment.
6
7 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; more information.
9 ;;;;
10 ;;;; This software is derived from the CMU CL system, which was
11 ;;;; written at Carnegie Mellon University and released into the
12 ;;;; public domain. The software is in the public domain and is
13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
14 ;;;; files for more information.
15
16 (in-package "SB!C")
17
18 (file-comment
19   "$Header$")
20
21 ;;; Do environment analysis on the code in Component. This involves
22 ;;; various things:
23 ;;;  1. Make an Environment structure for each non-let lambda, assigning 
24 ;;;     the lambda-environment for all lambdas.
25 ;;;  2. Find all values that need to be closed over by each environment.
26 ;;;  3. Scan the blocks in the component closing over non-local-exit
27 ;;;     continuations.
28 ;;;  4. Delete all non-top-level functions with no references. This
29 ;;;     should only get functions with non-NULL kinds, since normal
30 ;;;     functions are deleted when their references go to zero. If
31 ;;;     *byte-compiling*, then don't delete optional entries with no
32 ;;;     references, since the byte interpreter wants to call entries
33 ;;;     that the XEP doesn't.
34 (defun environment-analyze (component)
35   (declare (type component component))
36   (assert (every #'(lambda (x)
37                      (eq (functional-kind x) :deleted))
38                  (component-new-functions component)))
39   (setf (component-new-functions component) ())
40   (dolist (fun (component-lambdas component))
41     (reinit-lambda-environment fun))
42   (dolist (fun (component-lambdas component))
43     (compute-closure fun)
44     (dolist (let (lambda-lets fun))
45       (compute-closure let)))
46
47   (find-non-local-exits component)
48   (find-cleanup-points component)
49   (tail-annotate component)
50
51   (dolist (fun (component-lambdas component))
52     (when (null (leaf-refs fun))
53       (let ((kind (functional-kind fun)))
54         (unless (or (eq kind :top-level)
55                     (and *byte-compiling* (eq kind :optional)))
56           (assert (member kind '(:optional :cleanup :escape)))
57           (setf (functional-kind fun) nil)
58           (delete-functional fun)))))
59
60   (values))
61
62 ;;; Called on component with top-level lambdas before the compilation of the
63 ;;; associated non-top-level code to detect closed over top-level variables.
64 ;;; We just do COMPUTE-CLOSURE on all the lambdas. This will pre-allocate
65 ;;; environments for all the functions with closed-over top-level variables.
66 ;;; The post-pass will use the existing structure, rather than allocating a new
67 ;;; one. We return true if we discover any possible closure vars.
68 (defun pre-environment-analyze-top-level (component)
69   (declare (type component component))
70   (let ((found-it nil))
71     (dolist (lambda (component-lambdas component))
72       (when (compute-closure lambda)
73         (setq found-it t))
74       (dolist (let (lambda-lets lambda))
75         (when (compute-closure let)
76           (setq found-it t))))
77     found-it))
78
79 ;;; If Fun has an environment, return it, otherwise assign one.
80 (defun get-lambda-environment (fun)
81   (declare (type clambda fun))
82   (let* ((fun (lambda-home fun))
83          (env (lambda-environment fun)))
84     (or env
85         (let ((res (make-environment :function fun)))
86           (setf (lambda-environment fun) res)
87           (dolist (lambda (lambda-lets fun))
88             (setf (lambda-environment lambda) res))
89           res))))
90
91 ;;; If Fun has no environment, assign one, otherwise clean up variables that
92 ;;; have no sets or refs. If a var has no references, we remove it from the
93 ;;; closure. If it has no sets, we clear the INDIRECT flag. This is
94 ;;; necessary because pre-analysis is done before optimization.
95 (defun reinit-lambda-environment (fun)
96   (let ((old (lambda-environment (lambda-home fun))))
97     (cond (old
98            (setf (environment-closure old)
99                  (delete-if #'(lambda (x)
100                                 (and (lambda-var-p x)
101                                      (null (leaf-refs x))))
102                             (environment-closure old)))
103            (flet ((clear (fun)
104                     (dolist (var (lambda-vars fun))
105                       (unless (lambda-var-sets var)
106                         (setf (lambda-var-indirect var) nil)))))
107              (clear fun)
108              (dolist (let (lambda-lets fun))
109                (clear let))))
110           (t
111            (get-lambda-environment fun))))
112   (values))
113
114 ;;; Get node's environment, assigning one if necessary.
115 (defun get-node-environment (node)
116   (declare (type node node))
117   (get-lambda-environment (node-home-lambda node)))
118
119 ;;; Find any variables in Fun with references outside of the home
120 ;;; environment and close over them. If a closed over variable is set, then we
121 ;;; set the Indirect flag so that we will know the closed over value is really
122 ;;; a pointer to the value cell. We also warn about unreferenced variables
123 ;;; here, just because it's a convenient place to do it. We return true if we
124 ;;; close over anything.
125 (defun compute-closure (fun)
126   (declare (type clambda fun))
127   (let ((env (get-lambda-environment fun))
128         (did-something nil))
129     (note-unreferenced-vars fun)
130     (dolist (var (lambda-vars fun))
131       (dolist (ref (leaf-refs var))
132         (let ((ref-env (get-node-environment ref)))
133           (unless (eq ref-env env)
134             (when (lambda-var-sets var)
135               (setf (lambda-var-indirect var) t))
136             (setq did-something t)
137             (close-over var ref-env env))))
138       (dolist (set (basic-var-sets var))
139         (let ((set-env (get-node-environment set)))
140           (unless (eq set-env env)
141             (setq did-something t)
142             (setf (lambda-var-indirect var) t)
143             (close-over var set-env env)))))
144     did-something))
145
146 ;;; Make sure that Thing is closed over in Ref-Env and in all environments
147 ;;; for the functions that reference Ref-Env's function (not just calls.)
148 ;;; Home-Env is Thing's home environment. When we reach the home environment,
149 ;;; we stop propagating the closure.
150 (defun close-over (thing ref-env home-env)
151   (declare (type environment ref-env home-env))
152   (cond ((eq ref-env home-env))
153         ((member thing (environment-closure ref-env)))
154         (t
155          (push thing (environment-closure ref-env))
156          (dolist (call (leaf-refs (environment-function ref-env)))
157            (close-over thing (get-node-environment call) home-env))))
158   (values))
159 \f
160 ;;;; non-local exit
161
162 ;;; Insert the entry stub before the original exit target, and add a new
163 ;;; entry to the Environment-Nlx-Info. The %NLX-Entry call in the stub is
164 ;;; passed the NLX-Info as an argument so that the back end knows what entry is
165 ;;; being done.
166 ;;;
167 ;;; The link from the Exit block to the entry stub is changed to be a link to
168 ;;; the component head. Similarly, the Exit block is linked to the component
169 ;;; tail. This leaves the entry stub reachable, but makes the flow graph less
170 ;;; confusing to flow analysis.
171 ;;;
172 ;;; If a catch or an unwind-protect, then we set the Lexenv for the last node
173 ;;; in the cleanup code to be the enclosing environment, to represent the fact
174 ;;; that the binding was undone as a side-effect of the exit. This will cause
175 ;;; a lexical exit to be broken up if we are actually exiting the scope (i.e.
176 ;;; a BLOCK), and will also do any other cleanups that may have to be done on
177 ;;; the way.
178 (defun insert-nlx-entry-stub (exit env)
179   (declare (type environment env) (type exit exit))
180   (let* ((exit-block (node-block exit))
181          (next-block (first (block-succ exit-block)))
182          (cleanup (entry-cleanup (exit-entry exit)))
183          (info (make-nlx-info :cleanup cleanup
184                               :continuation (node-cont exit)))
185          (entry (exit-entry exit))
186          (new-block (insert-cleanup-code exit-block next-block
187                                          entry
188                                          `(%nlx-entry ',info)
189                                          (entry-cleanup entry)))
190          (component (block-component new-block)))
191     (unlink-blocks exit-block new-block)
192     (link-blocks exit-block (component-tail component))
193     (link-blocks (component-head component) new-block)
194
195     (setf (nlx-info-target info) new-block)
196     (push info (environment-nlx-info env))
197     (push info (cleanup-nlx-info cleanup))
198     (when (member (cleanup-kind cleanup) '(:catch :unwind-protect))
199       (setf (node-lexenv (block-last new-block))
200             (node-lexenv entry))))
201
202   (values))
203
204 ;;; Do stuff necessary to represent a non-local exit from the node Exit into
205 ;;; Env. This is called for each non-local exit node, of which there may be
206 ;;; several per exit continuation. This is what we do:
207 ;;; -- If there isn't any NLX-Info entry in the environment, make an entry
208 ;;;    stub, otherwise just move the exit block link to the component tail.
209 ;;; -- Close over the NLX-Info in the exit environment.
210 ;;; -- If the exit is from an :Escape function, then substitute a constant
211 ;;;    reference to NLX-Info structure for the escape function reference. This
212 ;;;    will cause the escape function to be deleted (although not removed from
213 ;;;    the DFO.)  The escape function is no longer needed, and we don't want to
214 ;;;    emit code for it. We then also change the %NLX-ENTRY call to use
215 ;;;    the NLX continuation so that there will be a use to represent the NLX
216 ;;;    use.
217 (defun note-non-local-exit (env exit)
218   (declare (type environment env) (type exit exit))
219   (let ((entry (exit-entry exit))
220         (cont (node-cont exit))
221         (exit-fun (node-home-lambda exit)))
222
223     (if (find-nlx-info entry cont)
224         (let ((block (node-block exit)))
225           (assert (= (length (block-succ block)) 1))
226           (unlink-blocks block (first (block-succ block)))
227           (link-blocks block (component-tail (block-component block))))
228         (insert-nlx-entry-stub exit env))
229
230     (let ((info (find-nlx-info entry cont)))
231       (assert info)
232       (close-over info (node-environment exit) env)
233       (when (eq (functional-kind exit-fun) :escape)
234         (mapc #'(lambda (x)
235                   (setf (node-derived-type x) *wild-type*))
236               (leaf-refs exit-fun))
237         (substitute-leaf (find-constant info) exit-fun)
238         (let ((node (block-last (nlx-info-target info))))
239           (delete-continuation-use node)
240           (add-continuation-use node (nlx-info-continuation info))))))
241
242   (values))
243
244 ;;; Iterate over the Exits in Component, calling Note-Non-Local-Exit when we
245 ;;; find a block that ends in a non-local Exit node. We also ensure that all
246 ;;; Exit nodes are either non-local or degenerate by calling IR1-Optimize-Exit
247 ;;; on local exits. This makes life simpler for later phases.
248 (defun find-non-local-exits (component)
249   (declare (type component component))
250   (dolist (lambda (component-lambdas component))
251     (dolist (entry (lambda-entries lambda))
252       (dolist (exit (entry-exits entry))
253         (let ((target-env (node-environment entry)))
254           (if (eq (node-environment exit) target-env)
255               (unless *converting-for-interpreter*
256                 (maybe-delete-exit exit))
257               (note-non-local-exit target-env exit))))))
258
259   (values))
260 \f
261 ;;;; cleanup emission
262
263 ;;; Zoom up the cleanup nesting until we hit Cleanup1, accumulating cleanup
264 ;;; code as we go. When we are done, convert the cleanup code in an implicit
265 ;;; MV-Prog1. We have to force local call analysis of new references to
266 ;;; Unwind-Protect cleanup functions. If we don't actually have to do
267 ;;; anything, then we don't insert any cleanup code.
268 ;;;
269 ;;; If we do insert cleanup code, we check that Block1 doesn't end in a "tail"
270 ;;; local call.
271 ;;;
272 ;;; We don't need to adjust the ending cleanup of the cleanup block, since
273 ;;; the cleanup blocks are inserted at the start of the DFO, and are thus never
274 ;;; scanned.
275 (defun emit-cleanups (block1 block2)
276   (declare (type cblock block1 block2))
277   (collect ((code)
278             (reanalyze-funs))
279     (let ((cleanup2 (block-start-cleanup block2)))
280       (do ((cleanup (block-end-cleanup block1)
281                     (node-enclosing-cleanup (cleanup-mess-up cleanup))))
282           ((eq cleanup cleanup2))
283         (let* ((node (cleanup-mess-up cleanup))
284                (args (when (basic-combination-p node)
285                        (basic-combination-args node))))
286           (ecase (cleanup-kind cleanup)
287             (:special-bind
288              (code `(%special-unbind ',(continuation-value (first args)))))
289             (:catch
290              (code `(%catch-breakup)))
291             (:unwind-protect
292              (code `(%unwind-protect-breakup))
293              (let ((fun (ref-leaf (continuation-use (second args)))))
294                (reanalyze-funs fun)
295                (code `(%funcall ,fun))))
296             ((:block :tagbody)
297              (dolist (nlx (cleanup-nlx-info cleanup))
298                (code `(%lexical-exit-breakup ',nlx)))))))
299
300       (when (code)
301         (assert (not (node-tail-p (block-last block1))))
302         (insert-cleanup-code block1 block2
303                              (block-last block1)
304                              `(progn ,@(code)))
305         (dolist (fun (reanalyze-funs))
306           (local-call-analyze-1 fun)))))
307
308   (values))
309
310 ;;; Loop over the blocks in component, calling Emit-Cleanups when we see a
311 ;;; successor in the same environment with a different cleanup. We ignore the
312 ;;; cleanup transition if it is to a cleanup enclosed by the current cleanup,
313 ;;; since in that case we are just messing up the environment, hence this is
314 ;;; not the place to clean it.
315 (defun find-cleanup-points (component)
316   (declare (type component component))
317   (do-blocks (block1 component)
318     (let ((env1 (block-environment block1))
319           (cleanup1 (block-end-cleanup block1)))
320       (dolist (block2 (block-succ block1))
321         (when (block-start block2)
322           (let ((env2 (block-environment block2))
323                 (cleanup2 (block-start-cleanup block2)))
324             (unless (or (not (eq env2 env1))
325                         (eq cleanup1 cleanup2)
326                         (and cleanup2
327                              (eq (node-enclosing-cleanup
328                                   (cleanup-mess-up cleanup2))
329                                  cleanup1)))
330               (emit-cleanups block1 block2)))))))
331   (values))
332
333 ;;; Mark all tail-recursive uses of function result continuations with the
334 ;;; corresponding tail-set. Nodes whose type is NIL (i.e. don't return) such
335 ;;; as calls to ERROR are never annotated as tail in order to preserve
336 ;;; debugging information.
337 (defun tail-annotate (component)
338   (declare (type component component))
339   (dolist (fun (component-lambdas component))
340     (let ((ret (lambda-return fun)))
341       (when ret
342         (let ((result (return-result ret)))
343           (do-uses (use result)
344             (when (and (immediately-used-p result use)
345                      (or (not (eq (node-derived-type use) *empty-type*))
346                          (not (basic-combination-p use))
347                          (eq (basic-combination-kind use) :local)))
348                 (setf (node-tail-p use) t)))))))
349   (values))