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 (defun lexenv-enclosing-cleanup (lexenv)
18 (declare (type lexenv lexenv
))
20 (lambda-call-lexenv (lexenv-lambda lexenv2
))))
22 (awhen (lexenv-cleanup lexenv2
)
25 ;;; Return the innermost cleanup enclosing NODE, or NIL if there is
26 ;;; none in its function. If NODE has no cleanup, but is in a LET,
27 ;;; then we must still check the environment that the call is in.
28 (defun node-enclosing-cleanup (node)
29 (declare (type node node
))
30 (lexenv-enclosing-cleanup (node-lexenv node
)))
32 (defun map-nested-cleanups (function lexenv
&optional return-value
)
33 (declare (type lexenv lexenv
))
34 (do ((cleanup (lexenv-enclosing-cleanup lexenv
)
35 (node-enclosing-cleanup (cleanup-mess-up cleanup
))))
36 ((not cleanup
) return-value
)
37 (funcall function cleanup
)))
39 ;;; Convert the FORM in a block inserted between BLOCK1 and BLOCK2 as
40 ;;; an implicit MV-PROG1. The inserted block is returned. NODE is used
41 ;;; for IR1 context when converting the form. Note that the block is
42 ;;; not assigned a number, and is linked into the DFO at the
43 ;;; beginning. We indicate that we have trashed the DFO by setting
44 ;;; COMPONENT-REANALYZE. If CLEANUP is supplied, then convert with
46 (defun insert-cleanup-code (block1 block2 node form
&optional cleanup
)
47 (declare (type cblock block1 block2
) (type node node
)
48 (type (or cleanup null
) cleanup
))
49 (setf (component-reanalyze (block-component block1
)) t
)
50 (with-ir1-environment-from-node node
51 (with-component-last-block (*current-component
*
52 (block-next (component-head *current-component
*)))
53 (let* ((start (make-ctran))
54 (block (ctran-starts-block start
))
57 (make-lexenv :cleanup cleanup
)
59 (change-block-successor block1 block2 block
)
60 (link-blocks block block2
)
61 (ir1-convert start next nil form
)
62 (setf (block-last block
) (ctran-use next
))
63 (setf (node-next (block-last block
)) nil
)
68 ;;; Return a list of all the nodes which use LVAR.
69 (declaim (ftype (sfunction (lvar) list
) find-uses
))
70 (defun find-uses (lvar)
71 (ensure-list (lvar-uses lvar
)))
73 (declaim (ftype (sfunction (lvar) lvar
) principal-lvar
))
74 (defun principal-lvar (lvar)
76 (let ((use (lvar-uses lvar
)))
82 (defun principal-lvar-use (lvar)
84 (declare (type lvar lvar
))
85 (let ((use (lvar-uses lvar
)))
87 (plu (cast-value use
))
91 (defun principal-lvar-dest (lvar)
93 (declare (type lvar lvar
))
94 (let ((dest (lvar-dest lvar
)))
96 (pld (cast-lvar dest
))
100 ;;; Update lvar use information so that NODE is no longer a use of its
103 ;;; Note: if you call this function, you may have to do a
104 ;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
106 (declaim (ftype (sfunction (node) (values))
109 ;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may
110 ;;; be given a new use.
111 (defun %delete-lvar-use
(node)
112 (let ((lvar (node-lvar node
)))
114 (if (listp (lvar-uses lvar
))
115 (let ((new-uses (delq node
(lvar-uses lvar
))))
116 (setf (lvar-uses lvar
)
117 (if (singleton-p new-uses
)
120 (setf (lvar-uses lvar
) nil
))
123 ;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete
124 ;;; its DEST's block, which must be unreachable.
125 (defun delete-lvar-use (node)
126 (let ((lvar (node-lvar node
)))
128 (%delete-lvar-use node
)
129 (if (null (lvar-uses lvar
))
130 (binding* ((dest (lvar-dest lvar
) :exit-if-null
)
131 (() (not (node-deleted dest
)) :exit-if-null
)
132 (block (node-block dest
)))
133 (mark-for-deletion block
))
134 (reoptimize-lvar lvar
))))
137 ;;; Update lvar use information so that NODE uses LVAR.
139 ;;; Note: if you call this function, you may have to do a
140 ;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
142 (declaim (ftype (sfunction (node (or lvar null
)) (values)) add-lvar-use
))
143 (defun add-lvar-use (node lvar
)
144 (aver (not (node-lvar node
)))
146 (let ((uses (lvar-uses lvar
)))
147 (setf (lvar-uses lvar
)
154 (setf (node-lvar node
) lvar
)))
158 ;;; Return true if LVAR destination is executed immediately after
159 ;;; NODE. Cleanups are ignored.
160 (defun immediately-used-p (lvar node
)
161 (declare (type lvar lvar
) (type node node
))
162 (aver (eq (node-lvar node
) lvar
))
163 (let ((dest (lvar-dest lvar
)))
164 (acond ((node-next node
)
165 (eq (ctran-next it
) dest
))
166 (t (eq (block-start (first (block-succ (node-block node
))))
167 (node-prev dest
))))))
169 ;;; Returns the defined (usually untrusted) type of the combination,
170 ;;; or NIL if we couldn't figure it out.
171 (defun combination-defined-type (combination)
172 (let ((use (principal-lvar-use (basic-combination-fun combination
))))
173 (or (when (ref-p use
)
174 (let ((type (leaf-defined-type (ref-leaf use
))))
175 (when (fun-type-p type
)
176 (fun-type-returns type
))))
179 ;;; Return true if LVAR destination is executed after node with only
180 ;;; uninteresting nodes intervening.
182 ;;; Uninteresting nodes are nodes in the same block which are either
183 ;;; REFs, external CASTs to the same destination, or known combinations
184 ;;; that never unwind.
185 (defun almost-immediately-used-p (lvar node
)
186 (declare (type lvar lvar
)
188 (aver (eq (node-lvar node
) lvar
))
189 (let ((dest (lvar-dest lvar
)))
192 (let ((ctran (node-next node
)))
194 (setf node
(ctran-next ctran
))
196 (return-from almost-immediately-used-p t
)
201 (when (and (eq :external
(cast-type-check node
))
202 (eq dest
(node-dest node
)))
205 ;; KLUDGE: Unfortunately we don't have an attribute for
206 ;; "never unwinds", so we just special case
207 ;; %ALLOCATE-CLOSURES: it is easy to run into with eg.
208 ;; FORMAT and a non-constant first argument.
209 (when (eq '%allocate-closures
(combination-fun-source-name node nil
))
212 (when (eq (block-start (first (block-succ (node-block node
))))
214 (return-from almost-immediately-used-p t
))))))))
216 ;;;; lvar substitution
218 ;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be
219 ;;; NIL. We do not flush OLD's DEST.
220 (defun substitute-lvar (new old
)
221 (declare (type lvar old new
))
222 (aver (not (lvar-dest new
)))
223 (let ((dest (lvar-dest old
)))
226 (cif (setf (if-test dest
) new
))
227 (cset (setf (set-value dest
) new
))
228 (creturn (setf (return-result dest
) new
))
229 (exit (setf (exit-value dest
) new
))
231 (if (eq old
(basic-combination-fun dest
))
232 (setf (basic-combination-fun dest
) new
)
233 (setf (basic-combination-args dest
)
234 (nsubst new old
(basic-combination-args dest
)))))
235 (cast (setf (cast-value dest
) new
)))
237 (setf (lvar-dest old
) nil
)
238 (setf (lvar-dest new
) dest
)
239 (flush-lvar-externally-checkable-type new
))
242 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
243 ;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
244 (defun substitute-lvar-uses (new old propagate-dx
)
245 (declare (type lvar old
)
246 (type (or lvar null
) new
)
247 (type boolean propagate-dx
))
251 (%delete-lvar-use node
)
252 (add-lvar-use node new
))
253 (reoptimize-lvar new
)
254 (awhen (and propagate-dx
(lvar-dynamic-extent old
))
255 (setf (lvar-dynamic-extent old
) nil
)
256 (unless (lvar-dynamic-extent new
)
257 (setf (lvar-dynamic-extent new
) it
)
258 (setf (cleanup-info it
) (subst new old
(cleanup-info it
)))))
259 (when (lvar-dynamic-extent new
)
261 (node-ends-block node
))))
262 (t (flush-dest old
)))
266 ;;;; block starting/creation
268 ;;; Return the block that CTRAN is the start of, making a block if
269 ;;; necessary. This function is called by IR1 translators which may
270 ;;; cause a CTRAN to be used more than once. Every CTRAN which may be
271 ;;; used more than once must start a block by the time that anyone
272 ;;; does a USE-CTRAN on it.
274 ;;; We also throw the block into the next/prev list for the
275 ;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have
277 (defun ctran-starts-block (ctran)
278 (declare (type ctran ctran
))
279 (ecase (ctran-kind ctran
)
281 (aver (not (ctran-block ctran
)))
282 (let* ((next (component-last-block *current-component
*))
283 (prev (block-prev next
))
284 (new-block (make-block ctran
)))
285 (setf (block-next new-block
) next
286 (block-prev new-block
) prev
287 (block-prev next
) new-block
288 (block-next prev
) new-block
289 (ctran-block ctran
) new-block
290 (ctran-kind ctran
) :block-start
)
291 (aver (not (ctran-use ctran
)))
294 (ctran-block ctran
))))
296 ;;; Ensure that CTRAN is the start of a block so that the use set can
297 ;;; be freely manipulated.
298 (defun ensure-block-start (ctran)
299 (declare (type ctran ctran
))
300 (let ((kind (ctran-kind ctran
)))
304 (setf (ctran-block ctran
)
305 (make-block-key :start ctran
))
306 (setf (ctran-kind ctran
) :block-start
))
308 (node-ends-block (ctran-use ctran
)))))
311 ;;; CTRAN must be the last ctran in an incomplete block; finish the
312 ;;; block and start a new one if necessary.
313 (defun start-block (ctran)
314 (declare (type ctran ctran
))
315 (aver (not (ctran-next ctran
)))
316 (ecase (ctran-kind ctran
)
318 (let ((block (ctran-block ctran
))
319 (node (ctran-use ctran
)))
320 (aver (not (block-last block
)))
322 (setf (block-last block
) node
)
323 (setf (node-next node
) nil
)
324 (setf (ctran-use ctran
) nil
)
325 (setf (ctran-kind ctran
) :unused
)
326 (setf (ctran-block ctran
) nil
)
327 (link-blocks block
(ctran-starts-block ctran
))))
332 ;;; Filter values of LVAR through FORM, which must be an ordinary/mv
333 ;;; call. Exactly one argument must be 'DUMMY, which will be replaced
334 ;;; with LVAR. In case of an ordinary call the function should not
335 ;;; have return type NIL. We create a new "filtered" lvar.
337 ;;; TODO: remove preconditions.
338 (defun filter-lvar (lvar form
)
339 (declare (type lvar lvar
) (type list form
))
340 (let* ((dest (lvar-dest lvar
))
341 (ctran (node-prev dest
)))
342 (with-ir1-environment-from-node dest
344 (ensure-block-start ctran
)
345 (let* ((old-block (ctran-block ctran
))
346 (new-start (make-ctran))
347 (filtered-lvar (make-lvar))
348 (new-block (ctran-starts-block new-start
)))
350 ;; Splice in the new block before DEST, giving the new block
351 ;; all of DEST's predecessors.
352 (dolist (block (block-pred old-block
))
353 (change-block-successor block old-block new-block
))
355 (ir1-convert new-start ctran filtered-lvar form
)
357 ;; KLUDGE: Comments at the head of this function in CMU CL
358 ;; said that somewhere in here we
359 ;; Set the new block's start and end cleanups to the *start*
360 ;; cleanup of PREV's block. This overrides the incorrect
361 ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
362 ;; Unfortunately I can't find any code which corresponds to this.
363 ;; Perhaps it was a stale comment? Or perhaps I just don't
364 ;; understand.. -- WHN 19990521
366 ;; Replace 'DUMMY with the LVAR. (We can find 'DUMMY because
367 ;; no LET conversion has been done yet.) The [mv-]combination
368 ;; code from the call in the form will be the use of the new
369 ;; check lvar. We substitute exactly one argument.
370 (let* ((node (lvar-use filtered-lvar
))
372 (dolist (arg (basic-combination-args node
) (aver victim
))
373 (let* ((arg (principal-lvar arg
))
376 (when (and (ref-p use
)
377 (constant-p (setf leaf
(ref-leaf use
)))
378 (eql (constant-value leaf
) 'dummy
))
381 (aver (eq (constant-value (ref-leaf (lvar-use victim
)))
384 (substitute-lvar filtered-lvar lvar
)
385 (substitute-lvar lvar victim
)
388 ;; Invoking local call analysis converts this call to a LET.
389 (locall-analyze-component *current-component
*))))
392 ;;; Delete NODE and VALUE. It may result in some calls becoming tail.
393 (defun delete-filter (node lvar value
)
394 (aver (eq (lvar-dest value
) node
))
395 (aver (eq (node-lvar node
) lvar
))
396 (cond (lvar (collect ((merges))
397 (when (return-p (lvar-dest lvar
))
399 (when (and (basic-combination-p use
)
400 (eq (basic-combination-kind use
) :local
))
402 (substitute-lvar-uses lvar value
403 (and lvar
(eq (lvar-uses lvar
) node
)))
404 (%delete-lvar-use node
)
407 (dolist (merge (merges))
408 (merge-tail-sets merge
)))))
409 (t (flush-dest value
)
410 (unlink-node node
))))
412 ;;; Make a CAST and insert it into IR1 before node NEXT.
413 (defun insert-cast-before (next lvar type policy
&optional context
)
414 (declare (type node next
) (type lvar lvar
) (type ctype type
))
415 (with-ir1-environment-from-node next
416 (let* ((ctran (node-prev next
))
417 (cast (make-cast lvar type policy context
))
418 (internal-ctran (make-ctran)))
419 (setf (ctran-next ctran
) cast
420 (node-prev cast
) ctran
)
421 (use-ctran cast internal-ctran
)
422 (link-node-to-previous-ctran next internal-ctran
)
423 (setf (lvar-dest lvar
) cast
)
424 (reoptimize-lvar lvar
)
425 (when (return-p next
)
426 (node-ends-block cast
))
427 (setf (block-attributep (block-flags (node-block cast
))
428 type-check type-asserted
)
432 ;;;; miscellaneous shorthand functions
434 ;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since
435 ;;; the LEXENV-LAMBDA may be deleted, we must chain up the
436 ;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't
437 ;;; deleted, and then return its home.
438 (defun node-home-lambda (node)
439 (declare (type node node
))
440 (do ((fun (lexenv-lambda (node-lexenv node
))
441 (lexenv-lambda (lambda-call-lexenv fun
))))
442 ((not (memq (functional-kind fun
) '(:deleted
:zombie
)))
444 (when (eq (lambda-home fun
) fun
)
447 (declaim (ftype (sfunction (node) component
) node-component
))
448 (defun node-component (node)
449 (block-component (node-block node
)))
450 (declaim (ftype (sfunction (node) physenv
) node-physenv
))
451 (defun node-physenv (node)
452 (lambda-physenv (node-home-lambda node
)))
454 #!-sb-fluid
(declaim (inline node-stack-allocate-p
))
455 (defun node-stack-allocate-p (node)
456 (awhen (node-lvar node
)
457 (lvar-dynamic-extent it
)))
459 (defun flushable-combination-p (call)
460 (declare (type combination call
))
461 (let ((kind (combination-kind call
))
462 (info (combination-fun-info call
)))
463 (when (and (eq kind
:known
) (fun-info-p info
))
464 (let ((attr (fun-info-attributes info
)))
465 (when (and (not (ir1-attributep attr call
))
466 ;; FIXME: For now, don't consider potentially flushable
467 ;; calls flushable when they have the CALL attribute.
468 ;; Someday we should look at the functional args to
469 ;; determine if they have any side effects.
470 (if (policy call
(= safety
3))
471 (ir1-attributep attr flushable
)
472 (ir1-attributep attr unsafely-flushable
)))
475 ;;;; DYNAMIC-EXTENT related
477 (defun lambda-var-original-name (leaf)
478 (let ((home (lambda-var-home leaf
)))
479 (if (eq :external
(functional-kind home
))
480 (let* ((entry (functional-entry-fun home
))
481 (p (1- (position leaf
(lambda-vars home
)))))
483 (if (optional-dispatch-p entry
)
484 (elt (optional-dispatch-arglist entry
) p
)
485 (elt (lambda-vars entry
) p
))))
486 (leaf-debug-name leaf
))))
488 (defun note-no-stack-allocation (lvar &key flush
)
489 (do-uses (use (principal-lvar lvar
))
491 ;; Don't complain about not being able to stack allocate constants.
492 (and (ref-p use
) (constant-p (ref-leaf use
)))
493 ;; If we're flushing, don't complain if we can flush the combination.
494 (and flush
(combination-p use
) (flushable-combination-p use
))
495 ;; Don't report those with homes in :OPTIONAL -- we'd get doubled
497 (and (ref-p use
) (lambda-var-p (ref-leaf use
))
498 (eq :optional
(lambda-kind (lambda-var-home (ref-leaf use
))))))
499 ;; FIXME: For the first leg (lambda-bind (lambda-var-home ...))
500 ;; would be a far better description, but since we use
501 ;; *COMPILER-ERROR-CONTEXT* for muffling we can't -- as that node
502 ;; can have different handled conditions.
503 (let ((*compiler-error-context
* use
))
504 (if (and (ref-p use
) (lambda-var-p (ref-leaf use
)))
505 (compiler-notify "~@<could~2:I not stack allocate ~S in: ~S~:@>"
506 (lambda-var-original-name (ref-leaf use
))
507 (find-original-source (node-source-path use
)))
508 (compiler-notify "~@<could~2:I not stack allocate: ~S~:@>"
509 (find-original-source (node-source-path use
))))))))
511 (defun use-good-for-dx-p (use dx
&optional component
)
512 ;; FIXME: Can casts point to LVARs in other components?
513 ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the
514 ;; PRINCIPAL-LVAR is always in the same component as the original one. It
515 ;; would be either good to have an explanation of why casts don't point
516 ;; across components, or an explanation of when they do it. ...in the
517 ;; meanwhile AVER that our assumption holds true.
518 (aver (or (not component
) (eq component
(node-component use
))))
519 (or (dx-combination-p use dx
)
521 (not (cast-type-check use
))
522 (lvar-good-for-dx-p (cast-value use
) dx component
))
523 (and (trivial-lambda-var-ref-p use
)
524 (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use
))))
526 (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use
) dx component
))))))
528 (defun lvar-good-for-dx-p (lvar dx
&optional component
)
529 (let ((uses (lvar-uses lvar
))) ; TODO use ENSURE-LIST? or is it too slow?
533 (use-good-for-dx-p use dx component
))
535 (use-good-for-dx-p uses dx component
))))
537 (defun known-dx-combination-p (use dx
)
538 (and (eq (combination-kind use
) :known
)
539 (let ((info (combination-fun-info use
)))
540 (or (awhen (fun-info-stack-allocate-result info
)
542 (awhen (fun-info-result-arg info
)
543 (lvar-good-for-dx-p (nth it
(combination-args use
))
546 ;;; Bound to NIL in RECHECK-DYNAMIC-EXTENT-LVARS, so that the
547 ;;; combinations that didn't get converted are not treated as dx-safe.
548 (defvar *dx-combination-p-check-local
* t
)
550 (defun dx-combination-p (use dx
)
551 (and (combination-p use
)
553 ;; Known, and can do DX.
554 (known-dx-combination-p use dx
)
555 ;; Possibly a not-yet-eliminated lambda which ends up returning the
556 ;; results of an actual known DX combination.
557 (and *dx-combination-p-check-local
*
558 (let* ((fun (combination-fun use
))
559 (ref (principal-lvar-use fun
))
560 (clambda (when (ref-p ref
)
562 (creturn (when (lambda-p clambda
)
563 (lambda-return clambda
)))
564 (result-use (when (return-p creturn
)
565 (principal-lvar-use (return-result creturn
)))))
566 ;; FIXME: We should be able to deal with multiple uses here as well.
567 (and (dx-combination-p result-use dx
)
568 (combination-args-flow-cleanly-p use result-use dx
)))))))
570 (defun combination-args-flow-cleanly-p (combination1 combination2 dx
)
571 (labels ((recurse (combination)
572 (or (eq combination combination2
)
573 (if (known-dx-combination-p combination dx
)
574 (let ((dest (lvar-dest (combination-lvar combination
))))
575 (and (combination-p dest
)
577 (let* ((fun1 (combination-fun combination
))
578 (ref1 (principal-lvar-use fun1
))
579 (clambda1 (when (ref-p ref1
) (ref-leaf ref1
))))
580 (when (lambda-p clambda1
)
581 (dolist (var (lambda-vars clambda1
) t
)
582 (dolist (var-ref (lambda-var-refs var
))
583 (let* ((lvar (ref-lvar var-ref
))
584 (dest (and lvar
(principal-lvar-dest lvar
))))
585 (unless (or (not dest
)
586 (and (combination-p dest
) (recurse dest
)))
587 (return-from combination-args-flow-cleanly-p nil
)))))))))))
588 (recurse combination1
)))
590 (defun ref-good-for-dx-p (ref)
591 (let* ((lvar (ref-lvar ref
))
592 (dest (when lvar
(lvar-dest lvar
))))
593 (and (combination-p dest
)
594 (eq :known
(combination-kind dest
))
595 (awhen (combination-fun-info dest
)
596 (or (ir1-attributep (fun-info-attributes it
) dx-safe
)
597 (and (not (combination-lvar dest
))
598 (awhen (fun-info-result-arg it
)
599 (eql lvar
(nth it
(combination-args dest
))))))))))
601 (defun trivial-lambda-var-ref-p (use)
603 (let ((var (ref-leaf use
)))
604 ;; lambda-var, no SETS, not explicitly indefinite-extent.
605 (when (and (lambda-var-p var
) (not (lambda-var-sets var
))
606 (neq :indefinite
(lambda-var-extent var
)))
607 (let ((home (lambda-var-home var
))
608 (refs (lambda-var-refs var
)))
609 ;; bound by a non-XEP system lambda, no other REFS that aren't
610 ;; DX-SAFE, or are result-args when the result is discarded.
611 (when (and (lambda-system-lambda-p home
)
612 (neq :external
(lambda-kind home
))
614 (unless (or (eq use ref
) (ref-good-for-dx-p ref
))
616 ;; the LAMBDA this var is bound by has only a single REF, going
618 (let* ((lambda-refs (lambda-refs home
))
619 (primary (car lambda-refs
)))
621 (not (cdr lambda-refs
))
622 (combination-p (lvar-dest (ref-lvar primary
)))))))))))
624 (defun trivial-lambda-var-ref-lvar (use)
625 (let* ((this (ref-leaf use
))
626 (fun (lambda-var-home this
))
627 (vars (lambda-vars fun
))
628 (combination (lvar-dest (ref-lvar (car (lambda-refs fun
)))))
629 (args (combination-args combination
)))
630 (aver (= (length vars
) (length args
)))
631 (loop for var in vars
636 ;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends.
637 (defun handle-nested-dynamic-extent-lvars (dx lvar
&optional recheck-component
)
638 (let ((uses (lvar-uses lvar
)))
639 ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS.
640 ;; Uses of mupltiple-use LVARs already end their blocks, so we just need
641 ;; to process uses of single-use LVARs.
643 (node-ends-block uses
))
644 ;; If this LVAR's USE is good for DX, it is either a CAST, or it
645 ;; must be a regular combination whose arguments are potentially DX as well.
646 (flet ((recurse (use)
649 (handle-nested-dynamic-extent-lvars
650 dx
(cast-value use
) recheck-component
))
652 (loop for arg in
(combination-args use
)
653 ;; deleted args show up as NIL here
655 (lvar-good-for-dx-p arg dx recheck-component
))
656 append
(handle-nested-dynamic-extent-lvars
657 dx arg recheck-component
)))
659 (let* ((other (trivial-lambda-var-ref-lvar use
)))
660 (unless (eq other lvar
)
661 (handle-nested-dynamic-extent-lvars
662 dx other recheck-component
)))))))
664 (if (listp uses
) ; TODO use ENSURE-LIST? or is it too slow?
665 (loop for use in uses
666 when
(use-good-for-dx-p use dx recheck-component
)
668 (when (use-good-for-dx-p uses dx recheck-component
)
673 (declaim (inline block-to-be-deleted-p
))
674 (defun block-to-be-deleted-p (block)
675 (or (block-delete-p block
)
676 (eq (functional-kind (block-home-lambda block
)) :deleted
)))
678 ;;; Checks whether NODE is in a block to be deleted
679 (declaim (inline node-to-be-deleted-p
))
680 (defun node-to-be-deleted-p (node)
681 (block-to-be-deleted-p (node-block node
)))
683 (declaim (ftype (sfunction (clambda) cblock
) lambda-block
))
684 (defun lambda-block (clambda)
685 (node-block (lambda-bind clambda
)))
686 (declaim (ftype (sfunction (clambda) component
) lambda-component
))
687 (defun lambda-component (clambda)
688 (block-component (lambda-block clambda
)))
690 (declaim (ftype (sfunction (cblock) node
) block-start-node
))
691 (defun block-start-node (block)
692 (ctran-next (block-start block
)))
694 ;;; Return the enclosing cleanup for environment of the first or last
696 (defun block-start-cleanup (block)
697 (node-enclosing-cleanup (block-start-node block
)))
698 (defun block-end-cleanup (block)
699 (node-enclosing-cleanup (block-last block
)))
701 ;;; Return the lexenv of the last node in BLOCK.
702 (defun block-end-lexenv (block)
703 (node-lexenv (block-last block
)))
705 ;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL
706 ;;; if there is none.
708 ;;; There can legitimately be no home lambda in dead code early in the
709 ;;; IR1 conversion process, e.g. when IR1-converting the SETQ form in
710 ;;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
711 ;;; where the block is just a placeholder during parsing and doesn't
712 ;;; actually correspond to code which will be written anywhere.
713 (declaim (ftype (sfunction (cblock) (or clambda null
)) block-home-lambda-or-null
))
714 (defun block-home-lambda-or-null (block)
715 (if (node-p (block-last block
))
716 ;; This is the old CMU CL way of doing it.
717 (node-home-lambda (block-last block
))
718 ;; Now that SBCL uses this operation more aggressively than CMU
719 ;; CL did, the old CMU CL way of doing it can fail in two ways.
720 ;; 1. It can fail in a few cases even when a meaningful home
721 ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of
723 ;; 2. It can fail when converting a form which is born orphaned
724 ;; so that it never had a meaningful home lambda, e.g. a form
725 ;; which follows a RETURN-FROM or GO form.
726 (let ((pred-list (block-pred block
)))
727 ;; To deal with case 1, we reason that
728 ;; previous-in-target-execution-order blocks should be in the
729 ;; same lambda, and that they seem in practice to be
730 ;; previous-in-compilation-order blocks too, so we look back
731 ;; to find one which is sufficiently initialized to tell us
732 ;; what the home lambda is.
734 ;; We could get fancy about this, flooding through the
735 ;; graph of all the previous blocks, but in practice it
736 ;; seems to work just to grab the first previous block and
738 (node-home-lambda (block-last (first pred-list
)))
739 ;; In case 2, we end up with an empty PRED-LIST and
740 ;; have to punt: There's no home lambda.
743 ;;; Return the non-LET LAMBDA that holds BLOCK's code.
744 (declaim (ftype (sfunction (cblock) clambda
) block-home-lambda
))
745 (defun block-home-lambda (block)
746 (block-home-lambda-or-null block
))
748 ;;; Return the IR1 physical environment for BLOCK.
749 (declaim (ftype (sfunction (cblock) physenv
) block-physenv
))
750 (defun block-physenv (block)
751 (lambda-physenv (block-home-lambda block
)))
753 ;;; Return the Top Level Form number of PATH, i.e. the ordinal number
754 ;;; of its original source's top level form in its compilation unit.
755 (defun source-path-tlf-number (path)
756 (declare (list path
))
759 ;;; Return the (reversed) list for the PATH in the original source
760 ;;; (with the Top Level Form number last).
761 (defun source-path-original-source (path)
762 (declare (list path
) (inline member
))
763 (cddr (member 'original-source-start path
:test
#'eq
)))
765 ;;; Return the Form Number of PATH's original source inside the Top
766 ;;; Level Form that contains it. This is determined by the order that
767 ;;; we walk the subforms of the top level source form.
768 (defun source-path-form-number (path)
769 (declare (list path
) (inline member
))
770 (cadr (member 'original-source-start path
:test
#'eq
)))
772 ;;; Return a list of all the enclosing forms not in the original
773 ;;; source that converted to get to this form, with the immediate
774 ;;; source for node at the start of the list.
775 (defun source-path-forms (path)
776 (subseq path
0 (position 'original-source-start path
)))
778 (defun tree-some (predicate tree
)
779 (let ((seen (make-hash-table)))
780 (labels ((walk (tree)
781 (cond ((funcall predicate tree
))
783 (not (gethash tree seen
)))
784 (setf (gethash tree seen
) t
)
785 (or (walk (car tree
))
786 (walk (cdr tree
)))))))
789 ;;; Return the innermost source form for NODE.
790 (defun node-source-form (node)
791 (declare (type node node
))
792 (let* ((path (node-source-path node
))
793 (forms (remove-if (lambda (x)
794 (tree-some #'leaf-p x
))
795 (source-path-forms path
))))
796 ;; another option: if first form includes a leaf, return
797 ;; find-original-source instead.
800 (values (find-original-source path
)))))
802 ;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise
804 (defun lvar-source (lvar)
805 (let ((use (lvar-uses lvar
)))
808 (values (node-source-form use
) t
))))
810 (defun common-suffix (x y
)
811 (let ((mismatch (mismatch x y
:from-end t
)))
816 ;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a
817 ;;; singleton. Otherwise, return a list of the lowest common
818 ;;; ancestor source form of all the uses (if it can be found),
819 ;;; followed by all the uses' source forms.
820 (defun lvar-all-sources (lvar)
821 (let ((use (lvar-uses lvar
)))
824 (path (node-source-path (first use
))))
825 (dolist (use use
(cons (if (find 'original-source-start path
)
826 (find-original-source path
)
829 (pushnew (node-source-form use
) forms
)
830 (setf path
(common-suffix path
831 (node-source-path use
)))))
832 (list (node-source-form use
)))))
834 ;;; Return the LAMBDA that is CTRAN's home, or NIL if there is none.
835 (declaim (ftype (sfunction (ctran) (or clambda null
))
836 ctran-home-lambda-or-null
))
837 (defun ctran-home-lambda-or-null (ctran)
838 ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
839 ;; implementation might not be quite right, or might be uglier than
840 ;; necessary. It appears that the original Python never found a need
841 ;; to do this operation. The obvious things based on
842 ;; NODE-HOME-LAMBDA of CTRAN-USE usually work; then if that fails,
843 ;; BLOCK-HOME-LAMBDA of CTRAN-BLOCK works, given that we
844 ;; generalize it enough to grovel harder when the simple CMU CL
845 ;; approach fails, and furthermore realize that in some exceptional
846 ;; cases it might return NIL. -- WHN 2001-12-04
847 (cond ((ctran-use ctran
)
848 (node-home-lambda (ctran-use ctran
)))
850 (block-home-lambda-or-null (ctran-block ctran
)))
852 (bug "confused about home lambda for ~S" ctran
))))
854 ;;; Return the LAMBDA that is CTRAN's home.
855 (declaim (ftype (sfunction (ctran) clambda
) ctran-home-lambda
))
856 (defun ctran-home-lambda (ctran)
857 (ctran-home-lambda-or-null ctran
))
859 (declaim (inline cast-single-value-p
))
860 (defun cast-single-value-p (cast)
861 (not (values-type-p (cast-asserted-type cast
))))
863 #!-sb-fluid
(declaim (inline lvar-single-value-p
))
864 (defun lvar-single-value-p (lvar)
865 (or (not lvar
) (%lvar-single-value-p lvar
)))
866 (defun %lvar-single-value-p
(lvar)
867 (let ((dest (lvar-dest lvar
)))
872 (eq (basic-combination-fun dest
) lvar
))
874 (and (cast-single-value-p dest
)
875 (acond ((node-lvar dest
) (%lvar-single-value-p it
))
879 (defun principal-lvar-end (lvar)
880 (loop for prev
= lvar then
(node-lvar dest
)
881 for dest
= (and prev
(lvar-dest prev
))
883 finally
(return (values dest prev
))))
885 (defun principal-lvar-single-valuify (lvar)
886 (loop for prev
= lvar then
(node-lvar dest
)
887 for dest
= (and prev
(lvar-dest prev
))
889 do
(setf (node-derived-type dest
)
890 (make-short-values-type (list (single-value-type
891 (node-derived-type dest
)))))
892 (reoptimize-lvar prev
)))
894 ;;; Return a new LEXENV just like DEFAULT except for the specified
895 ;;; slot values. Values for the alist slots are APPENDed to the
896 ;;; beginning of the current value, rather than replacing it entirely.
897 (defun make-lexenv (&key
(default *lexenv
*)
898 funs vars blocks tags
900 (lambda (lexenv-lambda default
))
901 (cleanup (lexenv-cleanup default
))
902 (handled-conditions (lexenv-handled-conditions default
))
903 (disabled-package-locks
904 (lexenv-disabled-package-locks default
))
905 (policy (lexenv-policy default
))
906 (user-data (lexenv-user-data default
)))
907 (macrolet ((frob (var slot
)
908 `(let ((old (,slot default
)))
912 (internal-make-lexenv
913 (frob funs lexenv-funs
)
914 (frob vars lexenv-vars
)
915 (frob blocks lexenv-blocks
)
916 (frob tags lexenv-tags
)
917 (frob type-restrictions lexenv-type-restrictions
)
919 cleanup handled-conditions disabled-package-locks
924 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
926 (defun make-restricted-lexenv (lexenv)
927 (flet ((fun-good-p (fun)
928 (destructuring-bind (name . thing
) fun
929 (declare (ignore name
))
933 (cons (aver (eq (car thing
) 'macro
))
936 (destructuring-bind (name . thing
) var
937 (declare (ignore name
))
939 ;; The evaluator will mark lexicals with :BOGUS when it
940 ;; translates an interpreter lexenv to a compiler
942 ((or leaf
#!+sb-eval
(member :bogus
)) nil
)
943 (cons (aver (eq (car thing
) 'macro
))
945 (heap-alien-info nil
)))))
946 (internal-make-lexenv
947 (remove-if-not #'fun-good-p
(lexenv-funs lexenv
))
948 (remove-if-not #'var-good-p
(lexenv-vars lexenv
))
951 (lexenv-type-restrictions lexenv
) ; XXX
954 (lexenv-handled-conditions lexenv
)
955 (lexenv-disabled-package-locks lexenv
)
956 (lexenv-policy lexenv
)
957 (lexenv-user-data lexenv
)
960 ;;;; flow/DFO/component hackery
962 ;;; Join BLOCK1 and BLOCK2.
963 (defun link-blocks (block1 block2
)
964 (declare (type cblock block1 block2
))
965 (setf (block-succ block1
)
966 (if (block-succ block1
)
967 (%link-blocks block1 block2
)
969 (push block1
(block-pred block2
))
971 (defun %link-blocks
(block1 block2
)
972 (declare (type cblock block1 block2
))
973 (let ((succ1 (block-succ block1
)))
974 (aver (not (memq block2 succ1
)))
975 (cons block2 succ1
)))
977 ;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If
978 ;;; this leaves a successor with a single predecessor that ends in an
979 ;;; IF, then set BLOCK-TEST-MODIFIED so that any test constraint will
980 ;;; now be able to be propagated to the successor.
981 (defun unlink-blocks (block1 block2
)
982 (declare (type cblock block1 block2
))
983 (let ((succ1 (block-succ block1
)))
984 (if (eq block2
(car succ1
))
985 (setf (block-succ block1
) (cdr succ1
))
986 (do ((succ (cdr succ1
) (cdr succ
))
988 ((eq (car succ
) block2
)
989 (setf (cdr prev
) (cdr succ
)))
992 (let ((new-pred (delq block1
(block-pred block2
))))
993 (setf (block-pred block2
) new-pred
)
994 (when (singleton-p new-pred
)
995 (let ((pred-block (first new-pred
)))
996 (when (if-p (block-last pred-block
))
997 (setf (block-test-modified pred-block
) t
)))))
1000 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK
1001 ;;; and NEW. If BLOCK ends in an IF, then we have to fix up the
1002 ;;; consequent/alternative blocks to point to NEW. We also set
1003 ;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to
1004 ;;; the new successor.
1005 (defun change-block-successor (block old new
)
1006 (declare (type cblock new old block
))
1007 (unlink-blocks block old
)
1008 (let ((last (block-last block
))
1009 (comp (block-component block
)))
1010 (setf (component-reanalyze comp
) t
)
1013 (setf (block-test-modified block
) t
)
1014 (let* ((succ-left (block-succ block
))
1015 (new (if (and (eq new
(component-tail comp
))
1019 (unless (memq new succ-left
)
1020 (link-blocks block new
))
1021 (macrolet ((frob (slot)
1022 `(when (eq (,slot last
) old
)
1023 (setf (,slot last
) new
))))
1024 (frob if-consequent
)
1025 (frob if-alternative
)
1026 (when (eq (if-consequent last
)
1027 (if-alternative last
))
1028 (reoptimize-component (block-component block
) :maybe
)))))
1030 (unless (memq new
(block-succ block
))
1031 (link-blocks block new
)))))
1035 ;;; Unlink a block from the next/prev chain. We also null out the
1037 (declaim (ftype (sfunction (cblock) (values)) remove-from-dfo
))
1038 (defun remove-from-dfo (block)
1039 (let ((next (block-next block
))
1040 (prev (block-prev block
)))
1041 (setf (block-component block
) nil
)
1042 (setf (block-next prev
) next
)
1043 (setf (block-prev next
) prev
))
1046 ;;; Add BLOCK to the next/prev chain following AFTER. We also set the
1047 ;;; COMPONENT to be the same as for AFTER.
1048 (defun add-to-dfo (block after
)
1049 (declare (type cblock block after
))
1050 (let ((next (block-next after
))
1051 (comp (block-component after
)))
1052 (aver (not (eq (component-kind comp
) :deleted
)))
1053 (setf (block-component block
) comp
)
1054 (setf (block-next after
) block
)
1055 (setf (block-prev block
) after
)
1056 (setf (block-next block
) next
)
1057 (setf (block-prev next
) block
))
1060 ;;; List all NLX-INFOs which BLOCK can exit to.
1062 ;;; We hope that no cleanup actions are performed in the middle of
1063 ;;; BLOCK, so it is enough to look only at cleanups in the block
1064 ;;; end. The tricky thing is a special cleanup block; all its nodes
1065 ;;; have the same cleanup info, corresponding to the start, so the
1066 ;;; same approach returns safe result.
1067 (defun map-block-nlxes (fun block
&optional dx-cleanup-fun
)
1068 (do-nested-cleanups (cleanup (block-end-lexenv block
))
1069 (let ((mess-up (cleanup-mess-up cleanup
)))
1070 (case (cleanup-kind cleanup
)
1072 (aver (entry-p mess-up
))
1073 (loop for exit in
(entry-exits mess-up
)
1074 for nlx-info
= (exit-nlx-info exit
)
1075 do
(funcall fun nlx-info
)))
1076 ((:catch
:unwind-protect
)
1077 (aver (combination-p mess-up
))
1078 (let* ((arg-lvar (first (basic-combination-args mess-up
)))
1079 (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar
)))))
1080 (funcall fun nlx-info
)))
1082 (when dx-cleanup-fun
1083 (funcall dx-cleanup-fun cleanup
)))))))
1085 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
1086 ;;; the head and tail which are set to T.
1087 (declaim (ftype (sfunction (component) (values)) clear-flags
))
1088 (defun clear-flags (component)
1089 (let ((head (component-head component
))
1090 (tail (component-tail component
)))
1091 (setf (block-flag head
) t
)
1092 (setf (block-flag tail
) t
)
1093 (do-blocks (block component
)
1094 (setf (block-flag block
) nil
)))
1097 ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially
1098 ;;; true in the head and tail blocks.
1099 (declaim (ftype (sfunction () component
) make-empty-component
))
1100 (defun make-empty-component ()
1101 (let* ((head (make-block-key :start nil
:component nil
))
1102 (tail (make-block-key :start nil
:component nil
))
1103 (res (make-component head tail
)))
1104 (setf (block-flag head
) t
)
1105 (setf (block-flag tail
) t
)
1106 (setf (block-component head
) res
)
1107 (setf (block-component tail
) res
)
1108 (setf (block-next head
) tail
)
1109 (setf (block-prev tail
) head
)
1112 ;;; Make NODE the LAST node in its block, splitting the block if necessary.
1113 ;;; The new block is added to the DFO immediately following NODE's block.
1114 (defun node-ends-block (node)
1115 (declare (type node node
))
1116 (let* ((block (node-block node
))
1117 (start (node-next node
))
1118 (last (block-last block
)))
1119 (check-type last node
)
1120 (unless (eq last node
)
1121 (aver (and (eq (ctran-kind start
) :inside-block
)
1122 (not (block-delete-p block
))))
1123 (let* ((succ (block-succ block
))
1125 (make-block-key :start start
1126 :component
(block-component block
)
1127 :succ succ
:last last
)))
1128 (setf (ctran-kind start
) :block-start
)
1129 (setf (ctran-use start
) nil
)
1130 (setf (block-last block
) node
)
1131 (setf (node-next node
) nil
)
1133 (setf (block-pred b
)
1134 (cons new-block
(remove block
(block-pred b
)))))
1135 (setf (block-succ block
) ())
1136 (link-blocks block new-block
)
1137 (add-to-dfo new-block block
)
1138 (setf (component-reanalyze (block-component block
)) t
)
1140 (do ((ctran start
(node-next (ctran-next ctran
))))
1142 (setf (ctran-block ctran
) new-block
))
1144 (setf (block-type-asserted block
) t
)
1145 (setf (block-test-modified block
) t
))))
1150 ;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
1151 (defun delete-lambda-var (leaf)
1152 (declare (type lambda-var leaf
))
1154 (setf (lambda-var-deleted leaf
) t
)
1155 ;; Iterate over all local calls flushing the corresponding argument,
1156 ;; allowing the computation of the argument to be deleted. We also
1157 ;; mark the LET for reoptimization, since it may be that we have
1158 ;; deleted its last variable.
1159 (let* ((fun (lambda-var-home leaf
))
1160 (n (position leaf
(lambda-vars fun
))))
1161 (dolist (ref (leaf-refs fun
))
1162 (let* ((lvar (node-lvar ref
))
1163 (dest (and lvar
(lvar-dest lvar
))))
1164 (when (and (combination-p dest
)
1165 (eq (basic-combination-fun dest
) lvar
)
1166 (eq (basic-combination-kind dest
) :local
))
1167 (let* ((args (basic-combination-args dest
))
1169 (reoptimize-lvar arg
)
1171 (setf (elt args n
) nil
))))))
1173 ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
1174 ;; too much difficulty, since we can efficiently implement
1175 ;; write-only variables. We iterate over the SETs, marking their
1176 ;; blocks for dead code flushing, since we can delete SETs whose
1178 (dolist (set (lambda-var-sets leaf
))
1179 (setf (block-flush-p (node-block set
)) t
))
1183 ;;; Note that something interesting has happened to VAR.
1184 (defun reoptimize-lambda-var (var)
1185 (declare (type lambda-var var
))
1186 (let ((fun (lambda-var-home var
)))
1187 ;; We only deal with LET variables, marking the corresponding
1188 ;; initial value arg as needing to be reoptimized.
1189 (when (and (eq (functional-kind fun
) :let
)
1191 (do ((args (basic-combination-args
1192 (lvar-dest (node-lvar (first (leaf-refs fun
)))))
1194 (vars (lambda-vars fun
) (cdr vars
)))
1195 ((eq (car vars
) var
)
1196 (reoptimize-lvar (car args
))))))
1199 ;;; Delete a function that has no references. This need only be called
1200 ;;; on functions that never had any references, since otherwise
1201 ;;; DELETE-REF will handle the deletion.
1202 (defun delete-functional (fun)
1203 (aver (and (null (leaf-refs fun
))
1204 (not (functional-entry-fun fun
))))
1206 (optional-dispatch (delete-optional-dispatch fun
))
1207 (clambda (delete-lambda fun
)))
1210 ;;; Deal with deleting the last reference to a CLAMBDA, which means
1211 ;;; that the lambda is unreachable, so that its body may be
1212 ;;; deleted. We set FUNCTIONAL-KIND to :DELETED and rely on
1213 ;;; IR1-OPTIMIZE to delete its blocks.
1214 (defun delete-lambda (clambda)
1215 (declare (type clambda clambda
))
1216 (let ((original-kind (functional-kind clambda
))
1217 (bind (lambda-bind clambda
)))
1218 (aver (not (member original-kind
'(:deleted
:toplevel
))))
1219 (aver (not (functional-has-external-references-p clambda
)))
1220 (aver (or (eq original-kind
:zombie
) bind
))
1221 (setf (functional-kind clambda
) :deleted
)
1222 (setf (lambda-bind clambda
) nil
)
1224 (labels ((delete-children (lambda)
1225 (dolist (child (lambda-children lambda
))
1226 (cond ((eq (functional-kind child
) :deleted
)
1227 (delete-children child
))
1229 (delete-lambda child
))))
1230 (setf (lambda-children lambda
) nil
)
1231 (setf (lambda-parent lambda
) nil
)))
1232 (delete-children clambda
))
1234 ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
1235 ;; that we're using the old value of the KIND slot, not the
1236 ;; current slot value, which has now been set to :DELETED.)
1239 ((:let
:mv-let
:assignment
)
1240 (let ((bind-block (node-block bind
)))
1241 (mark-for-deletion bind-block
))
1242 (let ((home (lambda-home clambda
)))
1243 (setf (lambda-lets home
) (delete clambda
(lambda-lets home
))))
1244 ;; KLUDGE: In presence of NLEs we cannot always understand that
1245 ;; LET's BIND dominates its body [for a LET "its" body is not
1246 ;; quite its]; let's delete too dangerous for IR2 stuff. --
1248 (dolist (var (lambda-vars clambda
))
1249 (flet ((delete-node (node)
1250 (mark-for-deletion (node-block node
))))
1251 (mapc #'delete-node
(leaf-refs var
))
1252 (mapc #'delete-node
(lambda-var-sets var
)))))
1254 ;; Function has no reachable references.
1255 (dolist (ref (lambda-refs clambda
))
1256 (mark-for-deletion (node-block ref
)))
1257 ;; If the function isn't a LET, we unlink the function head
1258 ;; and tail from the component head and tail to indicate that
1259 ;; the code is unreachable. We also delete the function from
1260 ;; COMPONENT-LAMBDAS (it won't be there before local call
1261 ;; analysis, but no matter.) If the lambda was never
1262 ;; referenced, we give a note.
1263 (let* ((bind-block (node-block bind
))
1264 (component (block-component bind-block
))
1265 (return (lambda-return clambda
))
1266 (return-block (and return
(node-block return
))))
1267 (unless (leaf-ever-used clambda
)
1268 (let ((*compiler-error-context
* bind
))
1269 (compiler-notify 'code-deletion-note
1270 :format-control
"deleting unused function~:[.~;~:*~% ~S~]"
1271 :format-arguments
(list (leaf-debug-name clambda
)))))
1272 (unless (block-delete-p bind-block
)
1273 (unlink-blocks (component-head component
) bind-block
))
1274 (when (and return-block
(not (block-delete-p return-block
)))
1275 (mark-for-deletion return-block
)
1276 (unlink-blocks return-block
(component-tail component
)))
1277 (setf (component-reanalyze component
) t
)
1278 (let ((tails (lambda-tail-set clambda
)))
1279 (setf (tail-set-funs tails
)
1280 (delete clambda
(tail-set-funs tails
)))
1281 (setf (lambda-tail-set clambda
) nil
))
1282 (setf (component-lambdas component
)
1283 (delq clambda
(component-lambdas component
))))))
1285 ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
1286 ;; ENTRY-FUN so that people will know that it is not an entry
1288 (when (eq original-kind
:external
)
1289 (let ((fun (functional-entry-fun clambda
)))
1290 (setf (functional-entry-fun fun
) nil
)
1291 (when (optional-dispatch-p fun
)
1292 (delete-optional-dispatch fun
)))))
1296 ;;; Deal with deleting the last reference to an OPTIONAL-DISPATCH. We
1297 ;;; have to be a bit more careful than with lambdas, since DELETE-REF
1298 ;;; is used both before and after local call analysis. Afterward, all
1299 ;;; references to still-existing OPTIONAL-DISPATCHes have been moved
1300 ;;; to the XEP, leaving it with no references at all. So we look at
1301 ;;; the XEP to see whether an optional-dispatch is still really being
1302 ;;; used. But before local call analysis, there are no XEPs, and all
1303 ;;; references are direct.
1305 ;;; When we do delete the OPTIONAL-DISPATCH, we grovel all of its
1306 ;;; entry-points, making them be normal lambdas, and then deleting the
1307 ;;; ones with no references. This deletes any e-p lambdas that were
1308 ;;; either never referenced, or couldn't be deleted when the last
1309 ;;; reference was deleted (due to their :OPTIONAL kind.)
1311 ;;; Note that the last optional entry point may alias the main entry,
1312 ;;; so when we process the main entry, its KIND may have been changed
1313 ;;; to NIL or even converted to a LETlike value.
1314 (defun delete-optional-dispatch (leaf)
1315 (declare (type optional-dispatch leaf
))
1316 (let ((entry (functional-entry-fun leaf
)))
1318 (or (leaf-refs entry
)
1319 (eq (functional-kind entry
) :external
)))
1320 (aver (or (not entry
) (eq (functional-kind entry
) :deleted
)))
1321 (setf (functional-kind leaf
) :deleted
)
1324 (unless (eq (functional-kind fun
) :deleted
)
1325 (aver (eq (functional-kind fun
) :optional
))
1326 (setf (functional-kind fun
) nil
)
1327 (let ((refs (leaf-refs fun
)))
1329 (delete-lambda fun
))
1331 (or (maybe-let-convert fun
)
1332 (maybe-convert-to-assignment fun
)))
1334 (maybe-convert-to-assignment fun
)))))))
1336 (dolist (ep (optional-dispatch-entry-points leaf
))
1337 (when (promise-ready-p ep
)
1339 (when (optional-dispatch-more-entry leaf
)
1340 (frob (optional-dispatch-more-entry leaf
)))
1341 (let ((main (optional-dispatch-main-entry leaf
)))
1343 (setf (functional-entry-fun entry
) main
)
1344 (setf (functional-entry-fun main
) entry
))
1345 (when (eq (functional-kind main
) :optional
)
1350 ;;; This is called by locall-analyze-fun-1 after it convers a call to
1351 ;;; FUN into a local call.
1352 ;;; Presumably, the function can be no longer reused by new calls to
1353 ;;; FUN, so the whole thing has to be removed from *FREE-FUNS*
1354 (defun note-local-functional (fun)
1355 (declare (type functional fun
))
1356 (when (and (leaf-has-source-name-p fun
)
1357 (eq (leaf-source-name fun
) (functional-debug-name fun
)))
1358 (let* ((name (leaf-source-name fun
))
1359 (defined-fun (gethash name
*free-funs
*)))
1360 (when (defined-fun-p defined-fun
)
1361 (remhash name
*free-funs
*)))))
1363 ;;; Return functional for DEFINED-FUN which has been converted in policy
1364 ;;; corresponding to the current one, or NIL if no such functional exists.
1366 ;;; Also check that the parent of the functional is visible in the current
1367 ;;; environment and is in the current component.
1368 (defun defined-fun-functional (defined-fun)
1369 (let ((functionals (defined-fun-functionals defined-fun
)))
1371 (let* ((sample (car functionals
))
1372 (there (lambda-parent (if (lambda-p sample
)
1374 (optional-dispatch-main-entry sample
)))))
1376 (labels ((lookup (here)
1377 (unless (eq here there
)
1379 (lookup (lambda-parent here
))
1380 ;; We looked up all the way up, and didn't find the parent
1381 ;; of the functional -- therefore it is nested in a lambda
1382 ;; we don't see, so return nil.
1383 (return-from defined-fun-functional nil
)))))
1384 (lookup (lexenv-lambda *lexenv
*)))))
1385 ;; Now find a functional whose policy matches the current one, if we already
1387 (let ((policy (lexenv-%policy
*lexenv
*)))
1388 (dolist (functional functionals
)
1389 (when (and (policy= policy
(lexenv-%policy
(functional-lexenv functional
)))
1390 (eq (lambda-component
1392 (if (lambda-p functional
)
1394 (optional-dispatch-main-entry functional
))))
1395 *current-component
*))
1396 (return functional
)))))))
1398 ;;; Do stuff to delete the semantic attachments of a REF node. When
1399 ;;; this leaves zero or one reference, we do a type dispatch off of
1400 ;;; the leaf to determine if a special action is appropriate.
1401 (defun delete-ref (ref)
1402 (declare (type ref ref
))
1403 (let* ((leaf (ref-leaf ref
))
1404 (refs (delq ref
(leaf-refs leaf
))))
1405 (setf (leaf-refs leaf
) refs
)
1410 (delete-lambda-var leaf
))
1412 (ecase (functional-kind leaf
)
1413 ((nil :let
:mv-let
:assignment
:escape
:cleanup
)
1414 (aver (null (functional-entry-fun leaf
)))
1415 (delete-lambda leaf
))
1417 (unless (functional-has-external-references-p leaf
)
1418 (delete-lambda leaf
)))
1419 ((:deleted
:zombie
:optional
))))
1421 (unless (eq (functional-kind leaf
) :deleted
)
1422 (delete-optional-dispatch leaf
)))))
1425 (clambda (or (maybe-let-convert leaf
)
1426 (maybe-convert-to-assignment leaf
)))
1427 (lambda-var (reoptimize-lambda-var leaf
))))
1430 (clambda (maybe-convert-to-assignment leaf
))))))
1434 ;;; This function is called to unlink a node from its LVAR;
1435 ;;; we assume that the LVAR's USE list has already been updated,
1436 ;;; and that we only have to mark the node as up for dead code
1437 ;;; elimination, and to clear it LVAR slot.
1438 (defun flush-node (node)
1439 (declare (type node node
))
1440 (let* ((prev (node-prev node
))
1441 (block (ctran-block prev
)))
1442 (reoptimize-component (block-component block
) t
)
1443 (setf (block-attributep (block-flags block
)
1444 flush-p type-asserted type-check
)
1446 (setf (node-lvar node
) nil
))
1448 ;;; This function is called by people who delete nodes; it provides a
1449 ;;; way to indicate that the value of a lvar is no longer used. We
1450 ;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses
1451 ;;; of LVAR and set COMPONENT-REOPTIMIZE.
1452 (defun flush-dest (lvar)
1453 (declare (type (or lvar null
) lvar
))
1455 (when (lvar-dynamic-extent lvar
)
1456 (note-no-stack-allocation lvar
:flush t
))
1457 (setf (lvar-dest lvar
) nil
)
1458 (flush-lvar-externally-checkable-type lvar
)
1461 (setf (lvar-uses lvar
) nil
))
1464 (defun delete-dest (lvar)
1466 (let* ((dest (lvar-dest lvar
))
1467 (prev (node-prev dest
)))
1468 (let ((block (ctran-block prev
)))
1469 (unless (block-delete-p block
)
1470 (mark-for-deletion block
))))))
1472 ;;; Queue the block for deletion
1473 (defun delete-block-lazily (block)
1474 (declare (type cblock block
))
1475 (unless (block-delete-p block
)
1476 (setf (block-delete-p block
) t
)
1477 (push block
(component-delete-blocks (block-component block
)))))
1479 ;;; Do a graph walk backward from BLOCK, marking all predecessor
1480 ;;; blocks with the DELETE-P flag.
1481 (defun mark-for-deletion (block)
1482 (declare (type cblock block
))
1483 (let* ((component (block-component block
))
1484 (head (component-head component
)))
1485 (labels ((helper (block)
1486 (delete-block-lazily block
)
1487 (dolist (pred (block-pred block
))
1488 (unless (or (block-delete-p pred
)
1491 (unless (block-delete-p block
)
1493 (setf (component-reanalyze component
) t
))))
1496 ;;; This function does what is necessary to eliminate the code in it
1497 ;;; from the IR1 representation. This involves unlinking it from its
1498 ;;; predecessors and successors and deleting various node-specific
1499 ;;; semantic information. BLOCK must be already removed from
1500 ;;; COMPONENT-DELETE-BLOCKS.
1501 (defun delete-block (block &optional silent
)
1502 (declare (type cblock block
))
1503 (aver (block-component block
)) ; else block is already deleted!
1504 #!+high-security
(aver (not (memq block
(component-delete-blocks (block-component block
)))))
1506 (note-block-deletion block
))
1507 (setf (block-delete-p block
) t
)
1509 (dolist (b (block-pred block
))
1510 (unlink-blocks b block
)
1511 ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
1512 ;; broken when successors were deleted without setting the
1513 ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
1514 ;; doesn't happen again.
1515 (aver (not (and (null (block-succ b
))
1516 (not (block-delete-p b
))
1517 (not (eq b
(component-head (block-component b
))))))))
1518 (dolist (b (block-succ block
))
1519 (unlink-blocks block b
))
1521 (do-nodes-carefully (node block
)
1522 (when (valued-node-p node
)
1523 (delete-lvar-use node
))
1525 (ref (delete-ref node
))
1526 (cif (flush-dest (if-test node
)))
1527 ;; The next two cases serve to maintain the invariant that a LET
1528 ;; always has a well-formed COMBINATION, REF and BIND. We delete
1529 ;; the lambda whenever we delete any of these, but we must be
1530 ;; careful that this LET has not already been partially deleted.
1532 (when (and (eq (basic-combination-kind node
) :local
)
1533 ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
1534 (lvar-uses (basic-combination-fun node
)))
1535 (let ((fun (combination-lambda node
)))
1536 ;; If our REF was the second-to-last ref, and has been
1537 ;; deleted, then FUN may be a LET for some other
1539 (when (and (functional-letlike-p fun
)
1540 (eq (let-combination fun
) node
))
1541 (delete-lambda fun
))))
1542 (flush-dest (basic-combination-fun node
))
1543 (dolist (arg (basic-combination-args node
))
1544 (when arg
(flush-dest arg
))))
1546 (let ((lambda (bind-lambda node
)))
1547 (unless (eq (functional-kind lambda
) :deleted
)
1548 (delete-lambda lambda
))))
1550 (let ((value (exit-value node
))
1551 (entry (exit-entry node
)))
1555 (setf (entry-exits entry
)
1556 (delq node
(entry-exits entry
))))))
1558 (dolist (exit (entry-exits node
))
1559 (mark-for-deletion (node-block exit
)))
1560 (let ((home (node-home-lambda node
)))
1561 (setf (lambda-entries home
) (delq node
(lambda-entries home
)))))
1563 (flush-dest (return-result node
))
1564 (delete-return node
))
1566 (flush-dest (set-value node
))
1567 (let ((var (set-var node
)))
1568 (setf (basic-var-sets var
)
1569 (delete node
(basic-var-sets var
)))))
1571 (flush-dest (cast-value node
)))))
1573 (remove-from-dfo block
)
1576 ;;; Do stuff to indicate that the return node NODE is being deleted.
1577 (defun delete-return (node)
1578 (declare (type creturn node
))
1579 (let* ((fun (return-lambda node
))
1580 (tail-set (lambda-tail-set fun
)))
1581 (aver (lambda-return fun
))
1582 (setf (lambda-return fun
) nil
)
1583 (when (and tail-set
(not (find-if #'lambda-return
1584 (tail-set-funs tail-set
))))
1585 (setf (tail-set-type tail-set
) *empty-type
*)))
1588 ;;; If any of the VARS in FUN was never referenced and was not
1589 ;;; declared IGNORE, then complain.
1590 (defun note-unreferenced-vars (vars policy
)
1592 (unless (or (leaf-ever-used var
)
1593 (lambda-var-ignorep var
))
1594 (unless (policy policy
(= inhibit-warnings
3))
1595 ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
1596 ;; requires this to be no more than a STYLE-WARNING.
1598 (compiler-style-warn "The variable ~S is defined but never used."
1599 (leaf-debug-name var
))
1600 ;; There's no reason to accept this kind of equivocation
1601 ;; when compiling our own code, though.
1603 (warn "The variable ~S is defined but never used."
1604 (leaf-debug-name var
)))
1605 (setf (leaf-ever-used var
) t
)))) ; to avoid repeated warnings? -- WHN
1607 (defun note-unreferenced-fun-vars (fun)
1608 (declare (type clambda fun
))
1609 (let ((*compiler-error-context
* (lambda-bind fun
)))
1610 (note-unreferenced-vars (lambda-vars fun
)
1611 *compiler-error-context
*))
1614 (defvar *deletion-ignored-objects
* '(t nil
))
1616 ;;; Return true if we can find OBJ in FORM, NIL otherwise. We bound
1617 ;;; our recursion so that we don't get lost in circular structures. We
1618 ;;; ignore the car of forms if they are a symbol (to prevent confusing
1619 ;;; function referencess with variables), and we also ignore anything
1621 (defun present-in-form (obj form depth
)
1622 (declare (type (integer 0 20) depth
))
1623 (cond ((= depth
20) nil
)
1627 (let ((first (car form
))
1629 (if (member first
'(quote function
))
1631 (or (and (not (symbolp first
))
1632 (present-in-form obj first depth
))
1633 (do ((l (cdr form
) (cdr l
))
1635 ((or (atom l
) (> n
100))
1637 (declare (fixnum n
))
1638 (when (present-in-form obj
(car l
) depth
)
1641 ;;; This function is called on a block immediately before we delete
1642 ;;; it. We check to see whether any of the code about to die appeared
1643 ;;; in the original source, and emit a note if so.
1645 ;;; If the block was in a lambda is now deleted, then we ignore the
1646 ;;; whole block, since this case is picked off in DELETE-LAMBDA. We
1647 ;;; also ignore the deletion of CRETURN nodes, since it is somewhat
1648 ;;; reasonable for a function to not return, and there is a different
1649 ;;; note for that case anyway.
1651 ;;; If the actual source is an atom, then we use a bunch of heuristics
1652 ;;; to guess whether this reference really appeared in the original
1654 ;;; -- If a symbol, it must be interned and not a keyword.
1655 ;;; -- It must not be an easily introduced constant (T or NIL, a fixnum
1656 ;;; or a character.)
1657 ;;; -- The atom must be "present" in the original source form, and
1658 ;;; present in all intervening actual source forms.
1659 (defun note-block-deletion (block)
1660 (let ((home (block-home-lambda block
)))
1661 (unless (eq (functional-kind home
) :deleted
)
1662 (do-nodes (node nil block
)
1663 (let* ((path (node-source-path node
))
1664 (first (first path
)))
1665 (when (or (eq first
'original-source-start
)
1667 (or (not (symbolp first
))
1668 (let ((pkg (symbol-package first
)))
1670 (not (eq pkg
(symbol-package :end
))))))
1671 (not (member first
*deletion-ignored-objects
*))
1672 (not (typep first
'(or fixnum character
)))
1674 (present-in-form first x
0))
1675 (source-path-forms path
))
1676 (present-in-form first
(find-original-source path
)
1678 (unless (return-p node
)
1679 (let ((*compiler-error-context
* node
))
1680 (compiler-notify 'code-deletion-note
1681 :format-control
"deleting unreachable code"
1682 :format-arguments nil
)))
1686 ;;; Delete a node from a block, deleting the block if there are no
1687 ;;; nodes left. We remove the node from the uses of its LVAR.
1689 ;;; If the node is the last node, there must be exactly one successor.
1690 ;;; We link all of our precedessors to the successor and unlink the
1691 ;;; block. In this case, we return T, otherwise NIL. If no nodes are
1692 ;;; left, and the block is a successor of itself, then we replace the
1693 ;;; only node with a degenerate exit node. This provides a way to
1694 ;;; represent the bodyless infinite loop, given the prohibition on
1695 ;;; empty blocks in IR1.
1696 (defun unlink-node (node)
1697 (declare (type node node
))
1698 (when (valued-node-p node
)
1699 (delete-lvar-use node
))
1701 (let* ((ctran (node-next node
))
1702 (next (and ctran
(ctran-next ctran
)))
1703 (prev (node-prev node
))
1704 (block (ctran-block prev
))
1705 (prev-kind (ctran-kind prev
))
1706 (last (block-last block
)))
1708 (setf (block-type-asserted block
) t
)
1709 (setf (block-test-modified block
) t
)
1711 (cond ((or (eq prev-kind
:inside-block
)
1712 (and (eq prev-kind
:block-start
)
1713 (not (eq node last
))))
1714 (cond ((eq node last
)
1715 (setf (block-last block
) (ctran-use prev
))
1716 (setf (node-next (ctran-use prev
)) nil
))
1718 (setf (ctran-next prev
) next
)
1719 (setf (node-prev next
) prev
)
1720 (when (if-p next
) ; AOP wanted
1721 (reoptimize-lvar (if-test next
)))))
1722 (setf (node-prev node
) nil
)
1725 (aver (eq prev-kind
:block-start
))
1726 (aver (eq node last
))
1727 (let* ((succ (block-succ block
))
1728 (next (first succ
)))
1729 (aver (singleton-p succ
))
1731 ((eq block
(first succ
))
1732 (with-ir1-environment-from-node node
1733 (let ((exit (make-exit)))
1734 (setf (ctran-next prev
) nil
)
1735 (link-node-to-previous-ctran exit prev
)
1736 (setf (block-last block
) exit
)))
1737 (setf (node-prev node
) nil
)
1740 (aver (eq (block-start-cleanup block
)
1741 (block-end-cleanup block
)))
1742 (unlink-blocks block next
)
1743 (dolist (pred (block-pred block
))
1744 (change-block-successor pred block next
))
1745 (when (block-delete-p block
)
1746 (let ((component (block-component block
)))
1747 (setf (component-delete-blocks component
)
1748 (delq block
(component-delete-blocks component
)))))
1749 (remove-from-dfo block
)
1750 (setf (block-delete-p block
) t
)
1751 (setf (node-prev node
) nil
)
1754 ;;; Return true if CTRAN has been deleted, false if it is still a valid
1756 (defun ctran-deleted-p (ctran)
1757 (declare (type ctran ctran
))
1758 (let ((block (ctran-block ctran
)))
1759 (or (not (block-component block
))
1760 (block-delete-p block
))))
1762 ;;; Return true if NODE has been deleted, false if it is still a valid
1764 (defun node-deleted (node)
1765 (declare (type node node
))
1766 (let ((prev (node-prev node
)))
1768 (ctran-deleted-p prev
))))
1770 ;;; Delete all the blocks and functions in COMPONENT. We scan first
1771 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
1772 ;;; triggered by deletion.
1773 (defun delete-component (component)
1774 (declare (type component component
))
1775 (aver (null (component-new-functionals component
)))
1776 (setf (component-kind component
) :deleted
)
1777 (do-blocks (block component
)
1778 (delete-block-lazily block
))
1779 (dolist (fun (component-lambdas component
))
1780 (unless (eq (functional-kind fun
) :deleted
)
1781 (setf (functional-kind fun
) nil
)
1782 (setf (functional-entry-fun fun
) nil
)
1783 (setf (leaf-refs fun
) nil
)
1784 (delete-functional fun
)))
1785 (clean-component component
)
1788 ;;; Remove all pending blocks to be deleted. Return the nearest live
1789 ;;; block after or equal to BLOCK.
1790 (defun clean-component (component &optional block
)
1791 (loop while
(component-delete-blocks component
)
1792 ;; actual deletion of a block may queue new blocks
1793 do
(let ((current (pop (component-delete-blocks component
))))
1794 (when (eq block current
)
1795 (setq block
(block-next block
)))
1796 (delete-block current
)))
1799 ;;; Convert code of the form
1800 ;;; (FOO ... (FUN ...) ...)
1802 ;;; (FOO ... ... ...).
1803 ;;; In other words, replace the function combination FUN by its
1804 ;;; arguments. If there are any problems with doing this, use GIVE-UP
1805 ;;; to blow out of whatever transform called this. Note, as the number
1806 ;;; of arguments changes, the transform must be prepared to return a
1807 ;;; lambda with a new lambda-list with the correct number of
1809 (defun splice-fun-args (lvar fun num-args
)
1810 "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed
1811 directly to the LVAR-DEST of LVAR, which must be a combination. If FUN
1812 is :ANY, the function name is not checked."
1813 (declare (type lvar lvar
)
1815 (type index num-args
))
1816 (let ((outside (lvar-dest lvar
))
1817 (inside (lvar-uses lvar
)))
1818 (aver (combination-p outside
))
1819 (unless (combination-p inside
)
1820 (give-up-ir1-transform))
1821 (let ((inside-fun (combination-fun inside
)))
1822 (unless (or (eq fun
:any
)
1823 (eq (lvar-fun-name inside-fun
) fun
))
1824 (give-up-ir1-transform))
1825 (let ((inside-args (combination-args inside
)))
1826 (unless (= (length inside-args
) num-args
)
1827 (give-up-ir1-transform))
1828 (let* ((outside-args (combination-args outside
))
1829 (arg-position (position lvar outside-args
))
1830 (before-args (subseq outside-args
0 arg-position
))
1831 (after-args (subseq outside-args
(1+ arg-position
))))
1832 (dolist (arg inside-args
)
1833 (setf (lvar-dest arg
) outside
)
1834 (flush-lvar-externally-checkable-type arg
))
1835 (setf (combination-args inside
) nil
)
1836 (setf (combination-args outside
)
1837 (append before-args inside-args after-args
))
1838 (change-ref-leaf (lvar-uses inside-fun
)
1839 (find-free-fun 'list
"???"))
1840 (setf (combination-fun-info inside
) (info :function
:info
'list
)
1841 (combination-kind inside
) :known
)
1842 (setf (node-derived-type inside
) *wild-type
*)
1846 ;;; Eliminate keyword arguments from the call (leaving the
1847 ;;; parameters in place.
1849 ;;; (FOO ... :BAR X :QUUX Y)
1853 ;;; SPECS is a list of (:KEYWORD PARAMETER) specifications.
1854 ;;; Returns the list of specified parameters names in the
1855 ;;; order they appeared in the call. N-POSITIONAL is the
1856 ;;; number of positional arguments in th call.
1857 (defun eliminate-keyword-args (call n-positional specs
)
1858 (let* ((specs (copy-tree specs
))
1859 (all (combination-args call
))
1860 (new-args (reverse (subseq all
0 n-positional
)))
1861 (key-args (subseq all n-positional
))
1864 (loop while key-args
1865 do
(let* ((key (pop key-args
))
1866 (val (pop key-args
))
1867 (keyword (if (constant-lvar-p key
)
1869 (give-up-ir1-transform)))
1870 (spec (or (assoc keyword specs
:test
#'eq
)
1871 (give-up-ir1-transform))))
1873 (push key flushed-keys
)
1874 (push (second spec
) parameters
)
1875 ;; In case of duplicate keys.
1876 (setf (second spec
) (gensym))))
1877 (dolist (key flushed-keys
)
1879 (setf (combination-args call
) (reverse new-args
))
1880 (reverse parameters
)))
1882 (defun extract-fun-args (lvar fun num-args
)
1883 (declare (type lvar lvar
)
1884 (type (or symbol list
) fun
)
1885 (type index num-args
))
1886 (let ((inside (lvar-uses lvar
)))
1887 (unless (combination-p inside
)
1888 (give-up-ir1-transform))
1889 (let ((inside-fun (combination-fun inside
)))
1890 (unless (member (lvar-fun-name inside-fun
) (ensure-list fun
))
1891 (give-up-ir1-transform))
1892 (let ((inside-args (combination-args inside
)))
1893 (unless (= (length inside-args
) num-args
)
1894 (give-up-ir1-transform))
1895 (values (lvar-fun-name inside-fun
) inside-args
)))))
1897 (defun flush-combination (combination)
1898 (declare (type combination combination
))
1899 (flush-dest (combination-fun combination
))
1900 (dolist (arg (combination-args combination
))
1902 (unlink-node combination
)
1908 ;;; Change the LEAF that a REF refers to.
1909 (defun change-ref-leaf (ref leaf
&key recklessly
)
1910 (declare (type ref ref
) (type leaf leaf
))
1911 (unless (eq (ref-leaf ref
) leaf
)
1912 (push ref
(leaf-refs leaf
))
1914 (setf (ref-leaf ref
) leaf
)
1915 (setf (leaf-ever-used leaf
) t
)
1916 (let* ((ltype (leaf-type leaf
))
1917 (vltype (make-single-value-type ltype
)))
1918 (if (let* ((lvar (node-lvar ref
))
1919 (dest (and lvar
(lvar-dest lvar
))))
1920 (and (basic-combination-p dest
)
1921 (eq lvar
(basic-combination-fun dest
))
1922 (csubtypep ltype
(specifier-type 'function
))))
1923 (setf (node-derived-type ref
) vltype
)
1924 (derive-node-type ref vltype
:from-scratch recklessly
)))
1925 (reoptimize-lvar (node-lvar ref
)))
1928 ;;; Change all REFS for OLD-LEAF to NEW-LEAF.
1929 (defun substitute-leaf (new-leaf old-leaf
)
1930 (declare (type leaf new-leaf old-leaf
))
1931 (dolist (ref (leaf-refs old-leaf
))
1932 (change-ref-leaf ref new-leaf
))
1935 ;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
1936 ;;; whether to substitute
1937 (defun substitute-leaf-if (test new-leaf old-leaf
)
1938 (declare (type leaf new-leaf old-leaf
) (type function test
))
1939 (dolist (ref (leaf-refs old-leaf
))
1940 (when (funcall test ref
)
1941 (change-ref-leaf ref new-leaf
)))
1944 ;;; Return a LEAF which represents the specified constant object. If
1945 ;;; the object is not in *CONSTANTS*, then we create a new constant
1946 ;;; LEAF and enter it. If we are producing a fasl file, make sure that
1947 ;;; MAKE-LOAD-FORM gets used on any parts of the constant that it
1950 ;;; We are allowed to coalesce things like EQUAL strings and bit-vectors
1951 ;;; when file-compiling, but not when using COMPILE.
1952 (defun find-constant (object &optional
(name nil namep
))
1953 (let ((faslp (producing-fasl-file)))
1954 (labels ((make-it ()
1957 (maybe-emit-make-load-forms object name
)
1958 (maybe-emit-make-load-forms object
)))
1959 (make-constant object
))
1960 (core-coalesce-p (x)
1961 ;; True for things which retain their identity under EQUAL,
1962 ;; so we can safely share the same CONSTANT leaf between
1963 ;; multiple references.
1964 (or (typep x
'(or symbol number character
))
1965 ;; Amusingly enough, we see CLAMBDAs --among other things--
1966 ;; here, from compiling things like %ALLOCATE-CLOSUREs forms.
1967 ;; No point in stuffing them in the hash-table.
1968 (and (typep x
'instance
)
1969 (not (or (leaf-p x
) (node-p x
))))))
1970 (file-coalesce-p (x)
1971 ;; CLHS 3.2.4.2.2: We are also allowed to coalesce various
1972 ;; other things when file-compiling.
1973 (or (core-coalesce-p x
)
1975 (if (eq +code-coverage-unmarked
+ (cdr x
))
1976 ;; These are already coalesced, and the CAR should
1977 ;; always be OK, so no need to check.
1979 (unless (maybe-cyclic-p x
) ; safe for EQUAL?
1981 ((atom y
) (file-coalesce-p y
))
1982 (unless (file-coalesce-p (car y
))
1984 ;; We *could* coalesce base-strings as well,
1985 ;; but we'd need a separate hash-table for
1986 ;; that, since we are not allowed to coalesce
1987 ;; base-strings with non-base-strings.
1990 ;; in the cross-compiler, we coalesce
1991 ;; all strings with the same contents,
1992 ;; because we will end up dumping them
1993 ;; as base-strings anyway. In the
1994 ;; real compiler, we're not allowed to
1995 ;; coalesce regardless of string
1996 ;; specialized element type, so we
1997 ;; KLUDGE by coalescing only character
1998 ;; strings (the common case) and
1999 ;; punting on the other types.
2003 (vector character
))))))
2005 (if faslp
(file-coalesce-p x
) (core-coalesce-p x
))))
2006 (if (and (boundp '*constants
*) (coalescep object
))
2007 (or (gethash object
*constants
*)
2008 (setf (gethash object
*constants
*)
2012 ;;; Return true if VAR would have to be closed over if environment
2013 ;;; analysis ran now (i.e. if there are any uses that have a different
2014 ;;; home lambda than VAR's home.)
2015 (defun closure-var-p (var)
2016 (declare (type lambda-var var
))
2017 (let ((home (lambda-var-home var
)))
2018 (cond ((eq (functional-kind home
) :deleted
)
2020 (t (let ((home (lambda-home home
)))
2023 :key
#'node-home-lambda
2025 (or (frob (leaf-refs var
))
2026 (frob (basic-var-sets var
)))))))))
2028 ;;; If there is a non-local exit noted in ENTRY's environment that
2029 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
2030 (defun find-nlx-info (exit)
2031 (declare (type exit exit
))
2032 (let* ((entry (exit-entry exit
))
2033 (cleanup (entry-cleanup entry
))
2034 (block (first (block-succ (node-block exit
)))))
2035 (dolist (nlx (physenv-nlx-info (node-physenv entry
)) nil
)
2036 (when (and (eq (nlx-info-block nlx
) block
)
2037 (eq (nlx-info-cleanup nlx
) cleanup
))
2040 (defun nlx-info-lvar (nlx)
2041 (declare (type nlx-info nlx
))
2042 (node-lvar (block-last (nlx-info-target nlx
))))
2044 ;;;; functional hackery
2046 (declaim (ftype (sfunction (functional) clambda
) main-entry
))
2047 (defun main-entry (functional)
2048 (etypecase functional
2049 (clambda functional
)
2051 (optional-dispatch-main-entry functional
))))
2053 ;;; RETURN true if FUNCTIONAL is a thing that can be treated like
2054 ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
2055 ;;; optional with null default and no SUPPLIED-P. There must be a
2056 ;;; &REST arg with no references.
2057 (declaim (ftype (sfunction (functional) boolean
) looks-like-an-mv-bind
))
2058 (defun looks-like-an-mv-bind (functional)
2059 (and (optional-dispatch-p functional
)
2060 (do ((arg (optional-dispatch-arglist functional
) (cdr arg
)))
2062 (let ((info (lambda-var-arg-info (car arg
))))
2063 (unless info
(return nil
))
2064 (case (arg-info-kind info
)
2066 (when (or (arg-info-supplied-p info
) (arg-info-default info
))
2069 (return (and (null (cdr arg
)) (null (leaf-refs (car arg
))))))
2073 (defun call-all-args-fixed-p (call)
2074 (loop for arg in
(basic-combination-args call
)
2075 always
(numberp (nth-value 1 (values-types
2076 (lvar-derived-type arg
))))))
2078 ;;; Return true if function is an external entry point. This is true
2079 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
2080 ;;; (:TOPLEVEL kind.)
2082 (declare (type functional fun
))
2083 (not (null (member (functional-kind fun
) '(:external
:toplevel
)))))
2085 ;;; If LVAR's only use is a non-notinline global function reference,
2086 ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
2087 ;;; is true, then we don't care if the leaf is NOTINLINE.
2088 (defun lvar-fun-name (lvar &optional notinline-ok
)
2089 (declare (type lvar lvar
))
2090 (let ((use (lvar-uses lvar
)))
2092 (let ((leaf (ref-leaf use
)))
2093 (if (and (global-var-p leaf
)
2094 (eq (global-var-kind leaf
) :global-function
)
2095 (or (not (defined-fun-p leaf
))
2096 (not (eq (defined-fun-inlinep leaf
) :notinline
))
2098 (leaf-source-name leaf
)
2102 ;;; As above, but allow a quoted symbol also,
2103 ;;; in which case we don't check for notinline-ness,
2104 ;;; so be careful how you use this.
2105 ;;; Also note that Case 2 in LVAR-FUN-IS for dealing with #.#'NAME
2106 ;;; has no equivalent here.
2107 (defun lvar-fun-name* (lvar)
2108 (if (constant-lvar-p lvar
) (lvar-value lvar
) (lvar-fun-name lvar
)))
2110 (defun lvar-fun-debug-name (lvar)
2111 (declare (type lvar lvar
))
2112 (let ((uses (lvar-uses lvar
)))
2114 (leaf-debug-name (ref-leaf use
))))
2117 (mapcar #'name1 uses
)))))
2119 ;;; Return the source name of a combination -- or signals an error
2120 ;;; if the function leaf is anonymous.
2121 (defun combination-fun-source-name (combination &optional
(errorp t
))
2122 (let ((uses (principal-lvar-use (combination-fun combination
)))
2124 (cond ((and (ref-p uses
)
2125 (leaf-has-source-name-p (setf leaf
(ref-leaf uses
))))
2126 (values (leaf-source-name leaf
) t
))
2128 (aver (not "COMBINATION-FUN is not a ref to a nameful leaf")))
2130 (values nil nil
)))))
2132 (defun combination-fun-debug-name (combination)
2133 (leaf-debug-name (ref-leaf (lvar-uses (combination-fun combination
)))))
2135 ;;; Return the COMBINATION node that is the call to the LET FUN.
2136 (defun let-combination (fun)
2137 (declare (type clambda fun
))
2138 (aver (functional-letlike-p fun
))
2139 (lvar-dest (node-lvar (first (leaf-refs fun
)))))
2141 ;;; Return the initial value lvar for a LET variable, or NIL if there
2143 (defun let-var-initial-value (var)
2144 (declare (type lambda-var var
))
2145 (let ((fun (lambda-var-home var
)))
2146 (elt (combination-args (let-combination fun
))
2147 (position-or-lose var
(lambda-vars fun
)))))
2149 ;;; Return the LAMBDA that is called by the local CALL.
2150 (defun combination-lambda (call)
2151 (declare (type basic-combination call
))
2152 (aver (eq (basic-combination-kind call
) :local
))
2153 (ref-leaf (lvar-uses (basic-combination-fun call
))))
2155 (defvar *inline-expansion-limit
* 200
2156 "an upper limit on the number of inline function calls that will be expanded
2157 in any given code object (single function or block compilation)")
2159 ;;; Check whether NODE's component has exceeded its inline expansion
2160 ;;; limit, and warn if so, returning NIL.
2161 (defun inline-expansion-ok (node)
2162 (let ((expanded (incf (component-inline-expansions
2164 (node-block node
))))))
2165 (cond ((> expanded
*inline-expansion-limit
*) nil
)
2166 ((= expanded
*inline-expansion-limit
*)
2167 ;; FIXME: If the objective is to stop the recursive
2168 ;; expansion of inline functions, wouldn't it be more
2169 ;; correct to look back through surrounding expansions
2170 ;; (which are, I think, stored in the *CURRENT-PATH*, and
2171 ;; possibly stored elsewhere too) and suppress expansion
2172 ;; and print this warning when the function being proposed
2173 ;; for inline expansion is found there? (I don't like the
2174 ;; arbitrary numerical limit in principle, and I think
2175 ;; it'll be a nuisance in practice if we ever want the
2176 ;; compiler to be able to use WITH-COMPILATION-UNIT on
2177 ;; arbitrarily huge blocks of code. -- WHN)
2178 (let ((*compiler-error-context
* node
))
2179 (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
2180 probably trying to~% ~
2181 inline a recursive function."
2182 *inline-expansion-limit
*))
2186 ;;; Make sure that FUNCTIONAL is not let-converted or deleted.
2187 (defun assure-functional-live-p (functional)
2188 (declare (type functional functional
))
2190 ;; looks LET-converted
2191 (functional-somewhat-letlike-p functional
)
2192 ;; It's possible for a LET-converted function to end up
2193 ;; deleted later. In that case, for the purposes of this
2194 ;; analysis, it is LET-converted: LET-converted functionals
2195 ;; are too badly trashed to expand them inline, and deleted
2196 ;; LET-converted functionals are even worse.
2197 (memq (functional-kind functional
) '(:deleted
:zombie
))))
2198 (throw 'locall-already-let-converted functional
)))
2200 (defun assure-leaf-live-p (leaf)
2203 (when (lambda-var-deleted leaf
)
2204 (throw 'locall-already-let-converted leaf
)))
2206 (assure-functional-live-p leaf
))))
2209 (defun call-full-like-p (call)
2210 (declare (type basic-combination call
))
2211 (let ((kind (basic-combination-kind call
)))
2213 (and (eq kind
:known
)
2214 (let ((info (basic-combination-fun-info call
)))
2216 (not (fun-info-ir2-convert info
))
2217 (dolist (template (fun-info-templates info
) t
)
2218 (when (eq (template-ltn-policy template
) :fast-safe
)
2219 (multiple-value-bind (val win
)
2220 (valid-fun-use call
(template-type template
))
2221 (when (or val
(not win
)) (return nil
)))))))))))
2225 ;;; Apply a function to some arguments, returning a list of the values
2226 ;;; resulting of the evaluation. If an error is signalled during the
2227 ;;; application, then we produce a warning message using WARN-FUN and
2228 ;;; return NIL as our second value to indicate this. NODE is used as
2229 ;;; the error context for any error message, and CONTEXT is a string
2230 ;;; that is spliced into the warning.
2231 (declaim (ftype (sfunction ((or symbol function
) list node function string
)
2232 (values list boolean
))
2234 (defun careful-call (function args node warn-fun context
)
2236 (multiple-value-list
2237 (handler-case (apply function args
)
2239 (let ((*compiler-error-context
* node
))
2240 (funcall warn-fun
"Lisp error during ~A:~%~A" context condition
)
2241 (return-from careful-call
(values nil nil
))))))
2244 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
2247 ((deffrob (basic careful compiler transform
)
2249 (defun ,careful
(specifier)
2250 (handler-case (,basic specifier
)
2251 ((or sb
!kernel
::arg-count-error
2252 type-error
) (condition)
2253 (values nil
(list (princ-to-string condition
))))
2254 (simple-error (condition)
2255 (values nil
(list* (simple-condition-format-control condition
)
2256 (simple-condition-format-arguments condition
))))))
2257 (defun ,compiler
(specifier)
2258 (multiple-value-bind (type error-args
) (,careful specifier
)
2260 (apply #'compiler-error error-args
))))
2261 (defun ,transform
(specifier)
2262 (multiple-value-bind (type error-args
) (,careful specifier
)
2264 (apply #'give-up-ir1-transform
2266 (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type
)
2267 (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type
))
2270 ;;;; utilities used at run-time for parsing &KEY args in IR1
2272 ;;; This function is used by the result of PARSE-DEFTRANSFORM to find
2273 ;;; the lvar for the value of the &KEY argument KEY in the list of
2274 ;;; lvars ARGS. It returns the lvar if the keyword is present, or NIL
2275 ;;; otherwise. The legality and constantness of the keywords should
2276 ;;; already have been checked.
2277 (declaim (ftype (sfunction (list keyword
) (or lvar null
))
2279 (defun find-keyword-lvar (args key
)
2280 (do ((arg args
(cddr arg
)))
2282 (when (eq (lvar-value (first arg
)) key
)
2283 (return (second arg
)))))
2285 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
2286 ;;; verify that alternating lvars in ARGS are constant and that there
2287 ;;; is an even number of args.
2288 (declaim (ftype (sfunction (list) boolean
) check-key-args-constant
))
2289 (defun check-key-args-constant (args)
2290 (do ((arg args
(cddr arg
)))
2292 (unless (and (rest arg
)
2293 (constant-lvar-p (first arg
)))
2296 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
2297 ;;; verify that the list of lvars ARGS is a well-formed &KEY arglist
2298 ;;; and that only keywords present in the list KEYS are supplied.
2299 (declaim (ftype (sfunction (list list
) boolean
) check-transform-keys
))
2300 (defun check-transform-keys (args keys
)
2301 (and (check-key-args-constant args
)
2302 (do ((arg args
(cddr arg
)))
2304 (unless (member (lvar-value (first arg
)) keys
)
2309 ;;; Called by the expansion of the EVENT macro.
2310 (declaim (ftype (sfunction (event-info (or node null
)) *) %event
))
2311 (defun %event
(info node
)
2312 (incf (event-info-count info
))
2313 (when (and (>= (event-info-level info
) *event-note-threshold
*)
2314 (policy (or node
*lexenv
*)
2315 (= inhibit-warnings
0)))
2316 (let ((*compiler-error-context
* node
))
2317 (compiler-notify (event-info-description info
))))
2319 (let ((action (event-info-action info
)))
2320 (when action
(funcall action node
))))
2323 (defun make-cast (value type policy
&optional context
)
2324 (declare (type lvar value
)
2326 (type policy policy
))
2327 (%make-cast
:asserted-type type
2328 :type-to-check
(maybe-weaken-check type policy
)
2330 :derived-type
(coerce-to-values type
)
2333 (defun cast-type-check (cast)
2334 (declare (type cast cast
))
2335 (when (cast-reoptimize cast
)
2336 (ir1-optimize-cast cast t
))
2337 (cast-%type-check cast
))
2339 (defun note-single-valuified-lvar (lvar)
2340 (declare (type (or lvar null
) lvar
))
2342 (let ((use (lvar-uses lvar
)))
2344 (let ((leaf (ref-leaf use
)))
2345 (when (and (lambda-var-p leaf
)
2346 (null (rest (leaf-refs leaf
))))
2347 (reoptimize-lambda-var leaf
))))
2348 ((or (listp use
) (combination-p use
))
2349 (do-uses (node lvar
)
2350 (setf (node-reoptimize node
) t
)
2351 (setf (block-reoptimize (node-block node
)) t
)
2352 (reoptimize-component (node-component node
) :maybe
)))))))
2354 ;;; Return true if LVAR's only use is a reference to a global function
2355 ;;; designator with one of the specified NAMES, that hasn't been
2356 ;;; declared NOTINLINE.
2357 (defun lvar-fun-is (lvar names
)
2358 (declare (type lvar lvar
) (list names
))
2359 (let ((use (lvar-uses lvar
)))
2361 (let* ((*lexenv
* (node-lexenv use
))
2362 (leaf (ref-leaf use
))
2364 (cond ((global-var-p leaf
)
2366 (and (eq (global-var-kind leaf
) :global-function
)
2367 (car (member (leaf-source-name leaf
) names
2370 (let ((value (constant-value leaf
)))
2371 (car (if (functionp value
)
2376 (fdefinition name
)))
2380 :test
#'equal
))))))))
2382 (not (fun-lexically-notinline-p name
)))))))
2384 ;;; Return true if LVAR's only use is a call to one of the named functions
2385 ;;; (or any function if none are specified) with the specified number of
2386 ;;; of arguments (or any number if number is not specified)
2387 (defun lvar-matches (lvar &key fun-names arg-count
)
2388 (let ((use (lvar-uses lvar
)))
2389 (and (combination-p use
)
2391 (multiple-value-bind (name ok
)
2392 (combination-fun-source-name use nil
)
2393 (and ok
(member name fun-names
:test
#'eq
))))
2395 (= arg-count
(length (combination-args use
)))))))
2397 ;;; True if the optional has a rest-argument.
2398 (defun optional-rest-p (opt)
2399 (dolist (var (optional-dispatch-arglist opt
) nil
)
2400 (let* ((info (when (lambda-var-p var
)
2401 (lambda-var-arg-info var
)))
2403 (arg-info-kind info
))))
2404 (when (eq :rest kind
)
2407 ;;; Don't substitute single-ref variables on high-debug / low speed, to
2408 ;;; improve the debugging experience. ...but don't bother keeping those
2409 ;;; from system lambdas.
2410 (defun preserve-single-use-debug-var-p (call var
)
2411 (and (policy call
(eql preserve-single-use-debug-variables
3))
2412 (or (not (lambda-var-p var
))
2413 (not (lambda-system-lambda-p (lambda-var-home var
))))))