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 (function (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 (function (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 (function (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 (defun node-block (node)
370 (declare (type node node))
371 (the cblock (continuation-block (node-prev node))))
372 (defun node-component (node)
373 (declare (type node node))
374 (block-component (node-block node)))
375 (defun node-physenv (node)
376 (declare (type node node))
377 (the physenv (lambda-physenv (node-home-lambda node))))
379 (defun lambda-block (clambda)
380 (declare (type clambda clambda))
381 (node-block (lambda-bind clambda)))
382 (defun lambda-component (clambda)
383 (block-component (lambda-block clambda)))
385 ;;; Return the enclosing cleanup for environment of the first or last
387 (defun block-start-cleanup (block)
388 (declare (type cblock block))
389 (node-enclosing-cleanup (continuation-next (block-start block))))
390 (defun block-end-cleanup (block)
391 (declare (type cblock block))
392 (node-enclosing-cleanup (block-last block)))
394 ;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL
395 ;;; if there is none.
397 ;;; There can legitimately be no home lambda in dead code early in the
398 ;;; IR1 conversion process, e.g. when IR1-converting the SETQ form in
399 ;;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
400 ;;; where the block is just a placeholder during parsing and doesn't
401 ;;; actually correspond to code which will be written anywhere.
402 (declaim (ftype (sfunction (cblock) (or clambda null)) block-home-lambda-or-null))
403 (defun block-home-lambda-or-null (block)
404 (if (node-p (block-last block))
405 ;; This is the old CMU CL way of doing it.
406 (node-home-lambda (block-last block))
407 ;; Now that SBCL uses this operation more aggressively than CMU
408 ;; CL did, the old CMU CL way of doing it can fail in two ways.
409 ;; 1. It can fail in a few cases even when a meaningful home
410 ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of
412 ;; 2. It can fail when converting a form which is born orphaned
413 ;; so that it never had a meaningful home lambda, e.g. a form
414 ;; which follows a RETURN-FROM or GO form.
415 (let ((pred-list (block-pred block)))
416 ;; To deal with case 1, we reason that
417 ;; previous-in-target-execution-order blocks should be in the
418 ;; same lambda, and that they seem in practice to be
419 ;; previous-in-compilation-order blocks too, so we look back
420 ;; to find one which is sufficiently initialized to tell us
421 ;; what the home lambda is.
423 ;; We could get fancy about this, flooding through the
424 ;; graph of all the previous blocks, but in practice it
425 ;; seems to work just to grab the first previous block and
427 (node-home-lambda (block-last (first pred-list)))
428 ;; In case 2, we end up with an empty PRED-LIST and
429 ;; have to punt: There's no home lambda.
432 ;;; Return the non-LET LAMBDA that holds BLOCK's code.
433 (defun block-home-lambda (block)
435 (block-home-lambda-or-null block)))
437 ;;; Return the IR1 physical environment for BLOCK.
438 (defun block-physenv (block)
439 (declare (type cblock block))
440 (lambda-physenv (block-home-lambda block)))
442 ;;; Return the Top Level Form number of PATH, i.e. the ordinal number
443 ;;; of its original source's top level form in its compilation unit.
444 (defun source-path-tlf-number (path)
445 (declare (list path))
448 ;;; Return the (reversed) list for the PATH in the original source
449 ;;; (with the Top Level Form number last).
450 (defun source-path-original-source (path)
451 (declare (list path) (inline member))
452 (cddr (member 'original-source-start path :test #'eq)))
454 ;;; Return the Form Number of PATH's original source inside the Top
455 ;;; Level Form that contains it. This is determined by the order that
456 ;;; we walk the subforms of the top level source form.
457 (defun source-path-form-number (path)
458 (declare (list path) (inline member))
459 (cadr (member 'original-source-start path :test #'eq)))
461 ;;; Return a list of all the enclosing forms not in the original
462 ;;; source that converted to get to this form, with the immediate
463 ;;; source for node at the start of the list.
464 (defun source-path-forms (path)
465 (subseq path 0 (position 'original-source-start path)))
467 ;;; Return the innermost source form for NODE.
468 (defun node-source-form (node)
469 (declare (type node node))
470 (let* ((path (node-source-path node))
471 (forms (source-path-forms path)))
474 (values (find-original-source path)))))
476 ;;; Return NODE-SOURCE-FORM, T if continuation has a single use,
477 ;;; otherwise NIL, NIL.
478 (defun continuation-source (cont)
479 (let ((use (continuation-use cont)))
481 (values (node-source-form use) t)
484 ;;; Return the LAMBDA that is CONT's home, or NIL if there is none.
485 (declaim (ftype (sfunction (continuation) (or clambda null))
486 continuation-home-lambda-or-null))
487 (defun continuation-home-lambda-or-null (cont)
488 ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
489 ;; implementation might not be quite right, or might be uglier than
490 ;; necessary. It appears that the original Python never found a need
491 ;; to do this operation. The obvious things based on
492 ;; NODE-HOME-LAMBDA of CONTINUATION-USE usually work; then if that
493 ;; fails, BLOCK-HOME-LAMBDA of CONTINUATION-BLOCK works, given that
494 ;; we generalize it enough to grovel harder when the simple CMU CL
495 ;; approach fails, and furthermore realize that in some exceptional
496 ;; cases it might return NIL. -- WHN 2001-12-04
497 (cond ((continuation-use cont)
498 (node-home-lambda (continuation-use cont)))
499 ((continuation-block cont)
500 (block-home-lambda-or-null (continuation-block cont)))
502 (bug "confused about home lambda for ~S"))))
504 ;;; Return the LAMBDA that is CONT's home.
505 (defun continuation-home-lambda (cont)
507 (continuation-home-lambda-or-null cont)))
509 #!-sb-fluid (declaim (inline continuation-single-value-p))
510 (defun continuation-single-value-p (cont)
511 (let ((dest (continuation-dest cont)))
516 (eq (basic-combination-fun dest) cont))
520 (declare (notinline continuation-single-value-p))
521 (and (not (values-type-p (cast-asserted-type dest)))
522 (continuation-single-value-p (node-cont dest)))))
526 (defun principal-continuation-end (cont)
527 (loop for prev = cont then (node-cont dest)
528 for dest = (continuation-dest prev)
530 finally (return (values dest prev))))
532 ;;; Return a new LEXENV just like DEFAULT except for the specified
533 ;;; slot values. Values for the alist slots are NCONCed to the
534 ;;; beginning of the current value, rather than replacing it entirely.
535 (defun make-lexenv (&key (default *lexenv*)
536 funs vars blocks tags
537 type-restrictions weakend-type-restrictions
538 (lambda (lexenv-lambda default))
539 (cleanup (lexenv-cleanup default))
540 (policy (lexenv-policy default)))
541 (macrolet ((frob (var slot)
542 `(let ((old (,slot default)))
546 (internal-make-lexenv
547 (frob funs lexenv-funs)
548 (frob vars lexenv-vars)
549 (frob blocks lexenv-blocks)
550 (frob tags lexenv-tags)
551 (frob type-restrictions lexenv-type-restrictions)
552 (frob weakend-type-restrictions lexenv-weakend-type-restrictions)
553 lambda cleanup policy)))
555 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
557 (defun make-restricted-lexenv (lexenv)
558 (flet ((fun-good-p (fun)
559 (destructuring-bind (name . thing) fun
560 (declare (ignore name))
564 (cons (aver (eq (car thing) 'macro))
567 (destructuring-bind (name . thing) var
568 (declare (ignore name))
571 (cons (aver (eq (car thing) 'macro))
573 (heap-alien-info nil)))))
574 (internal-make-lexenv
575 (remove-if-not #'fun-good-p (lexenv-funs lexenv))
576 (remove-if-not #'var-good-p (lexenv-vars lexenv))
579 (lexenv-type-restrictions lexenv) ; XXX
580 (lexenv-weakend-type-restrictions lexenv)
583 (lexenv-policy lexenv))))
585 ;;;; flow/DFO/component hackery
587 ;;; Join BLOCK1 and BLOCK2.
588 (defun link-blocks (block1 block2)
589 (declare (type cblock block1 block2))
590 (setf (block-succ block1)
591 (if (block-succ block1)
592 (%link-blocks block1 block2)
594 (push block1 (block-pred block2))
596 (defun %link-blocks (block1 block2)
597 (declare (type cblock block1 block2) (inline member))
598 (let ((succ1 (block-succ block1)))
599 (aver (not (member block2 succ1 :test #'eq)))
600 (cons block2 succ1)))
602 ;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If
603 ;;; this leaves a successor with a single predecessor that ends in an
604 ;;; IF, then set BLOCK-TEST-MODIFIED so that any test constraint will
605 ;;; now be able to be propagated to the successor.
606 (defun unlink-blocks (block1 block2)
607 (declare (type cblock block1 block2))
608 (let ((succ1 (block-succ block1)))
609 (if (eq block2 (car succ1))
610 (setf (block-succ block1) (cdr succ1))
611 (do ((succ (cdr succ1) (cdr succ))
613 ((eq (car succ) block2)
614 (setf (cdr prev) (cdr succ)))
617 (let ((new-pred (delq block1 (block-pred block2))))
618 (setf (block-pred block2) new-pred)
619 (when (singleton-p new-pred)
620 (let ((pred-block (first new-pred)))
621 (when (if-p (block-last pred-block))
622 (setf (block-test-modified pred-block) t)))))
625 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK
626 ;;; and NEW. If BLOCK ends in an IF, then we have to fix up the
627 ;;; consequent/alternative blocks to point to NEW. We also set
628 ;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to
629 ;;; the new successor.
630 (defun change-block-successor (block old new)
631 (declare (type cblock new old block) (inline member))
632 (unlink-blocks block old)
633 (let ((last (block-last block))
634 (comp (block-component block)))
635 (setf (component-reanalyze comp) t)
638 (setf (block-test-modified block) t)
639 (let* ((succ-left (block-succ block))
640 (new (if (and (eq new (component-tail comp))
644 (unless (member new succ-left :test #'eq)
645 (link-blocks block new))
646 (macrolet ((frob (slot)
647 `(when (eq (,slot last) old)
648 (setf (,slot last) new))))
650 (frob if-alternative)
651 (when (eq (if-consequent last)
652 (if-alternative last))
653 (setf (component-reoptimize (block-component block)) t)))))
655 (unless (member new (block-succ block) :test #'eq)
656 (link-blocks block new)))))
660 ;;; Unlink a block from the next/prev chain. We also null out the
662 (declaim (ftype (function (cblock) (values)) remove-from-dfo))
663 (defun remove-from-dfo (block)
664 (let ((next (block-next block))
665 (prev (block-prev block)))
666 (setf (block-component block) nil)
667 (setf (block-next prev) next)
668 (setf (block-prev next) prev))
671 ;;; Add BLOCK to the next/prev chain following AFTER. We also set the
672 ;;; COMPONENT to be the same as for AFTER.
673 (defun add-to-dfo (block after)
674 (declare (type cblock block after))
675 (let ((next (block-next after))
676 (comp (block-component after)))
677 (aver (not (eq (component-kind comp) :deleted)))
678 (setf (block-component block) comp)
679 (setf (block-next after) block)
680 (setf (block-prev block) after)
681 (setf (block-next block) next)
682 (setf (block-prev next) block))
685 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
686 ;;; the head and tail which are set to T.
687 (declaim (ftype (function (component) (values)) clear-flags))
688 (defun clear-flags (component)
689 (let ((head (component-head component))
690 (tail (component-tail component)))
691 (setf (block-flag head) t)
692 (setf (block-flag tail) t)
693 (do-blocks (block component)
694 (setf (block-flag block) nil)))
697 ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially
698 ;;; true in the head and tail blocks.
699 (declaim (ftype (function nil component) make-empty-component))
700 (defun make-empty-component ()
701 (let* ((head (make-block-key :start nil :component nil))
702 (tail (make-block-key :start nil :component nil))
703 (res (make-component head tail)))
704 (setf (block-flag head) t)
705 (setf (block-flag tail) t)
706 (setf (block-component head) res)
707 (setf (block-component tail) res)
708 (setf (block-next head) tail)
709 (setf (block-prev tail) head)
712 ;;; Make NODE the LAST node in its block, splitting the block if necessary.
713 ;;; The new block is added to the DFO immediately following NODE's block.
714 (defun node-ends-block (node)
715 (declare (type node node))
716 (let* ((block (node-block node))
717 (start (node-cont node))
718 (last (block-last block))
719 (last-cont (node-cont last)))
720 (unless (eq last node)
721 (aver (and (eq (continuation-kind start) :inside-block)
722 (not (block-delete-p block))))
723 (let* ((succ (block-succ block))
725 (make-block-key :start start
726 :component (block-component block)
727 :start-uses (list (continuation-use start))
728 :succ succ :last last)))
729 (setf (continuation-kind start) :block-start)
732 (cons new-block (remove block (block-pred b)))))
733 (setf (block-succ block) ())
734 (setf (block-last block) node)
735 (link-blocks block new-block)
736 (add-to-dfo new-block block)
737 (setf (component-reanalyze (block-component block)) t)
739 (do ((cont start (node-cont (continuation-next cont))))
741 (when (eq (continuation-kind last-cont) :inside-block)
742 (setf (continuation-block last-cont) new-block)))
743 (setf (continuation-block cont) new-block))
745 (setf (block-type-asserted block) t)
746 (setf (block-test-modified block) t))))
752 ;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
753 (defun delete-lambda-var (leaf)
754 (declare (type lambda-var leaf))
756 ;; Iterate over all local calls flushing the corresponding argument,
757 ;; allowing the computation of the argument to be deleted. We also
758 ;; mark the LET for reoptimization, since it may be that we have
759 ;; deleted its last variable.
760 (let* ((fun (lambda-var-home leaf))
761 (n (position leaf (lambda-vars fun))))
762 (dolist (ref (leaf-refs fun))
763 (let* ((cont (node-cont ref))
764 (dest (continuation-dest cont)))
765 (when (and (combination-p dest)
766 (eq (basic-combination-fun dest) cont)
767 (eq (basic-combination-kind dest) :local))
768 (let* ((args (basic-combination-args dest))
770 (reoptimize-continuation arg)
772 (setf (elt args n) nil))))))
774 ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
775 ;; too much difficulty, since we can efficiently implement
776 ;; write-only variables. We iterate over the SETs, marking their
777 ;; blocks for dead code flushing, since we can delete SETs whose
779 (dolist (set (lambda-var-sets leaf))
780 (setf (block-flush-p (node-block set)) t))
784 ;;; Note that something interesting has happened to VAR.
785 (defun reoptimize-lambda-var (var)
786 (declare (type lambda-var var))
787 (let ((fun (lambda-var-home var)))
788 ;; We only deal with LET variables, marking the corresponding
789 ;; initial value arg as needing to be reoptimized.
790 (when (and (eq (functional-kind fun) :let)
792 (do ((args (basic-combination-args
795 (first (leaf-refs fun)))))
797 (vars (lambda-vars fun) (cdr vars)))
799 (reoptimize-continuation (car args))))))
802 ;;; Delete a function that has no references. This need only be called
803 ;;; on functions that never had any references, since otherwise
804 ;;; DELETE-REF will handle the deletion.
805 (defun delete-functional (fun)
806 (aver (and (null (leaf-refs fun))
807 (not (functional-entry-fun fun))))
809 (optional-dispatch (delete-optional-dispatch fun))
810 (clambda (delete-lambda fun)))
813 ;;; Deal with deleting the last reference to a CLAMBDA. Since there is
814 ;;; only one way into a CLAMBDA, deleting the last reference to a
815 ;;; CLAMBDA ensures that there is no way to reach any of the code in
816 ;;; it. So we just set the FUNCTIONAL-KIND for FUN and its LETs to
817 ;;; :DELETED, causing IR1 optimization to delete blocks in that
819 (defun delete-lambda (clambda)
820 (declare (type clambda clambda))
821 (let ((original-kind (functional-kind clambda))
822 (bind (lambda-bind clambda)))
823 (aver (not (member original-kind '(:deleted :optional :toplevel))))
824 (aver (not (functional-has-external-references-p clambda)))
825 (setf (functional-kind clambda) :deleted)
826 (setf (lambda-bind clambda) nil)
827 (dolist (let (lambda-lets clambda))
828 (setf (lambda-bind let) nil)
829 (setf (functional-kind let) :deleted))
831 ;; LET may be deleted if its BIND is unreachable. Autonomous
832 ;; function may be deleted if it has no reachable references.
833 (unless (member original-kind '(:let :mv-let :assignment))
834 (dolist (ref (lambda-refs clambda))
835 (mark-for-deletion (node-block ref))))
837 ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
838 ;; that we're using the old value of the KIND slot, not the
839 ;; current slot value, which has now been set to :DELETED.)
840 (if (member original-kind '(:let :mv-let :assignment))
841 (let ((home (lambda-home clambda)))
842 (setf (lambda-lets home) (delete clambda (lambda-lets home))))
843 ;; If the function isn't a LET, we unlink the function head
844 ;; and tail from the component head and tail to indicate that
845 ;; the code is unreachable. We also delete the function from
846 ;; COMPONENT-LAMBDAS (it won't be there before local call
847 ;; analysis, but no matter.) If the lambda was never
848 ;; referenced, we give a note.
849 (let* ((bind-block (node-block bind))
850 (component (block-component bind-block))
851 (return (lambda-return clambda))
852 (return-block (and return (node-block return))))
853 (unless (leaf-ever-used clambda)
854 (let ((*compiler-error-context* bind))
855 (compiler-note "deleting unused function~:[.~;~:*~% ~S~]"
856 (leaf-debug-name clambda))))
857 (unless (block-delete-p bind-block)
858 (unlink-blocks (component-head component) bind-block))
859 (when (and return-block (not (block-delete-p return-block)))
860 (mark-for-deletion return-block)
861 (unlink-blocks return-block (component-tail component)))
862 (setf (component-reanalyze component) t)
863 (let ((tails (lambda-tail-set clambda)))
864 (setf (tail-set-funs tails)
865 (delete clambda (tail-set-funs tails)))
866 (setf (lambda-tail-set clambda) nil))
867 (setf (component-lambdas component)
868 (delete clambda (component-lambdas component)))))
870 ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
871 ;; ENTRY-FUN so that people will know that it is not an entry
873 (when (eq original-kind :external)
874 (let ((fun (functional-entry-fun clambda)))
875 (setf (functional-entry-fun fun) nil)
876 (when (optional-dispatch-p fun)
877 (delete-optional-dispatch fun)))))
881 ;;; Deal with deleting the last reference to an OPTIONAL-DISPATCH. We
882 ;;; have to be a bit more careful than with lambdas, since DELETE-REF
883 ;;; is used both before and after local call analysis. Afterward, all
884 ;;; references to still-existing OPTIONAL-DISPATCHes have been moved
885 ;;; to the XEP, leaving it with no references at all. So we look at
886 ;;; the XEP to see whether an optional-dispatch is still really being
887 ;;; used. But before local call analysis, there are no XEPs, and all
888 ;;; references are direct.
890 ;;; When we do delete the OPTIONAL-DISPATCH, we grovel all of its
891 ;;; entry-points, making them be normal lambdas, and then deleting the
892 ;;; ones with no references. This deletes any e-p lambdas that were
893 ;;; either never referenced, or couldn't be deleted when the last
894 ;;; reference was deleted (due to their :OPTIONAL kind.)
896 ;;; Note that the last optional entry point may alias the main entry,
897 ;;; so when we process the main entry, its KIND may have been changed
898 ;;; to NIL or even converted to a LETlike value.
899 (defun delete-optional-dispatch (leaf)
900 (declare (type optional-dispatch leaf))
901 (let ((entry (functional-entry-fun leaf)))
902 (unless (and entry (leaf-refs entry))
903 (aver (or (not entry) (eq (functional-kind entry) :deleted)))
904 (setf (functional-kind leaf) :deleted)
907 (unless (eq (functional-kind fun) :deleted)
908 (aver (eq (functional-kind fun) :optional))
909 (setf (functional-kind fun) nil)
910 (let ((refs (leaf-refs fun)))
914 (or (maybe-let-convert fun)
915 (maybe-convert-to-assignment fun)))
917 (maybe-convert-to-assignment fun)))))))
919 (dolist (ep (optional-dispatch-entry-points leaf))
920 (when (promise-ready-p ep)
922 (when (optional-dispatch-more-entry leaf)
923 (frob (optional-dispatch-more-entry leaf)))
924 (let ((main (optional-dispatch-main-entry leaf)))
925 (when (eq (functional-kind main) :optional)
930 ;;; Do stuff to delete the semantic attachments of a REF node. When
931 ;;; this leaves zero or one reference, we do a type dispatch off of
932 ;;; the leaf to determine if a special action is appropriate.
933 (defun delete-ref (ref)
934 (declare (type ref ref))
935 (let* ((leaf (ref-leaf ref))
936 (refs (delete ref (leaf-refs leaf))))
937 (setf (leaf-refs leaf) refs)
942 (delete-lambda-var leaf))
944 (ecase (functional-kind leaf)
945 ((nil :let :mv-let :assignment :escape :cleanup)
946 (aver (null (functional-entry-fun leaf)))
947 (delete-lambda leaf))
949 (delete-lambda leaf))
950 ((:deleted :optional))))
952 (unless (eq (functional-kind leaf) :deleted)
953 (delete-optional-dispatch leaf)))))
956 (clambda (or (maybe-let-convert leaf)
957 (maybe-convert-to-assignment leaf)))
958 (lambda-var (reoptimize-lambda-var leaf))))
961 (clambda (maybe-convert-to-assignment leaf))))))
965 ;;; This function is called by people who delete nodes; it provides a
966 ;;; way to indicate that the value of a continuation is no longer
967 ;;; used. We null out the CONTINUATION-DEST, set FLUSH-P in the blocks
968 ;;; containing uses of CONT and set COMPONENT-REOPTIMIZE. If the PREV
969 ;;; of the use is deleted, then we blow off reoptimization.
971 ;;; If the continuation is :DELETED, then we don't do anything, since
972 ;;; all semantics have already been flushed. :DELETED-BLOCK-START
973 ;;; start continuations are treated just like :BLOCK-START; it is
974 ;;; possible that the continuation may be given a new dest (e.g. by
975 ;;; SUBSTITUTE-CONTINUATION), so we don't want to delete it.
976 (defun flush-dest (cont)
977 (declare (type continuation cont))
979 (unless (eq (continuation-kind cont) :deleted)
980 (aver (continuation-dest cont))
981 (setf (continuation-dest cont) nil)
982 (flush-continuation-externally-checkable-type cont)
984 (let ((prev (node-prev use)))
985 (unless (eq (continuation-kind prev) :deleted)
986 (let ((block (continuation-block prev)))
987 (setf (component-reoptimize (block-component block)) t)
988 (setf (block-attributep (block-flags block) flush-p type-asserted)
993 (defun delete-dest (cont)
994 (let ((dest (continuation-dest cont)))
996 (let ((prev (node-prev dest)))
998 (not (eq (continuation-kind prev) :deleted)))
999 (let ((block (continuation-block prev)))
1000 (unless (block-delete-p block)
1001 (mark-for-deletion block))))))))
1003 ;;; Do a graph walk backward from BLOCK, marking all predecessor
1004 ;;; blocks with the DELETE-P flag.
1005 (defun mark-for-deletion (block)
1006 (declare (type cblock block))
1007 (let* ((component (block-component block))
1008 (head (component-head component)))
1009 (labels ((helper (block)
1010 (setf (block-delete-p block) t)
1011 (dolist (pred (block-pred block))
1012 (unless (or (block-delete-p pred)
1015 (unless (block-delete-p block)
1017 (setf (component-reanalyze component) t))))
1020 ;;; Delete CONT, eliminating both control and value semantics. We set
1021 ;;; FLUSH-P and COMPONENT-REOPTIMIZE similarly to in FLUSH-DEST. Here
1022 ;;; we must get the component from the use block, since the
1023 ;;; continuation may be a :DELETED-BLOCK-START.
1025 ;;; If CONT has DEST, then it must be the case that the DEST is
1026 ;;; unreachable, since we can't compute the value desired. In this
1027 ;;; case, we call MARK-FOR-DELETION to cause the DEST block and its
1028 ;;; predecessors to tell people to ignore them, and to cause them to
1029 ;;; be deleted eventually.
1030 (defun delete-continuation (cont)
1031 (declare (type continuation cont))
1032 (aver (not (eq (continuation-kind cont) :deleted)))
1035 (let ((prev (node-prev use)))
1036 (unless (eq (continuation-kind prev) :deleted)
1037 (let ((block (continuation-block prev)))
1038 (setf (block-attributep (block-flags block) flush-p type-asserted) t)
1039 (setf (component-reoptimize (block-component block)) t)))))
1043 (setf (continuation-kind cont) :deleted)
1044 (setf (continuation-dest cont) nil)
1045 (flush-continuation-externally-checkable-type cont)
1046 (setf (continuation-next cont) nil)
1047 (setf (continuation-%derived-type cont) *empty-type*)
1048 (setf (continuation-use cont) nil)
1049 (setf (continuation-block cont) nil)
1050 (setf (continuation-reoptimize cont) nil)
1051 (setf (continuation-info cont) nil)
1055 ;;; This function does what is necessary to eliminate the code in it
1056 ;;; from the IR1 representation. This involves unlinking it from its
1057 ;;; predecessors and successors and deleting various node-specific
1058 ;;; semantic information.
1060 ;;; We mark the START as has having no next and remove the last node
1061 ;;; from its CONT's uses. We also flush the DEST for all continuations
1062 ;;; whose values are received by nodes in the block.
1063 (defun delete-block (block)
1064 (declare (type cblock block))
1065 (aver (block-component block)) ; else block is already deleted!
1066 (note-block-deletion block)
1067 (setf (block-delete-p block) t)
1069 (let* ((last (block-last block))
1070 (cont (node-cont last)))
1071 (delete-continuation-use last)
1072 (if (eq (continuation-kind cont) :unused)
1073 (delete-continuation cont)
1074 (reoptimize-continuation cont)))
1076 (dolist (b (block-pred block))
1077 (unlink-blocks b block)
1078 ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
1079 ;; broken when successors were deleted without setting the
1080 ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
1081 ;; doesn't happen again.
1082 (aver (not (and (null (block-succ b))
1083 (not (block-delete-p b))
1084 (not (eq b (component-head (block-component b))))))))
1085 (dolist (b (block-succ block))
1086 (unlink-blocks block b))
1088 (do-nodes (node cont block)
1090 (ref (delete-ref node))
1092 (flush-dest (if-test node)))
1093 ;; The next two cases serve to maintain the invariant that a LET
1094 ;; always has a well-formed COMBINATION, REF and BIND. We delete
1095 ;; the lambda whenever we delete any of these, but we must be
1096 ;; careful that this LET has not already been partially deleted.
1098 (when (and (eq (basic-combination-kind node) :local)
1099 ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
1100 (continuation-use (basic-combination-fun node)))
1101 (let ((fun (combination-lambda node)))
1102 ;; If our REF was the second-to-last ref, and has been
1103 ;; deleted, then FUN may be a LET for some other
1105 (when (and (functional-letlike-p fun)
1106 (eq (let-combination fun) node))
1107 (delete-lambda fun))))
1108 (flush-dest (basic-combination-fun node))
1109 (dolist (arg (basic-combination-args node))
1110 (when arg (flush-dest arg))))
1112 (let ((lambda (bind-lambda node)))
1113 (unless (eq (functional-kind lambda) :deleted)
1114 (delete-lambda lambda))))
1116 (let ((value (exit-value node))
1117 (entry (exit-entry node)))
1121 (setf (entry-exits entry)
1122 (delete node (entry-exits entry))))))
1124 (flush-dest (return-result node))
1125 (delete-return node))
1127 (flush-dest (set-value node))
1128 (let ((var (set-var node)))
1129 (setf (basic-var-sets var)
1130 (delete node (basic-var-sets var)))))
1132 (flush-dest (cast-value node))))
1134 (delete-continuation (node-prev node)))
1136 (remove-from-dfo block)
1139 ;;; Do stuff to indicate that the return node NODE is being deleted.
1140 (defun delete-return (node)
1141 (declare (type creturn node))
1142 (let* ((fun (return-lambda node))
1143 (tail-set (lambda-tail-set fun)))
1144 (aver (lambda-return fun))
1145 (setf (lambda-return fun) nil)
1146 (when (and tail-set (not (find-if #'lambda-return
1147 (tail-set-funs tail-set))))
1148 (setf (tail-set-type tail-set) *empty-type*)))
1151 ;;; If any of the VARS in FUN was never referenced and was not
1152 ;;; declared IGNORE, then complain.
1153 (defun note-unreferenced-vars (fun)
1154 (declare (type clambda fun))
1155 (dolist (var (lambda-vars fun))
1156 (unless (or (leaf-ever-used var)
1157 (lambda-var-ignorep var))
1158 (let ((*compiler-error-context* (lambda-bind fun)))
1159 (unless (policy *compiler-error-context* (= inhibit-warnings 3))
1160 ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
1161 ;; requires this to be no more than a STYLE-WARNING.
1162 (compiler-style-warn "The variable ~S is defined but never used."
1163 (leaf-debug-name var)))
1164 (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
1167 (defvar *deletion-ignored-objects* '(t nil))
1169 ;;; Return true if we can find OBJ in FORM, NIL otherwise. We bound
1170 ;;; our recursion so that we don't get lost in circular structures. We
1171 ;;; ignore the car of forms if they are a symbol (to prevent confusing
1172 ;;; function referencess with variables), and we also ignore anything
1174 (defun present-in-form (obj form depth)
1175 (declare (type (integer 0 20) depth))
1176 (cond ((= depth 20) nil)
1180 (let ((first (car form))
1182 (if (member first '(quote function))
1184 (or (and (not (symbolp first))
1185 (present-in-form obj first depth))
1186 (do ((l (cdr form) (cdr l))
1188 ((or (atom l) (> n 100))
1190 (declare (fixnum n))
1191 (when (present-in-form obj (car l) depth)
1194 ;;; This function is called on a block immediately before we delete
1195 ;;; it. We check to see whether any of the code about to die appeared
1196 ;;; in the original source, and emit a note if so.
1198 ;;; If the block was in a lambda is now deleted, then we ignore the
1199 ;;; whole block, since this case is picked off in DELETE-LAMBDA. We
1200 ;;; also ignore the deletion of CRETURN nodes, since it is somewhat
1201 ;;; reasonable for a function to not return, and there is a different
1202 ;;; note for that case anyway.
1204 ;;; If the actual source is an atom, then we use a bunch of heuristics
1205 ;;; to guess whether this reference really appeared in the original
1207 ;;; -- If a symbol, it must be interned and not a keyword.
1208 ;;; -- It must not be an easily introduced constant (T or NIL, a fixnum
1209 ;;; or a character.)
1210 ;;; -- The atom must be "present" in the original source form, and
1211 ;;; present in all intervening actual source forms.
1212 (defun note-block-deletion (block)
1213 (let ((home (block-home-lambda block)))
1214 (unless (eq (functional-kind home) :deleted)
1215 (do-nodes (node cont block)
1216 (let* ((path (node-source-path node))
1217 (first (first path)))
1218 (when (or (eq first 'original-source-start)
1220 (or (not (symbolp first))
1221 (let ((pkg (symbol-package first)))
1223 (not (eq pkg (symbol-package :end))))))
1224 (not (member first *deletion-ignored-objects*))
1225 (not (typep first '(or fixnum character)))
1227 (present-in-form first x 0))
1228 (source-path-forms path))
1229 (present-in-form first (find-original-source path)
1231 (unless (return-p node)
1232 (let ((*compiler-error-context* node))
1233 (compiler-note "deleting unreachable code")))
1237 ;;; Delete a node from a block, deleting the block if there are no
1238 ;;; nodes left. We remove the node from the uses of its CONT, but we
1239 ;;; don't deal with cleaning up any type-specific semantic
1240 ;;; attachments. If the CONT is :UNUSED after deleting this use, then
1241 ;;; we delete CONT. (Note :UNUSED is not the same as no uses. A
1242 ;;; continuation will only become :UNUSED if it was :INSIDE-BLOCK
1245 ;;; If the node is the last node, there must be exactly one successor.
1246 ;;; We link all of our precedessors to the successor and unlink the
1247 ;;; block. In this case, we return T, otherwise NIL. If no nodes are
1248 ;;; left, and the block is a successor of itself, then we replace the
1249 ;;; only node with a degenerate exit node. This provides a way to
1250 ;;; represent the bodyless infinite loop, given the prohibition on
1251 ;;; empty blocks in IR1.
1252 (defun unlink-node (node)
1253 (declare (type node node))
1254 (let* ((cont (node-cont node))
1255 (next (continuation-next cont))
1256 (prev (node-prev node))
1257 (block (continuation-block prev))
1258 (prev-kind (continuation-kind prev))
1259 (last (block-last block)))
1261 (unless (eq (continuation-kind cont) :deleted)
1262 (delete-continuation-use node)
1263 (when (eq (continuation-kind cont) :unused)
1264 (aver (not (continuation-dest cont)))
1265 (delete-continuation cont)))
1267 (setf (block-type-asserted block) t)
1268 (setf (block-test-modified block) t)
1270 (cond ((or (eq prev-kind :inside-block)
1271 (and (eq prev-kind :block-start)
1272 (not (eq node last))))
1273 (cond ((eq node last)
1274 (setf (block-last block) (continuation-use prev))
1275 (setf (continuation-next prev) nil))
1277 (setf (continuation-next prev) next)
1278 (setf (node-prev next) prev)
1279 (when (and (if-p next) ; AOP wanted
1280 (eq prev (if-test next)))
1281 (reoptimize-continuation prev))))
1282 (setf (node-prev node) nil)
1285 (aver (eq prev-kind :block-start))
1286 (aver (eq node last))
1287 (let* ((succ (block-succ block))
1288 (next (first succ)))
1289 (aver (singleton-p succ))
1291 ((member block succ)
1292 (with-ir1-environment-from-node node
1293 (let ((exit (make-exit))
1294 (dummy (make-continuation)))
1295 (setf (continuation-next prev) nil)
1296 (link-node-to-previous-continuation exit prev)
1297 (add-continuation-use exit dummy)
1298 (setf (block-last block) exit)))
1299 (setf (node-prev node) nil)
1302 (aver (eq (block-start-cleanup block)
1303 (block-end-cleanup block)))
1304 (unlink-blocks block next)
1305 (dolist (pred (block-pred block))
1306 (change-block-successor pred block next))
1307 (remove-from-dfo block)
1308 (cond ((continuation-dest prev)
1309 (setf (continuation-next prev) nil)
1310 (setf (continuation-kind prev) :deleted-block-start))
1312 (delete-continuation prev)))
1313 (setf (node-prev node) nil)
1316 ;;; Return true if NODE has been deleted, false if it is still a valid
1318 (defun node-deleted (node)
1319 (declare (type node node))
1320 (let ((prev (node-prev node)))
1322 (not (eq (continuation-kind prev) :deleted))
1323 (let ((block (continuation-block prev)))
1324 (and (block-component block)
1325 (not (block-delete-p block))))))))
1327 ;;; Delete all the blocks and functions in COMPONENT. We scan first
1328 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
1329 ;;; triggered by deletion.
1330 (defun delete-component (component)
1331 (declare (type component component))
1332 (aver (null (component-new-functionals component)))
1333 (setf (component-kind component) :deleted)
1334 (do-blocks (block component)
1335 (setf (block-delete-p block) t))
1336 (dolist (fun (component-lambdas component))
1337 (setf (functional-kind fun) nil)
1338 (setf (functional-entry-fun fun) nil)
1339 (setf (leaf-refs fun) nil)
1340 (delete-functional fun))
1341 (do-blocks (block component)
1342 (delete-block block))
1345 ;;; Convert code of the form
1346 ;;; (FOO ... (FUN ...) ...)
1348 ;;; (FOO ... ... ...).
1349 ;;; In other words, replace the function combination FUN by its
1350 ;;; arguments. If there are any problems with doing this, use GIVE-UP
1351 ;;; to blow out of whatever transform called this. Note, as the number
1352 ;;; of arguments changes, the transform must be prepared to return a
1353 ;;; lambda with a new lambda-list with the correct number of
1355 (defun extract-fun-args (cont fun num-args)
1357 "If CONT is a call to FUN with NUM-ARGS args, change those arguments
1358 to feed directly to the continuation-dest of CONT, which must be
1360 (declare (type continuation cont)
1362 (type index num-args))
1363 (let ((outside (continuation-dest cont))
1364 (inside (continuation-use cont)))
1365 (aver (combination-p outside))
1366 (unless (combination-p inside)
1367 (give-up-ir1-transform))
1368 (let ((inside-fun (combination-fun inside)))
1369 (unless (eq (continuation-fun-name inside-fun) fun)
1370 (give-up-ir1-transform))
1371 (let ((inside-args (combination-args inside)))
1372 (unless (= (length inside-args) num-args)
1373 (give-up-ir1-transform))
1374 (let* ((outside-args (combination-args outside))
1375 (arg-position (position cont outside-args))
1376 (before-args (subseq outside-args 0 arg-position))
1377 (after-args (subseq outside-args (1+ arg-position))))
1378 (dolist (arg inside-args)
1379 (setf (continuation-dest arg) outside)
1380 (flush-continuation-externally-checkable-type arg))
1381 (setf (combination-args inside) nil)
1382 (setf (combination-args outside)
1383 (append before-args inside-args after-args))
1384 (change-ref-leaf (continuation-use inside-fun)
1385 (find-free-fun 'list "???"))
1386 (setf (combination-kind inside)
1387 (info :function :info 'list))
1388 (setf (node-derived-type inside) *wild-type*)
1392 (defun flush-combination (combination)
1393 (declare (type combination combination))
1394 (flush-dest (combination-fun combination))
1395 (dolist (arg (combination-args combination))
1397 (unlink-node combination)
1403 ;;; Change the LEAF that a REF refers to.
1404 (defun change-ref-leaf (ref leaf)
1405 (declare (type ref ref) (type leaf leaf))
1406 (unless (eq (ref-leaf ref) leaf)
1407 (push ref (leaf-refs leaf))
1409 (setf (ref-leaf ref) leaf)
1410 (setf (leaf-ever-used leaf) t)
1411 (let* ((ltype (leaf-type leaf))
1412 (vltype (make-single-value-type ltype)))
1413 (if (let* ((cont (node-cont ref))
1414 (dest (continuation-dest cont)))
1415 (and (basic-combination-p dest)
1416 (eq cont (basic-combination-fun dest))
1417 (csubtypep ltype (specifier-type 'function))))
1418 (setf (node-derived-type ref) vltype)
1419 (derive-node-type ref vltype)))
1420 (reoptimize-continuation (node-cont ref)))
1423 ;;; Change all REFS for OLD-LEAF to NEW-LEAF.
1424 (defun substitute-leaf (new-leaf old-leaf)
1425 (declare (type leaf new-leaf old-leaf))
1426 (dolist (ref (leaf-refs old-leaf))
1427 (change-ref-leaf ref new-leaf))
1430 ;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
1431 ;;; whether to substitute
1432 (defun substitute-leaf-if (test new-leaf old-leaf)
1433 (declare (type leaf new-leaf old-leaf) (type function test))
1434 (dolist (ref (leaf-refs old-leaf))
1435 (when (funcall test ref)
1436 (change-ref-leaf ref new-leaf)))
1439 ;;; Return a LEAF which represents the specified constant object. If
1440 ;;; the object is not in *CONSTANTS*, then we create a new constant
1441 ;;; LEAF and enter it.
1442 (defun find-constant (object)
1444 ;; FIXME: What is the significance of this test? ("things
1445 ;; that are worth uniquifying"?)
1446 '(or symbol number character instance))
1447 (or (gethash object *constants*)
1448 (setf (gethash object *constants*)
1449 (make-constant :value object
1450 :%source-name '.anonymous.
1451 :type (ctype-of object)
1452 :where-from :defined)))
1453 (make-constant :value object
1454 :%source-name '.anonymous.
1455 :type (ctype-of object)
1456 :where-from :defined)))
1458 ;;; Return true if VAR would have to be closed over if environment
1459 ;;; analysis ran now (i.e. if there are any uses that have a different
1460 ;;; home lambda than VAR's home.)
1461 (defun closure-var-p (var)
1462 (declare (type lambda-var var))
1463 (let ((home (lambda-var-home var)))
1464 (cond ((eq (functional-kind home) :deleted)
1466 (t (let ((home (lambda-home home)))
1468 (find home l :key #'node-home-lambda
1470 (or (frob (leaf-refs var))
1471 (frob (basic-var-sets var)))))))))
1473 ;;; If there is a non-local exit noted in ENTRY's environment that
1474 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
1475 (defun find-nlx-info (entry cont)
1476 (declare (type entry entry) (type continuation cont))
1477 (let ((entry-cleanup (entry-cleanup entry)))
1478 (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
1479 (when (and (eq (nlx-info-continuation nlx) cont)
1480 (eq (nlx-info-cleanup nlx) entry-cleanup))
1483 ;;;; functional hackery
1485 (declaim (ftype (function (functional) clambda) main-entry))
1486 (defun main-entry (functional)
1487 (etypecase functional
1488 (clambda functional)
1490 (optional-dispatch-main-entry functional))))
1492 ;;; RETURN true if FUNCTIONAL is a thing that can be treated like
1493 ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
1494 ;;; optional with null default and no SUPPLIED-P. There must be a
1495 ;;; &REST arg with no references.
1496 (declaim (ftype (function (functional) boolean) looks-like-an-mv-bind))
1497 (defun looks-like-an-mv-bind (functional)
1498 (and (optional-dispatch-p functional)
1499 (do ((arg (optional-dispatch-arglist functional) (cdr arg)))
1501 (let ((info (lambda-var-arg-info (car arg))))
1502 (unless info (return nil))
1503 (case (arg-info-kind info)
1505 (when (or (arg-info-supplied-p info) (arg-info-default info))
1508 (return (and (null (cdr arg)) (null (leaf-refs (car arg))))))
1512 ;;; Return true if function is an external entry point. This is true
1513 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
1514 ;;; (:TOPLEVEL kind.)
1516 (declare (type functional fun))
1517 (not (null (member (functional-kind fun) '(:external :toplevel)))))
1519 ;;; If CONT's only use is a non-notinline global function reference,
1520 ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
1521 ;;; is true, then we don't care if the leaf is NOTINLINE.
1522 (defun continuation-fun-name (cont &optional notinline-ok)
1523 (declare (type continuation cont))
1524 (let ((use (continuation-use cont)))
1526 (let ((leaf (ref-leaf use)))
1527 (if (and (global-var-p leaf)
1528 (eq (global-var-kind leaf) :global-function)
1529 (or (not (defined-fun-p leaf))
1530 (not (eq (defined-fun-inlinep leaf) :notinline))
1532 (leaf-source-name leaf)
1536 ;;; Return the source name of a combination. (This is an idiom
1537 ;;; which was used in CMU CL. I gather it always works. -- WHN)
1538 (defun combination-fun-source-name (combination)
1539 (let ((ref (continuation-use (combination-fun combination))))
1540 (leaf-source-name (ref-leaf ref))))
1542 ;;; Return the COMBINATION node that is the call to the LET FUN.
1543 (defun let-combination (fun)
1544 (declare (type clambda fun))
1545 (aver (functional-letlike-p fun))
1546 (continuation-dest (node-cont (first (leaf-refs fun)))))
1548 ;;; Return the initial value continuation for a LET variable, or NIL
1549 ;;; if there is none.
1550 (defun let-var-initial-value (var)
1551 (declare (type lambda-var var))
1552 (let ((fun (lambda-var-home var)))
1553 (elt (combination-args (let-combination fun))
1554 (position-or-lose var (lambda-vars fun)))))
1556 ;;; Return the LAMBDA that is called by the local CALL.
1557 (defun combination-lambda (call)
1558 (declare (type basic-combination call))
1559 (aver (eq (basic-combination-kind call) :local))
1560 (ref-leaf (continuation-use (basic-combination-fun call))))
1562 (defvar *inline-expansion-limit* 200
1564 "an upper limit on the number of inline function calls that will be expanded
1565 in any given code object (single function or block compilation)")
1567 ;;; Check whether NODE's component has exceeded its inline expansion
1568 ;;; limit, and warn if so, returning NIL.
1569 (defun inline-expansion-ok (node)
1570 (let ((expanded (incf (component-inline-expansions
1572 (node-block node))))))
1573 (cond ((> expanded *inline-expansion-limit*) nil)
1574 ((= expanded *inline-expansion-limit*)
1575 ;; FIXME: If the objective is to stop the recursive
1576 ;; expansion of inline functions, wouldn't it be more
1577 ;; correct to look back through surrounding expansions
1578 ;; (which are, I think, stored in the *CURRENT-PATH*, and
1579 ;; possibly stored elsewhere too) and suppress expansion
1580 ;; and print this warning when the function being proposed
1581 ;; for inline expansion is found there? (I don't like the
1582 ;; arbitrary numerical limit in principle, and I think
1583 ;; it'll be a nuisance in practice if we ever want the
1584 ;; compiler to be able to use WITH-COMPILATION-UNIT on
1585 ;; arbitrarily huge blocks of code. -- WHN)
1586 (let ((*compiler-error-context* node))
1587 (compiler-note "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
1588 probably trying to~% ~
1589 inline a recursive function."
1590 *inline-expansion-limit*))
1596 ;;; Apply a function to some arguments, returning a list of the values
1597 ;;; resulting of the evaluation. If an error is signalled during the
1598 ;;; application, then we produce a warning message using WARN-FUN and
1599 ;;; return NIL as our second value to indicate this. NODE is used as
1600 ;;; the error context for any error message, and CONTEXT is a string
1601 ;;; that is spliced into the warning.
1602 (declaim (ftype (function ((or symbol function) list node function string)
1603 (values list boolean))
1605 (defun careful-call (function args node warn-fun context)
1607 (multiple-value-list
1608 (handler-case (apply function args)
1610 (let ((*compiler-error-context* node))
1611 (funcall warn-fun "Lisp error during ~A:~%~A" context condition)
1612 (return-from careful-call (values nil nil))))))
1615 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
1618 ((deffrob (basic careful compiler transform)
1620 (defun ,careful (specifier)
1621 (handler-case (,basic specifier)
1622 (simple-error (condition)
1623 (values nil (list* (simple-condition-format-control condition)
1624 (simple-condition-format-arguments condition))))))
1625 (defun ,compiler (specifier)
1626 (multiple-value-bind (type error-args) (,careful specifier)
1628 (apply #'compiler-error error-args))))
1629 (defun ,transform (specifier)
1630 (multiple-value-bind (type error-args) (,careful specifier)
1632 (apply #'give-up-ir1-transform
1634 (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type)
1635 (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type))
1638 ;;;; utilities used at run-time for parsing &KEY args in IR1
1640 ;;; This function is used by the result of PARSE-DEFTRANSFORM to find
1641 ;;; the continuation for the value of the &KEY argument KEY in the
1642 ;;; list of continuations ARGS. It returns the continuation if the
1643 ;;; keyword is present, or NIL otherwise. The legality and
1644 ;;; constantness of the keywords should already have been checked.
1645 (declaim (ftype (function (list keyword) (or continuation null))
1646 find-keyword-continuation))
1647 (defun find-keyword-continuation (args key)
1648 (do ((arg args (cddr arg)))
1650 (when (eq (continuation-value (first arg)) key)
1651 (return (second arg)))))
1653 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
1654 ;;; verify that alternating continuations in ARGS are constant and
1655 ;;; that there is an even number of args.
1656 (declaim (ftype (function (list) boolean) check-key-args-constant))
1657 (defun check-key-args-constant (args)
1658 (do ((arg args (cddr arg)))
1660 (unless (and (rest arg)
1661 (constant-continuation-p (first arg)))
1664 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
1665 ;;; verify that the list of continuations ARGS is a well-formed &KEY
1666 ;;; arglist and that only keywords present in the list KEYS are
1668 (declaim (ftype (function (list list) boolean) check-transform-keys))
1669 (defun check-transform-keys (args keys)
1670 (and (check-key-args-constant args)
1671 (do ((arg args (cddr arg)))
1673 (unless (member (continuation-value (first arg)) keys)
1678 ;;; Called by the expansion of the EVENT macro.
1679 (declaim (ftype (function (event-info (or node null)) *) %event))
1680 (defun %event (info node)
1681 (incf (event-info-count info))
1682 (when (and (>= (event-info-level info) *event-note-threshold*)
1683 (policy (or node *lexenv*)
1684 (= inhibit-warnings 0)))
1685 (let ((*compiler-error-context* node))
1686 (compiler-note (event-info-description info))))
1688 (let ((action (event-info-action info)))
1689 (when action (funcall action node))))
1692 (defun make-cast (value type policy)
1693 (declare (type continuation value)
1695 (type policy policy))
1696 (%make-cast :asserted-type type
1697 :type-to-check (maybe-weaken-check type policy)
1699 :derived-type (coerce-to-values type)))
1701 (defun cast-type-check (cast)
1702 (declare (type cast cast))
1703 (when (cast-reoptimize cast)
1704 (ir1-optimize-cast cast t))
1705 (cast-%type-check cast))
1707 (defun note-single-valuified-continuation (cont)
1708 (declare (type continuation cont))
1709 (let ((use (continuation-use cont)))
1711 (let ((leaf (ref-leaf use)))
1712 (when (and (lambda-var-p leaf)
1713 (null (rest (leaf-refs leaf))))
1714 (reoptimize-lambda-var leaf))))
1715 ((or (null use) (combination-p use))
1716 (dolist (node (find-uses cont))
1717 (setf (node-reoptimize node) t)
1718 (setf (block-reoptimize (node-block node)) t)
1719 (setf (component-reoptimize (node-component node)) t))))))