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