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.
7 ;;;; This software is part of the SBCL system. See the README file for
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.
21 ;;; Do environment analysis on the code in Component. This involves
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
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))
44 (dolist (let (lambda-lets fun))
45 (compute-closure let)))
47 (find-non-local-exits component)
48 (find-cleanup-points component)
49 (tail-annotate component)
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)))))
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))
71 (dolist (lambda (component-lambdas component))
72 (when (compute-closure lambda)
74 (dolist (let (lambda-lets lambda))
75 (when (compute-closure let)
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)))
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))
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))))
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)))
104 (dolist (var (lambda-vars fun))
105 (unless (lambda-var-sets var)
106 (setf (lambda-var-indirect var) nil)))))
108 (dolist (let (lambda-lets fun))
111 (get-lambda-environment fun))))
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)))
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))
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)))))
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)))
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))))
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
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.
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
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
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)
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))))
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
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)))
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))
230 (let ((info (find-nlx-info entry cont)))
232 (close-over info (node-environment exit) env)
233 (when (eq (functional-kind exit-fun) :escape)
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))))))
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))))))
261 ;;;; cleanup emission
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.
269 ;;; If we do insert cleanup code, we check that Block1 doesn't end in a "tail"
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
275 (defun emit-cleanups (block1 block2)
276 (declare (type cblock block1 block2))
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)
288 (code `(%special-unbind ',(continuation-value (first args)))))
290 (code `(%catch-breakup)))
292 (code `(%unwind-protect-breakup))
293 (let ((fun (ref-leaf (continuation-use (second args)))))
295 (code `(%funcall ,fun))))
297 (dolist (nlx (cleanup-nlx-info cleanup))
298 (code `(%lexical-exit-breakup ',nlx)))))))
301 (assert (not (node-tail-p (block-last block1))))
302 (insert-cleanup-code block1 block2
305 (dolist (fun (reanalyze-funs))
306 (local-call-analyze-1 fun)))))
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)
327 (eq (node-enclosing-cleanup
328 (cleanup-mess-up cleanup2))
330 (emit-cleanups block1 block2)))))))
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)))
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)))))))