/[cmucl]/src/compiler/dfo.lisp
ViewVC logotype

Contents of /src/compiler/dfo.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (show annotations)
Tue Apr 20 17:57:46 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.28: +2 -2 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/dfo.lisp,v 1.29 2010/04/20 17:57:46 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the code that finds the initial components and DFO,
13 ;;; and recomputes the DFO if it is invalidated.
14 ;;;
15 ;;; Written by Rob MacLachlan
16 ;;;
17 (in-package "C")
18 (intl:textdomain "cmucl")
19
20
21 ;;; Find-DFO -- Interface
22 ;;;
23 ;;; Find the DFO for a component, deleting any unreached blocks and merging
24 ;;; any other components we reach. We repeatedly iterate over the entry
25 ;;; points, since new ones may show up during the walk.
26 ;;;
27 (defun find-dfo (component)
28 (declare (type component component))
29 (clear-flags component)
30 (setf (component-reanalyze component) nil)
31 (let ((head (component-head component)))
32 (do ()
33 ((dolist (ep (block-succ head) t)
34 (unless (block-flag ep)
35 (find-dfo-aux ep head component)
36 (return nil))))))
37
38 (let ((num 0))
39 (declare (fixnum num))
40 (do-blocks-backwards (block component :both)
41 (if (block-flag block)
42 (setf (block-number block) (incf num))
43 (setf (block-delete-p block) t)))
44 (do-blocks (block component)
45 (unless (block-flag block)
46 (delete-block block)))))
47
48
49 ;;; Join-Components -- Interface
50 ;;;
51 ;;; Move all the code and entry points from Old to New. The code in Old is
52 ;;; inserted at the head of New. This is also called during let conversion
53 ;;; when we are about in insert the body of a let in a different component. [A
54 ;;; local call can be to a different component before FIND-INITIAL-DFO runs.]
55 ;;;
56 (defun join-components (new old)
57 (declare (type component new old))
58 (assert (eq (component-kind new) (component-kind old)))
59 (let ((old-head (component-head old))
60 (old-tail (component-tail old))
61 (head (component-head new))
62 (tail (component-tail new)))
63
64 (do-blocks (block old)
65 (setf (block-flag block) nil)
66 (setf (block-component block) new))
67
68 (let ((old-next (block-next old-head))
69 (old-last (block-prev old-tail))
70 (next (block-next head)))
71 (unless (eq old-next old-tail)
72 (setf (block-next head) old-next)
73 (setf (block-prev old-next) head)
74
75 (setf (block-prev next) old-last)
76 (setf (block-next old-last) next))
77
78 (setf (block-next old-head) old-tail)
79 (setf (block-prev old-tail) old-head))
80
81 (setf (component-lambdas new)
82 (nconc (component-lambdas old) (component-lambdas new)))
83 (setf (component-lambdas old) ())
84 (setf (component-new-functions new)
85 (nconc (component-new-functions old) (component-new-functions new)))
86 (setf (component-new-functions old) ())
87
88 (dolist (xp (block-pred old-tail))
89 (unlink-blocks xp old-tail)
90 (link-blocks xp tail))
91 (dolist (ep (block-succ old-head))
92 (unlink-blocks old-head ep)
93 (link-blocks head ep))))
94
95
96 ;;; Find-DFO-Aux -- Internal
97 ;;;
98 ;;; Do a depth-first walk from Block, inserting ourself in the DFO after
99 ;;; Head. If we somehow find ourselves in another component, then we join that
100 ;;; component to our component.
101 ;;;
102 (defun find-dfo-aux (block head component)
103 (declare (type cblock block head) (type component component))
104 (unless (eq (block-component block) component)
105 (join-components component (block-component block)))
106
107 (unless (block-flag block)
108 (setf (block-flag block) t)
109 (dolist (succ (block-succ block))
110 (find-dfo-aux succ head component))
111
112 (remove-from-dfo block)
113 (add-to-dfo block head)))
114
115
116 ;;; Walk-Home-Call-Graph -- Internal
117 ;;;
118 ;;; This function is called on each block by Find-Initial-DFO-Aux before it
119 ;;; walks the successors. It looks at the home lambda's bind block to see if
120 ;;; that block is in some other component:
121 ;;; -- If the block is in the initial component, then do DFO-Walk-Call-Graph on
122 ;;; the home function to move it into component.
123 ;;; -- If the block is in some other component, join Component into it and
124 ;;; return that component.
125 ;;; -- If the home function is deleted, do nothing. Block must eventually be
126 ;;; discovered to be unreachable as well. This can happen when we have a
127 ;;; NLX into a function with no references. The escape function still has
128 ;;; refs (in the deleted function).
129 ;;;
130 ;;; This ensures that all the blocks in a given environment will be in the same
131 ;;; component, even when they might not seem reachable from the environment
132 ;;; entry. Consider the case of code that is only reachable from a non-local
133 ;;; exit.
134 ;;;
135 (defun walk-home-call-graph (block component)
136 (declare (type cblock block) (type component component))
137 (let ((home (block-home-lambda block)))
138 (if (eq (functional-kind home) :deleted)
139 component
140 (let* ((bind-block (node-block (lambda-bind home)))
141 (home-component (block-component bind-block)))
142 (cond ((eq (component-kind home-component) :initial)
143 (dfo-walk-call-graph home component))
144 ((eq home-component component)
145 component)
146 (t
147 (join-components home-component component)
148 home-component))))))
149
150
151 ;;; Find-Initial-DFO-Aux -- Internal
152 ;;;
153 ;;; Somewhat similar to Find-DFO-Aux, except that it merges the current
154 ;;; component with any strange component, rather than the other way around.
155 ;;; This is more efficient in the common case where the current component
156 ;;; doesn't have much stuff in it.
157 ;;;
158 ;;; We return the current component as a result, allowing the caller to
159 ;;; detect when the old current component has been merged with another.
160 ;;;
161 ;;; We walk blocks in initial components as though they were already in the
162 ;;; current component, moving them to the current component in the process.
163 ;;; The blocks are inserted at the head of the current component.
164 ;;;
165 (defun find-initial-dfo-aux (block component)
166 (declare (type cblock block) (type component component))
167 (let ((this (block-component block)))
168 (cond
169 ((not (or (eq this component)
170 (eq (component-kind this) :initial)))
171 (join-components this component)
172 this)
173 ((block-flag block) component)
174 (t
175 (setf (block-flag block) t)
176 (let ((current (walk-home-call-graph block component)))
177 (dolist (succ (block-succ block))
178 (setq current (find-initial-dfo-aux succ current)))
179
180 (remove-from-dfo block)
181 (add-to-dfo block (component-head current))
182 current)))))
183
184
185 ;;; Find-Reference-Functions -- Internal
186 ;;;
187 ;;; Return a list of all the home lambdas that reference Fun (may contain
188 ;;; duplications).
189 ;;;
190 ;;; References to functions which local call analysis could not (or were
191 ;;; chosen not) to local call convert will appear as references to XEP lambdas.
192 ;;; We can ignore references to XEPs that appear in :TOP-LEVEL components,
193 ;;; since environment analysis goes to special effort to allow closing over of
194 ;;; values from a separate top-level component. All other references must
195 ;;; cause components to be joined.
196 ;;;
197 ;;; References in deleted functions are also ignored, since this code will be
198 ;;; deleted eventually.
199 ;;;
200 (defun find-reference-functions (fun)
201 (collect ((res))
202 (dolist (ref (leaf-refs fun))
203 (let* ((home (node-home-lambda ref))
204 (home-kind (functional-kind home)))
205 (unless (or (and (eq home-kind :top-level)
206 (eq (functional-kind fun) :external))
207 (eq home-kind :deleted))
208 (res home))))
209 (res)))
210
211
212 ;;; DFO-Walk-Call-Graph -- Internal
213 ;;;
214 ;;; Move the code for Fun and all functions called by it into Component. If
215 ;;; Fun is already in Component, then we just return that component.
216 ;;;
217 ;;; If the function is in an initial component, then we move its head and
218 ;;; tail to Component and add it to Component's lambdas. It is harmless to
219 ;;; move the tail (even though the return might be unreachable) because if the
220 ;;; return is unreachable it (and its successor link) will be deleted in the
221 ;;; post-deletion pass.
222 ;;;
223 ;;; We then do a Find-DFO-Aux starting at the head of Fun. If this
224 ;;; flow-graph walk encounters another component (which can only happen due to
225 ;;; a non-local exit), then we move code into that component instead. We then
226 ;;; recurse on all functions called from Fun, moving code into whichever
227 ;;; component the preceding call returned.
228 ;;;
229 ;;; If Fun is in the initial component, but the Block-Flag is set in the
230 ;;; bind block, then we just return Component, since we must have already
231 ;;; reached this function in the current walk (or the component would have been
232 ;;; changed).
233 ;;;
234 ;;; If the function is an XEP, then we also walk all functions that contain
235 ;;; references to the XEP. This is done so that environment analysis doesn't
236 ;;; need to cross component boundries. This also ensures that conversion of a
237 ;;; full call to a local call won't result in a need to join components, since
238 ;;; the components will already be one.
239 ;;;
240 (defun dfo-walk-call-graph (fun component)
241 (declare (type clambda fun) (type component component))
242 (let* ((bind-block (node-block (lambda-bind fun)))
243 (this (block-component bind-block))
244 (return (lambda-return fun)))
245 (cond ((eq this component)
246 component)
247 ((not (eq (component-kind this) :initial))
248 (join-components this component)
249 this)
250 ((block-flag bind-block)
251 component)
252 (t
253 (push fun (component-lambdas component))
254 (setf (component-lambdas this)
255 (delete fun (component-lambdas this)))
256 (link-blocks (component-head component) bind-block)
257 (unlink-blocks (component-head this) bind-block)
258 (when return
259 (let ((return-block (node-block return)))
260 (link-blocks return-block (component-tail component))
261 (unlink-blocks return-block (component-tail this))))
262 (let ((res (find-initial-dfo-aux bind-block component)))
263 (declare (type component res))
264 (flet ((walk (clambda)
265 (unless (eq (lambda-kind clambda) :deleted)
266 (let ((home (lambda-home clambda)))
267 (setq res (dfo-walk-call-graph home res))))))
268 (dolist (dd (lambda-dfo-dependencies fun))
269 (etypecase dd
270 (clambda
271 (walk dd))
272 (lambda-var
273 (unless (null (lambda-var-refs dd))
274 (walk (lambda-home (lambda-var-home dd)))))
275 (entry
276 (walk (node-home-lambda dd)))))
277 (when (eq (lambda-kind fun) :external)
278 (dolist (lambda (find-reference-functions fun))
279 (walk lambda))))
280 res)))))
281
282 ;;; HAS-XEP-OR-NLX -- Internal
283 ;;;
284 ;;; Return true if Fun is either an XEP or has EXITS to some of its ENTRIES.
285 ;;;
286 (defun has-xep-or-nlx (fun)
287 (declare (type clambda fun))
288 (or (eq (functional-kind fun) :external)
289 (let ((entries (lambda-entries fun)))
290 (and entries
291 (find-if #'entry-exits entries)))))
292
293
294 ;;; FIND-TOP-LEVEL-COMPONENTS -- Internal
295 ;;;
296 ;;; Compute the result of FIND-INITIAL-DFO given the list of all resulting
297 ;;; components. Components with a :TOP-LEVEL lambda, but no normal XEPs or
298 ;;; potential non-local exits are marked as :TOP-LEVEL. If there is a
299 ;;; :TOP-LEVEL lambda, and also a normal XEP, then we treat the component as
300 ;;; normal, but also return such components in a list as the third value.
301 ;;; Components with no entry of any sort are deleted.
302 ;;;
303 (defun find-top-level-components (components)
304 (declare (list components))
305 (collect ((real)
306 (top)
307 (real-top))
308 (dolist (com components)
309 (unless (eq (block-next (component-head com)) (component-tail com))
310 (let* ((funs (component-lambdas com))
311 (has-top (find :top-level funs :key #'functional-kind)))
312 (cond ((or (find-if #'has-xep-or-nlx funs)
313 (and has-top (rest funs)))
314 (setf (component-name com) (find-component-name com))
315 (real com)
316 (when has-top
317 (setf (component-kind com) :complex-top-level)
318 (real-top com)))
319 (has-top
320 (setf (component-kind com) :top-level)
321 (setf (component-name com) (intl:gettext "Top-Level Form"))
322 (top com))
323 (t
324 (delete-component com))))))
325
326 (values (real) (top) (real-top))))
327
328
329 ;;; Find-Initial-DFO -- Interface
330 ;;;
331 ;;; Given a list of top-level lambdas, return three lists of components
332 ;;; representing the actual component division:
333 ;;; 1] the non-top-level components,
334 ;;; 2] and the second is the top-level components, and
335 ;;; 3] Components in [1] that also have a top-level lambda.
336 ;;;
337 ;;; We assign the DFO for each component, and delete any unreachable blocks.
338 ;;; We assume that the Flags have already been cleared.
339 ;;;
340 ;;; We iterate over the lambdas in each initial component, trying to put
341 ;;; each function in its own component, but joining it to an existing component
342 ;;; if we find that there are references between them. Any code that is left
343 ;;; in an initial component must be unreachable, so we can delete it. Stray
344 ;;; links to the initial component tail (due NIL function terminated blocks)
345 ;;; are moved to the appropriate newc component tail.
346 ;;;
347 ;;; When we are done, we assign DFNs and call FIND-TOP-LEVEL-COMPONENTS to
348 ;;; pull out top-level code.
349 ;;;
350 (defun find-initial-dfo (lambdas)
351 (declare (list lambdas))
352 (collect ((components))
353 (let ((new (make-empty-component)))
354 (dolist (tll lambdas)
355 (let ((component (block-component (node-block (lambda-bind tll)))))
356 (dolist (fun (component-lambdas component))
357 (assert (member (functional-kind fun)
358 '(:optional :external :top-level nil :escape
359 :cleanup)))
360 (let ((res (dfo-walk-call-graph fun new)))
361 (when (eq res new)
362 (components new)
363 (setq new (make-empty-component)))))
364 (when (eq (component-kind component) :initial)
365 (assert (null (component-lambdas component)))
366 (let ((tail (component-tail component)))
367 (dolist (pred (block-pred tail))
368 (let ((pred-component (block-component pred)))
369 (unless (eq pred-component component)
370 (unlink-blocks pred tail)
371 (link-blocks pred (component-tail pred-component))))))
372 (delete-component component)))))
373
374 (dolist (com (components))
375 (let ((num 0))
376 (declare (fixnum num))
377 (do-blocks-backwards (block com :both)
378 (setf (block-number block) (incf num)))))
379
380 (find-top-level-components (components))))
381
382
383 ;;; MERGE-1-TL-LAMBDA -- Internal
384 ;;;
385 ;;; Insert the code in LAMBDA at the end of RESULT-LAMBDA.
386 ;;;
387 (defun merge-1-tl-lambda (result-lambda lambda)
388 (declare (type clambda result-lambda lambda))
389 ;;
390 ;; Delete the lambda, and combine the lets and entries.
391 (setf (functional-kind lambda) :deleted)
392 (dolist (let (lambda-lets lambda))
393 (setf (lambda-home let) result-lambda)
394 (setf (lambda-environment let) (lambda-environment result-lambda))
395 (push let (lambda-lets result-lambda)))
396 (setf (lambda-entries result-lambda)
397 (nconc (lambda-entries result-lambda)
398 (lambda-entries lambda)))
399
400 (let* ((bind (lambda-bind lambda))
401 (bind-block (node-block bind))
402 (component (block-component bind-block))
403 (result-component
404 (block-component (node-block (lambda-bind result-lambda))))
405 (result-return-block (node-block (lambda-return result-lambda))))
406 ;;
407 ;; Move blocks into the new component, and move any nodes directly in
408 ;; the old lambda into the new one (lets implicitly moved by changing
409 ;; their home.)
410 (do-blocks (block component)
411 (do-nodes (node cont block)
412 (let ((lexenv (node-lexenv node)))
413 (when (eq (lexenv-lambda lexenv) lambda)
414 (setf (lexenv-lambda lexenv) result-lambda))))
415 (setf (block-component block) result-component))
416 ;;
417 ;; Splice the blocks into the new DFO, and unlink them from the old
418 ;; component head and tail. Non-return blocks that jump to the tail
419 ;; (NIL returning calls) are switched to go to the new tail.
420 (let* ((head (component-head component))
421 (first (block-next head))
422 (tail (component-tail component))
423 (last (block-prev tail))
424 (prev (block-prev result-return-block)))
425 (setf (block-next prev) first)
426 (setf (block-prev first) prev)
427 (setf (block-next last) result-return-block)
428 (setf (block-prev result-return-block) last)
429 (dolist (succ (block-succ head))
430 (unlink-blocks head succ))
431 (dolist (pred (block-pred tail))
432 (unlink-blocks pred tail)
433 (let ((last (block-last pred)))
434 (unless (return-p last)
435 (assert (basic-combination-p last))
436 (link-blocks pred (component-tail result-component))))))
437
438 (let ((lambdas (component-lambdas component)))
439 (assert (and (null (rest lambdas))
440 (eq (first lambdas) lambda))))
441 ;;
442 ;; Switch the end of the code from the return block to the start of
443 ;; the next chunk.
444 (dolist (pred (block-pred result-return-block))
445 (unlink-blocks pred result-return-block)
446 (link-blocks pred bind-block))
447 (unlink-node bind)
448 ;;
449 ;; If there is a return, then delete it (making the preceding node the
450 ;; last node) and link the block to the result return. There is always a
451 ;; preceding REF NIL node in top-level lambdas.
452 (let ((return (lambda-return lambda)))
453 (when return
454 (let ((return-block (node-block return))
455 (result (return-result return)))
456 (setf (block-last return-block) (continuation-use result))
457 (flush-dest result)
458 (delete-continuation result)
459 (link-blocks return-block result-return-block))))))
460
461
462 ;;; MERGE-TOP-LEVEL-LAMBDAS -- Interface
463 ;;;
464 ;;; Given a non-empty list of top-level lambdas, smash them into a top-level
465 ;;; lambda and component, returning these as values. We use the first lambda
466 ;;; and its component, putting the other code in that component and deleting
467 ;;; the other lambdas.
468 ;;;
469 (defun merge-top-level-lambdas (lambdas)
470 (declare (cons lambdas))
471 (let* ((result-lambda (first lambdas))
472 (result-return (lambda-return result-lambda)))
473 (cond
474 (result-return
475 ;;
476 ;; Make sure the result's return node starts a block so that we can
477 ;; splice code in before it.
478 (let ((prev (node-prev
479 (continuation-use
480 (return-result result-return)))))
481 (when (continuation-use prev)
482 (node-ends-block (continuation-use prev)))
483 (do-uses (use prev)
484 (let ((new (make-continuation)))
485 (delete-continuation-use use)
486 (add-continuation-use use new))))
487
488 (dolist (lambda (rest lambdas))
489 (merge-1-tl-lambda result-lambda lambda)))
490 (t
491 (dolist (lambda (rest lambdas))
492 (setf (functional-entry-function lambda) nil)
493 (delete-component
494 (block-component
495 (node-block (lambda-bind lambda)))))))
496
497 (values (block-component (node-block (lambda-bind result-lambda)))
498 result-lambda)))

  ViewVC Help
Powered by ViewVC 1.1.5