detect cpl-protocol-violations early
[sbcl.git] / src / compiler / dfo.lisp
blob8ee0621c00a689473391d72505eb78749fa31723
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
5 ;;;; more information.
6 ;;;;
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.
13 (in-package "SB!C")
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)))
23 (do ()
24 ((dolist (ep (block-succ head) t)
25 (unless (or (block-flag ep) (block-delete-p ep))
26 (find-dfo-aux ep head component)
27 (return nil))))))
28 (let ((num 0))
29 (declare (fixnum num))
30 (do-blocks-backwards (block component :both)
31 (if (block-flag block)
32 (setf (block-number block) (incf num))
33 (delete-block-lazily block)))
34 (clean-component component (component-head component)))
35 (values))
37 ;;; Move all the code and entry points from OLD to NEW. The code in
38 ;;; OLD is inserted at the head of NEW. This is also called during LET
39 ;;; conversion when we are about in insert the body of a LET in a
40 ;;; different component. [A local call can be to a different component
41 ;;; before FIND-INITIAL-DFO runs.]
42 (declaim (ftype (function (component component) (values)) join-components))
43 (defun join-components (new old)
44 (aver (eq (component-kind new) (component-kind old)))
45 (let ((old-head (component-head old))
46 (old-tail (component-tail old))
47 (head (component-head new))
48 (tail (component-tail new)))
50 (do-blocks (block old)
51 (setf (block-flag block) nil)
52 (setf (block-component block) new))
54 (let ((old-next (block-next old-head))
55 (old-last (block-prev old-tail))
56 (next (block-next head)))
57 (unless (eq old-next old-tail)
58 (setf (block-next head) old-next)
59 (setf (block-prev old-next) head)
61 (setf (block-prev next) old-last)
62 (setf (block-next old-last) next))
64 (setf (block-next old-head) old-tail)
65 (setf (block-prev old-tail) old-head))
67 (setf (component-lambdas new)
68 (nconc (component-lambdas old) (component-lambdas new)))
69 (setf (component-lambdas old) nil)
70 (setf (component-new-functionals new)
71 (nconc (component-new-functionals old)
72 (component-new-functionals new)))
73 (setf (component-new-functionals old) nil)
75 (dolist (xp (block-pred old-tail))
76 (unlink-blocks xp old-tail)
77 (link-blocks xp tail))
78 (dolist (ep (block-succ old-head))
79 (unlink-blocks old-head ep)
80 (link-blocks head ep)))
81 (values))
83 ;;; Do a depth-first walk from BLOCK, inserting ourself in the DFO
84 ;;; after HEAD. If we somehow find ourselves in another component,
85 ;;; then we join that component to our component.
86 (declaim (ftype (function (cblock cblock component) (values)) find-dfo-aux))
87 (defun find-dfo-aux (block head component)
88 (unless (eq (block-component block) component)
89 (join-components component (block-component block)))
90 (unless (or (block-flag block) (block-delete-p block))
91 (setf (block-flag block) t)
92 (dolist (succ (block-succ block))
93 (find-dfo-aux succ head component))
94 (when (component-nlx-info-generated-p component)
95 ;; FIXME: We also need (and do) this walk before physenv
96 ;; analysis, but at that time we are probably not very
97 ;; interested in the actual DF order.
99 ;; TODO: It is probable that one of successors have the same (or
100 ;; similar) set of NLXes; try to shorten the walk (but think
101 ;; about a loop, the only exit from which is non-local).
102 (map-block-nlxes (lambda (nlx-info)
103 (let ((nle (nlx-info-target nlx-info)))
104 (find-dfo-aux nle head component)))
105 block))
106 (remove-from-dfo block)
107 (add-to-dfo block head))
108 (values))
110 ;;; This function is called on each block by FIND-INITIAL-DFO-AUX
111 ;;; before it walks the successors. It looks at the home CLAMBDA's
112 ;;; BIND block to see whether that block is in some other component:
113 ;;; -- If the block is in the initial component, then do
114 ;;; DFO-SCAVENGE-DEPENDENCY-GRAPH on the home function to move it
115 ;;; into COMPONENT.
116 ;;; -- If the block is in some other component, join COMPONENT into
117 ;;; it and return that component.
118 ;;; -- If the home function is deleted, do nothing. BLOCK must
119 ;;; eventually be discovered to be unreachable as well. This can
120 ;;; happen when we have a NLX into a function with no references.
121 ;;; The escape function still has refs (in the deleted function).
123 ;;; This ensures that all the blocks in a given environment will be in
124 ;;; the same component, even when they might not seem reachable from
125 ;;; the environment entry. Consider the case of code that is only
126 ;;; reachable from a non-local exit.
127 (defun scavenge-home-dependency-graph (block component)
128 (declare (type cblock block) (type component component))
129 (let ((home-lambda (block-home-lambda block)))
130 (if (eq (functional-kind home-lambda) :deleted)
131 component
132 (let ((home-component (lambda-component home-lambda)))
133 (cond ((eq (component-kind home-component) :initial)
134 (dfo-scavenge-dependency-graph home-lambda component))
135 ((eq home-component component)
136 component)
138 (join-components home-component component)
139 home-component))))))
141 ;;; This is somewhat similar to FIND-DFO-AUX, except that it merges
142 ;;; the current component with any strange component, rather than the
143 ;;; other way around. This is more efficient in the common case where
144 ;;; the current component doesn't have much stuff in it.
146 ;;; We return the current component as a result, allowing the caller
147 ;;; to detect when the old current component has been merged with
148 ;;; another.
150 ;;; We walk blocks in initial components as though they were already
151 ;;; in the current component, moving them to the current component in
152 ;;; the process. The blocks are inserted at the head of the current
153 ;;; component.
154 (defun find-initial-dfo-aux (block component)
155 (declare (type cblock block) (type component component))
156 (let ((this (block-component block)))
157 (cond
158 ((not (or (eq this component)
159 (eq (component-kind this) :initial)))
160 (join-components this component)
161 this)
162 ((block-flag block) component)
164 (setf (block-flag block) t)
165 (let ((current (scavenge-home-dependency-graph block component)))
166 (dolist (succ (block-succ block))
167 (setq current (find-initial-dfo-aux succ current)))
168 (remove-from-dfo block)
169 (add-to-dfo block (component-head current))
170 current)))))
172 ;;; Return a list of all the home lambdas that reference FUN (may
173 ;;; contain duplications).
175 ;;; References to functions which local call analysis could not (or
176 ;;; were chosen not) to local call convert will appear as references
177 ;;; to XEP lambdas. We can ignore references to XEPs that appear in
178 ;;; :TOPLEVEL components, since environment analysis goes to special
179 ;;; effort to allow closing over of values from a separate top level
180 ;;; component. (And now that HAS-EXTERNAL-REFERENCES-P-ness
181 ;;; generalizes :TOPLEVEL-ness, we ignore those too.) All other
182 ;;; references must cause components to be joined.
184 ;;; References in deleted functions are also ignored, since this code
185 ;;; will be deleted eventually.
186 (defun find-reference-funs (fun)
187 (collect ((res))
188 (dolist (ref (leaf-refs fun))
189 (let* ((home (node-home-lambda ref))
190 (home-kind (functional-kind home))
191 (home-externally-visible-p
192 (or (eq home-kind :toplevel)
193 (functional-has-external-references-p home)
194 (let ((entry (functional-entry-fun home)))
195 (and entry
196 (functional-has-external-references-p entry))))))
197 (unless (or (and home-externally-visible-p
198 (eq (functional-kind fun) :external))
199 (eq home-kind :deleted))
200 (res home))))
201 (res)))
203 ;;; If CLAMBDA is already in COMPONENT, just return that
204 ;;; component. Otherwise, move the code for CLAMBDA and all lambdas it
205 ;;; physically depends on (either because of calls or because of
206 ;;; closure relationships) into COMPONENT, or possibly into another
207 ;;; COMPONENT that we find to be related. Return whatever COMPONENT we
208 ;;; actually merged into.
210 ;;; (Note: The analogous CMU CL code only scavenged call-based
211 ;;; dependencies, not closure dependencies. That seems to've been by
212 ;;; oversight, not by design, as per the bug reported by WHN on
213 ;;; cmucl-imp ca. 2001-11-29 and explained by DTC shortly after.)
215 ;;; If the function is in an initial component, then we move its head
216 ;;; and tail to COMPONENT and add it to COMPONENT's lambdas. It is
217 ;;; harmless to move the tail (even though the return might be
218 ;;; unreachable) because if the return is unreachable it (and its
219 ;;; successor link) will be deleted in the post-deletion pass.
221 ;;; We then do a FIND-DFO-AUX starting at the head of CLAMBDA. If this
222 ;;; flow-graph walk encounters another component (which can only
223 ;;; happen due to a non-local exit), then we move code into that
224 ;;; component instead. We then recurse on all functions called from
225 ;;; CLAMBDA, moving code into whichever component the preceding call
226 ;;; returned.
228 ;;; If CLAMBDA is in the initial component, but the BLOCK-FLAG is set
229 ;;; in the bind block, then we just return COMPONENT, since we must
230 ;;; have already reached this function in the current walk (or the
231 ;;; component would have been changed).
233 ;;; If the function is an XEP, then we also walk all functions that
234 ;;; contain references to the XEP. This is done so that environment
235 ;;; analysis doesn't need to cross component boundaries. This also
236 ;;; ensures that conversion of a full call to a local call won't
237 ;;; result in a need to join components, since the components will
238 ;;; already be one.
239 (defun dfo-scavenge-dependency-graph (clambda component)
240 (declare (type clambda clambda) (type component component))
241 (assert (not (eql (lambda-kind clambda) :deleted)))
242 (let* ((bind-block (node-block (lambda-bind clambda)))
243 (old-lambda-component (block-component bind-block))
244 (return (lambda-return clambda)))
245 (cond
246 ((eq old-lambda-component component)
247 component)
248 ((not (eq (component-kind old-lambda-component) :initial))
249 (join-components old-lambda-component component)
250 old-lambda-component)
251 ((block-flag bind-block)
252 component)
254 (push clambda (component-lambdas component))
255 (setf (component-lambdas old-lambda-component)
256 (delete clambda (component-lambdas old-lambda-component)))
257 (link-blocks (component-head component) bind-block)
258 (unlink-blocks (component-head old-lambda-component) bind-block)
259 (when return
260 (let ((return-block (node-block return)))
261 (link-blocks return-block (component-tail component))
262 (unlink-blocks return-block (component-tail old-lambda-component))))
263 (let ((res (find-initial-dfo-aux bind-block component)))
264 (declare (type component res))
265 ;; Scavenge related lambdas.
266 (labels ((scavenge-lambda (clambda)
267 (setf res
268 (dfo-scavenge-dependency-graph (lambda-home clambda)
269 res)))
270 (scavenge-possibly-deleted-lambda (clambda)
271 (unless (eql (lambda-kind clambda) :deleted)
272 (scavenge-lambda clambda)))
273 ;; Scavenge call relationship.
274 (scavenge-call (called-lambda)
275 (scavenge-lambda called-lambda))
276 ;; Scavenge closure over a variable: if CLAMBDA
277 ;; refers to a variable whose home lambda is not
278 ;; CLAMBDA, then the home lambda should be in the
279 ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU
280 ;; CL, didn't do this, leading to the occasional
281 ;; failure when physenv analysis, which is local to
282 ;; each component, would bogusly conclude that a
283 ;; closed-over variable was unused and thus delete
284 ;; it. See e.g. cmucl-imp 2001-11-29.)
285 (scavenge-closure-var (var)
286 (unless (null (lambda-var-refs var)) ; unless var deleted
287 (let ((var-home-home (lambda-home (lambda-var-home var))))
288 (scavenge-possibly-deleted-lambda var-home-home))))
289 ;; Scavenge closure over an entry for nonlocal exit.
290 ;; This is basically parallel to closure over a
291 ;; variable above.
292 (scavenge-entry (entry)
293 (declare (type entry entry))
294 (let ((entry-home (node-home-lambda entry)))
295 (scavenge-possibly-deleted-lambda entry-home))))
296 (do-sset-elements (cc (lambda-calls-or-closes clambda))
297 (etypecase cc
298 (clambda (scavenge-call cc))
299 (lambda-var (scavenge-closure-var cc))
300 (entry (scavenge-entry cc))))
301 (when (eq (lambda-kind clambda) :external)
302 (mapc #'scavenge-call (find-reference-funs clambda))))
303 ;; Voila.
304 res)))))
306 ;;; Return true if CLAMBDA either is an XEP or has EXITS to some of
307 ;;; its ENTRIES.
308 (defun has-xep-or-nlx (clambda)
309 (declare (type clambda clambda))
310 (or (eq (functional-kind clambda) :external)
311 (let ((entries (lambda-entries clambda)))
312 (and entries
313 (find-if #'entry-exits entries)))))
315 ;;; Compute the result of FIND-INITIAL-DFO given the list of all
316 ;;; resulting components. Components with a :TOPLEVEL lambda, but no
317 ;;; normal XEPs or potential non-local exits are marked as :TOPLEVEL.
318 ;;; If there is a :TOPLEVEL lambda, and also a normal XEP, then we
319 ;;; treat the component as normal, but also return such components in
320 ;;; a list as the third value. Components with no entry of any sort
321 ;;; are deleted.
322 (defun separate-toplevelish-components (components)
323 (declare (list components))
324 (collect ((real)
325 (top)
326 (real-top))
327 (dolist (component components)
328 (unless (eq (block-next (component-head component))
329 (component-tail component))
330 (let* ((funs (component-lambdas component))
331 (has-top (find :toplevel funs :key #'functional-kind))
332 (has-external-references
333 (some #'functional-has-external-references-p funs)))
334 (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
335 ;; is newer than the rest of this function, and
336 ;; doesn't really seem to fit into its mindset. Here
337 ;; we mark components which contain such FUNCTIONs
338 ;; them as :COMPLEX-TOPLEVEL, since they do get
339 ;; executed at run time, and since it's not valid to
340 ;; delete them just because they don't have any
341 ;; references from pure :TOPLEVEL components. -- WHN
342 has-external-references
343 (setf (component-kind component) :complex-toplevel)
344 (real component)
345 (real-top component))
346 ((or (some #'has-xep-or-nlx funs)
347 (and has-top (rest funs)))
348 (setf (component-name component)
349 (find-component-name component))
350 (real component)
351 (when has-top
352 (setf (component-kind component) :complex-toplevel)
353 (real-top component)))
354 (has-top
355 (setf (component-kind component) :toplevel)
356 (setf (component-name component) "top level form")
357 (top component))
359 (delete-component component))))))
361 (values (real) (top) (real-top))))
363 ;;; Given a list of top level lambdas, return
364 ;;; (VALUES NONTOP-COMPONENTS TOP-COMPONENTS HAIRY-TOP-COMPONENTS).
365 ;;; Each of the three values returned is a list of COMPONENTs:
366 ;;; NONTOP-COMPONENTS = non-top-level-ish COMPONENTs;
367 ;;; TOP-COMPONENTS = top-level-ish COMPONENTs;
368 ;;; HAIRY-TOP-COMPONENTS = a subset of NONTOP-COMPONENTS, those
369 ;;; elements which include a top-level-ish lambda.
371 ;;; We assign the DFO for each component, and delete any unreachable
372 ;;; blocks. We assume that the FLAGS have already been cleared.
373 (defun find-initial-dfo (toplevel-lambdas)
374 (declare (list toplevel-lambdas))
375 (collect ((components))
376 ;; We iterate over the lambdas in each initial component, trying
377 ;; to put each function in its own component, but joining it to
378 ;; an existing component if we find that there are references
379 ;; between them. Any code that is left in an initial component
380 ;; must be unreachable, so we can delete it. Stray links to the
381 ;; initial component tail (due to NIL function terminated blocks)
382 ;; are moved to the appropriate new component tail.
383 (dolist (toplevel-lambda toplevel-lambdas)
384 (let* ((old-component (lambda-component toplevel-lambda))
385 (old-component-lambdas (component-lambdas old-component))
386 (new-component nil))
387 (aver (member toplevel-lambda old-component-lambdas))
388 (dolist (component-lambda old-component-lambdas)
389 (aver (member (functional-kind component-lambda)
390 '(:optional :external :toplevel nil :escape
391 :cleanup)))
392 (unless new-component
393 (setf new-component (make-empty-component))
394 (setf (component-name new-component)
395 ;; This isn't necessarily an ideal name for the
396 ;; component, since it might end up with multiple
397 ;; lambdas in it, not just this one, but it does
398 ;; seem a better name than just "<unknown>".
399 (leaf-debug-name component-lambda)))
400 (let ((res (dfo-scavenge-dependency-graph component-lambda
401 new-component)))
402 (when (eq res new-component)
403 (aver (not (position new-component (components))))
404 (components new-component)
405 (setq new-component nil))))
406 (when (eq (component-kind old-component) :initial)
407 (aver (null (component-lambdas old-component)))
408 (let ((tail (component-tail old-component)))
409 (dolist (pred (block-pred tail))
410 (let ((pred-component (block-component pred)))
411 (unless (eq pred-component old-component)
412 (unlink-blocks pred tail)
413 (link-blocks pred (component-tail pred-component))))))
414 (delete-component old-component))))
416 ;; When we are done, we assign DFNs.
417 (dolist (component (components))
418 (let ((num 0))
419 (declare (fixnum num))
420 (do-blocks-backwards (block component :both)
421 (setf (block-number block) (incf num)))))
423 ;; Pull out top-level-ish code.
424 (separate-toplevelish-components (components))))
426 ;;; Insert the code in LAMBDA at the end of RESULT-LAMBDA.
427 (defun merge-1-toplevel-lambda (result-lambda lambda)
428 (declare (type clambda result-lambda lambda))
430 ;; Delete the lambda, and combine the LETs and entries.
431 (setf (functional-kind lambda) :deleted)
432 (dolist (let (lambda-lets lambda))
433 (setf (lambda-home let) result-lambda)
434 (setf (lambda-physenv let) (lambda-physenv result-lambda))
435 (push let (lambda-lets result-lambda)))
436 (setf (lambda-entries result-lambda)
437 (nconc (lambda-entries result-lambda)
438 (lambda-entries lambda)))
440 (let* ((bind (lambda-bind lambda))
441 (bind-block (node-block bind))
442 (component (block-component bind-block))
443 (result-component (lambda-component result-lambda))
444 (result-return-block (node-block (lambda-return result-lambda))))
446 ;; Move blocks into the new COMPONENT, and move any nodes directly
447 ;; in the old LAMBDA into the new one (with LETs implicitly moved
448 ;; by changing their home.)
449 (do-blocks (block component)
450 (do-nodes (node nil block)
451 (let ((lexenv (node-lexenv node)))
452 (when (eq (lexenv-lambda lexenv) lambda)
453 (setf (lexenv-lambda lexenv) result-lambda))))
454 (setf (block-component block) result-component))
456 ;; Splice the blocks into the new DFO, and unlink them from the
457 ;; old component head and tail. Non-return blocks that jump to the
458 ;; tail (NIL-returning calls) are switched to go to the new tail.
459 (let* ((head (component-head component))
460 (first (block-next head))
461 (tail (component-tail component))
462 (last (block-prev tail))
463 (prev (block-prev result-return-block)))
464 (setf (block-next prev) first)
465 (setf (block-prev first) prev)
466 (setf (block-next last) result-return-block)
467 (setf (block-prev result-return-block) last)
468 (dolist (succ (block-succ head))
469 (unlink-blocks head succ))
470 (dolist (pred (block-pred tail))
471 (unlink-blocks pred tail)
472 (let ((last (block-last pred)))
473 (unless (return-p last)
474 (aver (basic-combination-p last))
475 (link-blocks pred (component-tail result-component))))))
477 (let ((lambdas (component-lambdas component)))
478 (aver (and (null (rest lambdas))
479 (eq (first lambdas) lambda))))
481 ;; Switch the end of the code from the return block to the start of
482 ;; the next chunk.
483 (dolist (pred (block-pred result-return-block))
484 (unlink-blocks pred result-return-block)
485 (link-blocks pred bind-block))
486 (unlink-node bind)
488 ;; If there is a return, then delete it (making the preceding node
489 ;; the last node) and link the block to the result return. There
490 ;; is always a preceding REF NIL node in top level lambdas.
491 (let ((return (lambda-return lambda)))
492 (when return
493 (link-blocks (node-block return) result-return-block)
494 (flush-dest (return-result return))
495 (unlink-node return)))))
497 ;;; Given a non-empty list of top level LAMBDAs, smash them into a
498 ;;; top level lambda and component, returning these as values. We use
499 ;;; the first lambda and its component, putting the other code in that
500 ;;; component and deleting the other lambdas.
501 (defun merge-toplevel-lambdas (lambdas)
502 (declare (cons lambdas))
503 (let* ((result-lambda (first lambdas))
504 (result-return (lambda-return result-lambda)))
505 (cond
506 (result-return
508 ;; Make sure the result's return node starts a block so that we
509 ;; can splice code in before it.
510 (let ((prev (node-prev
511 (lvar-uses (return-result result-return)))))
512 (when (ctran-use prev)
513 (node-ends-block (ctran-use prev))))
515 (dolist (lambda (rest lambdas))
516 (merge-1-toplevel-lambda result-lambda lambda)))
518 (dolist (lambda (rest lambdas))
519 (setf (functional-entry-fun lambda) nil)
520 (delete-component (lambda-component lambda)))))
522 (values (lambda-component result-lambda) result-lambda)))