1 ;;;; This file contains the code that finds the initial components and
2 ;;;; DFO, and recomputes the DFO if it is invalidated.
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
18 ;;; Find the DFO for a component, deleting any unreached blocks and
19 ;;; merging any other components we reach. We repeatedly iterate over
20 ;;; the entry points, since new ones may show up during the walk.
21 (declaim (ftype (function (component) (values)) find-dfo))
22 (defun find-dfo (component)
23 (clear-flags component)
24 (setf (component-reanalyze component) nil)
25 (let ((head (component-head component)))
27 ((dolist (ep (block-succ head) t)
28 (unless (block-flag ep)
29 (find-dfo-aux ep head component)
33 (declare (fixnum num))
34 (do-blocks-backwards (block component :both)
35 (if (block-flag block)
36 (setf (block-number block) (incf num))
37 (setf (block-delete-p block) t)))
38 (do-blocks (block component)
39 (unless (block-flag block)
40 (delete-block block))))
43 ;;; Move all the code and entry points from Old to New. The code in
44 ;;; Old is inserted at the head of New. This is also called during let
45 ;;; conversion when we are about in insert the body of a let in a
46 ;;; different component. [A local call can be to a different component
47 ;;; before FIND-INITIAL-DFO runs.]
48 (declaim (ftype (function (component component) (values)) join-components))
49 (defun join-components (new old)
50 (assert (eq (component-kind new) (component-kind old)))
51 (let ((old-head (component-head old))
52 (old-tail (component-tail old))
53 (head (component-head new))
54 (tail (component-tail new)))
56 (do-blocks (block old)
57 (setf (block-flag block) nil)
58 (setf (block-component block) new))
60 (let ((old-next (block-next old-head))
61 (old-last (block-prev old-tail))
62 (next (block-next head)))
63 (unless (eq old-next old-tail)
64 (setf (block-next head) old-next)
65 (setf (block-prev old-next) head)
67 (setf (block-prev next) old-last)
68 (setf (block-next old-last) next))
70 (setf (block-next old-head) old-tail)
71 (setf (block-prev old-tail) old-head))
73 (setf (component-lambdas new)
74 (nconc (component-lambdas old) (component-lambdas new)))
75 (setf (component-lambdas old) ())
76 (setf (component-new-functions new)
77 (nconc (component-new-functions old) (component-new-functions new)))
78 (setf (component-new-functions old) ())
80 (dolist (xp (block-pred old-tail))
81 (unlink-blocks xp old-tail)
82 (link-blocks xp tail))
83 (dolist (ep (block-succ old-head))
84 (unlink-blocks old-head ep)
85 (link-blocks head ep)))
88 ;;; Do a depth-first walk from Block, inserting ourself in the DFO
89 ;;; after Head. If we somehow find ourselves in another component,
90 ;;; then we join that component to our component.
91 (declaim (ftype (function (cblock cblock component) (values)) find-dfo-aux))
92 (defun find-dfo-aux (block head component)
93 (unless (eq (block-component block) component)
94 (join-components component (block-component block)))
96 (unless (block-flag block)
97 (setf (block-flag block) t)
98 (dolist (succ (block-succ block))
99 (find-dfo-aux succ head component))
101 (remove-from-dfo block)
102 (add-to-dfo block head))
105 ;;; This function is called on each block by Find-Initial-DFO-Aux before it
106 ;;; walks the successors. It looks at the home lambda's bind block to see
107 ;;; whether that block is in some other component:
108 ;;; -- If the block is in the initial component, then do DFO-Walk-Call-Graph on
109 ;;; the home function to move it into component.
110 ;;; -- If the block is in some other component, join Component into it and
111 ;;; return that component.
112 ;;; -- If the home function is deleted, do nothing. Block must eventually be
113 ;;; discovered to be unreachable as well. This can happen when we have a
114 ;;; NLX into a function with no references. The escape function still has
115 ;;; refs (in the deleted function).
117 ;;; This ensures that all the blocks in a given environment will be in the same
118 ;;; component, even when they might not seem reachable from the environment
119 ;;; entry. Consider the case of code that is only reachable from a non-local
121 (defun walk-home-call-graph (block component)
122 (declare (type cblock block) (type component component))
123 (let ((home (block-home-lambda block)))
124 (if (eq (functional-kind home) :deleted)
126 (let* ((bind-block (node-block (lambda-bind home)))
127 (home-component (block-component bind-block)))
128 (cond ((eq (component-kind home-component) :initial)
129 (dfo-walk-call-graph home component))
130 ((eq home-component component)
133 (join-components home-component component)
136 ;;; Somewhat similar to Find-DFO-Aux, except that it merges the current
137 ;;; component with any strange component, rather than the other way around.
138 ;;; This is more efficient in the common case where the current component
139 ;;; doesn't have much stuff in it.
141 ;;; We return the current component as a result, allowing the caller to
142 ;;; detect when the old current component has been merged with another.
144 ;;; We walk blocks in initial components as though they were already in the
145 ;;; current component, moving them to the current component in the process.
146 ;;; The blocks are inserted at the head of the current component.
147 (defun find-initial-dfo-aux (block component)
148 (declare (type cblock block) (type component component))
149 (let ((this (block-component block)))
151 ((not (or (eq this component)
152 (eq (component-kind this) :initial)))
153 (join-components this component)
155 ((block-flag block) component)
157 (setf (block-flag block) t)
158 (let ((current (walk-home-call-graph block component)))
159 (dolist (succ (block-succ block))
160 (setq current (find-initial-dfo-aux succ current)))
162 (remove-from-dfo block)
163 (add-to-dfo block (component-head current))
166 ;;; Return a list of all the home lambdas that reference Fun (may contain
169 ;;; References to functions which local call analysis could not (or were
170 ;;; chosen not) to local call convert will appear as references to XEP lambdas.
171 ;;; We can ignore references to XEPs that appear in :TOP-LEVEL components,
172 ;;; since environment analysis goes to special effort to allow closing over of
173 ;;; values from a separate top-level component. All other references must
174 ;;; cause components to be joined.
176 ;;; References in deleted functions are also ignored, since this code will be
177 ;;; deleted eventually.
178 (defun find-reference-functions (fun)
180 (dolist (ref (leaf-refs fun))
181 (let* ((home (node-home-lambda ref))
182 (home-kind (functional-kind home)))
183 (unless (or (and (eq home-kind :top-level)
184 (eq (functional-kind fun) :external))
185 (eq home-kind :deleted))
189 ;;; Move the code for Fun and all functions called by it into Component. If
190 ;;; Fun is already in Component, then we just return that component.
192 ;;; If the function is in an initial component, then we move its head and
193 ;;; tail to Component and add it to Component's lambdas. It is harmless to
194 ;;; move the tail (even though the return might be unreachable) because if the
195 ;;; return is unreachable it (and its successor link) will be deleted in the
196 ;;; post-deletion pass.
198 ;;; We then do a Find-DFO-Aux starting at the head of Fun. If this
199 ;;; flow-graph walk encounters another component (which can only happen due to
200 ;;; a non-local exit), then we move code into that component instead. We then
201 ;;; recurse on all functions called from Fun, moving code into whichever
202 ;;; component the preceding call returned.
204 ;;; If Fun is in the initial component, but the Block-Flag is set in the
205 ;;; bind block, then we just return Component, since we must have already
206 ;;; reached this function in the current walk (or the component would have been
209 ;;; if the function is an XEP, then we also walk all functions that contain
210 ;;; references to the XEP. This is done so that environment analysis doesn't
211 ;;; need to cross component boundaries. This also ensures that conversion of a
212 ;;; full call to a local call won't result in a need to join components, since
213 ;;; the components will already be one.
214 (defun dfo-walk-call-graph (fun component)
215 (declare (type clambda fun) (type component component))
216 (let* ((bind-block (node-block (lambda-bind fun)))
217 (this (block-component bind-block))
218 (return (lambda-return fun)))
220 ((eq this component) component)
221 ((not (eq (component-kind this) :initial))
222 (join-components this component)
224 ((block-flag bind-block)
227 (push fun (component-lambdas component))
228 (setf (component-lambdas this)
229 (delete fun (component-lambdas this)))
230 (link-blocks (component-head component) bind-block)
231 (unlink-blocks (component-head this) bind-block)
233 (let ((return-block (node-block return)))
234 (link-blocks return-block (component-tail component))
235 (unlink-blocks return-block (component-tail this))))
236 (let ((calls (if (eq (functional-kind fun) :external)
237 (append (find-reference-functions fun)
239 (lambda-calls fun))))
240 (do ((res (find-initial-dfo-aux bind-block component)
241 (dfo-walk-call-graph (first funs) res))
242 (funs calls (rest funs)))
244 (declare (type component res))))))))
246 ;;; Return true if Fun is either an XEP or has EXITS to some of its ENTRIES.
247 (defun has-xep-or-nlx (fun)
248 (declare (type clambda fun))
249 (or (eq (functional-kind fun) :external)
250 (let ((entries (lambda-entries fun)))
252 (find-if #'entry-exits entries)))))
254 ;;; Compute the result of FIND-INITIAL-DFO given the list of all resulting
255 ;;; components. Components with a :TOP-LEVEL lambda, but no normal XEPs or
256 ;;; potential non-local exits are marked as :TOP-LEVEL. If there is a
257 ;;; :TOP-LEVEL lambda, and also a normal XEP, then we treat the component as
258 ;;; normal, but also return such components in a list as the third value.
259 ;;; Components with no entry of any sort are deleted.
260 (defun find-top-level-components (components)
261 (declare (list components))
265 (dolist (com components)
266 (unless (eq (block-next (component-head com)) (component-tail com))
267 (let* ((funs (component-lambdas com))
268 (has-top (find :top-level funs :key #'functional-kind)))
269 (cond ((or (find-if #'has-xep-or-nlx funs)
270 (and has-top (rest funs)))
271 (setf (component-name com) (find-component-name com))
274 (setf (component-kind com) :complex-top-level)
277 (setf (component-kind com) :top-level)
278 (setf (component-name com) "top-level form")
281 (delete-component com))))))
283 (values (real) (top) (real-top))))
285 ;;; Given a list of top-level lambdas, return three lists of components
286 ;;; representing the actual component division:
287 ;;; 1. the non-top-level components,
288 ;;; 2. and the second is the top-level components, and
289 ;;; 3. Components in [1] that also have a top-level lambda.
291 ;;; We assign the DFO for each component, and delete any unreachable blocks.
292 ;;; We assume that the Flags have already been cleared.
294 ;;; We iterate over the lambdas in each initial component, trying to put
295 ;;; each function in its own component, but joining it to an existing component
296 ;;; if we find that there are references between them. Any code that is left
297 ;;; in an initial component must be unreachable, so we can delete it. Stray
298 ;;; links to the initial component tail (due NIL function terminated blocks)
299 ;;; are moved to the appropriate newc component tail.
301 ;;; When we are done, we assign DFNs and call FIND-TOP-LEVEL-COMPONENTS to
302 ;;; pull out top-level code.
303 (defun find-initial-dfo (lambdas)
304 (declare (list lambdas))
305 (collect ((components))
306 (let ((new (make-empty-component)))
307 (dolist (tll lambdas)
308 (let ((component (block-component (node-block (lambda-bind tll)))))
309 (dolist (fun (component-lambdas component))
310 (assert (member (functional-kind fun)
311 '(:optional :external :top-level nil :escape
313 (let ((res (dfo-walk-call-graph fun new)))
316 (setq new (make-empty-component)))))
317 (when (eq (component-kind component) :initial)
318 (assert (null (component-lambdas component)))
319 (let ((tail (component-tail component)))
320 (dolist (pred (block-pred tail))
321 (let ((pred-component (block-component pred)))
322 (unless (eq pred-component component)
323 (unlink-blocks pred tail)
324 (link-blocks pred (component-tail pred-component))))))
325 (delete-component component)))))
327 (dolist (com (components))
329 (declare (fixnum num))
330 (do-blocks-backwards (block com :both)
331 (setf (block-number block) (incf num)))))
333 (find-top-level-components (components))))
335 ;;; Insert the code in LAMBDA at the end of RESULT-LAMBDA.
336 (defun merge-1-tl-lambda (result-lambda lambda)
337 (declare (type clambda result-lambda lambda))
339 ;; Delete the lambda, and combine the lets and entries.
340 (setf (functional-kind lambda) :deleted)
341 (dolist (let (lambda-lets lambda))
342 (setf (lambda-home let) result-lambda)
343 (setf (lambda-environment let) (lambda-environment result-lambda))
344 (push let (lambda-lets result-lambda)))
345 (setf (lambda-entries result-lambda)
346 (nconc (lambda-entries result-lambda)
347 (lambda-entries lambda)))
349 (let* ((bind (lambda-bind lambda))
350 (bind-block (node-block bind))
351 (component (block-component bind-block))
353 (block-component (node-block (lambda-bind result-lambda))))
354 (result-return-block (node-block (lambda-return result-lambda))))
356 ;; Move blocks into the new component, and move any nodes directly in
357 ;; the old lambda into the new one (lets implicitly moved by changing
359 (do-blocks (block component)
360 (do-nodes (node cont block)
361 (let ((lexenv (node-lexenv node)))
362 (when (eq (lexenv-lambda lexenv) lambda)
363 (setf (lexenv-lambda lexenv) result-lambda))))
364 (setf (block-component block) result-component))
366 ;; Splice the blocks into the new DFO, and unlink them from the old
367 ;; component head and tail. Non-return blocks that jump to the tail
368 ;; (NIL returning calls) are switched to go to the new tail.
369 (let* ((head (component-head component))
370 (first (block-next head))
371 (tail (component-tail component))
372 (last (block-prev tail))
373 (prev (block-prev result-return-block)))
374 (setf (block-next prev) first)
375 (setf (block-prev first) prev)
376 (setf (block-next last) result-return-block)
377 (setf (block-prev result-return-block) last)
378 (dolist (succ (block-succ head))
379 (unlink-blocks head succ))
380 (dolist (pred (block-pred tail))
381 (unlink-blocks pred tail)
382 (let ((last (block-last pred)))
383 (unless (return-p last)
384 (assert (basic-combination-p last))
385 (link-blocks pred (component-tail result-component))))))
387 (let ((lambdas (component-lambdas component)))
388 (assert (and (null (rest lambdas))
389 (eq (first lambdas) lambda))))
391 ;; Switch the end of the code from the return block to the start of
393 (dolist (pred (block-pred result-return-block))
394 (unlink-blocks pred result-return-block)
395 (link-blocks pred bind-block))
398 ;; If there is a return, then delete it (making the preceding node the
399 ;; last node) and link the block to the result return. There is always a
400 ;; preceding REF NIL node in top-level lambdas.
401 (let ((return (lambda-return lambda)))
403 (let ((return-block (node-block return))
404 (result (return-result return)))
405 (setf (block-last return-block) (continuation-use result))
407 (delete-continuation result)
408 (link-blocks return-block result-return-block))))))
410 ;;; Given a non-empty list of top-level lambdas, smash them into a top-level
411 ;;; lambda and component, returning these as values. We use the first lambda
412 ;;; and its component, putting the other code in that component and deleting
413 ;;; the other lambdas.
414 (defun merge-top-level-lambdas (lambdas)
415 (declare (cons lambdas))
416 (let* ((result-lambda (first lambdas))
417 (result-return (lambda-return result-lambda)))
421 ;; Make sure the result's return node starts a block so that we can
422 ;; splice code in before it.
423 (let ((prev (node-prev
425 (return-result result-return)))))
426 (when (continuation-use prev)
427 (node-ends-block (continuation-use prev)))
429 (let ((new (make-continuation)))
430 (delete-continuation-use use)
431 (add-continuation-use use new))))
433 (dolist (lambda (rest lambdas))
434 (merge-1-tl-lambda result-lambda lambda)))
436 (dolist (lambda (rest lambdas))
437 (setf (functional-entry-function lambda) nil)
440 (node-block (lambda-bind lambda)))))))
442 (values (block-component (node-block (lambda-bind result-lambda)))