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.
15 ;;; Find the DFO for a component, deleting any unreached blocks and
16 ;;; merging any other components we reach. We repeatedly iterate over
17 ;;; the entry points, since new ones may show up during the walk.
18 (declaim (ftype (function (component) (values)) find-dfo
))
19 (defun find-dfo (component)
20 (clear-flags component
)
21 (setf (component-reanalyze component
) nil
)
22 (let ((head (component-head component
)))
24 ((dolist (ep (block-succ head
) t
)
25 (unless (block-flag ep
)
26 (find-dfo-aux ep head component
)
29 (declare (fixnum num
))
30 (do-blocks-backwards (block component
:both
)
31 (if (block-flag block
)
32 (setf (block-number block
) (incf num
))
33 (setf (block-delete-p block
) t
)))
34 (do-blocks (block component
)
35 (unless (block-flag block
)
36 (delete-block block
))))
39 ;;; Move all the code and entry points from OLD to NEW. The code in
40 ;;; OLD is inserted at the head of NEW. This is also called during LET
41 ;;; conversion when we are about in insert the body of a LET in a
42 ;;; different component. [A local call can be to a different component
43 ;;; before FIND-INITIAL-DFO runs.]
44 (declaim (ftype (function (component component
) (values)) join-components
))
45 (defun join-components (new old
)
46 (aver (eq (component-kind new
) (component-kind old
)))
47 (let ((old-head (component-head old
))
48 (old-tail (component-tail old
))
49 (head (component-head new
))
50 (tail (component-tail new
)))
52 (do-blocks (block old
)
53 (setf (block-flag block
) nil
)
54 (setf (block-component block
) new
))
56 (let ((old-next (block-next old-head
))
57 (old-last (block-prev old-tail
))
58 (next (block-next head
)))
59 (unless (eq old-next old-tail
)
60 (setf (block-next head
) old-next
)
61 (setf (block-prev old-next
) head
)
63 (setf (block-prev next
) old-last
)
64 (setf (block-next old-last
) next
))
66 (setf (block-next old-head
) old-tail
)
67 (setf (block-prev old-tail
) old-head
))
69 (setf (component-lambdas new
)
70 (nconc (component-lambdas old
) (component-lambdas new
)))
71 (setf (component-lambdas old
) nil
)
72 (setf (component-new-functionals new
)
73 (nconc (component-new-functionals old
)
74 (component-new-functionals new
)))
75 (setf (component-new-functionals old
) nil
)
77 (dolist (xp (block-pred old-tail
))
78 (unlink-blocks xp old-tail
)
79 (link-blocks xp tail
))
80 (dolist (ep (block-succ old-head
))
81 (unlink-blocks old-head ep
)
82 (link-blocks head ep
)))
85 ;;; Do a depth-first walk from BLOCK, inserting ourself in the DFO
86 ;;; after HEAD. If we somehow find ourselves in another component,
87 ;;; then we join that component to our component.
88 (declaim (ftype (function (cblock cblock component
) (values)) find-dfo-aux
))
89 (defun find-dfo-aux (block head component
)
90 (unless (eq (block-component block
) component
)
91 (join-components component
(block-component block
)))
92 (unless (block-flag block
)
93 (setf (block-flag block
) t
)
94 (dolist (succ (block-succ block
))
95 (find-dfo-aux succ head component
))
96 (remove-from-dfo block
)
97 (add-to-dfo block head
))
100 ;;; This function is called on each block by FIND-INITIAL-DFO-AUX
101 ;;; before it walks the successors. It looks at the home CLAMBDA's
102 ;;; BIND block to see whether that block is in some other component:
103 ;;; -- If the block is in the initial component, then do
104 ;;; DFO-SCAVENGE-DEPENDENCY-GRAPH on the home function to move it
106 ;;; -- If the block is in some other component, join COMPONENT into
107 ;;; it and return that component.
108 ;;; -- If the home function is deleted, do nothing. BLOCK must
109 ;;; eventually be discovered to be unreachable as well. This can
110 ;;; happen when we have a NLX into a function with no references.
111 ;;; The escape function still has refs (in the deleted function).
113 ;;; This ensures that all the blocks in a given environment will be in
114 ;;; the same component, even when they might not seem reachable from
115 ;;; the environment entry. Consider the case of code that is only
116 ;;; reachable from a non-local exit.
117 (defun scavenge-home-dependency-graph (block component
)
118 (declare (type cblock block
) (type component component
))
119 (let ((home-lambda (block-home-lambda block
)))
120 (if (eq (functional-kind home-lambda
) :deleted
)
122 (let ((home-component (lambda-component home-lambda
)))
123 (cond ((eq (component-kind home-component
) :initial
)
124 (dfo-scavenge-dependency-graph home-lambda component
))
125 ((eq home-component component
)
128 (join-components home-component component
)
131 ;;; This is somewhat similar to FIND-DFO-AUX, except that it merges
132 ;;; the current component with any strange component, rather than the
133 ;;; other way around. This is more efficient in the common case where
134 ;;; the current component doesn't have much stuff in it.
136 ;;; We return the current component as a result, allowing the caller
137 ;;; to detect when the old current component has been merged with
140 ;;; We walk blocks in initial components as though they were already
141 ;;; in the current component, moving them to the current component in
142 ;;; the process. The blocks are inserted at the head of the current
144 (defun find-initial-dfo-aux (block component
)
145 (declare (type cblock block
) (type component component
))
146 (let ((this (block-component block
)))
148 ((not (or (eq this component
)
149 (eq (component-kind this
) :initial
)))
150 (join-components this component
)
152 ((block-flag block
) component
)
154 (setf (block-flag block
) t
)
155 (let ((current (scavenge-home-dependency-graph block component
)))
156 (dolist (succ (block-succ block
))
157 (setq current
(find-initial-dfo-aux succ current
)))
158 (remove-from-dfo block
)
159 (add-to-dfo block
(component-head current
))
162 ;;; Return a list of all the home lambdas that reference FUN (may
163 ;;; contain duplications).
165 ;;; References to functions which local call analysis could not (or
166 ;;; were chosen not) to local call convert will appear as references
167 ;;; to XEP lambdas. We can ignore references to XEPs that appear in
168 ;;; :TOPLEVEL components, since environment analysis goes to special
169 ;;; effort to allow closing over of values from a separate top level
170 ;;; component. (And now that HAS-EXTERNAL-REFERENCES-P-ness
171 ;;; generalizes :TOPLEVEL-ness, we ignore those too.) All other
172 ;;; references must cause components to be joined.
174 ;;; References in deleted functions are also ignored, since this code
175 ;;; will be deleted eventually.
176 (defun find-reference-funs (fun)
178 (dolist (ref (leaf-refs fun
))
179 (let* ((home (node-home-lambda ref
))
180 (home-kind (functional-kind home
))
181 (home-externally-visible-p
182 (or (eq home-kind
:toplevel
)
183 (functional-has-external-references-p home
))))
184 (unless (or (and home-externally-visible-p
185 (eq (functional-kind fun
) :external
))
186 (eq home-kind
:deleted
))
190 ;;; If CLAMBDA is already in COMPONENT, just return that
191 ;;; component. Otherwise, move the code for CLAMBDA and all lambdas it
192 ;;; physically depends on (either because of calls or because of
193 ;;; closure relationships) into COMPONENT, or possibly into another
194 ;;; COMPONENT that we find to be related. Return whatever COMPONENT we
195 ;;; actually merged into.
197 ;;; (Note: The analogous CMU CL code only scavenged call-based
198 ;;; dependencies, not closure dependencies. That seems to've been by
199 ;;; oversight, not by design, as per the bug reported by WHN on
200 ;;; cmucl-imp ca. 2001-11-29 and explained by DTC shortly after.)
202 ;;; If the function is in an initial component, then we move its head
203 ;;; and tail to COMPONENT and add it to COMPONENT's lambdas. It is
204 ;;; harmless to move the tail (even though the return might be
205 ;;; unreachable) because if the return is unreachable it (and its
206 ;;; successor link) will be deleted in the post-deletion pass.
208 ;;; We then do a FIND-DFO-AUX starting at the head of CLAMBDA. If this
209 ;;; flow-graph walk encounters another component (which can only
210 ;;; happen due to a non-local exit), then we move code into that
211 ;;; component instead. We then recurse on all functions called from
212 ;;; CLAMBDA, moving code into whichever component the preceding call
215 ;;; If CLAMBDA is in the initial component, but the BLOCK-FLAG is set
216 ;;; in the bind block, then we just return COMPONENT, since we must
217 ;;; have already reached this function in the current walk (or the
218 ;;; component would have been changed).
220 ;;; If the function is an XEP, then we also walk all functions that
221 ;;; contain references to the XEP. This is done so that environment
222 ;;; analysis doesn't need to cross component boundaries. This also
223 ;;; ensures that conversion of a full call to a local call won't
224 ;;; result in a need to join components, since the components will
226 (defun dfo-scavenge-dependency-graph (clambda component
)
227 (declare (type clambda clambda
) (type component component
))
228 (assert (not (eql (lambda-kind clambda
) :deleted
)))
229 (let* ((bind-block (node-block (lambda-bind clambda
)))
230 (old-lambda-component (block-component bind-block
))
231 (return (lambda-return clambda
)))
233 ((eq old-lambda-component component
)
235 ((not (eq (component-kind old-lambda-component
) :initial
))
236 (join-components old-lambda-component component
)
237 old-lambda-component
)
238 ((block-flag bind-block
)
241 (push clambda
(component-lambdas component
))
242 (setf (component-lambdas old-lambda-component
)
243 (delete clambda
(component-lambdas old-lambda-component
)))
244 (link-blocks (component-head component
) bind-block
)
245 (unlink-blocks (component-head old-lambda-component
) bind-block
)
247 (let ((return-block (node-block return
)))
248 (link-blocks return-block
(component-tail component
))
249 (unlink-blocks return-block
(component-tail old-lambda-component
))))
250 (let ((res (find-initial-dfo-aux bind-block component
)))
251 (declare (type component res
))
252 ;; Scavenge related lambdas.
253 (labels ((scavenge-lambda (clambda)
255 (dfo-scavenge-dependency-graph (lambda-home clambda
)
257 (scavenge-possibly-deleted-lambda (clambda)
258 (unless (eql (lambda-kind clambda
) :deleted
)
259 (scavenge-lambda clambda
)))
260 ;; Scavenge call relationship.
261 (scavenge-call (called-lambda)
262 (scavenge-lambda called-lambda
))
263 ;; Scavenge closure over a variable: if CLAMBDA
264 ;; refers to a variable whose home lambda is not
265 ;; CLAMBDA, then the home lambda should be in the
266 ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU
267 ;; CL, didn't do this, leading to the occasional
268 ;; failure when physenv analysis, which is local to
269 ;; each component, would bogusly conclude that a
270 ;; closed-over variable was unused and thus delete
271 ;; it. See e.g. cmucl-imp 2001-11-29.)
272 (scavenge-closure-var (var)
273 (unless (null (lambda-var-refs var
)) ; unless var deleted
274 (let ((var-home-home (lambda-home (lambda-var-home var
))))
275 (scavenge-possibly-deleted-lambda var-home-home
))))
276 ;; Scavenge closure over an entry for nonlocal exit.
277 ;; This is basically parallel to closure over a
279 (scavenge-entry (entry)
280 (declare (type entry entry
))
281 (let ((entry-home (node-home-lambda entry
)))
282 (scavenge-possibly-deleted-lambda entry-home
))))
283 (dolist (cc (lambda-calls-or-closes clambda
))
285 (clambda (scavenge-call cc
))
286 (lambda-var (scavenge-closure-var cc
))
287 (entry (scavenge-entry cc
))))
288 (when (eq (lambda-kind clambda
) :external
)
289 (mapc #'scavenge-call
(find-reference-funs clambda
))))
293 ;;; Return true if CLAMBDA either is an XEP or has EXITS to some of
295 (defun has-xep-or-nlx (clambda)
296 (declare (type clambda clambda
))
297 (or (eq (functional-kind clambda
) :external
)
298 (let ((entries (lambda-entries clambda
)))
300 (find-if #'entry-exits entries
)))))
302 ;;; Compute the result of FIND-INITIAL-DFO given the list of all
303 ;;; resulting components. Components with a :TOPLEVEL lambda, but no
304 ;;; normal XEPs or potential non-local exits are marked as :TOPLEVEL.
305 ;;; If there is a :TOPLEVEL lambda, and also a normal XEP, then we
306 ;;; treat the component as normal, but also return such components in
307 ;;; a list as the third value. Components with no entry of any sort
309 (defun separate-toplevelish-components (components)
310 (declare (list components
))
314 (dolist (component components
)
315 (unless (eq (block-next (component-head component
))
316 (component-tail component
))
317 (let* ((funs (component-lambdas component
))
318 (has-top (find :toplevel funs
:key
#'functional-kind
))
319 (has-external-references
320 (some #'functional-has-external-references-p funs
)))
321 (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
322 ;; is newer than the rest of this function, and
323 ;; doesn't really seem to fit into its mindset. Here
324 ;; we mark components which contain such FUNCTIONs
325 ;; them as :COMPLEX-TOPLEVEL, since they do get
326 ;; executed at run time, and since it's not valid to
327 ;; delete them just because they don't have any
328 ;; references from pure :TOPLEVEL components. -- WHN
329 has-external-references
330 (setf (component-kind component
) :complex-toplevel
)
332 (real-top component
))
333 ((or (some #'has-xep-or-nlx funs
)
334 (and has-top
(rest funs
)))
335 (setf (component-name component
)
336 (find-component-name component
))
339 (setf (component-kind component
) :complex-toplevel
)
340 (real-top component
)))
342 (setf (component-kind component
) :toplevel
)
343 (setf (component-name component
) "top level form")
346 (delete-component component
))))))
348 (values (real) (top) (real-top))))
350 ;;; COMPONENTs want strings for names, LEAF-DEBUG-NAMEs mightn't be
352 (defun component-name-from-functional-debug-name (functional)
353 (declare (type functional functional
))
354 (let ((leaf-debug-name (leaf-debug-name functional
)))
356 (if (stringp leaf-debug-name
)
358 (debug-namify "function ~S" leaf-debug-name
)))))
360 ;;; Given a list of top level lambdas, return
361 ;;; (VALUES NONTOP-COMPONENTS TOP-COMPONENTS HAIRY-TOP-COMPONENTS).
362 ;;; Each of the three values returned is a list of COMPONENTs:
363 ;;; NONTOP-COMPONENTS = non-top-level-ish COMPONENTs;
364 ;;; TOP-COMPONENTS = top-level-ish COMPONENTs;
365 ;;; HAIRY-TOP-COMPONENTS = a subset of NONTOP-COMPONENTS, those
366 ;;; elements which include a top-level-ish lambda.
368 ;;; We assign the DFO for each component, and delete any unreachable
369 ;;; blocks. We assume that the FLAGS have already been cleared.
370 (defun find-initial-dfo (toplevel-lambdas)
371 (declare (list toplevel-lambdas
))
372 (collect ((components))
373 ;; We iterate over the lambdas in each initial component, trying
374 ;; to put each function in its own component, but joining it to
375 ;; an existing component if we find that there are references
376 ;; between them. Any code that is left in an initial component
377 ;; must be unreachable, so we can delete it. Stray links to the
378 ;; initial component tail (due to NIL function terminated blocks)
379 ;; are moved to the appropriate new component tail.
380 (dolist (toplevel-lambda toplevel-lambdas
)
381 (let* ((old-component (lambda-component toplevel-lambda
))
382 (old-component-lambdas (component-lambdas old-component
))
384 (aver (member toplevel-lambda old-component-lambdas
))
385 (dolist (component-lambda old-component-lambdas
)
386 (aver (member (functional-kind component-lambda
)
387 '(:optional
:external
:toplevel nil
:escape
389 (unless new-component
390 (setf new-component
(make-empty-component))
391 (setf (component-name new-component
)
392 ;; This isn't necessarily an ideal name for the
393 ;; component, since it might end up with multiple
394 ;; lambdas in it, not just this one, but it does
395 ;; seem a better name than just "<unknown>".
396 (component-name-from-functional-debug-name
398 (let ((res (dfo-scavenge-dependency-graph component-lambda
400 (when (eq res new-component
)
401 (aver (not (position new-component
(components))))
402 (components new-component
)
403 (setq new-component nil
))))
404 (when (eq (component-kind old-component
) :initial
)
405 (aver (null (component-lambdas old-component
)))
406 (let ((tail (component-tail old-component
)))
407 (dolist (pred (block-pred tail
))
408 (let ((pred-component (block-component pred
)))
409 (unless (eq pred-component old-component
)
410 (unlink-blocks pred tail
)
411 (link-blocks pred
(component-tail pred-component
))))))
412 (delete-component old-component
))))
414 ;; When we are done, we assign DFNs.
415 (dolist (component (components))
417 (declare (fixnum num
))
418 (do-blocks-backwards (block component
:both
)
419 (setf (block-number block
) (incf num
)))))
421 ;; Pull out top-level-ish code.
422 (separate-toplevelish-components (components))))
424 ;;; Insert the code in LAMBDA at the end of RESULT-LAMBDA.
425 (defun merge-1-toplevel-lambda (result-lambda lambda
)
426 (declare (type clambda result-lambda lambda
))
428 ;; Delete the lambda, and combine the LETs and entries.
429 (setf (functional-kind lambda
) :deleted
)
430 (dolist (let (lambda-lets lambda
))
431 (setf (lambda-home let
) result-lambda
)
432 (setf (lambda-physenv let
) (lambda-physenv result-lambda
))
433 (push let
(lambda-lets result-lambda
)))
434 (setf (lambda-entries result-lambda
)
435 (nconc (lambda-entries result-lambda
)
436 (lambda-entries lambda
)))
438 (let* ((bind (lambda-bind lambda
))
439 (bind-block (node-block bind
))
440 (component (block-component bind-block
))
441 (result-component (lambda-component result-lambda
))
442 (result-return-block (node-block (lambda-return result-lambda
))))
444 ;; Move blocks into the new COMPONENT, and move any nodes directly
445 ;; in the old LAMBDA into the new one (with LETs implicitly moved
446 ;; by changing their home.)
447 (do-blocks (block component
)
448 (do-nodes (node cont block
)
449 (let ((lexenv (node-lexenv node
)))
450 (when (eq (lexenv-lambda lexenv
) lambda
)
451 (setf (lexenv-lambda lexenv
) result-lambda
))))
452 (setf (block-component block
) result-component
))
454 ;; Splice the blocks into the new DFO, and unlink them from the
455 ;; old component head and tail. Non-return blocks that jump to the
456 ;; tail (NIL-returning calls) are switched to go to the new tail.
457 (let* ((head (component-head component
))
458 (first (block-next head
))
459 (tail (component-tail component
))
460 (last (block-prev tail
))
461 (prev (block-prev result-return-block
)))
462 (setf (block-next prev
) first
)
463 (setf (block-prev first
) prev
)
464 (setf (block-next last
) result-return-block
)
465 (setf (block-prev result-return-block
) last
)
466 (dolist (succ (block-succ head
))
467 (unlink-blocks head succ
))
468 (dolist (pred (block-pred tail
))
469 (unlink-blocks pred tail
)
470 (let ((last (block-last pred
)))
471 (unless (return-p last
)
472 (aver (basic-combination-p last
))
473 (link-blocks pred
(component-tail result-component
))))))
475 (let ((lambdas (component-lambdas component
)))
476 (aver (and (null (rest lambdas
))
477 (eq (first lambdas
) lambda
))))
479 ;; Switch the end of the code from the return block to the start of
481 (dolist (pred (block-pred result-return-block
))
482 (unlink-blocks pred result-return-block
)
483 (link-blocks pred bind-block
))
486 ;; If there is a return, then delete it (making the preceding node
487 ;; the last node) and link the block to the result return. There
488 ;; is always a preceding REF NIL node in top level lambdas.
489 (let ((return (lambda-return lambda
)))
491 (let ((return-block (node-block return
))
492 (result (return-result return
)))
493 (setf (block-last return-block
) (continuation-use result
))
495 (delete-continuation result
)
496 (link-blocks return-block result-return-block
))))))
498 ;;; Given a non-empty list of top level LAMBDAs, smash them into a
499 ;;; top level lambda and component, returning these as values. We use
500 ;;; the first lambda and its component, putting the other code in that
501 ;;; component and deleting the other lambdas.
502 (defun merge-toplevel-lambdas (lambdas)
503 (declare (cons lambdas
))
504 (let* ((result-lambda (first lambdas
))
505 (result-return (lambda-return result-lambda
)))
509 ;; Make sure the result's return node starts a block so that we
510 ;; can splice code in before it.
511 (let ((prev (node-prev
513 (return-result result-return
)))))
514 (when (continuation-use prev
)
515 (node-ends-block (continuation-use prev
)))
517 (let ((new (make-continuation)))
518 (delete-continuation-use use
)
519 (add-continuation-use use new
))))
521 (dolist (lambda (rest lambdas
))
522 (merge-1-toplevel-lambda result-lambda lambda
)))
524 (dolist (lambda (rest lambdas
))
525 (setf (functional-entry-fun lambda
) nil
)
526 (delete-component (lambda-component lambda
)))))
528 (values (lambda-component result-lambda
) result-lambda
)))