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