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))
519 ;; The following property means that the cast chain allows
520 ;; changing number of values, produced by the USE of CONT, but
521 ;; derived types of the casts must be updated (TODO: how?).
524 (declare (notinline continuation-single-value-p))
525 (and (not (values-type-p (cast-asserted-type dest)))
526 (continuation-single-value-p (node-cont dest)))))
530 (defun principal-continuation-end (cont)
531 (loop for prev = cont then (node-cont dest)
532 for dest = (continuation-dest prev)
534 finally (return (values dest prev))))
536 ;;; Return a new LEXENV just like DEFAULT except for the specified
537 ;;; slot values. Values for the alist slots are NCONCed to the
538 ;;; beginning of the current value, rather than replacing it entirely.
539 (defun make-lexenv (&key (default *lexenv*)
540 funs vars blocks tags
541 type-restrictions weakend-type-restrictions
542 (lambda (lexenv-lambda default))
543 (cleanup (lexenv-cleanup default))
544 (policy (lexenv-policy default)))
545 (macrolet ((frob (var slot)
546 `(let ((old (,slot default)))
550 (internal-make-lexenv
551 (frob funs lexenv-funs)
552 (frob vars lexenv-vars)
553 (frob blocks lexenv-blocks)
554 (frob tags lexenv-tags)
555 (frob type-restrictions lexenv-type-restrictions)
556 (frob weakend-type-restrictions lexenv-weakend-type-restrictions)
557 lambda cleanup policy)))
559 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
561 (defun make-restricted-lexenv (lexenv)
562 (flet ((fun-good-p (fun)
563 (destructuring-bind (name . thing) fun
564 (declare (ignore name))
568 (cons (aver (eq (car thing) 'macro))
571 (destructuring-bind (name . thing) var
572 (declare (ignore name))
575 (cons (aver (eq (car thing) 'macro))
577 (heap-alien-info nil)))))
578 (internal-make-lexenv
579 (remove-if-not #'fun-good-p (lexenv-funs lexenv))
580 (remove-if-not #'var-good-p (lexenv-vars lexenv))
583 (lexenv-type-restrictions lexenv) ; XXX
584 (lexenv-weakend-type-restrictions lexenv)
587 (lexenv-policy lexenv))))
589 ;;;; flow/DFO/component hackery
591 ;;; Join BLOCK1 and BLOCK2.
592 (defun link-blocks (block1 block2)
593 (declare (type cblock block1 block2))
594 (setf (block-succ block1)
595 (if (block-succ block1)
596 (%link-blocks block1 block2)
598 (push block1 (block-pred block2))
600 (defun %link-blocks (block1 block2)
601 (declare (type cblock block1 block2) (inline member))
602 (let ((succ1 (block-succ block1)))
603 (aver (not (member block2 succ1 :test #'eq)))
604 (cons block2 succ1)))
606 ;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If
607 ;;; this leaves a successor with a single predecessor that ends in an
608 ;;; IF, then set BLOCK-TEST-MODIFIED so that any test constraint will
609 ;;; now be able to be propagated to the successor.
610 (defun unlink-blocks (block1 block2)
611 (declare (type cblock block1 block2))
612 (let ((succ1 (block-succ block1)))
613 (if (eq block2 (car succ1))
614 (setf (block-succ block1) (cdr succ1))
615 (do ((succ (cdr succ1) (cdr succ))
617 ((eq (car succ) block2)
618 (setf (cdr prev) (cdr succ)))
621 (let ((new-pred (delq block1 (block-pred block2))))
622 (setf (block-pred block2) new-pred)
623 (when (singleton-p new-pred)
624 (let ((pred-block (first new-pred)))
625 (when (if-p (block-last pred-block))
626 (setf (block-test-modified pred-block) t)))))
629 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK
630 ;;; and NEW. If BLOCK ends in an IF, then we have to fix up the
631 ;;; consequent/alternative blocks to point to NEW. We also set
632 ;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to
633 ;;; the new successor.
634 (defun change-block-successor (block old new)
635 (declare (type cblock new old block) (inline member))
636 (unlink-blocks block old)
637 (let ((last (block-last block))
638 (comp (block-component block)))
639 (setf (component-reanalyze comp) t)
642 (setf (block-test-modified block) t)
643 (let* ((succ-left (block-succ block))
644 (new (if (and (eq new (component-tail comp))
648 (unless (member new succ-left :test #'eq)
649 (link-blocks block new))
650 (macrolet ((frob (slot)
651 `(when (eq (,slot last) old)
652 (setf (,slot last) new))))
654 (frob if-alternative)
655 (when (eq (if-consequent last)
656 (if-alternative last))
657 (setf (component-reoptimize (block-component block)) t)))))
659 (unless (member new (block-succ block) :test #'eq)
660 (link-blocks block new)))))
664 ;;; Unlink a block from the next/prev chain. We also null out the
666 (declaim (ftype (function (cblock) (values)) remove-from-dfo))
667 (defun remove-from-dfo (block)
668 (let ((next (block-next block))
669 (prev (block-prev block)))
670 (setf (block-component block) nil)
671 (setf (block-next prev) next)
672 (setf (block-prev next) prev))
675 ;;; Add BLOCK to the next/prev chain following AFTER. We also set the
676 ;;; COMPONENT to be the same as for AFTER.
677 (defun add-to-dfo (block after)
678 (declare (type cblock block after))
679 (let ((next (block-next after))
680 (comp (block-component after)))
681 (aver (not (eq (component-kind comp) :deleted)))
682 (setf (block-component block) comp)
683 (setf (block-next after) block)
684 (setf (block-prev block) after)
685 (setf (block-next block) next)
686 (setf (block-prev next) block))
689 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
690 ;;; the head and tail which are set to T.
691 (declaim (ftype (function (component) (values)) clear-flags))
692 (defun clear-flags (component)
693 (let ((head (component-head component))
694 (tail (component-tail component)))
695 (setf (block-flag head) t)
696 (setf (block-flag tail) t)
697 (do-blocks (block component)
698 (setf (block-flag block) nil)))
701 ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially
702 ;;; true in the head and tail blocks.
703 (declaim (ftype (function nil component) make-empty-component))
704 (defun make-empty-component ()
705 (let* ((head (make-block-key :start nil :component nil))
706 (tail (make-block-key :start nil :component nil))
707 (res (make-component head tail)))
708 (setf (block-flag head) t)
709 (setf (block-flag tail) t)
710 (setf (block-component head) res)
711 (setf (block-component tail) res)
712 (setf (block-next head) tail)
713 (setf (block-prev tail) head)
716 ;;; Make NODE the LAST node in its block, splitting the block if necessary.
717 ;;; The new block is added to the DFO immediately following NODE's block.
718 (defun node-ends-block (node)
719 (declare (type node node))
720 (let* ((block (node-block node))
721 (start (node-cont node))
722 (last (block-last block))
723 (last-cont (node-cont last)))
724 (unless (eq last node)
725 (aver (and (eq (continuation-kind start) :inside-block)
726 (not (block-delete-p block))))
727 (let* ((succ (block-succ block))
729 (make-block-key :start start
730 :component (block-component block)
731 :start-uses (list (continuation-use start))
732 :succ succ :last last)))
733 (setf (continuation-kind start) :block-start)
736 (cons new-block (remove block (block-pred b)))))
737 (setf (block-succ block) ())
738 (setf (block-last block) node)
739 (link-blocks block new-block)
740 (add-to-dfo new-block block)
741 (setf (component-reanalyze (block-component block)) t)
743 (do ((cont start (node-cont (continuation-next cont))))
745 (when (eq (continuation-kind last-cont) :inside-block)
746 (setf (continuation-block last-cont) new-block)))
747 (setf (continuation-block cont) new-block))
749 (setf (block-type-asserted block) t)
750 (setf (block-test-modified block) t))))
756 ;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
757 (defun delete-lambda-var (leaf)
758 (declare (type lambda-var leaf))
760 ;; Iterate over all local calls flushing the corresponding argument,
761 ;; allowing the computation of the argument to be deleted. We also
762 ;; mark the LET for reoptimization, since it may be that we have
763 ;; deleted its last variable.
764 (let* ((fun (lambda-var-home leaf))
765 (n (position leaf (lambda-vars fun))))
766 (dolist (ref (leaf-refs fun))
767 (let* ((cont (node-cont ref))
768 (dest (continuation-dest cont)))
769 (when (and (combination-p dest)
770 (eq (basic-combination-fun dest) cont)
771 (eq (basic-combination-kind dest) :local))
772 (let* ((args (basic-combination-args dest))
774 (reoptimize-continuation arg)
776 (setf (elt args n) nil))))))
778 ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
779 ;; too much difficulty, since we can efficiently implement
780 ;; write-only variables. We iterate over the SETs, marking their
781 ;; blocks for dead code flushing, since we can delete SETs whose
783 (dolist (set (lambda-var-sets leaf))
784 (setf (block-flush-p (node-block set)) t))
788 ;;; Note that something interesting has happened to VAR.
789 (defun reoptimize-lambda-var (var)
790 (declare (type lambda-var var))
791 (let ((fun (lambda-var-home var)))
792 ;; We only deal with LET variables, marking the corresponding
793 ;; initial value arg as needing to be reoptimized.
794 (when (and (eq (functional-kind fun) :let)
796 (do ((args (basic-combination-args
799 (first (leaf-refs fun)))))
801 (vars (lambda-vars fun) (cdr vars)))
803 (reoptimize-continuation (car args))))))
806 ;;; Delete a function that has no references. This need only be called
807 ;;; on functions that never had any references, since otherwise
808 ;;; DELETE-REF will handle the deletion.
809 (defun delete-functional (fun)
810 (aver (and (null (leaf-refs fun))
811 (not (functional-entry-fun fun))))
813 (optional-dispatch (delete-optional-dispatch fun))
814 (clambda (delete-lambda fun)))
817 ;;; Deal with deleting the last reference to a CLAMBDA. Since there is
818 ;;; only one way into a CLAMBDA, deleting the last reference to a
819 ;;; CLAMBDA ensures that there is no way to reach any of the code in
820 ;;; it. So we just set the FUNCTIONAL-KIND for FUN and its LETs to
821 ;;; :DELETED, causing IR1 optimization to delete blocks in that
823 (defun delete-lambda (clambda)
824 (declare (type clambda clambda))
825 (let ((original-kind (functional-kind clambda))
826 (bind (lambda-bind clambda)))
827 (aver (not (member original-kind '(:deleted :optional :toplevel))))
828 (aver (not (functional-has-external-references-p clambda)))
829 (setf (functional-kind clambda) :deleted)
830 (setf (lambda-bind clambda) nil)
831 (dolist (let (lambda-lets clambda))
832 (setf (lambda-bind let) nil)
833 (setf (functional-kind let) :deleted))
835 ;; LET may be deleted if its BIND is unreachable. Autonomous
836 ;; function may be deleted if it has no reachable references.
837 (unless (member original-kind '(:let :mv-let :assignment))
838 (dolist (ref (lambda-refs clambda))
839 (mark-for-deletion (node-block ref))))
841 ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
842 ;; that we're using the old value of the KIND slot, not the
843 ;; current slot value, which has now been set to :DELETED.)
844 (if (member original-kind '(:let :mv-let :assignment))
845 (let ((home (lambda-home clambda)))
846 (setf (lambda-lets home) (delete clambda (lambda-lets home))))
847 ;; If the function isn't a LET, we unlink the function head
848 ;; and tail from the component head and tail to indicate that
849 ;; the code is unreachable. We also delete the function from
850 ;; COMPONENT-LAMBDAS (it won't be there before local call
851 ;; analysis, but no matter.) If the lambda was never
852 ;; referenced, we give a note.
853 (let* ((bind-block (node-block bind))
854 (component (block-component bind-block))
855 (return (lambda-return clambda))
856 (return-block (and return (node-block return))))
857 (unless (leaf-ever-used clambda)
858 (let ((*compiler-error-context* bind))
859 (compiler-note "deleting unused function~:[.~;~:*~% ~S~]"
860 (leaf-debug-name clambda))))
861 (unless (block-delete-p bind-block)
862 (unlink-blocks (component-head component) bind-block))
863 (when (and return-block (not (block-delete-p return-block)))
864 (mark-for-deletion return-block)
865 (unlink-blocks return-block (component-tail component)))
866 (setf (component-reanalyze component) t)
867 (let ((tails (lambda-tail-set clambda)))
868 (setf (tail-set-funs tails)
869 (delete clambda (tail-set-funs tails)))
870 (setf (lambda-tail-set clambda) nil))
871 (setf (component-lambdas component)
872 (delete clambda (component-lambdas component)))))
874 ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
875 ;; ENTRY-FUN so that people will know that it is not an entry
877 (when (eq original-kind :external)
878 (let ((fun (functional-entry-fun clambda)))
879 (setf (functional-entry-fun fun) nil)
880 (when (optional-dispatch-p fun)
881 (delete-optional-dispatch fun)))))
885 ;;; Deal with deleting the last reference to an OPTIONAL-DISPATCH. We
886 ;;; have to be a bit more careful than with lambdas, since DELETE-REF
887 ;;; is used both before and after local call analysis. Afterward, all
888 ;;; references to still-existing OPTIONAL-DISPATCHes have been moved
889 ;;; to the XEP, leaving it with no references at all. So we look at
890 ;;; the XEP to see whether an optional-dispatch is still really being
891 ;;; used. But before local call analysis, there are no XEPs, and all
892 ;;; references are direct.
894 ;;; When we do delete the OPTIONAL-DISPATCH, we grovel all of its
895 ;;; entry-points, making them be normal lambdas, and then deleting the
896 ;;; ones with no references. This deletes any e-p lambdas that were
897 ;;; either never referenced, or couldn't be deleted when the last
898 ;;; reference was deleted (due to their :OPTIONAL kind.)
900 ;;; Note that the last optional entry point may alias the main entry,
901 ;;; so when we process the main entry, its KIND may have been changed
902 ;;; to NIL or even converted to a LETlike value.
903 (defun delete-optional-dispatch (leaf)
904 (declare (type optional-dispatch leaf))
905 (let ((entry (functional-entry-fun leaf)))
906 (unless (and entry (leaf-refs entry))
907 (aver (or (not entry) (eq (functional-kind entry) :deleted)))
908 (setf (functional-kind leaf) :deleted)
911 (unless (eq (functional-kind fun) :deleted)
912 (aver (eq (functional-kind fun) :optional))
913 (setf (functional-kind fun) nil)
914 (let ((refs (leaf-refs fun)))
918 (or (maybe-let-convert fun)
919 (maybe-convert-to-assignment fun)))
921 (maybe-convert-to-assignment fun)))))))
923 (dolist (ep (optional-dispatch-entry-points leaf))
924 (when (promise-ready-p ep)
926 (when (optional-dispatch-more-entry leaf)
927 (frob (optional-dispatch-more-entry leaf)))
928 (let ((main (optional-dispatch-main-entry leaf)))
929 (when (eq (functional-kind main) :optional)
934 ;;; Do stuff to delete the semantic attachments of a REF node. When
935 ;;; this leaves zero or one reference, we do a type dispatch off of
936 ;;; the leaf to determine if a special action is appropriate.
937 (defun delete-ref (ref)
938 (declare (type ref ref))
939 (let* ((leaf (ref-leaf ref))
940 (refs (delete ref (leaf-refs leaf))))
941 (setf (leaf-refs leaf) refs)
946 (delete-lambda-var leaf))
948 (ecase (functional-kind leaf)
949 ((nil :let :mv-let :assignment :escape :cleanup)
950 (aver (null (functional-entry-fun leaf)))
951 (delete-lambda leaf))
953 (delete-lambda leaf))
954 ((:deleted :optional))))
956 (unless (eq (functional-kind leaf) :deleted)
957 (delete-optional-dispatch leaf)))))
960 (clambda (or (maybe-let-convert leaf)
961 (maybe-convert-to-assignment leaf)))
962 (lambda-var (reoptimize-lambda-var leaf))))
965 (clambda (maybe-convert-to-assignment leaf))))))
969 ;;; This function is called by people who delete nodes; it provides a
970 ;;; way to indicate that the value of a continuation is no longer
971 ;;; used. We null out the CONTINUATION-DEST, set FLUSH-P in the blocks
972 ;;; containing uses of CONT and set COMPONENT-REOPTIMIZE. If the PREV
973 ;;; of the use is deleted, then we blow off reoptimization.
975 ;;; If the continuation is :DELETED, then we don't do anything, since
976 ;;; all semantics have already been flushed. :DELETED-BLOCK-START
977 ;;; start continuations are treated just like :BLOCK-START; it is
978 ;;; possible that the continuation may be given a new dest (e.g. by
979 ;;; SUBSTITUTE-CONTINUATION), so we don't want to delete it.
980 (defun flush-dest (cont)
981 (declare (type continuation cont))
983 (unless (eq (continuation-kind cont) :deleted)
984 (aver (continuation-dest cont))
985 (setf (continuation-dest cont) nil)
986 (flush-continuation-externally-checkable-type cont)
988 (let ((prev (node-prev use)))
989 (unless (eq (continuation-kind prev) :deleted)
990 (let ((block (continuation-block prev)))
991 (setf (component-reoptimize (block-component block)) t)
992 (setf (block-attributep (block-flags block) flush-p type-asserted)
997 (defun delete-dest (cont)
998 (let ((dest (continuation-dest cont)))
1000 (let ((prev (node-prev dest)))
1002 (not (eq (continuation-kind prev) :deleted)))
1003 (let ((block (continuation-block prev)))
1004 (unless (block-delete-p block)
1005 (mark-for-deletion block))))))))
1007 ;;; Do a graph walk backward from BLOCK, marking all predecessor
1008 ;;; blocks with the DELETE-P flag.
1009 (defun mark-for-deletion (block)
1010 (declare (type cblock block))
1011 (let* ((component (block-component block))
1012 (head (component-head component)))
1013 (labels ((helper (block)
1014 (setf (block-delete-p block) t)
1015 (dolist (pred (block-pred block))
1016 (unless (or (block-delete-p pred)
1019 (unless (block-delete-p block)
1021 (setf (component-reanalyze component) t))))
1024 ;;; Delete CONT, eliminating both control and value semantics. We set
1025 ;;; FLUSH-P and COMPONENT-REOPTIMIZE similarly to in FLUSH-DEST. Here
1026 ;;; we must get the component from the use block, since the
1027 ;;; continuation may be a :DELETED-BLOCK-START.
1029 ;;; If CONT has DEST, then it must be the case that the DEST is
1030 ;;; unreachable, since we can't compute the value desired. In this
1031 ;;; case, we call MARK-FOR-DELETION to cause the DEST block and its
1032 ;;; predecessors to tell people to ignore them, and to cause them to
1033 ;;; be deleted eventually.
1034 (defun delete-continuation (cont)
1035 (declare (type continuation cont))
1036 (aver (not (eq (continuation-kind cont) :deleted)))
1039 (let ((prev (node-prev use)))
1040 (unless (eq (continuation-kind prev) :deleted)
1041 (let ((block (continuation-block prev)))
1042 (setf (block-attributep (block-flags block) flush-p type-asserted) t)
1043 (setf (component-reoptimize (block-component block)) t)))))
1047 (setf (continuation-kind cont) :deleted)
1048 (setf (continuation-dest cont) nil)
1049 (flush-continuation-externally-checkable-type cont)
1050 (setf (continuation-next cont) nil)
1051 (setf (continuation-%derived-type cont) *empty-type*)
1052 (setf (continuation-use cont) nil)
1053 (setf (continuation-block cont) nil)
1054 (setf (continuation-reoptimize cont) nil)
1055 (setf (continuation-info cont) nil)
1059 ;;; This function does what is necessary to eliminate the code in it
1060 ;;; from the IR1 representation. This involves unlinking it from its
1061 ;;; predecessors and successors and deleting various node-specific
1062 ;;; semantic information.
1064 ;;; We mark the START as has having no next and remove the last node
1065 ;;; from its CONT's uses. We also flush the DEST for all continuations
1066 ;;; whose values are received by nodes in the block.
1067 (defun delete-block (block)
1068 (declare (type cblock block))
1069 (aver (block-component block)) ; else block is already deleted!
1070 (note-block-deletion block)
1071 (setf (block-delete-p block) t)
1073 (let* ((last (block-last block))
1074 (cont (node-cont last)))
1075 (delete-continuation-use last)
1076 (if (eq (continuation-kind cont) :unused)
1077 (delete-continuation cont)
1078 (reoptimize-continuation cont)))
1080 (dolist (b (block-pred block))
1081 (unlink-blocks b block)
1082 ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
1083 ;; broken when successors were deleted without setting the
1084 ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
1085 ;; doesn't happen again.
1086 (aver (not (and (null (block-succ b))
1087 (not (block-delete-p b))
1088 (not (eq b (component-head (block-component b))))))))
1089 (dolist (b (block-succ block))
1090 (unlink-blocks block b))
1092 (do-nodes (node cont block)
1094 (ref (delete-ref node))
1096 (flush-dest (if-test node)))
1097 ;; The next two cases serve to maintain the invariant that a LET
1098 ;; always has a well-formed COMBINATION, REF and BIND. We delete
1099 ;; the lambda whenever we delete any of these, but we must be
1100 ;; careful that this LET has not already been partially deleted.
1102 (when (and (eq (basic-combination-kind node) :local)
1103 ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
1104 (continuation-use (basic-combination-fun node)))
1105 (let ((fun (combination-lambda node)))
1106 ;; If our REF was the second-to-last ref, and has been
1107 ;; deleted, then FUN may be a LET for some other
1109 (when (and (functional-letlike-p fun)
1110 (eq (let-combination fun) node))
1111 (delete-lambda fun))))
1112 (flush-dest (basic-combination-fun node))
1113 (dolist (arg (basic-combination-args node))
1114 (when arg (flush-dest arg))))
1116 (let ((lambda (bind-lambda node)))
1117 (unless (eq (functional-kind lambda) :deleted)
1118 (delete-lambda lambda))))
1120 (let ((value (exit-value node))
1121 (entry (exit-entry node)))
1125 (setf (entry-exits entry)
1126 (delete node (entry-exits entry))))))
1128 (flush-dest (return-result node))
1129 (delete-return node))
1131 (flush-dest (set-value node))
1132 (let ((var (set-var node)))
1133 (setf (basic-var-sets var)
1134 (delete node (basic-var-sets var)))))
1136 (flush-dest (cast-value node))))
1138 (delete-continuation (node-prev node)))
1140 (remove-from-dfo block)
1143 ;;; Do stuff to indicate that the return node NODE is being deleted.
1144 (defun delete-return (node)
1145 (declare (type creturn node))
1146 (let* ((fun (return-lambda node))
1147 (tail-set (lambda-tail-set fun)))
1148 (aver (lambda-return fun))
1149 (setf (lambda-return fun) nil)
1150 (when (and tail-set (not (find-if #'lambda-return
1151 (tail-set-funs tail-set))))
1152 (setf (tail-set-type tail-set) *empty-type*)))
1155 ;;; If any of the VARS in FUN was never referenced and was not
1156 ;;; declared IGNORE, then complain.
1157 (defun note-unreferenced-vars (fun)
1158 (declare (type clambda fun))
1159 (dolist (var (lambda-vars fun))
1160 (unless (or (leaf-ever-used var)
1161 (lambda-var-ignorep var))
1162 (let ((*compiler-error-context* (lambda-bind fun)))
1163 (unless (policy *compiler-error-context* (= inhibit-warnings 3))
1164 ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
1165 ;; requires this to be no more than a STYLE-WARNING.
1166 (compiler-style-warn "The variable ~S is defined but never used."
1167 (leaf-debug-name var)))
1168 (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
1171 (defvar *deletion-ignored-objects* '(t nil))
1173 ;;; Return true if we can find OBJ in FORM, NIL otherwise. We bound
1174 ;;; our recursion so that we don't get lost in circular structures. We
1175 ;;; ignore the car of forms if they are a symbol (to prevent confusing
1176 ;;; function referencess with variables), and we also ignore anything
1178 (defun present-in-form (obj form depth)
1179 (declare (type (integer 0 20) depth))
1180 (cond ((= depth 20) nil)
1184 (let ((first (car form))
1186 (if (member first '(quote function))
1188 (or (and (not (symbolp first))
1189 (present-in-form obj first depth))
1190 (do ((l (cdr form) (cdr l))
1192 ((or (atom l) (> n 100))
1194 (declare (fixnum n))
1195 (when (present-in-form obj (car l) depth)
1198 ;;; This function is called on a block immediately before we delete
1199 ;;; it. We check to see whether any of the code about to die appeared
1200 ;;; in the original source, and emit a note if so.
1202 ;;; If the block was in a lambda is now deleted, then we ignore the
1203 ;;; whole block, since this case is picked off in DELETE-LAMBDA. We
1204 ;;; also ignore the deletion of CRETURN nodes, since it is somewhat
1205 ;;; reasonable for a function to not return, and there is a different
1206 ;;; note for that case anyway.
1208 ;;; If the actual source is an atom, then we use a bunch of heuristics
1209 ;;; to guess whether this reference really appeared in the original
1211 ;;; -- If a symbol, it must be interned and not a keyword.
1212 ;;; -- It must not be an easily introduced constant (T or NIL, a fixnum
1213 ;;; or a character.)
1214 ;;; -- The atom must be "present" in the original source form, and
1215 ;;; present in all intervening actual source forms.
1216 (defun note-block-deletion (block)
1217 (let ((home (block-home-lambda block)))
1218 (unless (eq (functional-kind home) :deleted)
1219 (do-nodes (node cont block)
1220 (let* ((path (node-source-path node))
1221 (first (first path)))
1222 (when (or (eq first 'original-source-start)
1224 (or (not (symbolp first))
1225 (let ((pkg (symbol-package first)))
1227 (not (eq pkg (symbol-package :end))))))
1228 (not (member first *deletion-ignored-objects*))
1229 (not (typep first '(or fixnum character)))
1231 (present-in-form first x 0))
1232 (source-path-forms path))
1233 (present-in-form first (find-original-source path)
1235 (unless (return-p node)
1236 (let ((*compiler-error-context* node))
1237 (compiler-note "deleting unreachable code")))
1241 ;;; Delete a node from a block, deleting the block if there are no
1242 ;;; nodes left. We remove the node from the uses of its CONT, but we
1243 ;;; don't deal with cleaning up any type-specific semantic
1244 ;;; attachments. If the CONT is :UNUSED after deleting this use, then
1245 ;;; we delete CONT. (Note :UNUSED is not the same as no uses. A
1246 ;;; continuation will only become :UNUSED if it was :INSIDE-BLOCK
1249 ;;; If the node is the last node, there must be exactly one successor.
1250 ;;; We link all of our precedessors to the successor and unlink the
1251 ;;; block. In this case, we return T, otherwise NIL. If no nodes are
1252 ;;; left, and the block is a successor of itself, then we replace the
1253 ;;; only node with a degenerate exit node. This provides a way to
1254 ;;; represent the bodyless infinite loop, given the prohibition on
1255 ;;; empty blocks in IR1.
1256 (defun unlink-node (node)
1257 (declare (type node node))
1258 (let* ((cont (node-cont node))
1259 (next (continuation-next cont))
1260 (prev (node-prev node))
1261 (block (continuation-block prev))
1262 (prev-kind (continuation-kind prev))
1263 (last (block-last block)))
1265 (unless (eq (continuation-kind cont) :deleted)
1266 (delete-continuation-use node)
1267 (when (eq (continuation-kind cont) :unused)
1268 (aver (not (continuation-dest cont)))
1269 (delete-continuation cont)))
1271 (setf (block-type-asserted block) t)
1272 (setf (block-test-modified block) t)
1274 (cond ((or (eq prev-kind :inside-block)
1275 (and (eq prev-kind :block-start)
1276 (not (eq node last))))
1277 (cond ((eq node last)
1278 (setf (block-last block) (continuation-use prev))
1279 (setf (continuation-next prev) nil))
1281 (setf (continuation-next prev) next)
1282 (setf (node-prev next) prev)
1283 (when (and (if-p next) ; AOP wanted
1284 (eq prev (if-test next)))
1285 (reoptimize-continuation prev))))
1286 (setf (node-prev node) nil)
1289 (aver (eq prev-kind :block-start))
1290 (aver (eq node last))
1291 (let* ((succ (block-succ block))
1292 (next (first succ)))
1293 (aver (singleton-p succ))
1295 ((member block succ)
1296 (with-ir1-environment-from-node node
1297 (let ((exit (make-exit))
1298 (dummy (make-continuation)))
1299 (setf (continuation-next prev) nil)
1300 (link-node-to-previous-continuation exit prev)
1301 (add-continuation-use exit dummy)
1302 (setf (block-last block) exit)))
1303 (setf (node-prev node) nil)
1306 (aver (eq (block-start-cleanup block)
1307 (block-end-cleanup block)))
1308 (unlink-blocks block next)
1309 (dolist (pred (block-pred block))
1310 (change-block-successor pred block next))
1311 (remove-from-dfo block)
1312 (cond ((continuation-dest prev)
1313 (setf (continuation-next prev) nil)
1314 (setf (continuation-kind prev) :deleted-block-start))
1316 (delete-continuation prev)))
1317 (setf (node-prev node) nil)
1320 ;;; Return true if NODE has been deleted, false if it is still a valid
1322 (defun node-deleted (node)
1323 (declare (type node node))
1324 (let ((prev (node-prev node)))
1326 (not (eq (continuation-kind prev) :deleted))
1327 (let ((block (continuation-block prev)))
1328 (and (block-component block)
1329 (not (block-delete-p block))))))))
1331 ;;; Delete all the blocks and functions in COMPONENT. We scan first
1332 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
1333 ;;; triggered by deletion.
1334 (defun delete-component (component)
1335 (declare (type component component))
1336 (aver (null (component-new-functionals component)))
1337 (setf (component-kind component) :deleted)
1338 (do-blocks (block component)
1339 (setf (block-delete-p block) t))
1340 (dolist (fun (component-lambdas component))
1341 (setf (functional-kind fun) nil)
1342 (setf (functional-entry-fun fun) nil)
1343 (setf (leaf-refs fun) nil)
1344 (delete-functional fun))
1345 (do-blocks (block component)
1346 (delete-block block))
1349 ;;; Convert code of the form
1350 ;;; (FOO ... (FUN ...) ...)
1352 ;;; (FOO ... ... ...).
1353 ;;; In other words, replace the function combination FUN by its
1354 ;;; arguments. If there are any problems with doing this, use GIVE-UP
1355 ;;; to blow out of whatever transform called this. Note, as the number
1356 ;;; of arguments changes, the transform must be prepared to return a
1357 ;;; lambda with a new lambda-list with the correct number of
1359 (defun extract-fun-args (cont fun num-args)
1361 "If CONT is a call to FUN with NUM-ARGS args, change those arguments
1362 to feed directly to the continuation-dest of CONT, which must be
1364 (declare (type continuation cont)
1366 (type index num-args))
1367 (let ((outside (continuation-dest cont))
1368 (inside (continuation-use cont)))
1369 (aver (combination-p outside))
1370 (unless (combination-p inside)
1371 (give-up-ir1-transform))
1372 (let ((inside-fun (combination-fun inside)))
1373 (unless (eq (continuation-fun-name inside-fun) fun)
1374 (give-up-ir1-transform))
1375 (let ((inside-args (combination-args inside)))
1376 (unless (= (length inside-args) num-args)
1377 (give-up-ir1-transform))
1378 (let* ((outside-args (combination-args outside))
1379 (arg-position (position cont outside-args))
1380 (before-args (subseq outside-args 0 arg-position))
1381 (after-args (subseq outside-args (1+ arg-position))))
1382 (dolist (arg inside-args)
1383 (setf (continuation-dest arg) outside)
1384 (flush-continuation-externally-checkable-type arg))
1385 (setf (combination-args inside) nil)
1386 (setf (combination-args outside)
1387 (append before-args inside-args after-args))
1388 (change-ref-leaf (continuation-use inside-fun)
1389 (find-free-fun 'list "???"))
1390 (setf (combination-kind inside)
1391 (info :function :info 'list))
1392 (setf (node-derived-type inside) *wild-type*)
1396 (defun flush-combination (combination)
1397 (declare (type combination combination))
1398 (flush-dest (combination-fun combination))
1399 (dolist (arg (combination-args combination))
1401 (unlink-node combination)
1407 ;;; Change the LEAF that a REF refers to.
1408 (defun change-ref-leaf (ref leaf)
1409 (declare (type ref ref) (type leaf leaf))
1410 (unless (eq (ref-leaf ref) leaf)
1411 (push ref (leaf-refs leaf))
1413 (setf (ref-leaf ref) leaf)
1414 (setf (leaf-ever-used leaf) t)
1415 (let* ((ltype (leaf-type leaf))
1416 (vltype (make-single-value-type ltype)))
1417 (if (let* ((cont (node-cont ref))
1418 (dest (continuation-dest cont)))
1419 (and (basic-combination-p dest)
1420 (eq cont (basic-combination-fun dest))
1421 (csubtypep ltype (specifier-type 'function))))
1422 (setf (node-derived-type ref) vltype)
1423 (derive-node-type ref vltype)))
1424 (reoptimize-continuation (node-cont ref)))
1427 ;;; Change all REFS for OLD-LEAF to NEW-LEAF.
1428 (defun substitute-leaf (new-leaf old-leaf)
1429 (declare (type leaf new-leaf old-leaf))
1430 (dolist (ref (leaf-refs old-leaf))
1431 (change-ref-leaf ref new-leaf))
1434 ;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
1435 ;;; whether to substitute
1436 (defun substitute-leaf-if (test new-leaf old-leaf)
1437 (declare (type leaf new-leaf old-leaf) (type function test))
1438 (dolist (ref (leaf-refs old-leaf))
1439 (when (funcall test ref)
1440 (change-ref-leaf ref new-leaf)))
1443 ;;; Return a LEAF which represents the specified constant object. If
1444 ;;; the object is not in *CONSTANTS*, then we create a new constant
1445 ;;; LEAF and enter it.
1446 (defun find-constant (object)
1448 ;; FIXME: What is the significance of this test? ("things
1449 ;; that are worth uniquifying"?)
1450 '(or symbol number character instance))
1451 (or (gethash object *constants*)
1452 (setf (gethash object *constants*)
1453 (make-constant :value object
1454 :%source-name '.anonymous.
1455 :type (ctype-of object)
1456 :where-from :defined)))
1457 (make-constant :value object
1458 :%source-name '.anonymous.
1459 :type (ctype-of object)
1460 :where-from :defined)))
1462 ;;; Return true if VAR would have to be closed over if environment
1463 ;;; analysis ran now (i.e. if there are any uses that have a different
1464 ;;; home lambda than VAR's home.)
1465 (defun closure-var-p (var)
1466 (declare (type lambda-var var))
1467 (let ((home (lambda-var-home var)))
1468 (cond ((eq (functional-kind home) :deleted)
1470 (t (let ((home (lambda-home home)))
1472 (find home l :key #'node-home-lambda
1474 (or (frob (leaf-refs var))
1475 (frob (basic-var-sets var)))))))))
1477 ;;; If there is a non-local exit noted in ENTRY's environment that
1478 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
1479 (defun find-nlx-info (entry cont)
1480 (declare (type entry entry) (type continuation cont))
1481 (let ((entry-cleanup (entry-cleanup entry)))
1482 (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
1483 (when (and (eq (nlx-info-continuation nlx) cont)
1484 (eq (nlx-info-cleanup nlx) entry-cleanup))
1487 ;;;; functional hackery
1489 (declaim (ftype (function (functional) clambda) main-entry))
1490 (defun main-entry (functional)
1491 (etypecase functional
1492 (clambda functional)
1494 (optional-dispatch-main-entry functional))))
1496 ;;; RETURN true if FUNCTIONAL is a thing that can be treated like
1497 ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
1498 ;;; optional with null default and no SUPPLIED-P. There must be a
1499 ;;; &REST arg with no references.
1500 (declaim (ftype (function (functional) boolean) looks-like-an-mv-bind))
1501 (defun looks-like-an-mv-bind (functional)
1502 (and (optional-dispatch-p functional)
1503 (do ((arg (optional-dispatch-arglist functional) (cdr arg)))
1505 (let ((info (lambda-var-arg-info (car arg))))
1506 (unless info (return nil))
1507 (case (arg-info-kind info)
1509 (when (or (arg-info-supplied-p info) (arg-info-default info))
1512 (return (and (null (cdr arg)) (null (leaf-refs (car arg))))))
1516 ;;; Return true if function is an external entry point. This is true
1517 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
1518 ;;; (:TOPLEVEL kind.)
1520 (declare (type functional fun))
1521 (not (null (member (functional-kind fun) '(:external :toplevel)))))
1523 ;;; If CONT's only use is a non-notinline global function reference,
1524 ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
1525 ;;; is true, then we don't care if the leaf is NOTINLINE.
1526 (defun continuation-fun-name (cont &optional notinline-ok)
1527 (declare (type continuation cont))
1528 (let ((use (continuation-use cont)))
1530 (let ((leaf (ref-leaf use)))
1531 (if (and (global-var-p leaf)
1532 (eq (global-var-kind leaf) :global-function)
1533 (or (not (defined-fun-p leaf))
1534 (not (eq (defined-fun-inlinep leaf) :notinline))
1536 (leaf-source-name leaf)
1540 ;;; Return the source name of a combination. (This is an idiom
1541 ;;; which was used in CMU CL. I gather it always works. -- WHN)
1542 (defun combination-fun-source-name (combination)
1543 (let ((ref (continuation-use (combination-fun combination))))
1544 (leaf-source-name (ref-leaf ref))))
1546 ;;; Return the COMBINATION node that is the call to the LET FUN.
1547 (defun let-combination (fun)
1548 (declare (type clambda fun))
1549 (aver (functional-letlike-p fun))
1550 (continuation-dest (node-cont (first (leaf-refs fun)))))
1552 ;;; Return the initial value continuation for a LET variable, or NIL
1553 ;;; if there is none.
1554 (defun let-var-initial-value (var)
1555 (declare (type lambda-var var))
1556 (let ((fun (lambda-var-home var)))
1557 (elt (combination-args (let-combination fun))
1558 (position-or-lose var (lambda-vars fun)))))
1560 ;;; Return the LAMBDA that is called by the local CALL.
1561 (defun combination-lambda (call)
1562 (declare (type basic-combination call))
1563 (aver (eq (basic-combination-kind call) :local))
1564 (ref-leaf (continuation-use (basic-combination-fun call))))
1566 (defvar *inline-expansion-limit* 200
1568 "an upper limit on the number of inline function calls that will be expanded
1569 in any given code object (single function or block compilation)")
1571 ;;; Check whether NODE's component has exceeded its inline expansion
1572 ;;; limit, and warn if so, returning NIL.
1573 (defun inline-expansion-ok (node)
1574 (let ((expanded (incf (component-inline-expansions
1576 (node-block node))))))
1577 (cond ((> expanded *inline-expansion-limit*) nil)
1578 ((= expanded *inline-expansion-limit*)
1579 ;; FIXME: If the objective is to stop the recursive
1580 ;; expansion of inline functions, wouldn't it be more
1581 ;; correct to look back through surrounding expansions
1582 ;; (which are, I think, stored in the *CURRENT-PATH*, and
1583 ;; possibly stored elsewhere too) and suppress expansion
1584 ;; and print this warning when the function being proposed
1585 ;; for inline expansion is found there? (I don't like the
1586 ;; arbitrary numerical limit in principle, and I think
1587 ;; it'll be a nuisance in practice if we ever want the
1588 ;; compiler to be able to use WITH-COMPILATION-UNIT on
1589 ;; arbitrarily huge blocks of code. -- WHN)
1590 (let ((*compiler-error-context* node))
1591 (compiler-note "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
1592 probably trying to~% ~
1593 inline a recursive function."
1594 *inline-expansion-limit*))
1600 ;;; Apply a function to some arguments, returning a list of the values
1601 ;;; resulting of the evaluation. If an error is signalled during the
1602 ;;; application, then we produce a warning message using WARN-FUN and
1603 ;;; return NIL as our second value to indicate this. NODE is used as
1604 ;;; the error context for any error message, and CONTEXT is a string
1605 ;;; that is spliced into the warning.
1606 (declaim (ftype (function ((or symbol function) list node function string)
1607 (values list boolean))
1609 (defun careful-call (function args node warn-fun context)
1611 (multiple-value-list
1612 (handler-case (apply function args)
1614 (let ((*compiler-error-context* node))
1615 (funcall warn-fun "Lisp error during ~A:~%~A" context condition)
1616 (return-from careful-call (values nil nil))))))
1619 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
1622 ((deffrob (basic careful compiler transform)
1624 (defun ,careful (specifier)
1625 (handler-case (,basic specifier)
1626 (simple-error (condition)
1627 (values nil (list* (simple-condition-format-control condition)
1628 (simple-condition-format-arguments condition))))))
1629 (defun ,compiler (specifier)
1630 (multiple-value-bind (type error-args) (,careful specifier)
1632 (apply #'compiler-error error-args))))
1633 (defun ,transform (specifier)
1634 (multiple-value-bind (type error-args) (,careful specifier)
1636 (apply #'give-up-ir1-transform
1638 (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type)
1639 (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type))
1642 ;;;; utilities used at run-time for parsing &KEY args in IR1
1644 ;;; This function is used by the result of PARSE-DEFTRANSFORM to find
1645 ;;; the continuation for the value of the &KEY argument KEY in the
1646 ;;; list of continuations ARGS. It returns the continuation if the
1647 ;;; keyword is present, or NIL otherwise. The legality and
1648 ;;; constantness of the keywords should already have been checked.
1649 (declaim (ftype (function (list keyword) (or continuation null))
1650 find-keyword-continuation))
1651 (defun find-keyword-continuation (args key)
1652 (do ((arg args (cddr arg)))
1654 (when (eq (continuation-value (first arg)) key)
1655 (return (second arg)))))
1657 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
1658 ;;; verify that alternating continuations in ARGS are constant and
1659 ;;; that there is an even number of args.
1660 (declaim (ftype (function (list) boolean) check-key-args-constant))
1661 (defun check-key-args-constant (args)
1662 (do ((arg args (cddr arg)))
1664 (unless (and (rest arg)
1665 (constant-continuation-p (first arg)))
1668 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
1669 ;;; verify that the list of continuations ARGS is a well-formed &KEY
1670 ;;; arglist and that only keywords present in the list KEYS are
1672 (declaim (ftype (function (list list) boolean) check-transform-keys))
1673 (defun check-transform-keys (args keys)
1674 (and (check-key-args-constant args)
1675 (do ((arg args (cddr arg)))
1677 (unless (member (continuation-value (first arg)) keys)
1682 ;;; Called by the expansion of the EVENT macro.
1683 (declaim (ftype (function (event-info (or node null)) *) %event))
1684 (defun %event (info node)
1685 (incf (event-info-count info))
1686 (when (and (>= (event-info-level info) *event-note-threshold*)
1687 (policy (or node *lexenv*)
1688 (= inhibit-warnings 0)))
1689 (let ((*compiler-error-context* node))
1690 (compiler-note (event-info-description info))))
1692 (let ((action (event-info-action info)))
1693 (when action (funcall action node))))
1696 (defun make-cast (value type policy)
1697 (declare (type continuation value)
1699 (type policy policy))
1700 (%make-cast :asserted-type type
1701 :type-to-check (maybe-weaken-check type policy)
1703 :derived-type (coerce-to-values type)))
1705 (defun cast-type-check (cast)
1706 (declare (type cast cast))
1707 (when (cast-reoptimize cast)
1708 (ir1-optimize-cast cast t))
1709 (cast-%type-check cast))
1711 (defun note-single-valuified-continuation (cont)
1712 (declare (type continuation cont))
1713 (let ((use (continuation-use cont)))
1715 (let ((leaf (ref-leaf use)))
1716 (when (and (lambda-var-p leaf)
1717 (null (rest (leaf-refs leaf))))
1718 (reoptimize-lambda-var leaf))))
1719 ((or (null use) (combination-p use))
1720 (dolist (node (find-uses cont))
1721 (setf (node-reoptimize node) t)
1722 (setf (block-reoptimize (node-block node)) t)
1723 (setf (component-reoptimize (node-component node)) t))))))