1 ;;;; This file contains miscellaneous utilities used for manipulating
2 ;;;; the IR1 representation.
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.
17 ;;; Return the innermost cleanup enclosing NODE, or NIL if there is
18 ;;; none in its function. If NODE has no cleanup, but is in a LET,
19 ;;; then we must still check the environment that the call is in.
20 (defun node-enclosing-cleanup (node)
21 (declare (type node node))
22 (do ((lexenv (node-lexenv node)
23 (lambda-call-lexenv (lexenv-lambda lexenv))))
25 (let ((cup (lexenv-cleanup lexenv)))
26 (when cup (return cup)))))
28 ;;; Convert the FORM in a block inserted between BLOCK1 and BLOCK2 as
29 ;;; an implicit MV-PROG1. The inserted block is returned. NODE is used
30 ;;; for IR1 context when converting the form. Note that the block is
31 ;;; not assigned a number, and is linked into the DFO at the
32 ;;; beginning. We indicate that we have trashed the DFO by setting
33 ;;; COMPONENT-REANALYZE. If CLEANUP is supplied, then convert with
35 (defun insert-cleanup-code (block1 block2 node form &optional cleanup)
36 (declare (type cblock block1 block2) (type node node)
37 (type (or cleanup null) cleanup))
38 (setf (component-reanalyze (block-component block1)) t)
39 (with-ir1-environment-from-node node
40 (with-component-last-block (*current-component*
41 (block-next (component-head *current-component*)))
42 (let* ((start (make-continuation))
43 (block (continuation-starts-block start))
44 (cont (make-continuation))
46 (make-lexenv :cleanup cleanup)
48 (change-block-successor block1 block2 block)
49 (link-blocks block block2)
50 (ir1-convert start cont form)
51 (setf (block-last block) (continuation-use cont))
54 ;;;; continuation use hacking
56 ;;; Return a list of all the nodes which use Cont.
57 (declaim (ftype (sfunction (continuation) list) find-uses))
58 (defun find-uses (cont)
59 (ecase (continuation-kind cont)
60 ((:block-start :deleted-block-start)
61 (block-start-uses (continuation-block cont)))
62 (:inside-block (list (continuation-use cont)))
66 (defun principal-continuation-use (cont)
67 (let ((use (continuation-use cont)))
69 (principal-continuation-use (cast-value use))
72 ;;; Update continuation use information so that NODE is no longer a
73 ;;; use of its CONT. If the old continuation doesn't start its block,
74 ;;; then we don't update the BLOCK-START-USES, since it will be
75 ;;; deleted when we are done.
77 ;;; Note: if you call this function, you may have to do a
78 ;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
80 (declaim (ftype (sfunction (node) (values)) delete-continuation-use))
81 (defun delete-continuation-use (node)
82 (let* ((cont (node-cont node))
83 (block (continuation-block cont)))
84 (ecase (continuation-kind cont)
86 ((:block-start :deleted-block-start)
87 (let ((uses (delete node (block-start-uses block))))
88 (setf (block-start-uses block) uses)
89 (setf (continuation-use cont)
90 (if (cdr uses) nil (car uses)))))
92 (setf (continuation-kind cont) :unused)
93 (setf (continuation-block cont) nil)
94 (setf (continuation-use cont) nil)
95 (setf (continuation-next cont) nil)))
96 (setf (node-cont node) nil))
99 ;;; Update continuation use information so that NODE uses CONT. If
100 ;;; CONT is :UNUSED, then we set its block to NODE's NODE-BLOCK (which
103 ;;; Note: if you call this function, you may have to do a
104 ;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
106 (declaim (ftype (sfunction (node continuation) (values)) add-continuation-use))
107 (defun add-continuation-use (node cont)
108 (aver (not (node-cont node)))
109 (let ((block (continuation-block cont)))
110 (ecase (continuation-kind cont)
114 (let ((block (node-block node)))
116 (setf (continuation-block cont) block))
117 (setf (continuation-kind cont) :inside-block)
118 (setf (continuation-use cont) node))
119 ((:block-start :deleted-block-start)
120 (let ((uses (cons node (block-start-uses block))))
121 (setf (block-start-uses block) uses)
122 (setf (continuation-use cont)
123 (if (cdr uses) nil (car uses)))
124 (let ((block (node-block node)))
125 (unless (block-last block)
126 (setf (block-last block) node)))))))
127 (setf (node-cont node) cont)
130 ;;; Return true if CONT is the NODE-CONT for NODE and CONT is
131 ;;; transferred to immediately after the evaluation of NODE.
132 (defun immediately-used-p (cont node)
133 (declare (type continuation cont) (type node node))
134 (and (eq (node-cont node) cont)
135 (not (eq (continuation-kind cont) :deleted))
136 (eq (continuation-dest cont)
137 (continuation-next cont))
138 (let ((cblock (continuation-block cont))
139 (nblock (node-block node)))
140 (or (eq cblock nblock)
141 (let ((succ (block-succ nblock)))
142 (and (= (length succ) 1)
143 (eq (first succ) cblock)))))))
145 ;;;; continuation substitution
147 ;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be
148 ;;; NIL. When we are done, we call FLUSH-DEST on OLD to clear its DEST
149 ;;; and to note potential optimization opportunities.
150 (defun substitute-continuation (new old)
151 (declare (type continuation old new))
152 (aver (not (continuation-dest new)))
153 (let ((dest (continuation-dest old)))
156 (cif (setf (if-test dest) new))
157 (cset (setf (set-value dest) new))
158 (creturn (setf (return-result dest) new))
159 (exit (setf (exit-value dest) new))
161 (if (eq old (basic-combination-fun dest))
162 (setf (basic-combination-fun dest) new)
163 (setf (basic-combination-args dest)
164 (nsubst new old (basic-combination-args dest)))))
165 (cast (setf (cast-value dest) new))
168 (when dest (flush-dest old))
169 (setf (continuation-dest new) dest)
170 (flush-continuation-externally-checkable-type new))
173 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
174 ;;; arbitary number of uses. If NEW will end up with more than one
175 ;;; use, then we must arrange for it to start a block if it doesn't
177 (defun substitute-continuation-uses (new old)
178 (declare (type continuation old new))
179 (unless (and (eq (continuation-kind new) :unused)
180 (eq (continuation-kind old) :inside-block))
181 (ensure-block-start new))
184 (delete-continuation-use node)
185 (add-continuation-use node new))
186 (dolist (lexenv-use (continuation-lexenv-uses old)) ; FIXME - APD
187 (setf (cadr lexenv-use) new))
189 (reoptimize-continuation new)
192 ;;;; block starting/creation
194 ;;; Return the block that CONT is the start of, making a block if
195 ;;; necessary. This function is called by IR1 translators which may
196 ;;; cause a continuation to be used more than once. Every continuation
197 ;;; which may be used more than once must start a block by the time
198 ;;; that anyone does a USE-CONTINUATION on it.
200 ;;; We also throw the block into the next/prev list for the
201 ;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have
203 (defun continuation-starts-block (cont)
204 (declare (type continuation cont))
205 (ecase (continuation-kind cont)
207 (aver (not (continuation-block cont)))
208 (let* ((next (component-last-block *current-component*))
209 (prev (block-prev next))
210 (new-block (make-block cont)))
211 (setf (block-next new-block) next
212 (block-prev new-block) prev
213 (block-prev next) new-block
214 (block-next prev) new-block
215 (continuation-block cont) new-block
216 (continuation-use cont) nil
217 (continuation-kind cont) :block-start)
220 (continuation-block cont))))
222 ;;; Ensure that CONT is the start of a block (or deleted) so that
223 ;;; the use set can be freely manipulated.
224 ;;; -- If the continuation is :UNUSED or is :INSIDE-BLOCK and the
225 ;;; CONT of LAST in its block, then we make it the start of a new
227 ;;; -- If the continuation is :INSIDE-BLOCK inside a block, then we
228 ;;; split the block using NODE-ENDS-BLOCK, which makes the
229 ;;; continuation be a :BLOCK-START.
230 (defun ensure-block-start (cont)
231 (declare (type continuation cont))
232 (let ((kind (continuation-kind cont)))
234 ((:deleted :block-start :deleted-block-start))
235 ((:unused :inside-block)
236 (let ((block (continuation-block cont)))
237 (cond ((or (eq kind :unused)
238 (eq (node-cont (block-last block)) cont))
239 (setf (continuation-block cont)
240 (make-block-key :start cont
242 :start-uses (find-uses cont)))
243 (setf (continuation-kind cont) :deleted-block-start))
245 (node-ends-block (continuation-use cont))))))))
250 ;;; Filter values of CONT with a destination through FORM, which must
251 ;;; be an ordinary/mv call. First argument must be 'DUMMY, which will
252 ;;; be replaced with CONT. In case of an ordinary call the function
253 ;;; should not have return type NIL.
255 ;;; TODO: remove preconditions.
256 (defun filter-continuation (cont form)
257 (declare (type continuation cont) (type list form))
258 (let ((dest (continuation-dest cont)))
259 (declare (type node dest))
260 (with-ir1-environment-from-node dest
262 ;; Ensuring that CONT starts a block lets us freely manipulate its uses.
263 (ensure-block-start cont)
265 ;; Make a new continuation and move CONT's uses to it.
266 (let ((new-start (make-continuation))
267 (prev (node-prev dest)))
268 (continuation-starts-block new-start)
269 (substitute-continuation-uses new-start cont)
271 ;; Make the DEST node start its block so that we can splice in
273 (when (continuation-use prev)
274 (node-ends-block (continuation-use prev)))
276 (let* ((prev-block (continuation-block prev))
277 (new-block (continuation-block new-start))
278 (dummy (make-continuation)))
280 ;; Splice in the new block before DEST, giving the new block
281 ;; all of DEST's predecessors.
282 (dolist (block (block-pred prev-block))
283 (change-block-successor block prev-block new-block))
285 ;; Convert the lambda form, using the new block start as
286 ;; START and a dummy continuation as CONT.
287 (ir1-convert new-start dummy form)
289 ;; TODO: Why should this be true? -- WHN 19990601
291 ;; It is somehow related to the precondition of non-NIL
292 ;; return type of the function. -- APD 2003-3-24
293 (aver (eq (continuation-block dummy) new-block))
295 ;; KLUDGE: Comments at the head of this function in CMU CL
296 ;; said that somewhere in here we
297 ;; Set the new block's start and end cleanups to the *start*
298 ;; cleanup of PREV's block. This overrides the incorrect
299 ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
300 ;; Unfortunately I can't find any code which corresponds to this.
301 ;; Perhaps it was a stale comment? Or perhaps I just don't
302 ;; understand.. -- WHN 19990521
304 (let ((node (continuation-use dummy)))
305 (setf (block-last new-block) node)
306 ;; Change the use to a use of CONT. (We need to use the
307 ;; dummy continuation to get the control transfer right,
308 ;; because we want to go to PREV's block, not CONT's.)
309 (delete-continuation-use node)
310 (add-continuation-use node cont))
311 ;; Link the new block to PREV's block.
312 (link-blocks new-block prev-block))
314 ;; Replace 'DUMMY with the new continuation. (We can find
315 ;; 'DUMMY because no LET conversion has been done yet.) The
316 ;; [mv-]combination code from the call in the form will be the
317 ;; use of the new check continuation. We substitute for the
318 ;; first argument of this node.
319 (let* ((node (continuation-use cont))
320 (args (basic-combination-args node))
321 (victim (first args)))
322 (aver (eq (constant-value (ref-leaf (continuation-use victim)))
324 (substitute-continuation new-start victim)))
326 ;; Invoking local call analysis converts this call to a LET.
327 (locall-analyze-component *current-component*)
331 ;;; Deleting a filter may result in some calls becoming tail.
332 (defun delete-filter (node cont value)
335 (when (return-p (continuation-dest cont))
337 (when (and (basic-combination-p use)
338 (eq (basic-combination-kind use) :local))
340 (cond ((and (eq (continuation-kind cont) :inside-block)
341 (eq (continuation-kind value) :inside-block))
342 (setf (continuation-dest value) nil)
343 (substitute-continuation value cont)
344 (prog1 (unlink-node node)
346 (t (ensure-block-start value)
347 (ensure-block-start cont)
348 (substitute-continuation-uses cont value)
349 (prog1 (unlink-node node)
350 (setf (continuation-dest value) nil))))
351 (dolist (merge (merges))
352 (merge-tail-sets merge)))))
354 ;;;; miscellaneous shorthand functions
356 ;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since
357 ;;; the LEXENV-LAMBDA may be deleted, we must chain up the
358 ;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't
359 ;;; deleted, and then return its home.
360 (defun node-home-lambda (node)
361 (declare (type node node))
362 (do ((fun (lexenv-lambda (node-lexenv node))
363 (lexenv-lambda (lambda-call-lexenv fun))))
364 ((not (eq (functional-kind fun) :deleted))
366 (when (eq (lambda-home fun) fun)
369 (declaim (ftype (sfunction (node) cblock) node-block))
370 (defun node-block (node)
371 (continuation-block (node-prev node)))
372 (declaim (ftype (sfunction (node) component) node-component))
373 (defun node-component (node)
374 (block-component (node-block node)))
375 (declaim (ftype (sfunction (node) physenv) node-physenv))
376 (defun node-physenv (node)
377 (lambda-physenv (node-home-lambda node)))
379 (declaim (ftype (sfunction (clambda) cblock) lambda-block))
380 (defun lambda-block (clambda)
381 (node-block (lambda-bind clambda)))
382 (declaim (ftype (sfunction (clambda) component) lambda-component))
383 (defun lambda-component (clambda)
384 (block-component (lambda-block clambda)))
386 ;;; Return the enclosing cleanup for environment of the first or last
388 (defun block-start-cleanup (block)
389 (declare (type cblock block))
390 (node-enclosing-cleanup (continuation-next (block-start block))))
391 (defun block-end-cleanup (block)
392 (declare (type cblock block))
393 (node-enclosing-cleanup (block-last block)))
395 ;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL
396 ;;; if there is none.
398 ;;; There can legitimately be no home lambda in dead code early in the
399 ;;; IR1 conversion process, e.g. when IR1-converting the SETQ form in
400 ;;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
401 ;;; where the block is just a placeholder during parsing and doesn't
402 ;;; actually correspond to code which will be written anywhere.
403 (declaim (ftype (sfunction (cblock) (or clambda null)) block-home-lambda-or-null))
404 (defun block-home-lambda-or-null (block)
405 (if (node-p (block-last block))
406 ;; This is the old CMU CL way of doing it.
407 (node-home-lambda (block-last block))
408 ;; Now that SBCL uses this operation more aggressively than CMU
409 ;; CL did, the old CMU CL way of doing it can fail in two ways.
410 ;; 1. It can fail in a few cases even when a meaningful home
411 ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of
413 ;; 2. It can fail when converting a form which is born orphaned
414 ;; so that it never had a meaningful home lambda, e.g. a form
415 ;; which follows a RETURN-FROM or GO form.
416 (let ((pred-list (block-pred block)))
417 ;; To deal with case 1, we reason that
418 ;; previous-in-target-execution-order blocks should be in the
419 ;; same lambda, and that they seem in practice to be
420 ;; previous-in-compilation-order blocks too, so we look back
421 ;; to find one which is sufficiently initialized to tell us
422 ;; what the home lambda is.
424 ;; We could get fancy about this, flooding through the
425 ;; graph of all the previous blocks, but in practice it
426 ;; seems to work just to grab the first previous block and
428 (node-home-lambda (block-last (first pred-list)))
429 ;; In case 2, we end up with an empty PRED-LIST and
430 ;; have to punt: There's no home lambda.
433 ;;; Return the non-LET LAMBDA that holds BLOCK's code.
434 (declaim (ftype (sfunction (cblock) clambda) block-home-lambda))
435 (defun block-home-lambda (block)
436 (block-home-lambda-or-null block))
438 ;;; Return the IR1 physical environment for BLOCK.
439 (declaim (ftype (sfunction (cblock) physenv) block-physenv))
440 (defun block-physenv (block)
441 (lambda-physenv (block-home-lambda block)))
443 ;;; Return the Top Level Form number of PATH, i.e. the ordinal number
444 ;;; of its original source's top level form in its compilation unit.
445 (defun source-path-tlf-number (path)
446 (declare (list path))
449 ;;; Return the (reversed) list for the PATH in the original source
450 ;;; (with the Top Level Form number last).
451 (defun source-path-original-source (path)
452 (declare (list path) (inline member))
453 (cddr (member 'original-source-start path :test #'eq)))
455 ;;; Return the Form Number of PATH's original source inside the Top
456 ;;; Level Form that contains it. This is determined by the order that
457 ;;; we walk the subforms of the top level source form.
458 (defun source-path-form-number (path)
459 (declare (list path) (inline member))
460 (cadr (member 'original-source-start path :test #'eq)))
462 ;;; Return a list of all the enclosing forms not in the original
463 ;;; source that converted to get to this form, with the immediate
464 ;;; source for node at the start of the list.
465 (defun source-path-forms (path)
466 (subseq path 0 (position 'original-source-start path)))
468 ;;; Return the innermost source form for NODE.
469 (defun node-source-form (node)
470 (declare (type node node))
471 (let* ((path (node-source-path node))
472 (forms (source-path-forms path)))
475 (values (find-original-source path)))))
477 ;;; Return NODE-SOURCE-FORM, T if continuation has a single use,
478 ;;; otherwise NIL, NIL.
479 (defun continuation-source (cont)
480 (let ((use (continuation-use cont)))
482 (values (node-source-form use) t)
485 ;;; Return the LAMBDA that is CONT's home, or NIL if there is none.
486 (declaim (ftype (sfunction (continuation) (or clambda null))
487 continuation-home-lambda-or-null))
488 (defun continuation-home-lambda-or-null (cont)
489 ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
490 ;; implementation might not be quite right, or might be uglier than
491 ;; necessary. It appears that the original Python never found a need
492 ;; to do this operation. The obvious things based on
493 ;; NODE-HOME-LAMBDA of CONTINUATION-USE usually work; then if that
494 ;; fails, BLOCK-HOME-LAMBDA of CONTINUATION-BLOCK works, given that
495 ;; we generalize it enough to grovel harder when the simple CMU CL
496 ;; approach fails, and furthermore realize that in some exceptional
497 ;; cases it might return NIL. -- WHN 2001-12-04
498 (cond ((continuation-use cont)
499 (node-home-lambda (continuation-use cont)))
500 ((continuation-block cont)
501 (block-home-lambda-or-null (continuation-block cont)))
503 (bug "confused about home lambda for ~S" cont))))
505 ;;; Return the LAMBDA that is CONT's home.
506 (declaim (ftype (sfunction (continuation) clambda)
507 continuation-home-lambda))
508 (defun continuation-home-lambda (cont)
509 (continuation-home-lambda-or-null cont))
511 #!-sb-fluid (declaim (inline continuation-single-value-p))
512 (defun continuation-single-value-p (cont)
513 (let ((dest (continuation-dest cont)))
518 (eq (basic-combination-fun dest) cont))
521 (declare (notinline continuation-single-value-p))
522 (and (not (values-type-p (cast-asserted-type dest)))
523 (continuation-single-value-p (node-cont dest)))))
527 (defun principal-continuation-end (cont)
528 (loop for prev = cont then (node-cont dest)
529 for dest = (continuation-dest prev)
531 finally (return (values dest prev))))
533 (defun principal-continuation-single-valuify (cont)
534 (loop for prev = cont then (node-cont dest)
535 for dest = (continuation-dest prev)
537 do (setf (node-derived-type dest)
538 (make-short-values-type (list (single-value-type
539 (node-derived-type dest)))))
540 (reoptimize-continuation prev)))
542 ;;; Return a new LEXENV just like DEFAULT except for the specified
543 ;;; slot values. Values for the alist slots are NCONCed to the
544 ;;; beginning of the current value, rather than replacing it entirely.
545 (defun make-lexenv (&key (default *lexenv*)
546 funs vars blocks tags
548 (lambda (lexenv-lambda default))
549 (cleanup (lexenv-cleanup default))
550 (policy (lexenv-policy default)))
551 (macrolet ((frob (var slot)
552 `(let ((old (,slot default)))
556 (internal-make-lexenv
557 (frob funs lexenv-funs)
558 (frob vars lexenv-vars)
559 (frob blocks lexenv-blocks)
560 (frob tags lexenv-tags)
561 (frob type-restrictions lexenv-type-restrictions)
562 lambda cleanup policy)))
564 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
566 (defun make-restricted-lexenv (lexenv)
567 (flet ((fun-good-p (fun)
568 (destructuring-bind (name . thing) fun
569 (declare (ignore name))
573 (cons (aver (eq (car thing) 'macro))
576 (destructuring-bind (name . thing) var
577 (declare (ignore name))
580 (cons (aver (eq (car thing) 'macro))
582 (heap-alien-info nil)))))
583 (internal-make-lexenv
584 (remove-if-not #'fun-good-p (lexenv-funs lexenv))
585 (remove-if-not #'var-good-p (lexenv-vars lexenv))
588 (lexenv-type-restrictions lexenv) ; XXX
591 (lexenv-policy lexenv))))
593 ;;;; flow/DFO/component hackery
595 ;;; Join BLOCK1 and BLOCK2.
596 (defun link-blocks (block1 block2)
597 (declare (type cblock block1 block2))
598 (setf (block-succ block1)
599 (if (block-succ block1)
600 (%link-blocks block1 block2)
602 (push block1 (block-pred block2))
604 (defun %link-blocks (block1 block2)
605 (declare (type cblock block1 block2) (inline member))
606 (let ((succ1 (block-succ block1)))
607 (aver (not (member block2 succ1 :test #'eq)))
608 (cons block2 succ1)))
610 ;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If
611 ;;; this leaves a successor with a single predecessor that ends in an
612 ;;; IF, then set BLOCK-TEST-MODIFIED so that any test constraint will
613 ;;; now be able to be propagated to the successor.
614 (defun unlink-blocks (block1 block2)
615 (declare (type cblock block1 block2))
616 (let ((succ1 (block-succ block1)))
617 (if (eq block2 (car succ1))
618 (setf (block-succ block1) (cdr succ1))
619 (do ((succ (cdr succ1) (cdr succ))
621 ((eq (car succ) block2)
622 (setf (cdr prev) (cdr succ)))
625 (let ((new-pred (delq block1 (block-pred block2))))
626 (setf (block-pred block2) new-pred)
627 (when (singleton-p new-pred)
628 (let ((pred-block (first new-pred)))
629 (when (if-p (block-last pred-block))
630 (setf (block-test-modified pred-block) t)))))
633 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK
634 ;;; and NEW. If BLOCK ends in an IF, then we have to fix up the
635 ;;; consequent/alternative blocks to point to NEW. We also set
636 ;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to
637 ;;; the new successor.
638 (defun change-block-successor (block old new)
639 (declare (type cblock new old block) (inline member))
640 (unlink-blocks block old)
641 (let ((last (block-last block))
642 (comp (block-component block)))
643 (setf (component-reanalyze comp) t)
646 (setf (block-test-modified block) t)
647 (let* ((succ-left (block-succ block))
648 (new (if (and (eq new (component-tail comp))
652 (unless (member new succ-left :test #'eq)
653 (link-blocks block new))
654 (macrolet ((frob (slot)
655 `(when (eq (,slot last) old)
656 (setf (,slot last) new))))
658 (frob if-alternative)
659 (when (eq (if-consequent last)
660 (if-alternative last))
661 (setf (component-reoptimize (block-component block)) t)))))
663 (unless (member new (block-succ block) :test #'eq)
664 (link-blocks block new)))))
668 ;;; Unlink a block from the next/prev chain. We also null out the
670 (declaim (ftype (sfunction (cblock) (values)) remove-from-dfo))
671 (defun remove-from-dfo (block)
672 (let ((next (block-next block))
673 (prev (block-prev block)))
674 (setf (block-component block) nil)
675 (setf (block-next prev) next)
676 (setf (block-prev next) prev))
679 ;;; Add BLOCK to the next/prev chain following AFTER. We also set the
680 ;;; COMPONENT to be the same as for AFTER.
681 (defun add-to-dfo (block after)
682 (declare (type cblock block after))
683 (let ((next (block-next after))
684 (comp (block-component after)))
685 (aver (not (eq (component-kind comp) :deleted)))
686 (setf (block-component block) comp)
687 (setf (block-next after) block)
688 (setf (block-prev block) after)
689 (setf (block-next block) next)
690 (setf (block-prev next) block))
693 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
694 ;;; the head and tail which are set to T.
695 (declaim (ftype (sfunction (component) (values)) clear-flags))
696 (defun clear-flags (component)
697 (let ((head (component-head component))
698 (tail (component-tail component)))
699 (setf (block-flag head) t)
700 (setf (block-flag tail) t)
701 (do-blocks (block component)
702 (setf (block-flag block) nil)))
705 ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially
706 ;;; true in the head and tail blocks.
707 (declaim (ftype (sfunction () component) make-empty-component))
708 (defun make-empty-component ()
709 (let* ((head (make-block-key :start nil :component nil))
710 (tail (make-block-key :start nil :component nil))
711 (res (make-component head tail)))
712 (setf (block-flag head) t)
713 (setf (block-flag tail) t)
714 (setf (block-component head) res)
715 (setf (block-component tail) res)
716 (setf (block-next head) tail)
717 (setf (block-prev tail) head)
720 ;;; Make NODE the LAST node in its block, splitting the block if necessary.
721 ;;; The new block is added to the DFO immediately following NODE's block.
722 (defun node-ends-block (node)
723 (declare (type node node))
724 (let* ((block (node-block node))
725 (start (node-cont node))
726 (last (block-last block))
727 (last-cont (node-cont last)))
728 (unless (eq last node)
729 (aver (and (eq (continuation-kind start) :inside-block)
730 (not (block-delete-p block))))
731 (let* ((succ (block-succ block))
733 (make-block-key :start start
734 :component (block-component block)
735 :start-uses (list (continuation-use start))
736 :succ succ :last last)))
737 (setf (continuation-kind start) :block-start)
740 (cons new-block (remove block (block-pred b)))))
741 (setf (block-succ block) ())
742 (setf (block-last block) node)
743 (link-blocks block new-block)
744 (add-to-dfo new-block block)
745 (setf (component-reanalyze (block-component block)) t)
747 (do ((cont start (node-cont (continuation-next cont))))
749 (when (eq (continuation-kind last-cont) :inside-block)
750 (setf (continuation-block last-cont) new-block)))
751 (setf (continuation-block cont) new-block))
753 (setf (block-type-asserted block) t)
754 (setf (block-test-modified block) t))))
760 ;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
761 (defun delete-lambda-var (leaf)
762 (declare (type lambda-var leaf))
764 ;; Iterate over all local calls flushing the corresponding argument,
765 ;; allowing the computation of the argument to be deleted. We also
766 ;; mark the LET for reoptimization, since it may be that we have
767 ;; deleted its last variable.
768 (let* ((fun (lambda-var-home leaf))
769 (n (position leaf (lambda-vars fun))))
770 (dolist (ref (leaf-refs fun))
771 (let* ((cont (node-cont ref))
772 (dest (continuation-dest cont)))
773 (when (and (combination-p dest)
774 (eq (basic-combination-fun dest) cont)
775 (eq (basic-combination-kind dest) :local))
776 (let* ((args (basic-combination-args dest))
778 (reoptimize-continuation arg)
780 (setf (elt args n) nil))))))
782 ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
783 ;; too much difficulty, since we can efficiently implement
784 ;; write-only variables. We iterate over the SETs, marking their
785 ;; blocks for dead code flushing, since we can delete SETs whose
787 (dolist (set (lambda-var-sets leaf))
788 (setf (block-flush-p (node-block set)) t))
792 ;;; Note that something interesting has happened to VAR.
793 (defun reoptimize-lambda-var (var)
794 (declare (type lambda-var var))
795 (let ((fun (lambda-var-home var)))
796 ;; We only deal with LET variables, marking the corresponding
797 ;; initial value arg as needing to be reoptimized.
798 (when (and (eq (functional-kind fun) :let)
800 (do ((args (basic-combination-args
803 (first (leaf-refs fun)))))
805 (vars (lambda-vars fun) (cdr vars)))
807 (reoptimize-continuation (car args))))))
810 ;;; Delete a function that has no references. This need only be called
811 ;;; on functions that never had any references, since otherwise
812 ;;; DELETE-REF will handle the deletion.
813 (defun delete-functional (fun)
814 (aver (and (null (leaf-refs fun))
815 (not (functional-entry-fun fun))))
817 (optional-dispatch (delete-optional-dispatch fun))
818 (clambda (delete-lambda fun)))
821 ;;; Deal with deleting the last reference to a CLAMBDA. Since there is
822 ;;; only one way into a CLAMBDA, deleting the last reference to a
823 ;;; CLAMBDA ensures that there is no way to reach any of the code in
824 ;;; it. So we just set the FUNCTIONAL-KIND for FUN and its LETs to
825 ;;; :DELETED, causing IR1 optimization to delete blocks in that
827 (defun delete-lambda (clambda)
828 (declare (type clambda clambda))
829 (let ((original-kind (functional-kind clambda))
830 (bind (lambda-bind clambda)))
831 (aver (not (member original-kind '(:deleted :optional :toplevel))))
832 (aver (not (functional-has-external-references-p clambda)))
833 (setf (functional-kind clambda) :deleted)
834 (setf (lambda-bind clambda) nil)
835 (dolist (let (lambda-lets clambda))
836 (setf (lambda-bind let) nil)
837 (setf (functional-kind let) :deleted))
839 ;; LET may be deleted if its BIND is unreachable. Autonomous
840 ;; function may be deleted if it has no reachable references.
841 (unless (member original-kind '(:let :mv-let :assignment))
842 (dolist (ref (lambda-refs clambda))
843 (mark-for-deletion (node-block ref))))
845 ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
846 ;; that we're using the old value of the KIND slot, not the
847 ;; current slot value, which has now been set to :DELETED.)
848 (if (member original-kind '(:let :mv-let :assignment))
849 (let ((home (lambda-home clambda)))
850 (setf (lambda-lets home) (delete clambda (lambda-lets home))))
851 ;; If the function isn't a LET, we unlink the function head
852 ;; and tail from the component head and tail to indicate that
853 ;; the code is unreachable. We also delete the function from
854 ;; COMPONENT-LAMBDAS (it won't be there before local call
855 ;; analysis, but no matter.) If the lambda was never
856 ;; referenced, we give a note.
857 (let* ((bind-block (node-block bind))
858 (component (block-component bind-block))
859 (return (lambda-return clambda))
860 (return-block (and return (node-block return))))
861 (unless (leaf-ever-used clambda)
862 (let ((*compiler-error-context* bind))
863 (compiler-notify 'code-deletion-note
864 :format-control "deleting unused function~:[.~;~:*~% ~S~]"
865 :format-arguments (list (leaf-debug-name clambda)))))
866 (unless (block-delete-p bind-block)
867 (unlink-blocks (component-head component) bind-block))
868 (when (and return-block (not (block-delete-p return-block)))
869 (mark-for-deletion return-block)
870 (unlink-blocks return-block (component-tail component)))
871 (setf (component-reanalyze component) t)
872 (let ((tails (lambda-tail-set clambda)))
873 (setf (tail-set-funs tails)
874 (delete clambda (tail-set-funs tails)))
875 (setf (lambda-tail-set clambda) nil))
876 (setf (component-lambdas component)
877 (delete clambda (component-lambdas component)))))
879 ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
880 ;; ENTRY-FUN so that people will know that it is not an entry
882 (when (eq original-kind :external)
883 (let ((fun (functional-entry-fun clambda)))
884 (setf (functional-entry-fun fun) nil)
885 (when (optional-dispatch-p fun)
886 (delete-optional-dispatch fun)))))
890 ;;; Deal with deleting the last reference to an OPTIONAL-DISPATCH. We
891 ;;; have to be a bit more careful than with lambdas, since DELETE-REF
892 ;;; is used both before and after local call analysis. Afterward, all
893 ;;; references to still-existing OPTIONAL-DISPATCHes have been moved
894 ;;; to the XEP, leaving it with no references at all. So we look at
895 ;;; the XEP to see whether an optional-dispatch is still really being
896 ;;; used. But before local call analysis, there are no XEPs, and all
897 ;;; references are direct.
899 ;;; When we do delete the OPTIONAL-DISPATCH, we grovel all of its
900 ;;; entry-points, making them be normal lambdas, and then deleting the
901 ;;; ones with no references. This deletes any e-p lambdas that were
902 ;;; either never referenced, or couldn't be deleted when the last
903 ;;; reference was deleted (due to their :OPTIONAL kind.)
905 ;;; Note that the last optional entry point may alias the main entry,
906 ;;; so when we process the main entry, its KIND may have been changed
907 ;;; to NIL or even converted to a LETlike value.
908 (defun delete-optional-dispatch (leaf)
909 (declare (type optional-dispatch leaf))
910 (let ((entry (functional-entry-fun leaf)))
911 (unless (and entry (leaf-refs entry))
912 (aver (or (not entry) (eq (functional-kind entry) :deleted)))
913 (setf (functional-kind leaf) :deleted)
916 (unless (eq (functional-kind fun) :deleted)
917 (aver (eq (functional-kind fun) :optional))
918 (setf (functional-kind fun) nil)
919 (let ((refs (leaf-refs fun)))
923 (or (maybe-let-convert fun)
924 (maybe-convert-to-assignment fun)))
926 (maybe-convert-to-assignment fun)))))))
928 (dolist (ep (optional-dispatch-entry-points leaf))
929 (when (promise-ready-p ep)
931 (when (optional-dispatch-more-entry leaf)
932 (frob (optional-dispatch-more-entry leaf)))
933 (let ((main (optional-dispatch-main-entry leaf)))
934 (when (eq (functional-kind main) :optional)
939 ;;; Do stuff to delete the semantic attachments of a REF node. When
940 ;;; this leaves zero or one reference, we do a type dispatch off of
941 ;;; the leaf to determine if a special action is appropriate.
942 (defun delete-ref (ref)
943 (declare (type ref ref))
944 (let* ((leaf (ref-leaf ref))
945 (refs (delete ref (leaf-refs leaf))))
946 (setf (leaf-refs leaf) refs)
951 (delete-lambda-var leaf))
953 (ecase (functional-kind leaf)
954 ((nil :let :mv-let :assignment :escape :cleanup)
955 (aver (null (functional-entry-fun leaf)))
956 (delete-lambda leaf))
958 (delete-lambda leaf))
959 ((:deleted :optional))))
961 (unless (eq (functional-kind leaf) :deleted)
962 (delete-optional-dispatch leaf)))))
965 (clambda (or (maybe-let-convert leaf)
966 (maybe-convert-to-assignment leaf)))
967 (lambda-var (reoptimize-lambda-var leaf))))
970 (clambda (maybe-convert-to-assignment leaf))))))
974 ;;; This function is called by people who delete nodes; it provides a
975 ;;; way to indicate that the value of a continuation is no longer
976 ;;; used. We null out the CONTINUATION-DEST, set FLUSH-P in the blocks
977 ;;; containing uses of CONT and set COMPONENT-REOPTIMIZE. If the PREV
978 ;;; of the use is deleted, then we blow off reoptimization.
980 ;;; If the continuation is :DELETED, then we don't do anything, since
981 ;;; all semantics have already been flushed. :DELETED-BLOCK-START
982 ;;; start continuations are treated just like :BLOCK-START; it is
983 ;;; possible that the continuation may be given a new dest (e.g. by
984 ;;; SUBSTITUTE-CONTINUATION), so we don't want to delete it.
985 (defun flush-dest (cont)
986 (declare (type continuation cont))
988 (unless (eq (continuation-kind cont) :deleted)
989 (aver (continuation-dest cont))
990 (setf (continuation-dest cont) nil)
991 (flush-continuation-externally-checkable-type cont)
993 (let ((prev (node-prev use)))
994 (unless (eq (continuation-kind prev) :deleted)
995 (let ((block (continuation-block prev)))
996 (setf (component-reoptimize (block-component block)) t)
997 (setf (block-attributep (block-flags block) flush-p type-asserted)
1002 (defun delete-dest (cont)
1003 (let ((dest (continuation-dest cont)))
1005 (let ((prev (node-prev dest)))
1007 (not (eq (continuation-kind prev) :deleted)))
1008 (let ((block (continuation-block prev)))
1009 (unless (block-delete-p block)
1010 (mark-for-deletion block))))))))
1012 ;;; Do a graph walk backward from BLOCK, marking all predecessor
1013 ;;; blocks with the DELETE-P flag.
1014 (defun mark-for-deletion (block)
1015 (declare (type cblock block))
1016 (let* ((component (block-component block))
1017 (head (component-head component)))
1018 (labels ((helper (block)
1019 (setf (block-delete-p block) t)
1020 (dolist (pred (block-pred block))
1021 (unless (or (block-delete-p pred)
1024 (unless (block-delete-p block)
1026 (setf (component-reanalyze component) t))))
1029 ;;; Delete CONT, eliminating both control and value semantics. We set
1030 ;;; FLUSH-P and COMPONENT-REOPTIMIZE similarly to in FLUSH-DEST. Here
1031 ;;; we must get the component from the use block, since the
1032 ;;; continuation may be a :DELETED-BLOCK-START.
1034 ;;; If CONT has DEST, then it must be the case that the DEST is
1035 ;;; unreachable, since we can't compute the value desired. In this
1036 ;;; case, we call MARK-FOR-DELETION to cause the DEST block and its
1037 ;;; predecessors to tell people to ignore them, and to cause them to
1038 ;;; be deleted eventually.
1039 (defun delete-continuation (cont)
1040 (declare (type continuation cont))
1041 (aver (not (eq (continuation-kind cont) :deleted)))
1044 (let ((prev (node-prev use)))
1045 (unless (eq (continuation-kind prev) :deleted)
1046 (let ((block (continuation-block prev)))
1047 (setf (block-attributep (block-flags block) flush-p type-asserted) t)
1048 (setf (component-reoptimize (block-component block)) t)))))
1052 (setf (continuation-kind cont) :deleted)
1053 (setf (continuation-dest cont) nil)
1054 (flush-continuation-externally-checkable-type cont)
1055 (setf (continuation-next cont) nil)
1056 (setf (continuation-%derived-type cont) *empty-type*)
1057 (setf (continuation-use cont) nil)
1058 (setf (continuation-block cont) nil)
1059 (setf (continuation-reoptimize cont) nil)
1060 (setf (continuation-info cont) nil)
1064 ;;; This function does what is necessary to eliminate the code in it
1065 ;;; from the IR1 representation. This involves unlinking it from its
1066 ;;; predecessors and successors and deleting various node-specific
1067 ;;; semantic information.
1069 ;;; We mark the START as has having no next and remove the last node
1070 ;;; from its CONT's uses. We also flush the DEST for all continuations
1071 ;;; whose values are received by nodes in the block.
1072 (defun delete-block (block &optional silent)
1073 (declare (type cblock block))
1074 (aver (block-component block)) ; else block is already deleted!
1076 (note-block-deletion block))
1077 (setf (block-delete-p block) t)
1079 (let ((last (block-last block)))
1081 (let ((cont (node-cont last)))
1082 (delete-continuation-use last)
1083 (acond ((eq (continuation-kind cont) :unused)
1084 (delete-continuation cont))
1085 ((and (null (find-uses cont))
1086 (continuation-dest cont))
1087 (mark-for-deletion (node-block it)))
1088 ((reoptimize-continuation cont))))))
1090 (dolist (b (block-pred block))
1091 (unlink-blocks b block)
1092 ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
1093 ;; broken when successors were deleted without setting the
1094 ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
1095 ;; doesn't happen again.
1096 (aver (not (and (null (block-succ b))
1097 (not (block-delete-p b))
1098 (not (eq b (component-head (block-component b))))))))
1099 (dolist (b (block-succ block))
1100 (unlink-blocks block b))
1102 (do-nodes-carefully (node cont block)
1104 (ref (delete-ref node))
1106 (flush-dest (if-test node)))
1107 ;; The next two cases serve to maintain the invariant that a LET
1108 ;; always has a well-formed COMBINATION, REF and BIND. We delete
1109 ;; the lambda whenever we delete any of these, but we must be
1110 ;; careful that this LET has not already been partially deleted.
1112 (when (and (eq (basic-combination-kind node) :local)
1113 ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
1114 (continuation-use (basic-combination-fun node)))
1115 (let ((fun (combination-lambda node)))
1116 ;; If our REF was the second-to-last ref, and has been
1117 ;; deleted, then FUN may be a LET for some other
1119 (when (and (functional-letlike-p fun)
1120 (eq (let-combination fun) node))
1121 (delete-lambda fun))))
1122 (flush-dest (basic-combination-fun node))
1123 (dolist (arg (basic-combination-args node))
1124 (when arg (flush-dest arg))))
1126 (let ((lambda (bind-lambda node)))
1127 (unless (eq (functional-kind lambda) :deleted)
1128 (delete-lambda lambda))))
1130 (let ((value (exit-value node))
1131 (entry (exit-entry node)))
1135 (setf (entry-exits entry)
1136 (delete node (entry-exits entry))))))
1138 (flush-dest (return-result node))
1139 (delete-return node))
1141 (flush-dest (set-value node))
1142 (let ((var (set-var node)))
1143 (setf (basic-var-sets var)
1144 (delete node (basic-var-sets var)))))
1146 (flush-dest (cast-value node))))
1148 (delete-continuation (node-prev node)))
1150 (remove-from-dfo block)
1153 ;;; Do stuff to indicate that the return node NODE is being deleted.
1154 (defun delete-return (node)
1155 (declare (type creturn node))
1156 (let* ((fun (return-lambda node))
1157 (tail-set (lambda-tail-set fun)))
1158 (aver (lambda-return fun))
1159 (setf (lambda-return fun) nil)
1160 (when (and tail-set (not (find-if #'lambda-return
1161 (tail-set-funs tail-set))))
1162 (setf (tail-set-type tail-set) *empty-type*)))
1165 ;;; If any of the VARS in FUN was never referenced and was not
1166 ;;; declared IGNORE, then complain.
1167 (defun note-unreferenced-vars (fun)
1168 (declare (type clambda fun))
1169 (dolist (var (lambda-vars fun))
1170 (unless (or (leaf-ever-used var)
1171 (lambda-var-ignorep var))
1172 (let ((*compiler-error-context* (lambda-bind fun)))
1173 (unless (policy *compiler-error-context* (= inhibit-warnings 3))
1174 ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
1175 ;; requires this to be no more than a STYLE-WARNING.
1176 (compiler-style-warn "The variable ~S is defined but never used."
1177 (leaf-debug-name var)))
1178 (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
1181 (defvar *deletion-ignored-objects* '(t nil))
1183 ;;; Return true if we can find OBJ in FORM, NIL otherwise. We bound
1184 ;;; our recursion so that we don't get lost in circular structures. We
1185 ;;; ignore the car of forms if they are a symbol (to prevent confusing
1186 ;;; function referencess with variables), and we also ignore anything
1188 (defun present-in-form (obj form depth)
1189 (declare (type (integer 0 20) depth))
1190 (cond ((= depth 20) nil)
1194 (let ((first (car form))
1196 (if (member first '(quote function))
1198 (or (and (not (symbolp first))
1199 (present-in-form obj first depth))
1200 (do ((l (cdr form) (cdr l))
1202 ((or (atom l) (> n 100))
1204 (declare (fixnum n))
1205 (when (present-in-form obj (car l) depth)
1208 ;;; This function is called on a block immediately before we delete
1209 ;;; it. We check to see whether any of the code about to die appeared
1210 ;;; in the original source, and emit a note if so.
1212 ;;; If the block was in a lambda is now deleted, then we ignore the
1213 ;;; whole block, since this case is picked off in DELETE-LAMBDA. We
1214 ;;; also ignore the deletion of CRETURN nodes, since it is somewhat
1215 ;;; reasonable for a function to not return, and there is a different
1216 ;;; note for that case anyway.
1218 ;;; If the actual source is an atom, then we use a bunch of heuristics
1219 ;;; to guess whether this reference really appeared in the original
1221 ;;; -- If a symbol, it must be interned and not a keyword.
1222 ;;; -- It must not be an easily introduced constant (T or NIL, a fixnum
1223 ;;; or a character.)
1224 ;;; -- The atom must be "present" in the original source form, and
1225 ;;; present in all intervening actual source forms.
1226 (defun note-block-deletion (block)
1227 (let ((home (block-home-lambda block)))
1228 (unless (eq (functional-kind home) :deleted)
1229 (do-nodes (node cont block)
1230 (let* ((path (node-source-path node))
1231 (first (first path)))
1232 (when (or (eq first 'original-source-start)
1234 (or (not (symbolp first))
1235 (let ((pkg (symbol-package first)))
1237 (not (eq pkg (symbol-package :end))))))
1238 (not (member first *deletion-ignored-objects*))
1239 (not (typep first '(or fixnum character)))
1241 (present-in-form first x 0))
1242 (source-path-forms path))
1243 (present-in-form first (find-original-source path)
1245 (unless (return-p node)
1246 (let ((*compiler-error-context* node))
1247 (compiler-notify 'code-deletion-note
1248 :format-control "deleting unreachable code"
1249 :format-arguments nil)))
1253 ;;; Delete a node from a block, deleting the block if there are no
1254 ;;; nodes left. We remove the node from the uses of its CONT, but we
1255 ;;; don't deal with cleaning up any type-specific semantic
1256 ;;; attachments. If the CONT is :UNUSED after deleting this use, then
1257 ;;; we delete CONT. (Note :UNUSED is not the same as no uses. A
1258 ;;; continuation will only become :UNUSED if it was :INSIDE-BLOCK
1261 ;;; If the node is the last node, there must be exactly one successor.
1262 ;;; We link all of our precedessors to the successor and unlink the
1263 ;;; block. In this case, we return T, otherwise NIL. If no nodes are
1264 ;;; left, and the block is a successor of itself, then we replace the
1265 ;;; only node with a degenerate exit node. This provides a way to
1266 ;;; represent the bodyless infinite loop, given the prohibition on
1267 ;;; empty blocks in IR1.
1268 (defun unlink-node (node)
1269 (declare (type node node))
1270 (let* ((cont (node-cont node))
1271 (next (continuation-next cont))
1272 (prev (node-prev node))
1273 (block (continuation-block prev))
1274 (prev-kind (continuation-kind prev))
1275 (last (block-last block)))
1277 (unless (eq (continuation-kind cont) :deleted)
1278 (delete-continuation-use node)
1279 (when (eq (continuation-kind cont) :unused)
1280 (aver (not (continuation-dest cont)))
1281 (delete-continuation cont)))
1283 (setf (block-type-asserted block) t)
1284 (setf (block-test-modified block) t)
1286 (cond ((or (eq prev-kind :inside-block)
1287 (and (eq prev-kind :block-start)
1288 (not (eq node last))))
1289 (cond ((eq node last)
1290 (setf (block-last block) (continuation-use prev))
1291 (setf (continuation-next prev) nil))
1293 (setf (continuation-next prev) next)
1294 (setf (node-prev next) prev)
1295 (when (and (if-p next) ; AOP wanted
1296 (eq prev (if-test next)))
1297 (reoptimize-continuation prev))))
1298 (setf (node-prev node) nil)
1301 (aver (eq prev-kind :block-start))
1302 (aver (eq node last))
1303 (let* ((succ (block-succ block))
1304 (next (first succ)))
1305 (aver (singleton-p succ))
1307 ((member block succ)
1308 (with-ir1-environment-from-node node
1309 (let ((exit (make-exit))
1310 (dummy (make-continuation)))
1311 (setf (continuation-next prev) nil)
1312 (link-node-to-previous-continuation exit prev)
1313 (add-continuation-use exit dummy)
1314 (setf (block-last block) exit)))
1315 (setf (node-prev node) nil)
1318 (aver (eq (block-start-cleanup block)
1319 (block-end-cleanup block)))
1320 (unlink-blocks block next)
1321 (dolist (pred (block-pred block))
1322 (change-block-successor pred block next))
1323 (remove-from-dfo block)
1324 (cond ((continuation-dest prev)
1325 (setf (continuation-next prev) nil)
1326 (setf (continuation-kind prev) :deleted-block-start))
1328 (delete-continuation prev)))
1329 (setf (node-prev node) nil)
1332 ;;; Return true if NODE has been deleted, false if it is still a valid
1334 (defun node-deleted (node)
1335 (declare (type node node))
1336 (let ((prev (node-prev node)))
1338 (not (eq (continuation-kind prev) :deleted))
1339 (let ((block (continuation-block prev)))
1340 (and (block-component block)
1341 (not (block-delete-p block))))))))
1343 ;;; Delete all the blocks and functions in COMPONENT. We scan first
1344 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
1345 ;;; triggered by deletion.
1346 (defun delete-component (component)
1347 (declare (type component component))
1348 (aver (null (component-new-functionals component)))
1349 (setf (component-kind component) :deleted)
1350 (do-blocks (block component)
1351 (setf (block-delete-p block) t))
1352 (dolist (fun (component-lambdas component))
1353 (setf (functional-kind fun) nil)
1354 (setf (functional-entry-fun fun) nil)
1355 (setf (leaf-refs fun) nil)
1356 (delete-functional fun))
1357 (do-blocks (block component)
1358 (delete-block block))
1361 ;;; Convert code of the form
1362 ;;; (FOO ... (FUN ...) ...)
1364 ;;; (FOO ... ... ...).
1365 ;;; In other words, replace the function combination FUN by its
1366 ;;; arguments. If there are any problems with doing this, use GIVE-UP
1367 ;;; to blow out of whatever transform called this. Note, as the number
1368 ;;; of arguments changes, the transform must be prepared to return a
1369 ;;; lambda with a new lambda-list with the correct number of
1371 (defun extract-fun-args (cont fun num-args)
1373 "If CONT is a call to FUN with NUM-ARGS args, change those arguments
1374 to feed directly to the continuation-dest of CONT, which must be
1376 (declare (type continuation cont)
1378 (type index num-args))
1379 (let ((outside (continuation-dest cont))
1380 (inside (continuation-use cont)))
1381 (aver (combination-p outside))
1382 (unless (combination-p inside)
1383 (give-up-ir1-transform))
1384 (let ((inside-fun (combination-fun inside)))
1385 (unless (eq (continuation-fun-name inside-fun) fun)
1386 (give-up-ir1-transform))
1387 (let ((inside-args (combination-args inside)))
1388 (unless (= (length inside-args) num-args)
1389 (give-up-ir1-transform))
1390 (let* ((outside-args (combination-args outside))
1391 (arg-position (position cont outside-args))
1392 (before-args (subseq outside-args 0 arg-position))
1393 (after-args (subseq outside-args (1+ arg-position))))
1394 (dolist (arg inside-args)
1395 (setf (continuation-dest arg) outside)
1396 (flush-continuation-externally-checkable-type arg))
1397 (setf (combination-args inside) nil)
1398 (setf (combination-args outside)
1399 (append before-args inside-args after-args))
1400 (change-ref-leaf (continuation-use inside-fun)
1401 (find-free-fun 'list "???"))
1402 (setf (combination-kind inside)
1403 (info :function :info 'list))
1404 (setf (node-derived-type inside) *wild-type*)
1408 (defun flush-combination (combination)
1409 (declare (type combination combination))
1410 (flush-dest (combination-fun combination))
1411 (dolist (arg (combination-args combination))
1413 (unlink-node combination)
1419 ;;; Change the LEAF that a REF refers to.
1420 (defun change-ref-leaf (ref leaf)
1421 (declare (type ref ref) (type leaf leaf))
1422 (unless (eq (ref-leaf ref) leaf)
1423 (push ref (leaf-refs leaf))
1425 (setf (ref-leaf ref) leaf)
1426 (setf (leaf-ever-used leaf) t)
1427 (let* ((ltype (leaf-type leaf))
1428 (vltype (make-single-value-type ltype)))
1429 (if (let* ((cont (node-cont ref))
1430 (dest (continuation-dest cont)))
1431 (and (basic-combination-p dest)
1432 (eq cont (basic-combination-fun dest))
1433 (csubtypep ltype (specifier-type 'function))))
1434 (setf (node-derived-type ref) vltype)
1435 (derive-node-type ref vltype)))
1436 (reoptimize-continuation (node-cont ref)))
1439 ;;; Change all REFS for OLD-LEAF to NEW-LEAF.
1440 (defun substitute-leaf (new-leaf old-leaf)
1441 (declare (type leaf new-leaf old-leaf))
1442 (dolist (ref (leaf-refs old-leaf))
1443 (change-ref-leaf ref new-leaf))
1446 ;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
1447 ;;; whether to substitute
1448 (defun substitute-leaf-if (test new-leaf old-leaf)
1449 (declare (type leaf new-leaf old-leaf) (type function test))
1450 (dolist (ref (leaf-refs old-leaf))
1451 (when (funcall test ref)
1452 (change-ref-leaf ref new-leaf)))
1455 ;;; Return a LEAF which represents the specified constant object. If
1456 ;;; the object is not in *CONSTANTS*, then we create a new constant
1457 ;;; LEAF and enter it.
1458 (defun find-constant (object)
1460 ;; FIXME: What is the significance of this test? ("things
1461 ;; that are worth uniquifying"?)
1462 '(or symbol number character instance))
1463 (or (gethash object *constants*)
1464 (setf (gethash object *constants*)
1465 (make-constant :value object
1466 :%source-name '.anonymous.
1467 :type (ctype-of object)
1468 :where-from :defined)))
1469 (make-constant :value object
1470 :%source-name '.anonymous.
1471 :type (ctype-of object)
1472 :where-from :defined)))
1474 ;;; Return true if VAR would have to be closed over if environment
1475 ;;; analysis ran now (i.e. if there are any uses that have a different
1476 ;;; home lambda than VAR's home.)
1477 (defun closure-var-p (var)
1478 (declare (type lambda-var var))
1479 (let ((home (lambda-var-home var)))
1480 (cond ((eq (functional-kind home) :deleted)
1482 (t (let ((home (lambda-home home)))
1484 (find home l :key #'node-home-lambda
1486 (or (frob (leaf-refs var))
1487 (frob (basic-var-sets var)))))))))
1489 ;;; If there is a non-local exit noted in ENTRY's environment that
1490 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
1491 (defun find-nlx-info (entry cont)
1492 (declare (type entry entry) (type continuation cont))
1493 (let ((entry-cleanup (entry-cleanup entry)))
1494 (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
1495 (when (and (eq (nlx-info-continuation nlx) cont)
1496 (eq (nlx-info-cleanup nlx) entry-cleanup))
1499 ;;;; functional hackery
1501 (declaim (ftype (sfunction (functional) clambda) main-entry))
1502 (defun main-entry (functional)
1503 (etypecase functional
1504 (clambda functional)
1506 (optional-dispatch-main-entry functional))))
1508 ;;; RETURN true if FUNCTIONAL is a thing that can be treated like
1509 ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
1510 ;;; optional with null default and no SUPPLIED-P. There must be a
1511 ;;; &REST arg with no references.
1512 (declaim (ftype (sfunction (functional) boolean) looks-like-an-mv-bind))
1513 (defun looks-like-an-mv-bind (functional)
1514 (and (optional-dispatch-p functional)
1515 (do ((arg (optional-dispatch-arglist functional) (cdr arg)))
1517 (let ((info (lambda-var-arg-info (car arg))))
1518 (unless info (return nil))
1519 (case (arg-info-kind info)
1521 (when (or (arg-info-supplied-p info) (arg-info-default info))
1524 (return (and (null (cdr arg)) (null (leaf-refs (car arg))))))
1528 ;;; Return true if function is an external entry point. This is true
1529 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
1530 ;;; (:TOPLEVEL kind.)
1532 (declare (type functional fun))
1533 (not (null (member (functional-kind fun) '(:external :toplevel)))))
1535 ;;; If CONT's only use is a non-notinline global function reference,
1536 ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
1537 ;;; is true, then we don't care if the leaf is NOTINLINE.
1538 (defun continuation-fun-name (cont &optional notinline-ok)
1539 (declare (type continuation cont))
1540 (let ((use (continuation-use cont)))
1542 (let ((leaf (ref-leaf use)))
1543 (if (and (global-var-p leaf)
1544 (eq (global-var-kind leaf) :global-function)
1545 (or (not (defined-fun-p leaf))
1546 (not (eq (defined-fun-inlinep leaf) :notinline))
1548 (leaf-source-name leaf)
1552 ;;; Return the source name of a combination. (This is an idiom
1553 ;;; which was used in CMU CL. I gather it always works. -- WHN)
1554 (defun combination-fun-source-name (combination)
1555 (let ((ref (continuation-use (combination-fun combination))))
1556 (leaf-source-name (ref-leaf ref))))
1558 ;;; Return the COMBINATION node that is the call to the LET FUN.
1559 (defun let-combination (fun)
1560 (declare (type clambda fun))
1561 (aver (functional-letlike-p fun))
1562 (continuation-dest (node-cont (first (leaf-refs fun)))))
1564 ;;; Return the initial value continuation for a LET variable, or NIL
1565 ;;; if there is none.
1566 (defun let-var-initial-value (var)
1567 (declare (type lambda-var var))
1568 (let ((fun (lambda-var-home var)))
1569 (elt (combination-args (let-combination fun))
1570 (position-or-lose var (lambda-vars fun)))))
1572 ;;; Return the LAMBDA that is called by the local CALL.
1573 (defun combination-lambda (call)
1574 (declare (type basic-combination call))
1575 (aver (eq (basic-combination-kind call) :local))
1576 (ref-leaf (continuation-use (basic-combination-fun call))))
1578 (defvar *inline-expansion-limit* 200
1580 "an upper limit on the number of inline function calls that will be expanded
1581 in any given code object (single function or block compilation)")
1583 ;;; Check whether NODE's component has exceeded its inline expansion
1584 ;;; limit, and warn if so, returning NIL.
1585 (defun inline-expansion-ok (node)
1586 (let ((expanded (incf (component-inline-expansions
1588 (node-block node))))))
1589 (cond ((> expanded *inline-expansion-limit*) nil)
1590 ((= expanded *inline-expansion-limit*)
1591 ;; FIXME: If the objective is to stop the recursive
1592 ;; expansion of inline functions, wouldn't it be more
1593 ;; correct to look back through surrounding expansions
1594 ;; (which are, I think, stored in the *CURRENT-PATH*, and
1595 ;; possibly stored elsewhere too) and suppress expansion
1596 ;; and print this warning when the function being proposed
1597 ;; for inline expansion is found there? (I don't like the
1598 ;; arbitrary numerical limit in principle, and I think
1599 ;; it'll be a nuisance in practice if we ever want the
1600 ;; compiler to be able to use WITH-COMPILATION-UNIT on
1601 ;; arbitrarily huge blocks of code. -- WHN)
1602 (let ((*compiler-error-context* node))
1603 (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
1604 probably trying to~% ~
1605 inline a recursive function."
1606 *inline-expansion-limit*))
1610 ;;; Make sure that FUNCTIONAL is not let-converted or deleted.
1611 (defun assure-functional-live-p (functional)
1612 (declare (type functional functional))
1614 ;; looks LET-converted
1615 (functional-somewhat-letlike-p functional)
1616 ;; It's possible for a LET-converted function to end up
1617 ;; deleted later. In that case, for the purposes of this
1618 ;; analysis, it is LET-converted: LET-converted functionals
1619 ;; are too badly trashed to expand them inline, and deleted
1620 ;; LET-converted functionals are even worse.
1621 (eql (functional-kind functional) :deleted)))
1622 (throw 'locall-already-let-converted functional)))
1626 ;;; Apply a function to some arguments, returning a list of the values
1627 ;;; resulting of the evaluation. If an error is signalled during the
1628 ;;; application, then we produce a warning message using WARN-FUN and
1629 ;;; return NIL as our second value to indicate this. NODE is used as
1630 ;;; the error context for any error message, and CONTEXT is a string
1631 ;;; that is spliced into the warning.
1632 (declaim (ftype (sfunction ((or symbol function) list node function string)
1633 (values list boolean))
1635 (defun careful-call (function args node warn-fun context)
1637 (multiple-value-list
1638 (handler-case (apply function args)
1640 (let ((*compiler-error-context* node))
1641 (funcall warn-fun "Lisp error during ~A:~%~A" context condition)
1642 (return-from careful-call (values nil nil))))))
1645 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
1648 ((deffrob (basic careful compiler transform)
1650 (defun ,careful (specifier)
1651 (handler-case (,basic specifier)
1652 (sb!kernel::arg-count-error (condition)
1653 (values nil (list (format nil "~A" condition))))
1654 (simple-error (condition)
1655 (values nil (list* (simple-condition-format-control condition)
1656 (simple-condition-format-arguments condition))))))
1657 (defun ,compiler (specifier)
1658 (multiple-value-bind (type error-args) (,careful specifier)
1660 (apply #'compiler-error error-args))))
1661 (defun ,transform (specifier)
1662 (multiple-value-bind (type error-args) (,careful specifier)
1664 (apply #'give-up-ir1-transform
1666 (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type)
1667 (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type))
1670 ;;;; utilities used at run-time for parsing &KEY args in IR1
1672 ;;; This function is used by the result of PARSE-DEFTRANSFORM to find
1673 ;;; the continuation for the value of the &KEY argument KEY in the
1674 ;;; list of continuations ARGS. It returns the continuation if the
1675 ;;; keyword is present, or NIL otherwise. The legality and
1676 ;;; constantness of the keywords should already have been checked.
1677 (declaim (ftype (sfunction (list keyword) (or continuation null))
1678 find-keyword-continuation))
1679 (defun find-keyword-continuation (args key)
1680 (do ((arg args (cddr arg)))
1682 (when (eq (continuation-value (first arg)) key)
1683 (return (second arg)))))
1685 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
1686 ;;; verify that alternating continuations in ARGS are constant and
1687 ;;; that there is an even number of args.
1688 (declaim (ftype (sfunction (list) boolean) check-key-args-constant))
1689 (defun check-key-args-constant (args)
1690 (do ((arg args (cddr arg)))
1692 (unless (and (rest arg)
1693 (constant-continuation-p (first arg)))
1696 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
1697 ;;; verify that the list of continuations ARGS is a well-formed &KEY
1698 ;;; arglist and that only keywords present in the list KEYS are
1700 (declaim (ftype (sfunction (list list) boolean) check-transform-keys))
1701 (defun check-transform-keys (args keys)
1702 (and (check-key-args-constant args)
1703 (do ((arg args (cddr arg)))
1705 (unless (member (continuation-value (first arg)) keys)
1710 ;;; Called by the expansion of the EVENT macro.
1711 (declaim (ftype (sfunction (event-info (or node null)) *) %event))
1712 (defun %event (info node)
1713 (incf (event-info-count info))
1714 (when (and (>= (event-info-level info) *event-note-threshold*)
1715 (policy (or node *lexenv*)
1716 (= inhibit-warnings 0)))
1717 (let ((*compiler-error-context* node))
1718 (compiler-notify (event-info-description info))))
1720 (let ((action (event-info-action info)))
1721 (when action (funcall action node))))
1724 (defun make-cast (value type policy)
1725 (declare (type continuation value)
1727 (type policy policy))
1728 (%make-cast :asserted-type type
1729 :type-to-check (maybe-weaken-check type policy)
1731 :derived-type (coerce-to-values type)))
1733 (defun cast-type-check (cast)
1734 (declare (type cast cast))
1735 (when (cast-reoptimize cast)
1736 (ir1-optimize-cast cast t))
1737 (cast-%type-check cast))
1739 (defun note-single-valuified-continuation (cont)
1740 (declare (type continuation cont))
1741 (let ((use (continuation-use cont)))
1743 (let ((leaf (ref-leaf use)))
1744 (when (and (lambda-var-p leaf)
1745 (null (rest (leaf-refs leaf))))
1746 (reoptimize-lambda-var leaf))))
1747 ((or (null use) (combination-p use))
1748 (dolist (node (find-uses cont))
1749 (setf (node-reoptimize node) t)
1750 (setf (block-reoptimize (node-block node)) t)
1751 (setf (component-reoptimize (node-component node)) t))))))