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
)))
477 (declaim (inline block-to-be-deleted-p
))
478 (defun block-to-be-deleted-p (block)
479 (or (block-delete-p block
)
480 (eq (functional-kind (block-home-lambda block
)) :deleted
)))
482 ;;; Checks whether NODE is in a block to be deleted
483 (declaim (inline node-to-be-deleted-p
))
484 (defun node-to-be-deleted-p (node)
485 (block-to-be-deleted-p (node-block node
)))
487 (declaim (ftype (sfunction (clambda) cblock
) lambda-block
))
488 (defun lambda-block (clambda)
489 (node-block (lambda-bind clambda
)))
490 (declaim (ftype (sfunction (clambda) component
) lambda-component
))
491 (defun lambda-component (clambda)
492 (block-component (lambda-block clambda
)))
494 (declaim (ftype (sfunction (cblock) node
) block-start-node
))
495 (defun block-start-node (block)
496 (ctran-next (block-start block
)))
498 ;;; Return the enclosing cleanup for environment of the first or last
500 (defun block-start-cleanup (block)
501 (node-enclosing-cleanup (block-start-node block
)))
502 (defun block-end-cleanup (block)
503 (node-enclosing-cleanup (block-last block
)))
505 ;;; Return the lexenv of the last node in BLOCK.
506 (defun block-end-lexenv (block)
507 (node-lexenv (block-last block
)))
509 ;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL
510 ;;; if there is none.
512 ;;; There can legitimately be no home lambda in dead code early in the
513 ;;; IR1 conversion process, e.g. when IR1-converting the SETQ form in
514 ;;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
515 ;;; where the block is just a placeholder during parsing and doesn't
516 ;;; actually correspond to code which will be written anywhere.
517 (declaim (ftype (sfunction (cblock) (or clambda null
)) block-home-lambda-or-null
))
518 (defun block-home-lambda-or-null (block)
519 (if (node-p (block-last block
))
520 ;; This is the old CMU CL way of doing it.
521 (node-home-lambda (block-last block
))
522 ;; Now that SBCL uses this operation more aggressively than CMU
523 ;; CL did, the old CMU CL way of doing it can fail in two ways.
524 ;; 1. It can fail in a few cases even when a meaningful home
525 ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of
527 ;; 2. It can fail when converting a form which is born orphaned
528 ;; so that it never had a meaningful home lambda, e.g. a form
529 ;; which follows a RETURN-FROM or GO form.
530 (let ((pred-list (block-pred block
)))
531 ;; To deal with case 1, we reason that
532 ;; previous-in-target-execution-order blocks should be in the
533 ;; same lambda, and that they seem in practice to be
534 ;; previous-in-compilation-order blocks too, so we look back
535 ;; to find one which is sufficiently initialized to tell us
536 ;; what the home lambda is.
538 ;; We could get fancy about this, flooding through the
539 ;; graph of all the previous blocks, but in practice it
540 ;; seems to work just to grab the first previous block and
542 (node-home-lambda (block-last (first pred-list
)))
543 ;; In case 2, we end up with an empty PRED-LIST and
544 ;; have to punt: There's no home lambda.
547 ;;; Return the non-LET LAMBDA that holds BLOCK's code.
548 (declaim (ftype (sfunction (cblock) clambda
) block-home-lambda
))
549 (defun block-home-lambda (block)
550 (block-home-lambda-or-null block
))
552 ;;; Return the IR1 physical environment for BLOCK.
553 (declaim (ftype (sfunction (cblock) physenv
) block-physenv
))
554 (defun block-physenv (block)
555 (lambda-physenv (block-home-lambda block
)))
557 ;;;; DYNAMIC-EXTENT related
559 (defun lambda-var-original-name (leaf)
560 (let ((home (lambda-var-home leaf
)))
561 (if (eq :external
(functional-kind home
))
562 (let* ((entry (functional-entry-fun home
))
563 (p (1- (position leaf
(lambda-vars home
)))))
565 (if (optional-dispatch-p entry
)
566 (elt (optional-dispatch-arglist entry
) p
)
567 (elt (lambda-vars entry
) p
))))
568 (leaf-debug-name leaf
))))
570 (defun note-no-stack-allocation (lvar &key flush
)
571 (do-uses (use (principal-lvar lvar
))
573 ;; Don't complain about not being able to stack allocate constants.
574 (and (ref-p use
) (constant-p (ref-leaf use
)))
575 ;; If we're flushing, don't complain if we can flush the combination.
576 (and flush
(combination-p use
) (flushable-combination-p use
))
577 ;; Don't report those with homes in :OPTIONAL -- we'd get doubled
579 (and (ref-p use
) (lambda-var-p (ref-leaf use
))
580 (eq :optional
(lambda-kind (lambda-var-home (ref-leaf use
))))))
581 ;; FIXME: For the first leg (lambda-bind (lambda-var-home ...))
582 ;; would be a far better description, but since we use
583 ;; *COMPILER-ERROR-CONTEXT* for muffling we can't -- as that node
584 ;; can have different handled conditions.
585 (let ((*compiler-error-context
* use
))
586 (if (and (ref-p use
) (lambda-var-p (ref-leaf use
)))
587 (compiler-notify "~@<could~2:I not stack allocate ~S in: ~S~:@>"
588 (lambda-var-original-name (ref-leaf use
))
589 (find-original-source (node-source-path use
)))
590 (compiler-notify "~@<could~2:I not stack allocate: ~S~:@>"
591 (find-original-source (node-source-path use
))))))))
593 (defun use-good-for-dx-p (use dx
&optional component
)
594 ;; FIXME: Can casts point to LVARs in other components?
595 ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the
596 ;; PRINCIPAL-LVAR is always in the same component as the original one. It
597 ;; would be either good to have an explanation of why casts don't point
598 ;; across components, or an explanation of when they do it. ...in the
599 ;; meanwhile AVER that our assumption holds true.
600 (aver (or (not component
) (eq component
(node-component use
))))
601 (or (dx-combination-p use dx
)
603 (not (cast-type-check use
))
604 (lvar-good-for-dx-p (cast-value use
) dx component
))
605 (and (trivial-lambda-var-ref-p use
)
606 (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use
))))
608 (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use
) dx component
))))))
610 (defun lvar-good-for-dx-p (lvar dx
&optional component
)
611 (let ((uses (lvar-uses lvar
)))
617 (use-good-for-dx-p use dx component
))
620 (use-good-for-dx-p uses dx component
)))))
622 (defun known-dx-combination-p (use dx
)
623 (and (eq (combination-kind use
) :known
)
624 (let ((info (combination-fun-info use
)))
625 (or (awhen (fun-info-stack-allocate-result info
)
627 (awhen (fun-info-result-arg info
)
628 (lvar-good-for-dx-p (nth it
(combination-args use
))
631 ;;; Bound to NIL in RECHECK-DYNAMIC-EXTENT-LVARS, so that the
632 ;;; combinations that didn't get converted are not treated as dx-safe.
633 (defvar *dx-combination-p-check-local
* t
)
635 (defun dx-combination-p (use dx
)
636 (and (combination-p use
)
638 ;; Known, and can do DX.
639 (known-dx-combination-p use dx
)
640 ;; Possibly a not-yet-eliminated lambda which ends up returning the
641 ;; results of an actual known DX combination.
642 (and *dx-combination-p-check-local
*
643 (let* ((fun (combination-fun use
))
644 (ref (principal-lvar-use fun
))
645 (clambda (when (ref-p ref
)
647 (creturn (when (lambda-p clambda
)
648 (lambda-return clambda
)))
649 (result-use (when (return-p creturn
)
650 (principal-lvar-use (return-result creturn
)))))
651 ;; FIXME: We should be able to deal with multiple uses here as well.
652 (and (dx-combination-p result-use dx
)
653 (combination-args-flow-cleanly-p use result-use dx
)))))))
655 (defun combination-args-flow-cleanly-p (combination1 combination2 dx
)
656 (labels ((recurse (combination)
657 (or (eq combination combination2
)
658 (if (known-dx-combination-p combination dx
)
659 (let ((dest (lvar-dest (combination-lvar combination
))))
660 (and (combination-p dest
)
662 (let* ((fun1 (combination-fun combination
))
663 (ref1 (principal-lvar-use fun1
))
664 (clambda1 (when (ref-p ref1
) (ref-leaf ref1
))))
665 (when (lambda-p clambda1
)
666 (dolist (var (lambda-vars clambda1
) t
)
667 (dolist (var-ref (lambda-var-refs var
))
668 (let* ((lvar (ref-lvar var-ref
))
669 (dest (and lvar
(principal-lvar-dest lvar
))))
670 (unless (or (not dest
)
671 (and (combination-p dest
) (recurse dest
)))
672 (return-from combination-args-flow-cleanly-p nil
)))))))))))
673 (recurse combination1
)))
675 (defun ref-good-for-dx-p (ref)
676 (let* ((lvar (ref-lvar ref
))
677 (dest (when lvar
(lvar-dest lvar
))))
678 (and (combination-p dest
)
679 (eq :known
(combination-kind dest
))
680 (awhen (combination-fun-info dest
)
681 (or (ir1-attributep (fun-info-attributes it
) dx-safe
)
682 (and (not (combination-lvar dest
))
683 (awhen (fun-info-result-arg it
)
684 (eql lvar
(nth it
(combination-args dest
))))))))))
686 (defun trivial-lambda-var-ref-p (use)
688 (let ((var (ref-leaf use
)))
689 ;; lambda-var, no SETS, not explicitly indefinite-extent.
690 (when (and (lambda-var-p var
) (not (lambda-var-sets var
))
691 (neq :indefinite
(lambda-var-extent var
)))
692 (let ((home (lambda-var-home var
))
693 (refs (lambda-var-refs var
)))
694 ;; bound by a non-XEP system lambda, no other REFS that aren't
695 ;; DX-SAFE, or are result-args when the result is discarded.
696 (when (and (lambda-system-lambda-p home
)
697 (neq :external
(lambda-kind home
))
699 (unless (or (eq use ref
) (ref-good-for-dx-p ref
))
701 ;; the LAMBDA this var is bound by has only a single REF, going
703 (let* ((lambda-refs (lambda-refs home
))
704 (primary (car lambda-refs
)))
706 (not (cdr lambda-refs
))
707 (combination-p (lvar-dest (ref-lvar primary
)))))))))))
709 (defun trivial-lambda-var-ref-lvar (use)
710 (let* ((this (ref-leaf use
))
711 (fun (lambda-var-home this
))
712 (vars (lambda-vars fun
))
713 (combination (lvar-dest (ref-lvar (car (lambda-refs fun
)))))
714 (args (combination-args combination
)))
715 (aver (= (length vars
) (length args
)))
716 (loop for var in vars
721 ;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends.
722 (defun handle-nested-dynamic-extent-lvars (dx lvar
&optional recheck-component
)
723 (let ((uses (lvar-uses lvar
)))
724 ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS.
725 ;; Uses of mupltiple-use LVARs already end their blocks, so we just need
726 ;; to process uses of single-use LVARs.
728 (when (node-to-be-deleted-p uses
)
729 (return-from handle-nested-dynamic-extent-lvars
))
730 (node-ends-block uses
))
731 ;; If this LVAR's USE is good for DX, it is either a CAST, or it
732 ;; must be a regular combination whose arguments are potentially DX as well.
733 (flet ((recurse (use)
736 (handle-nested-dynamic-extent-lvars
737 dx
(cast-value use
) recheck-component
))
739 (loop for arg in
(combination-args use
)
740 ;; deleted args show up as NIL here
742 (lvar-good-for-dx-p arg dx recheck-component
))
743 append
(handle-nested-dynamic-extent-lvars
744 dx arg recheck-component
)))
746 (let* ((other (trivial-lambda-var-ref-lvar use
)))
747 (unless (eq other lvar
)
748 (handle-nested-dynamic-extent-lvars
749 dx other recheck-component
)))))))
752 (loop for use in uses
753 when
(use-good-for-dx-p use dx recheck-component
)
755 (when (use-good-for-dx-p uses dx recheck-component
)
758 ;;; Return the Top Level Form number of PATH, i.e. the ordinal number
759 ;;; of its original source's top level form in its compilation unit.
760 (defun source-path-tlf-number (path)
761 (declare (list path
))
764 ;;; Return the (reversed) list for the PATH in the original source
765 ;;; (with the Top Level Form number last).
766 (declaim (ftype (sfunction (list) list
) source-path-original-source
))
767 (defun source-path-original-source (path)
768 (declare (list path
) (inline member
))
769 (cddr (member 'original-source-start path
:test
#'eq
)))
771 ;;; Return the Form Number of PATH's original source inside the Top
772 ;;; Level Form that contains it. This is determined by the order that
773 ;;; we walk the subforms of the top level source form.
774 (declaim (ftype (sfunction (list) (or null index
)) source-path-form-number
))
775 (defun source-path-form-number (path)
776 (declare (inline member
))
777 (cadr (member 'original-source-start path
:test
#'eq
)))
779 ;;; Return a list of all the enclosing forms not in the original
780 ;;; source that converted to get to this form, with the immediate
781 ;;; source for node at the start of the list.
782 (defun source-path-forms (path)
783 (subseq path
0 (position 'original-source-start path
)))
785 (defun tree-some (predicate tree
)
786 (let ((seen (make-hash-table)))
787 (labels ((walk (tree)
788 (cond ((funcall predicate tree
))
790 (not (gethash tree seen
)))
791 (setf (gethash tree seen
) t
)
792 (or (walk (car tree
))
793 (walk (cdr tree
)))))))
796 ;;; Return the innermost source form for NODE.
797 (defun node-source-form (node)
798 (declare (type node node
))
799 (let* ((path (node-source-path node
))
800 (forms (remove-if (lambda (x)
801 (tree-some #'leaf-p x
))
802 (source-path-forms path
))))
803 ;; another option: if first form includes a leaf, return
804 ;; find-original-source instead.
807 (values (find-original-source path
)))))
809 ;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise
811 (defun lvar-source (lvar)
812 (let ((use (lvar-uses lvar
)))
815 (values (node-source-form use
) t
))))
817 (defun common-suffix (x y
)
818 (let ((mismatch (mismatch x y
:from-end t
)))
823 ;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a
824 ;;; singleton. Otherwise, return a list of the lowest common
825 ;;; ancestor source form of all the uses (if it can be found),
826 ;;; followed by all the uses' source forms.
827 (defun lvar-all-sources (lvar)
828 (let ((use (principal-lvar-use lvar
)))
831 (path (node-source-path (first use
))))
832 (dolist (use use
(cons (if (find 'original-source-start path
)
833 (find-original-source path
)
836 (pushnew (node-source-form use
) forms
)
837 (setf path
(common-suffix path
838 (node-source-path use
)))))
839 (list (node-source-form use
)))))
841 ;;; Return the LAMBDA that is CTRAN's home, or NIL if there is none.
842 (declaim (ftype (sfunction (ctran) (or clambda null
))
843 ctran-home-lambda-or-null
))
844 (defun ctran-home-lambda-or-null (ctran)
845 ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
846 ;; implementation might not be quite right, or might be uglier than
847 ;; necessary. It appears that the original Python never found a need
848 ;; to do this operation. The obvious things based on
849 ;; NODE-HOME-LAMBDA of CTRAN-USE usually work; then if that fails,
850 ;; BLOCK-HOME-LAMBDA of CTRAN-BLOCK works, given that we
851 ;; generalize it enough to grovel harder when the simple CMU CL
852 ;; approach fails, and furthermore realize that in some exceptional
853 ;; cases it might return NIL. -- WHN 2001-12-04
854 (cond ((ctran-use ctran
)
855 (node-home-lambda (ctran-use ctran
)))
857 (block-home-lambda-or-null (ctran-block ctran
)))
859 (bug "confused about home lambda for ~S" ctran
))))
861 ;;; Return the LAMBDA that is CTRAN's home.
862 (declaim (ftype (sfunction (ctran) clambda
) ctran-home-lambda
))
863 (defun ctran-home-lambda (ctran)
864 (ctran-home-lambda-or-null ctran
))
866 (declaim (inline cast-single-value-p
))
867 (defun cast-single-value-p (cast)
868 (not (values-type-p (cast-asserted-type cast
))))
870 #!-sb-fluid
(declaim (inline lvar-single-value-p
))
871 (defun lvar-single-value-p (lvar)
872 (or (not lvar
) (%lvar-single-value-p lvar
)))
873 (defun %lvar-single-value-p
(lvar)
874 (let ((dest (lvar-dest lvar
)))
879 (eq (basic-combination-fun dest
) lvar
))
881 (and (cast-single-value-p dest
)
882 (acond ((node-lvar dest
) (%lvar-single-value-p it
))
886 (defun principal-lvar-end (lvar)
887 (loop for prev
= lvar then
(node-lvar dest
)
888 for dest
= (and prev
(lvar-dest prev
))
890 finally
(return (values dest prev
))))
892 (defun principal-lvar-single-valuify (lvar)
893 (loop for prev
= lvar then
(node-lvar dest
)
894 for dest
= (and prev
(lvar-dest prev
))
896 do
(setf (node-derived-type dest
)
897 (make-short-values-type (list (single-value-type
898 (node-derived-type dest
)))))
899 (reoptimize-lvar prev
)))
901 ;;; Return a new LEXENV just like DEFAULT except for the specified
902 ;;; slot values. Values for the alist slots are APPENDed to the
903 ;;; beginning of the current value, rather than replacing it entirely.
904 (defun make-lexenv (&key
(default *lexenv
*)
905 funs vars blocks tags
907 (lambda (lexenv-lambda default
))
908 (cleanup (lexenv-cleanup default
))
909 (handled-conditions (lexenv-handled-conditions default
))
910 (disabled-package-locks
911 (lexenv-disabled-package-locks default
))
912 (policy (lexenv-policy default
))
913 (user-data (lexenv-user-data default
)))
914 (macrolet ((frob (var slot
)
915 `(let ((old (,slot default
)))
919 (internal-make-lexenv
920 (frob funs lexenv-funs
)
921 (frob vars lexenv-vars
)
922 (frob blocks lexenv-blocks
)
923 (frob tags lexenv-tags
)
924 (frob type-restrictions lexenv-type-restrictions
)
926 cleanup handled-conditions disabled-package-locks
931 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
933 (defun make-restricted-lexenv (lexenv)
934 (flet ((fun-good-p (fun)
935 (destructuring-bind (name . thing
) fun
936 (declare (ignore name
))
940 (cons (aver (eq (car thing
) 'macro
))
943 (destructuring-bind (name . thing
) var
944 (declare (ignore name
))
946 ;; The evaluator will mark lexicals with :BOGUS when it
947 ;; translates an interpreter lexenv to a compiler
949 ((or leaf
#!+sb-eval
(member :bogus
)) nil
)
950 (cons (aver (eq (car thing
) 'macro
))
952 (heap-alien-info nil
)))))
953 (internal-make-lexenv
954 (remove-if-not #'fun-good-p
(lexenv-funs lexenv
))
955 (remove-if-not #'var-good-p
(lexenv-vars lexenv
))
958 (lexenv-type-restrictions lexenv
) ; XXX
961 (lexenv-handled-conditions lexenv
)
962 (lexenv-disabled-package-locks lexenv
)
963 (lexenv-policy lexenv
)
964 (lexenv-user-data lexenv
)
967 ;;;; flow/DFO/component hackery
969 ;;; Join BLOCK1 and BLOCK2.
970 (defun link-blocks (block1 block2
)
971 (declare (type cblock block1 block2
))
972 (setf (block-succ block1
)
973 (if (block-succ block1
)
974 (%link-blocks block1 block2
)
976 (push block1
(block-pred block2
))
978 (defun %link-blocks
(block1 block2
)
979 (declare (type cblock block1 block2
))
980 (let ((succ1 (block-succ block1
)))
981 (aver (not (memq block2 succ1
)))
982 (cons block2 succ1
)))
984 ;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If
985 ;;; this leaves a successor with a single predecessor that ends in an
986 ;;; IF, then set BLOCK-TEST-MODIFIED so that any test constraint will
987 ;;; now be able to be propagated to the successor.
988 (defun unlink-blocks (block1 block2
)
989 (declare (type cblock block1 block2
))
990 (let ((succ1 (block-succ block1
)))
991 (if (eq block2
(car succ1
))
992 (setf (block-succ block1
) (cdr succ1
))
993 (do ((succ (cdr succ1
) (cdr succ
))
995 ((eq (car succ
) block2
)
996 (setf (cdr prev
) (cdr succ
)))
999 (let ((new-pred (delq block1
(block-pred block2
))))
1000 (setf (block-pred block2
) new-pred
)
1001 (when (singleton-p new-pred
)
1002 (let ((pred-block (first new-pred
)))
1003 (when (if-p (block-last pred-block
))
1004 (setf (block-test-modified pred-block
) t
)))))
1007 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK
1008 ;;; and NEW. If BLOCK ends in an IF, then we have to fix up the
1009 ;;; consequent/alternative blocks to point to NEW. We also set
1010 ;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to
1011 ;;; the new successor.
1012 (defun change-block-successor (block old new
)
1013 (declare (type cblock new old block
))
1014 (unlink-blocks block old
)
1015 (let ((last (block-last block
))
1016 (comp (block-component block
)))
1017 (setf (component-reanalyze comp
) t
)
1020 (setf (block-test-modified block
) t
)
1021 (let* ((succ-left (block-succ block
))
1022 (new (if (and (eq new
(component-tail comp
))
1026 (unless (memq new succ-left
)
1027 (link-blocks block new
))
1028 (macrolet ((frob (slot)
1029 `(when (eq (,slot last
) old
)
1030 (setf (,slot last
) new
))))
1031 (frob if-consequent
)
1032 (frob if-alternative
)
1033 (when (eq (if-consequent last
)
1034 (if-alternative last
))
1035 (reoptimize-component (block-component block
) :maybe
)))))
1037 (unless (memq new
(block-succ block
))
1038 (link-blocks block new
)))))
1042 ;;; Unlink a block from the next/prev chain. We also null out the
1044 (declaim (ftype (sfunction (cblock) (values)) remove-from-dfo
))
1045 (defun remove-from-dfo (block)
1046 (let ((next (block-next block
))
1047 (prev (block-prev block
)))
1048 (setf (block-component block
) nil
)
1049 (setf (block-next prev
) next
)
1050 (setf (block-prev next
) prev
))
1053 ;;; Add BLOCK to the next/prev chain following AFTER. We also set the
1054 ;;; COMPONENT to be the same as for AFTER.
1055 (defun add-to-dfo (block after
)
1056 (declare (type cblock block after
))
1057 (let ((next (block-next after
))
1058 (comp (block-component after
)))
1059 (aver (not (eq (component-kind comp
) :deleted
)))
1060 (setf (block-component block
) comp
)
1061 (setf (block-next after
) block
)
1062 (setf (block-prev block
) after
)
1063 (setf (block-next block
) next
)
1064 (setf (block-prev next
) block
))
1067 ;;; List all NLX-INFOs which BLOCK can exit to.
1069 ;;; We hope that no cleanup actions are performed in the middle of
1070 ;;; BLOCK, so it is enough to look only at cleanups in the block
1071 ;;; end. The tricky thing is a special cleanup block; all its nodes
1072 ;;; have the same cleanup info, corresponding to the start, so the
1073 ;;; same approach returns safe result.
1074 (defun map-block-nlxes (fun block
&optional dx-cleanup-fun
)
1075 (do-nested-cleanups (cleanup (block-end-lexenv block
))
1076 (let ((mess-up (cleanup-mess-up cleanup
)))
1077 (case (cleanup-kind cleanup
)
1079 (aver (entry-p mess-up
))
1080 (loop for exit in
(entry-exits mess-up
)
1081 for nlx-info
= (exit-nlx-info exit
)
1082 do
(funcall fun nlx-info
)))
1083 ((:catch
:unwind-protect
)
1084 (aver (combination-p mess-up
))
1085 (let* ((arg-lvar (first (basic-combination-args mess-up
)))
1086 (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar
)))))
1087 (funcall fun nlx-info
)))
1089 (when dx-cleanup-fun
1090 (funcall dx-cleanup-fun cleanup
)))))))
1092 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
1093 ;;; the head and tail which are set to T.
1094 (declaim (ftype (sfunction (component) (values)) clear-flags
))
1095 (defun clear-flags (component)
1096 (let ((head (component-head component
))
1097 (tail (component-tail component
)))
1098 (setf (block-flag head
) t
)
1099 (setf (block-flag tail
) t
)
1100 (do-blocks (block component
)
1101 (setf (block-flag block
) nil
)))
1104 ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially
1105 ;;; true in the head and tail blocks.
1106 (declaim (ftype (sfunction () component
) make-empty-component
))
1107 (defun make-empty-component ()
1108 (let* ((head (make-block-key :start nil
:component nil
))
1109 (tail (make-block-key :start nil
:component nil
))
1110 (res (make-component head tail
)))
1111 (setf (block-flag head
) t
)
1112 (setf (block-flag tail
) t
)
1113 (setf (block-component head
) res
)
1114 (setf (block-component tail
) res
)
1115 (setf (block-next head
) tail
)
1116 (setf (block-prev tail
) head
)
1119 ;;; Make NODE the LAST node in its block, splitting the block if necessary.
1120 ;;; The new block is added to the DFO immediately following NODE's block.
1121 (defun node-ends-block (node)
1122 (declare (type node node
))
1123 (let* ((block (node-block node
))
1124 (start (node-next node
))
1125 (last (block-last block
)))
1126 (check-type last node
)
1127 (unless (eq last node
)
1128 (aver (and (eq (ctran-kind start
) :inside-block
)
1129 (not (block-delete-p block
))))
1130 (let* ((succ (block-succ block
))
1132 (make-block-key :start start
1133 :component
(block-component block
)
1134 :succ succ
:last last
)))
1135 (setf (ctran-kind start
) :block-start
)
1136 (setf (ctran-use start
) nil
)
1137 (setf (block-last block
) node
)
1138 (setf (node-next node
) nil
)
1140 (setf (block-pred b
)
1141 (cons new-block
(remove block
(block-pred b
)))))
1142 (setf (block-succ block
) ())
1143 (link-blocks block new-block
)
1144 (add-to-dfo new-block block
)
1145 (setf (component-reanalyze (block-component block
)) t
)
1147 (do ((ctran start
(node-next (ctran-next ctran
))))
1149 (setf (ctran-block ctran
) new-block
))
1151 (setf (block-type-asserted block
) t
)
1152 (setf (block-test-modified block
) t
))))
1157 ;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
1158 (defun delete-lambda-var (leaf)
1159 (declare (type lambda-var leaf
))
1161 (setf (lambda-var-deleted leaf
) t
)
1162 ;; Iterate over all local calls flushing the corresponding argument,
1163 ;; allowing the computation of the argument to be deleted. We also
1164 ;; mark the LET for reoptimization, since it may be that we have
1165 ;; deleted its last variable.
1166 (let* ((fun (lambda-var-home leaf
))
1167 (n (position leaf
(lambda-vars fun
))))
1168 (dolist (ref (leaf-refs fun
))
1169 (let* ((lvar (node-lvar ref
))
1170 (dest (and lvar
(lvar-dest lvar
))))
1171 (when (and (basic-combination-p dest
)
1172 (eq (basic-combination-fun dest
) lvar
)
1173 (eq (basic-combination-kind dest
) :local
))
1174 (if (mv-combination-p dest
)
1175 ;; Let FLUSH-DEAD-CODE deal with it
1176 ;; since it's a bit tricky to delete multiple-valued
1177 ;; args and existing code doesn't expect to see NIL in
1178 ;; mv-combination-args.
1179 (setf (block-flush-p (node-block dest
)) t
)
1180 (let* ((args (basic-combination-args dest
))
1182 (reoptimize-lvar arg
)
1184 (setf (elt args n
) nil
)))))))
1186 ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
1187 ;; too much difficulty, since we can efficiently implement
1188 ;; write-only variables. We iterate over the SETs, marking their
1189 ;; blocks for dead code flushing, since we can delete SETs whose
1191 (dolist (set (lambda-var-sets leaf
))
1192 (setf (block-flush-p (node-block set
)) t
))
1196 ;;; Note that something interesting has happened to VAR.
1197 (defun reoptimize-lambda-var (var)
1198 (declare (type lambda-var var
))
1199 (let ((fun (lambda-var-home var
)))
1200 ;; We only deal with LET variables, marking the corresponding
1201 ;; initial value arg as needing to be reoptimized.
1202 (when (and (eq (functional-kind fun
) :let
)
1204 (do ((args (basic-combination-args
1205 (lvar-dest (node-lvar (first (leaf-refs fun
)))))
1207 (vars (lambda-vars fun
) (cdr vars
)))
1208 ((eq (car vars
) var
)
1209 (reoptimize-lvar (car args
))))))
1212 ;;; Delete a function that has no references. This need only be called
1213 ;;; on functions that never had any references, since otherwise
1214 ;;; DELETE-REF will handle the deletion.
1215 (defun delete-functional (fun)
1216 (aver (and (null (leaf-refs fun
))
1217 (not (functional-entry-fun fun
))))
1219 (optional-dispatch (delete-optional-dispatch fun
))
1220 (clambda (delete-lambda fun
)))
1223 ;;; Deal with deleting the last reference to a CLAMBDA, which means
1224 ;;; that the lambda is unreachable, so that its body may be
1225 ;;; deleted. We set FUNCTIONAL-KIND to :DELETED and rely on
1226 ;;; IR1-OPTIMIZE to delete its blocks.
1227 (defun delete-lambda (clambda)
1228 (declare (type clambda clambda
))
1229 (let ((original-kind (functional-kind clambda
))
1230 (bind (lambda-bind clambda
)))
1231 (aver (not (member original-kind
'(:deleted
:toplevel
))))
1232 (aver (not (functional-has-external-references-p clambda
)))
1233 (aver (or (eq original-kind
:zombie
) bind
))
1234 (setf (functional-kind clambda
) :deleted
)
1235 (setf (lambda-bind clambda
) nil
)
1237 (labels ((delete-children (lambda)
1238 (dolist (child (lambda-children lambda
))
1239 (cond ((eq (functional-kind child
) :deleted
)
1240 (delete-children child
))
1242 (delete-lambda child
))))
1243 (setf (lambda-children lambda
) nil
)
1244 (setf (lambda-parent lambda
) nil
)))
1245 (delete-children clambda
))
1247 ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
1248 ;; that we're using the old value of the KIND slot, not the
1249 ;; current slot value, which has now been set to :DELETED.)
1252 ((:let
:mv-let
:assignment
)
1253 (let ((bind-block (node-block bind
)))
1254 (mark-for-deletion bind-block
))
1255 (let ((home (lambda-home clambda
)))
1256 (setf (lambda-lets home
) (delete clambda
(lambda-lets home
))))
1257 ;; KLUDGE: In presence of NLEs we cannot always understand that
1258 ;; LET's BIND dominates its body [for a LET "its" body is not
1259 ;; quite its]; let's delete too dangerous for IR2 stuff. --
1261 (dolist (var (lambda-vars clambda
))
1262 (flet ((delete-node (node)
1263 (mark-for-deletion (node-block node
))))
1264 (mapc #'delete-node
(leaf-refs var
))
1265 (mapc #'delete-node
(lambda-var-sets var
)))))
1267 ;; Function has no reachable references.
1268 (dolist (ref (lambda-refs clambda
))
1269 (mark-for-deletion (node-block ref
)))
1270 ;; If the function isn't a LET, we unlink the function head
1271 ;; and tail from the component head and tail to indicate that
1272 ;; the code is unreachable. We also delete the function from
1273 ;; COMPONENT-LAMBDAS (it won't be there before local call
1274 ;; analysis, but no matter.) If the lambda was never
1275 ;; referenced, we give a note.
1276 (let* ((bind-block (node-block bind
))
1277 (component (block-component bind-block
))
1278 (return (lambda-return clambda
))
1279 (return-block (and return
(node-block return
))))
1280 (unless (leaf-ever-used clambda
)
1281 (let ((*compiler-error-context
* bind
))
1282 (compiler-notify 'code-deletion-note
1283 :format-control
"deleting unused function~:[.~;~:*~% ~S~]"
1284 :format-arguments
(list (leaf-debug-name clambda
)))))
1285 (unless (block-delete-p bind-block
)
1286 (unlink-blocks (component-head component
) bind-block
))
1287 (when (and return-block
(not (block-delete-p return-block
)))
1288 (mark-for-deletion return-block
)
1289 (unlink-blocks return-block
(component-tail component
)))
1290 (setf (component-reanalyze component
) t
)
1291 (let ((tails (lambda-tail-set clambda
)))
1292 (setf (tail-set-funs tails
)
1293 (delete clambda
(tail-set-funs tails
)))
1294 (setf (lambda-tail-set clambda
) nil
))
1295 (setf (component-lambdas component
)
1296 (delq clambda
(component-lambdas component
))))))
1298 ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
1299 ;; ENTRY-FUN so that people will know that it is not an entry
1301 (when (eq original-kind
:external
)
1302 (let ((fun (functional-entry-fun clambda
)))
1303 (setf (functional-entry-fun fun
) nil
)
1304 (when (optional-dispatch-p fun
)
1305 (delete-optional-dispatch fun
)))))
1309 ;;; Deal with deleting the last reference to an OPTIONAL-DISPATCH. We
1310 ;;; have to be a bit more careful than with lambdas, since DELETE-REF
1311 ;;; is used both before and after local call analysis. Afterward, all
1312 ;;; references to still-existing OPTIONAL-DISPATCHes have been moved
1313 ;;; to the XEP, leaving it with no references at all. So we look at
1314 ;;; the XEP to see whether an optional-dispatch is still really being
1315 ;;; used. But before local call analysis, there are no XEPs, and all
1316 ;;; references are direct.
1318 ;;; When we do delete the OPTIONAL-DISPATCH, we grovel all of its
1319 ;;; entry-points, making them be normal lambdas, and then deleting the
1320 ;;; ones with no references. This deletes any e-p lambdas that were
1321 ;;; either never referenced, or couldn't be deleted when the last
1322 ;;; reference was deleted (due to their :OPTIONAL kind.)
1324 ;;; Note that the last optional entry point may alias the main entry,
1325 ;;; so when we process the main entry, its KIND may have been changed
1326 ;;; to NIL or even converted to a LETlike value.
1327 (defun delete-optional-dispatch (leaf)
1328 (declare (type optional-dispatch leaf
))
1329 (let ((entry (functional-entry-fun leaf
)))
1331 (or (leaf-refs entry
)
1332 (eq (functional-kind entry
) :external
)))
1333 (aver (or (not entry
) (eq (functional-kind entry
) :deleted
)))
1334 (setf (functional-kind leaf
) :deleted
)
1337 (unless (eq (functional-kind fun
) :deleted
)
1338 (aver (eq (functional-kind fun
) :optional
))
1339 (setf (functional-kind fun
) nil
)
1340 (let ((refs (leaf-refs fun
)))
1342 (delete-lambda fun
))
1344 (or (maybe-let-convert fun
)
1345 (maybe-convert-to-assignment fun
)))
1347 (maybe-convert-to-assignment fun
)))))))
1349 (dolist (ep (optional-dispatch-entry-points leaf
))
1350 (when (promise-ready-p ep
)
1352 (when (optional-dispatch-more-entry leaf
)
1353 (frob (optional-dispatch-more-entry leaf
)))
1354 (let ((main (optional-dispatch-main-entry leaf
)))
1356 (setf (functional-entry-fun entry
) main
)
1357 (setf (functional-entry-fun main
) entry
))
1358 (when (eq (functional-kind main
) :optional
)
1363 ;;; This is called by locall-analyze-fun-1 after it convers a call to
1364 ;;; FUN into a local call.
1365 ;;; Presumably, the function can be no longer reused by new calls to
1366 ;;; FUN, so the whole thing has to be removed from *FREE-FUNS*
1367 (defun note-local-functional (fun)
1368 (declare (type functional fun
))
1369 (when (and (leaf-has-source-name-p fun
)
1370 (eq (leaf-source-name fun
) (functional-debug-name fun
)))
1371 (let* ((name (leaf-source-name fun
))
1372 (defined-fun (gethash name
*free-funs
*)))
1373 (when (defined-fun-p defined-fun
)
1374 (remhash name
*free-funs
*)))))
1376 ;;; Return functional for DEFINED-FUN which has been converted in policy
1377 ;;; corresponding to the current one, or NIL if no such functional exists.
1379 ;;; Also check that the parent of the functional is visible in the current
1380 ;;; environment and is in the current component.
1381 (defun defined-fun-functional (defined-fun)
1382 (let ((functionals (defined-fun-functionals defined-fun
)))
1384 (let* ((sample (car functionals
))
1385 (there (lambda-parent (if (lambda-p sample
)
1387 (optional-dispatch-main-entry sample
)))))
1389 (labels ((lookup (here)
1390 (unless (eq here there
)
1392 (lookup (lambda-parent here
))
1393 ;; We looked up all the way up, and didn't find the parent
1394 ;; of the functional -- therefore it is nested in a lambda
1395 ;; we don't see, so return nil.
1396 (return-from defined-fun-functional nil
)))))
1397 (lookup (lexenv-lambda *lexenv
*)))))
1398 ;; Now find a functional whose policy matches the current one, if we already
1400 (let ((policy (lexenv-%policy
*lexenv
*)))
1401 (dolist (functional functionals
)
1402 (when (and (neq (functional-kind functional
) :deleted
)
1403 (policy= policy
(lexenv-%policy
(functional-lexenv functional
)))
1404 (eq (lambda-component
1406 (if (lambda-p functional
)
1408 (optional-dispatch-main-entry functional
))))
1409 *current-component
*))
1410 (return functional
)))))))
1412 ;;; Do stuff to delete the semantic attachments of a REF node. When
1413 ;;; this leaves zero or one reference, we do a type dispatch off of
1414 ;;; the leaf to determine if a special action is appropriate.
1415 (defun delete-ref (ref)
1416 (declare (type ref ref
))
1417 (let* ((leaf (ref-leaf ref
))
1418 (refs (delq ref
(leaf-refs leaf
))))
1419 (setf (leaf-refs leaf
) refs
)
1424 (delete-lambda-var leaf
))
1426 (ecase (functional-kind leaf
)
1427 ((nil :let
:mv-let
:assignment
:escape
:cleanup
)
1428 (aver (null (functional-entry-fun leaf
)))
1429 (delete-lambda leaf
))
1431 (unless (functional-has-external-references-p leaf
)
1432 (delete-lambda leaf
)))
1433 ((:deleted
:zombie
:optional
))))
1435 (unless (eq (functional-kind leaf
) :deleted
)
1436 (delete-optional-dispatch leaf
)))))
1439 (clambda (or (maybe-let-convert leaf
)
1440 (maybe-convert-to-assignment leaf
)))
1441 (lambda-var (reoptimize-lambda-var leaf
))))
1444 (clambda (maybe-convert-to-assignment leaf
))))))
1448 ;;; This function is called to unlink a node from its LVAR;
1449 ;;; we assume that the LVAR's USE list has already been updated,
1450 ;;; and that we only have to mark the node as up for dead code
1451 ;;; elimination, and to clear it LVAR slot.
1452 (defun flush-node (node)
1453 (declare (type node node
))
1454 (let* ((prev (node-prev node
))
1455 (block (ctran-block prev
)))
1456 (reoptimize-component (block-component block
) t
)
1457 (setf (block-attributep (block-flags block
)
1458 flush-p type-asserted type-check
)
1460 (setf (node-lvar node
) nil
))
1462 ;;; This function is called by people who delete nodes; it provides a
1463 ;;; way to indicate that the value of a lvar is no longer used. We
1464 ;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses
1465 ;;; of LVAR and set COMPONENT-REOPTIMIZE.
1466 (defun flush-dest (lvar)
1467 (declare (type (or lvar null
) lvar
))
1469 (when (lvar-dynamic-extent lvar
)
1470 (note-no-stack-allocation lvar
:flush t
))
1471 (setf (lvar-dest lvar
) nil
)
1472 (flush-lvar-externally-checkable-type lvar
)
1475 (setf (lvar-uses lvar
) nil
))
1478 (defun delete-dest (lvar)
1480 (let* ((dest (lvar-dest lvar
))
1481 (prev (node-prev dest
)))
1482 (let ((block (ctran-block prev
)))
1483 (unless (block-delete-p block
)
1484 (mark-for-deletion block
))))))
1486 ;;; Queue the block for deletion
1487 (defun delete-block-lazily (block)
1488 (declare (type cblock block
))
1489 (unless (block-delete-p block
)
1490 (setf (block-delete-p block
) t
)
1491 (push block
(component-delete-blocks (block-component block
)))))
1493 ;;; Do a graph walk backward from BLOCK, marking all predecessor
1494 ;;; blocks with the DELETE-P flag.
1495 (defun mark-for-deletion (block)
1496 (declare (type cblock block
))
1497 (let* ((component (block-component block
))
1498 (head (component-head component
)))
1499 (labels ((helper (block)
1500 (delete-block-lazily block
)
1501 (dolist (pred (block-pred block
))
1502 (unless (or (block-delete-p pred
)
1505 (unless (block-delete-p block
)
1507 (setf (component-reanalyze component
) t
))))
1510 ;;; This function does what is necessary to eliminate the code in it
1511 ;;; from the IR1 representation. This involves unlinking it from its
1512 ;;; predecessors and successors and deleting various node-specific
1513 ;;; semantic information. BLOCK must be already removed from
1514 ;;; COMPONENT-DELETE-BLOCKS.
1515 (defun delete-block (block &optional silent
)
1516 (declare (type cblock block
))
1517 (unless (block-component block
)
1519 (return-from delete-block
))
1520 #!+high-security
(aver (not (memq block
(component-delete-blocks (block-component block
)))))
1522 (note-block-deletion block
))
1523 (setf (block-delete-p block
) t
)
1525 (dolist (b (block-pred block
))
1526 (unlink-blocks b block
)
1527 ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
1528 ;; broken when successors were deleted without setting the
1529 ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
1530 ;; doesn't happen again.
1531 (aver (not (and (null (block-succ b
))
1532 (not (block-delete-p b
))
1533 (not (eq b
(component-head (block-component b
))))))))
1534 (dolist (b (block-succ block
))
1535 (unlink-blocks block b
))
1537 (do-nodes-carefully (node block
)
1538 (when (valued-node-p node
)
1539 (delete-lvar-use node
))
1541 (ref (delete-ref node
))
1542 (cif (flush-dest (if-test node
)))
1543 ;; The next two cases serve to maintain the invariant that a LET
1544 ;; always has a well-formed COMBINATION, REF and BIND. We delete
1545 ;; the lambda whenever we delete any of these, but we must be
1546 ;; careful that this LET has not already been partially deleted.
1548 (when (and (eq (basic-combination-kind node
) :local
)
1549 ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
1550 (lvar-uses (basic-combination-fun node
)))
1551 (let ((fun (combination-lambda node
)))
1552 ;; If our REF was the second-to-last ref, and has been
1553 ;; deleted, then FUN may be a LET for some other
1555 (when (and (functional-letlike-p fun
)
1556 (eq (let-combination fun
) node
))
1557 (delete-lambda fun
))))
1558 (flush-dest (basic-combination-fun node
))
1559 (dolist (arg (basic-combination-args node
))
1560 (when arg
(flush-dest arg
))))
1562 (let ((lambda (bind-lambda node
)))
1563 (unless (eq (functional-kind lambda
) :deleted
)
1564 (delete-lambda lambda
))))
1566 (let ((value (exit-value node
))
1567 (entry (exit-entry node
)))
1571 (setf (entry-exits entry
)
1572 (delq node
(entry-exits entry
))))))
1574 (dolist (exit (entry-exits node
))
1575 (mark-for-deletion (node-block exit
)))
1576 (let ((home (node-home-lambda node
)))
1577 (setf (lambda-entries home
) (delq node
(lambda-entries home
)))))
1579 (flush-dest (return-result node
))
1580 (delete-return node
))
1582 (flush-dest (set-value node
))
1583 (let ((var (set-var node
)))
1584 (setf (basic-var-sets var
)
1585 (delete node
(basic-var-sets var
)))))
1587 (flush-dest (cast-value node
)))))
1589 (remove-from-dfo block
)
1592 ;;; Do stuff to indicate that the return node NODE is being deleted.
1593 (defun delete-return (node)
1594 (declare (type creturn node
))
1595 (let* ((fun (return-lambda node
))
1596 (tail-set (lambda-tail-set fun
)))
1597 (aver (lambda-return fun
))
1598 (setf (lambda-return fun
) nil
)
1599 (when (and tail-set
(not (find-if #'lambda-return
1600 (tail-set-funs tail-set
))))
1601 (setf (tail-set-type tail-set
) *empty-type
*)))
1604 ;;; If any of the VARS in FUN was never referenced and was not
1605 ;;; declared IGNORE, then complain.
1606 (defun note-unreferenced-vars (vars policy
)
1608 (unless (or (leaf-ever-used var
)
1609 (lambda-var-ignorep var
))
1610 (unless (policy policy
(= inhibit-warnings
3))
1611 ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
1612 ;; requires this to be no more than a STYLE-WARNING.
1614 (compiler-style-warn "The variable ~S is defined but never used."
1615 (leaf-debug-name var
))
1616 ;; There's no reason to accept this kind of equivocation
1617 ;; when compiling our own code, though.
1619 (warn "The variable ~S is defined but never used."
1620 (leaf-debug-name var
)))
1621 (setf (leaf-ever-used var
) t
)))) ; to avoid repeated warnings? -- WHN
1623 (defun note-unreferenced-fun-vars (fun)
1624 (declare (type clambda fun
))
1625 (let ((*compiler-error-context
* (lambda-bind fun
)))
1626 (note-unreferenced-vars (lambda-vars fun
)
1627 *compiler-error-context
*))
1630 ;;; Return true if we can find OBJ in FORM, NIL otherwise. We bound
1631 ;;; our recursion so that we don't get lost in circular structures. We
1632 ;;; ignore the car of forms if they are a symbol (to prevent confusing
1633 ;;; function referencess with variables), and we also ignore anything
1635 (defun present-in-form (obj form depth
)
1636 (declare (type (integer 0 20) depth
))
1637 (cond ((= depth
20) nil
)
1641 (let ((first (car form
))
1643 (if (member first
'(quote function
))
1645 (or (and (not (symbolp first
))
1646 (present-in-form obj first depth
))
1647 (do ((l (cdr form
) (cdr l
))
1649 ((or (atom l
) (> n
100))
1651 (declare (fixnum n
))
1652 (when (present-in-form obj
(car l
) depth
)
1655 ;;; This function is called on a block immediately before we delete
1656 ;;; it. We check to see whether any of the code about to die appeared
1657 ;;; in the original source, and emit a note if so.
1659 ;;; If the block was in a lambda is now deleted, then we ignore the
1660 ;;; whole block, since this case is picked off in DELETE-LAMBDA. We
1661 ;;; also ignore the deletion of CRETURN nodes, since it is somewhat
1662 ;;; reasonable for a function to not return, and there is a different
1663 ;;; note for that case anyway.
1665 ;;; If the actual source is an atom, then we use a bunch of heuristics
1666 ;;; to guess whether this reference really appeared in the original
1668 ;;; -- If a symbol, it must be interned and not a keyword.
1669 ;;; -- It must not be an easily introduced constant (T or NIL, a fixnum
1670 ;;; or a character.)
1671 ;;; -- The atom must be "present" in the original source form, and
1672 ;;; present in all intervening actual source forms.
1673 (defun note-block-deletion (block)
1674 (let ((home (block-home-lambda block
)))
1675 (unless (eq (functional-kind home
) :deleted
)
1676 (do-nodes (node nil block
)
1677 (let* ((path (node-source-path node
))
1678 (first (first path
)))
1679 (when (or (eq first
'original-source-start
)
1681 (or (not (symbolp first
))
1682 (let ((pkg (symbol-package first
)))
1684 (not (eq pkg
(symbol-package :end
))))))
1685 (not (member first
'(t nil
)))
1686 (not (typep first
'(or fixnum character
)))
1688 (present-in-form first x
0))
1689 (source-path-forms path
))
1690 (present-in-form first
(find-original-source path
)
1692 (unless (return-p node
)
1693 (let ((*compiler-error-context
* node
))
1694 (compiler-notify 'code-deletion-note
1695 :format-control
"deleting unreachable code"
1696 :format-arguments nil
)))
1700 ;;; Delete a node from a block, deleting the block if there are no
1701 ;;; nodes left. We remove the node from the uses of its LVAR.
1703 ;;; If the node is the last node, there must be exactly one successor.
1704 ;;; We link all of our precedessors to the successor and unlink the
1705 ;;; block. In this case, we return T, otherwise NIL. If no nodes are
1706 ;;; left, and the block is a successor of itself, then we replace the
1707 ;;; only node with a degenerate exit node. This provides a way to
1708 ;;; represent the bodyless infinite loop, given the prohibition on
1709 ;;; empty blocks in IR1.
1710 (defun unlink-node (node)
1711 (declare (type node node
))
1712 (when (valued-node-p node
)
1713 (delete-lvar-use node
))
1715 (let* ((ctran (node-next node
))
1716 (next (and ctran
(ctran-next ctran
)))
1717 (prev (node-prev node
))
1718 (block (ctran-block prev
))
1719 (prev-kind (ctran-kind prev
))
1720 (last (block-last block
)))
1722 (setf (block-type-asserted block
) t
)
1723 (setf (block-test-modified block
) t
)
1725 (cond ((or (eq prev-kind
:inside-block
)
1726 (and (eq prev-kind
:block-start
)
1727 (not (eq node last
))))
1728 (cond ((eq node last
)
1729 (setf (block-last block
) (ctran-use prev
))
1730 (setf (node-next (ctran-use prev
)) nil
))
1732 (setf (ctran-next prev
) next
)
1733 (setf (node-prev next
) prev
)
1734 (when (if-p next
) ; AOP wanted
1735 (reoptimize-lvar (if-test next
)))))
1736 (setf (node-prev node
) nil
)
1739 (aver (eq prev-kind
:block-start
))
1740 (aver (eq node last
))
1741 (let* ((succ (block-succ block
))
1742 (next (first succ
)))
1743 (aver (singleton-p succ
))
1745 ((eq block
(first succ
))
1746 (with-ir1-environment-from-node node
1747 (let ((exit (make-exit)))
1748 (setf (ctran-next prev
) nil
)
1749 (link-node-to-previous-ctran exit prev
)
1750 (setf (block-last block
) exit
)))
1751 (setf (node-prev node
) nil
)
1754 (aver (eq (block-start-cleanup block
)
1755 (block-end-cleanup block
)))
1756 (unlink-blocks block next
)
1757 (dolist (pred (block-pred block
))
1758 (change-block-successor pred block next
))
1759 (when (block-delete-p block
)
1760 (let ((component (block-component block
)))
1761 (setf (component-delete-blocks component
)
1762 (delq block
(component-delete-blocks component
)))))
1763 (remove-from-dfo block
)
1764 (setf (block-delete-p block
) t
)
1765 (setf (node-prev node
) nil
)
1768 ;;; Return true if CTRAN has been deleted, false if it is still a valid
1770 (defun ctran-deleted-p (ctran)
1771 (declare (type ctran ctran
))
1772 (let ((block (ctran-block ctran
)))
1773 (or (not (block-component block
))
1774 (block-delete-p block
))))
1776 ;;; Return true if NODE has been deleted, false if it is still a valid
1778 (defun node-deleted (node)
1779 (declare (type node node
))
1780 (let ((prev (node-prev node
)))
1782 (ctran-deleted-p prev
))))
1784 ;;; Delete all the blocks and functions in COMPONENT. We scan first
1785 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
1786 ;;; triggered by deletion.
1787 (defun delete-component (component)
1788 (declare (type component component
))
1789 (aver (null (component-new-functionals component
)))
1790 (setf (component-kind component
) :deleted
)
1791 (do-blocks (block component
)
1792 (delete-block-lazily block
))
1793 (dolist (fun (component-lambdas component
))
1794 (unless (eq (functional-kind fun
) :deleted
)
1795 (setf (functional-kind fun
) nil
)
1796 (setf (functional-entry-fun fun
) nil
)
1797 (setf (leaf-refs fun
) nil
)
1798 (delete-functional fun
)))
1799 (clean-component component
)
1802 ;;; Remove all pending blocks to be deleted. Return the nearest live
1803 ;;; block after or equal to BLOCK.
1804 (defun clean-component (component &optional block
)
1805 (loop while
(component-delete-blocks component
)
1806 ;; actual deletion of a block may queue new blocks
1807 do
(let ((current (pop (component-delete-blocks component
))))
1808 (when (eq block current
)
1809 (setq block
(block-next block
)))
1810 (delete-block current
)))
1813 ;;; Convert code of the form
1814 ;;; (FOO ... (FUN ...) ...)
1816 ;;; (FOO ... ... ...).
1817 ;;; In other words, replace the function combination FUN by its
1818 ;;; arguments. If there are any problems with doing this, use GIVE-UP
1819 ;;; to blow out of whatever transform called this. Note, as the number
1820 ;;; of arguments changes, the transform must be prepared to return a
1821 ;;; lambda with a new lambda-list with the correct number of
1823 (defun splice-fun-args (lvar fun num-args
)
1824 "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed
1825 directly to the LVAR-DEST of LVAR, which must be a combination. If FUN
1826 is :ANY, the function name is not checked."
1827 (declare (type lvar lvar
)
1829 (type index num-args
))
1830 (let ((outside (lvar-dest lvar
))
1831 (inside (lvar-uses lvar
)))
1832 (aver (combination-p outside
))
1833 (unless (combination-p inside
)
1834 (give-up-ir1-transform))
1835 (let ((inside-fun (combination-fun inside
)))
1836 (unless (or (eq fun
:any
)
1837 (eq (lvar-fun-name inside-fun
) fun
))
1838 (give-up-ir1-transform))
1839 (let ((inside-args (combination-args inside
)))
1840 (unless (= (length inside-args
) num-args
)
1841 (give-up-ir1-transform))
1842 (let* ((outside-args (combination-args outside
))
1843 (arg-position (position lvar outside-args
))
1844 (before-args (subseq outside-args
0 arg-position
))
1845 (after-args (subseq outside-args
(1+ arg-position
))))
1846 (dolist (arg inside-args
)
1847 (setf (lvar-dest arg
) outside
)
1848 (flush-lvar-externally-checkable-type arg
))
1849 (setf (combination-args inside
) nil
)
1850 (setf (combination-args outside
)
1851 (append before-args inside-args after-args
))
1852 (change-ref-leaf (lvar-uses inside-fun
)
1853 (find-free-fun 'list
"???"))
1854 (setf (combination-fun-info inside
) (info :function
:info
'list
)
1855 (combination-kind inside
) :known
)
1856 (setf (node-derived-type inside
) *wild-type
*)
1860 ;;; Eliminate keyword arguments from the call (leaving the
1861 ;;; parameters in place.
1863 ;;; (FOO ... :BAR X :QUUX Y)
1867 ;;; SPECS is a list of (:KEYWORD PARAMETER) specifications.
1868 ;;; Returns the list of specified parameters names in the
1869 ;;; order they appeared in the call. N-POSITIONAL is the
1870 ;;; number of positional arguments in th call.
1871 (defun eliminate-keyword-args (call n-positional specs
)
1872 (let* ((specs (copy-tree specs
))
1873 (all (combination-args call
))
1874 (new-args (reverse (subseq all
0 n-positional
)))
1875 (key-args (subseq all n-positional
))
1878 (loop while key-args
1879 do
(let* ((key (pop key-args
))
1880 (val (pop key-args
))
1881 (keyword (if (constant-lvar-p key
)
1883 (give-up-ir1-transform)))
1884 (spec (or (assoc keyword specs
:test
#'eq
)
1885 (give-up-ir1-transform))))
1887 (push key flushed-keys
)
1888 (push (second spec
) parameters
)
1889 ;; In case of duplicate keys.
1890 (setf (second spec
) (gensym))))
1891 (dolist (key flushed-keys
)
1893 (setf (combination-args call
) (reverse new-args
))
1894 (reverse parameters
)))
1896 (defun extract-fun-args (lvar fun num-args
)
1897 (declare (type lvar lvar
)
1898 (type (or symbol list
) fun
)
1899 (type index num-args
))
1900 (let ((inside (lvar-uses lvar
)))
1901 (unless (combination-p inside
)
1902 (give-up-ir1-transform))
1903 (let ((inside-fun (combination-fun inside
)))
1904 (unless (member (lvar-fun-name inside-fun
) (ensure-list fun
))
1905 (give-up-ir1-transform))
1906 (let ((inside-args (combination-args inside
)))
1907 (unless (= (length inside-args
) num-args
)
1908 (give-up-ir1-transform))
1909 (values (lvar-fun-name inside-fun
) inside-args
)))))
1911 (defun flush-combination (combination)
1912 (declare (type combination combination
))
1913 (flush-dest (combination-fun combination
))
1914 (dolist (arg (combination-args combination
))
1916 (unlink-node combination
)
1922 ;;; Change the LEAF that a REF refers to.
1923 (defun change-ref-leaf (ref leaf
&key recklessly
)
1924 (declare (type ref ref
) (type leaf leaf
))
1925 (unless (eq (ref-leaf ref
) leaf
)
1926 (push ref
(leaf-refs leaf
))
1928 (setf (ref-leaf ref
) leaf
)
1929 (setf (leaf-ever-used leaf
) t
)
1930 (let* ((ltype (leaf-type leaf
))
1931 (vltype (make-single-value-type ltype
)))
1932 (if (let* ((lvar (node-lvar ref
))
1933 (dest (and lvar
(lvar-dest lvar
))))
1934 (and (basic-combination-p dest
)
1935 (eq lvar
(basic-combination-fun dest
))
1936 (csubtypep ltype
(specifier-type 'function
))))
1937 (setf (node-derived-type ref
) vltype
)
1938 (derive-node-type ref vltype
:from-scratch recklessly
)))
1939 (reoptimize-lvar (node-lvar ref
)))
1942 ;;; Change all REFS for OLD-LEAF to NEW-LEAF.
1943 (defun substitute-leaf (new-leaf old-leaf
)
1944 (declare (type leaf new-leaf old-leaf
))
1945 (dolist (ref (leaf-refs old-leaf
))
1946 (change-ref-leaf ref new-leaf
))
1949 ;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
1950 ;;; whether to substitute
1951 (defun substitute-leaf-if (test new-leaf old-leaf
)
1952 (declare (type leaf new-leaf old-leaf
) (type function test
))
1953 (dolist (ref (leaf-refs old-leaf
))
1954 (when (funcall test ref
)
1955 (change-ref-leaf ref new-leaf
)))
1958 ;;; Return a LEAF which represents the specified constant object. If
1959 ;;; the object is not in *CONSTANTS*, then we create a new constant
1960 ;;; LEAF and enter it. If we are producing a fasl file, make sure that
1961 ;;; MAKE-LOAD-FORM gets used on any parts of the constant that it
1964 ;;; We are allowed to coalesce things like EQUAL strings and bit-vectors
1965 ;;; when file-compiling, but not when using COMPILE.
1966 (defun find-constant (object &optional
(name nil namep
))
1967 (let ((faslp (producing-fasl-file)))
1968 (labels ((make-it ()
1971 (maybe-emit-make-load-forms object name
)
1972 (maybe-emit-make-load-forms object
)))
1973 (make-constant object
))
1974 (core-coalesce-p (x)
1975 ;; True for things which retain their identity under EQUAL,
1976 ;; so we can safely share the same CONSTANT leaf between
1977 ;; multiple references.
1978 (or (typep x
'(or symbol number character
))
1979 ;; Amusingly enough, we see CLAMBDAs --among other things--
1980 ;; here, from compiling things like %ALLOCATE-CLOSUREs forms.
1981 ;; No point in stuffing them in the hash-table.
1982 (and (typep x
'instance
)
1983 (not (or (leaf-p x
) (node-p x
))))))
1984 (cons-coalesce-p (x)
1985 (if (eq +code-coverage-unmarked
+ (cdr x
))
1986 ;; These are already coalesced, and the CAR should
1987 ;; always be OK, so no need to check.
1989 (when (coalesce-tree-p x
)
1990 (labels ((descend (x)
1992 ((atom y
) (atom-colesce-p y
))
1993 ;; Don't just call file-coalesce-p, because it'll
1994 ;; invoke COALESCE-TREE-P repeatedly
1995 (let ((car (car y
)))
1996 (unless (if (consp car
)
1998 (atom-colesce-p car
))
2002 (or (core-coalesce-p x
)
2003 ;; We *could* coalesce base-strings as well,
2004 ;; but we'd need a separate hash-table for
2005 ;; that, since we are not allowed to coalesce
2006 ;; base-strings with non-base-strings.
2009 ;; in the cross-compiler, we coalesce
2010 ;; all strings with the same contents,
2011 ;; because we will end up dumping them
2012 ;; as base-strings anyway. In the
2013 ;; real compiler, we're not allowed to
2014 ;; coalesce regardless of string
2015 ;; specialized element type, so we
2016 ;; KLUDGE by coalescing only character
2017 ;; strings (the common case) and
2018 ;; punting on the other types.
2022 (vector character
)))))
2023 (file-coalesce-p (x)
2024 ;; CLHS 3.2.4.2.2: We are also allowed to coalesce various
2025 ;; other things when file-compiling.
2028 (atom-colesce-p x
)))
2030 (if faslp
(file-coalesce-p x
) (core-coalesce-p x
))))
2031 ;; When compiling to core we don't coalesce strings, because
2032 ;; "The functions eval and compile are required to ensure that literal objects
2033 ;; referenced within the resulting interpreted or compiled code objects are
2034 ;; the _same_ as the corresponding objects in the source code."
2035 ;; but in a dumped image, if gc_coalesce_string_literals is 1 then GC will
2036 ;; coalesce similar immutable strings to save memory,
2037 ;; even if not technically permitted. According to CLHS 3.7.1
2038 ;; "The consequences are undefined if literal objects are destructively modified
2039 ;; For this purpose, the following operations are considered destructive:
2040 ;; array - Storing a new value into some element of the array ..."
2041 ;; so a string, once used as a literal in source, becomes logically immutable.
2043 (when (and (not faslp
) (simple-string-p object
))
2044 (logically-readonlyize object nil
))
2045 (if (and (boundp '*constants
*) (coalescep object
))
2046 (ensure-gethash object
*constants
* (make-it))
2049 ;;; Return true if VAR would have to be closed over if environment
2050 ;;; analysis ran now (i.e. if there are any uses that have a different
2051 ;;; home lambda than VAR's home.)
2052 (defun closure-var-p (var)
2053 (declare (type lambda-var var
))
2054 (let ((home (lambda-var-home var
)))
2055 (cond ((eq (functional-kind home
) :deleted
)
2057 (t (let ((home (lambda-home home
)))
2060 :key
#'node-home-lambda
2062 (or (frob (leaf-refs var
))
2063 (frob (basic-var-sets var
)))))))))
2065 ;;; If there is a non-local exit noted in ENTRY's environment that
2066 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
2067 (defun find-nlx-info (exit)
2068 (declare (type exit exit
))
2069 (let* ((entry (exit-entry exit
))
2070 (cleanup (entry-cleanup entry
))
2071 (block (first (block-succ (node-block exit
)))))
2072 (dolist (nlx (physenv-nlx-info (node-physenv entry
)) nil
)
2073 (when (and (eq (nlx-info-block nlx
) block
)
2074 (eq (nlx-info-cleanup nlx
) cleanup
))
2077 (defun nlx-info-lvar (nlx)
2078 (declare (type nlx-info nlx
))
2079 (node-lvar (block-last (nlx-info-target nlx
))))
2081 ;;;; functional hackery
2083 (declaim (ftype (sfunction (functional) clambda
) main-entry
))
2084 (defun main-entry (functional)
2085 (etypecase functional
2086 (clambda functional
)
2088 (optional-dispatch-main-entry functional
))))
2090 ;;; RETURN true if FUNCTIONAL is a thing that can be treated like
2091 ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
2092 ;;; optional with null default and no SUPPLIED-P. There must be a
2093 ;;; &REST arg with no references.
2094 (declaim (ftype (sfunction (functional) boolean
) looks-like-an-mv-bind
))
2095 (defun looks-like-an-mv-bind (functional)
2096 (and (optional-dispatch-p functional
)
2097 (do ((arg (optional-dispatch-arglist functional
) (cdr arg
)))
2099 (let ((info (lambda-var-arg-info (car arg
))))
2100 (unless info
(return nil
))
2101 (case (arg-info-kind info
)
2103 (when (or (arg-info-supplied-p info
) (arg-info-default info
))
2106 (return (and (null (cdr arg
)) (null (leaf-refs (car arg
))))))
2110 (defun call-all-args-fixed-p (call)
2111 (loop for arg in
(basic-combination-args call
)
2112 always
(numberp (nth-value 1 (values-types
2113 (lvar-derived-type arg
))))))
2115 ;;; Return true if function is an external entry point. This is true
2116 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
2117 ;;; (:TOPLEVEL kind.)
2119 (declare (type functional fun
))
2120 (not (null (member (functional-kind fun
) '(:external
:toplevel
)))))
2122 ;;; If LVAR's only use is a non-notinline global function reference,
2123 ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
2124 ;;; is true, then we don't care if the leaf is NOTINLINE.
2125 (defun lvar-fun-name (lvar &optional notinline-ok
)
2126 (declare (type lvar lvar
))
2127 (let ((use (lvar-uses lvar
)))
2129 (let ((leaf (ref-leaf use
)))
2130 (if (and (global-var-p leaf
)
2131 (eq (global-var-kind leaf
) :global-function
)
2132 (or (not (defined-fun-p leaf
))
2133 (not (eq (defined-fun-inlinep leaf
) :notinline
))
2135 (leaf-source-name leaf
)
2139 ;;; As above, but allow a quoted symbol also,
2140 ;;; in which case we don't check for notinline-ness,
2141 ;;; so be careful how you use this.
2142 ;;; Also note that Case 2 in LVAR-FUN-IS for dealing with #.#'NAME
2143 ;;; has no equivalent here.
2144 (defun lvar-fun-name* (lvar)
2145 (if (constant-lvar-p lvar
) (lvar-value lvar
) (lvar-fun-name lvar
)))
2147 (defun lvar-fun-debug-name (lvar)
2148 (declare (type lvar lvar
))
2149 (let ((uses (lvar-uses lvar
)))
2151 (leaf-debug-name (ref-leaf use
))))
2154 (mapcar #'name1 uses
)))))
2156 ;;; Return the source name of a combination -- or signals an error
2157 ;;; if the function leaf is anonymous.
2158 (defun combination-fun-source-name (combination &optional
(errorp t
))
2159 (let ((uses (principal-lvar-use (combination-fun combination
)))
2161 (cond ((and (ref-p uses
)
2162 (leaf-has-source-name-p (setf leaf
(ref-leaf uses
))))
2163 (values (leaf-source-name leaf
) t
))
2165 (aver (not "COMBINATION-FUN is not a ref to a nameful leaf")))
2167 (values nil nil
)))))
2169 (defun combination-fun-debug-name (combination)
2170 (let ((uses (principal-lvar-use (combination-fun combination
))))
2172 (let ((leaf (ref-leaf uses
)))
2175 (functional-debug-name leaf
))
2177 (and (leaf-has-source-name-p leaf
)
2178 (leaf-source-name leaf
))))))))
2180 ;;; Return the COMBINATION node that is the call to the LET FUN.
2181 (defun let-combination (fun)
2182 (declare (type clambda fun
))
2183 (aver (functional-letlike-p fun
))
2184 (lvar-dest (node-lvar (first (leaf-refs fun
)))))
2186 ;;; Return the initial value lvar for a LET variable, or NIL if there
2188 (defun let-var-initial-value (var)
2189 (declare (type lambda-var var
))
2190 (let ((fun (lambda-var-home var
)))
2191 (elt (combination-args (let-combination fun
))
2192 (position-or-lose var
(lambda-vars fun
)))))
2194 ;;; Return the LAMBDA that is called by the local CALL.
2195 (defun combination-lambda (call)
2196 (declare (type basic-combination call
))
2197 (aver (eq (basic-combination-kind call
) :local
))
2198 (ref-leaf (lvar-uses (basic-combination-fun call
))))
2200 (defvar *inline-expansion-limit
* 200
2201 "an upper limit on the number of inline function calls that will be expanded
2202 in any given code object (single function or block compilation)")
2204 ;;; Check whether NODE's component has exceeded its inline expansion
2205 ;;; limit, and warn if so, returning NIL.
2206 (defun inline-expansion-ok (node)
2207 (let ((expanded (incf (component-inline-expansions
2209 (node-block node
))))))
2210 (cond ((> expanded
*inline-expansion-limit
*) nil
)
2211 ((= expanded
*inline-expansion-limit
*)
2212 ;; FIXME: If the objective is to stop the recursive
2213 ;; expansion of inline functions, wouldn't it be more
2214 ;; correct to look back through surrounding expansions
2215 ;; (which are, I think, stored in the *CURRENT-PATH*, and
2216 ;; possibly stored elsewhere too) and suppress expansion
2217 ;; and print this warning when the function being proposed
2218 ;; for inline expansion is found there? (I don't like the
2219 ;; arbitrary numerical limit in principle, and I think
2220 ;; it'll be a nuisance in practice if we ever want the
2221 ;; compiler to be able to use WITH-COMPILATION-UNIT on
2222 ;; arbitrarily huge blocks of code. -- WHN)
2223 (let ((*compiler-error-context
* node
))
2224 (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
2225 probably trying to~% ~
2226 inline a recursive function."
2227 *inline-expansion-limit
*))
2231 ;;; Make sure that FUNCTIONAL is not let-converted or deleted.
2232 (defun assure-functional-live-p (functional)
2233 (declare (type functional functional
))
2235 ;; looks LET-converted
2236 (functional-somewhat-letlike-p functional
)
2237 ;; It's possible for a LET-converted function to end up
2238 ;; deleted later. In that case, for the purposes of this
2239 ;; analysis, it is LET-converted: LET-converted functionals
2240 ;; are too badly trashed to expand them inline, and deleted
2241 ;; LET-converted functionals are even worse.
2242 (memq (functional-kind functional
) '(:deleted
:zombie
))))
2243 (throw 'locall-already-let-converted functional
)))
2245 (defun assure-leaf-live-p (leaf)
2248 (when (lambda-var-deleted leaf
)
2249 (throw 'locall-already-let-converted leaf
)))
2251 (assure-functional-live-p leaf
))))
2254 (defun call-full-like-p (call)
2255 (declare (type basic-combination call
))
2256 (let ((kind (basic-combination-kind call
)))
2258 (and (eq kind
:known
)
2259 (let ((info (basic-combination-fun-info call
)))
2261 (not (fun-info-ir2-convert info
))
2262 (dolist (template (fun-info-templates info
) t
)
2263 (when (eq (template-ltn-policy template
) :fast-safe
)
2264 (multiple-value-bind (val win
)
2265 (valid-fun-use call
(template-type template
))
2266 (when (or val
(not win
)) (return nil
)))))))))))
2270 ;;; Apply a function to some arguments, returning a list of the values
2271 ;;; resulting of the evaluation. If an error is signalled during the
2272 ;;; application, then we produce a warning message using WARN-FUN and
2273 ;;; return NIL as our second value to indicate this. NODE is used as
2274 ;;; the error context for any error message, and CONTEXT is a string
2275 ;;; that is spliced into the warning.
2276 (declaim (ftype (sfunction ((or symbol function
) list node function string
)
2277 (values list boolean
))
2279 (defun careful-call (function args node warn-fun context
)
2281 (multiple-value-list
2282 (handler-case (apply function args
)
2284 (let ((*compiler-error-context
* node
))
2285 (funcall warn-fun
"Lisp error during ~A:~%~A" context condition
)
2286 (return-from careful-call
(values nil nil
))))))
2289 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
2292 ((deffrob (basic careful compiler transform
)
2294 (defun ,careful
(specifier)
2295 (handler-case (,basic specifier
)
2296 ((or sb
!kernel
::arg-count-error
2297 type-error
) (condition)
2298 (values nil
(list (princ-to-string condition
))))
2299 (simple-error (condition)
2300 (values nil
(list* (simple-condition-format-control condition
)
2301 (simple-condition-format-arguments condition
))))))
2302 (defun ,compiler
(specifier)
2303 (multiple-value-bind (type error-args
) (,careful specifier
)
2305 (apply #'compiler-error error-args
))))
2306 (defun ,transform
(specifier)
2307 (multiple-value-bind (type error-args
) (,careful specifier
)
2309 (apply #'give-up-ir1-transform
2311 (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type
)
2312 (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type
))
2315 ;;;; utilities used at run-time for parsing &KEY args in IR1
2317 ;;; This function is used by the result of PARSE-DEFTRANSFORM to find
2318 ;;; the lvar for the value of the &KEY argument KEY in the list of
2319 ;;; lvars ARGS. It returns the lvar if the keyword is present, or NIL
2320 ;;; otherwise. The legality and constantness of the keywords should
2321 ;;; already have been checked.
2322 (declaim (ftype (sfunction (list keyword
) (or lvar null
))
2324 (defun find-keyword-lvar (args key
)
2325 (do ((arg args
(cddr arg
)))
2327 (when (eq (lvar-value (first arg
)) key
)
2328 (return (second arg
)))))
2330 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
2331 ;;; verify that alternating lvars in ARGS are constant and that there
2332 ;;; is an even number of args.
2333 (declaim (ftype (sfunction (list) boolean
) check-key-args-constant
))
2334 (defun check-key-args-constant (args)
2335 (do ((arg args
(cddr arg
)))
2337 (unless (and (rest arg
)
2338 (constant-lvar-p (first arg
)))
2341 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
2342 ;;; verify that the list of lvars ARGS is a well-formed &KEY arglist
2343 ;;; and that only keywords present in the list KEYS are supplied.
2344 (declaim (ftype (sfunction (list list
) boolean
) check-transform-keys
))
2345 (defun check-transform-keys (args keys
)
2346 (and (check-key-args-constant args
)
2347 (do ((arg args
(cddr arg
)))
2349 (unless (member (lvar-value (first arg
)) keys
)
2354 ;;; Called by the expansion of the EVENT macro.
2355 (declaim (ftype (sfunction (event-info (or node null
)) *) %event
))
2356 (defun %event
(info node
)
2357 (incf (event-info-count info
))
2358 (when (and (>= (event-info-level info
) *event-note-threshold
*)
2359 (policy (or node
*lexenv
*)
2360 (= inhibit-warnings
0)))
2361 (let ((*compiler-error-context
* node
))
2362 (compiler-notify (event-info-description info
))))
2364 (let ((action (event-info-action info
)))
2365 (when action
(funcall action node
))))
2368 (defun make-cast (value type policy
&optional context
)
2369 (declare (type lvar value
)
2371 (type policy policy
))
2372 (%make-cast
:asserted-type type
2373 :type-to-check
(maybe-weaken-check type policy
)
2375 :derived-type
(coerce-to-values type
)
2378 (defun cast-type-check (cast)
2379 (declare (type cast cast
))
2380 (when (cast-reoptimize cast
)
2381 (ir1-optimize-cast cast t
))
2382 (cast-%type-check cast
))
2384 (defun note-single-valuified-lvar (lvar)
2385 (declare (type (or lvar null
) lvar
))
2387 (let ((use (lvar-uses lvar
)))
2389 (let ((leaf (ref-leaf use
)))
2390 (when (and (lambda-var-p leaf
)
2391 (null (rest (leaf-refs leaf
))))
2392 (reoptimize-lambda-var leaf
))))
2393 ((or (listp use
) (combination-p use
))
2394 (do-uses (node lvar
)
2395 (setf (node-reoptimize node
) t
)
2396 (setf (block-reoptimize (node-block node
)) t
)
2397 (reoptimize-component (node-component node
) :maybe
)))))))
2399 ;;; Return true if LVAR's only use is a reference to a global function
2400 ;;; designator with one of the specified NAMES, that hasn't been
2401 ;;; declared NOTINLINE.
2402 (defun lvar-fun-is (lvar names
)
2403 (declare (type lvar lvar
) (list names
))
2404 (let ((use (lvar-uses lvar
)))
2406 (let* ((*lexenv
* (node-lexenv use
))
2407 (leaf (ref-leaf use
))
2409 (cond ((global-var-p leaf
)
2411 (and (eq (global-var-kind leaf
) :global-function
)
2412 (car (member (leaf-source-name leaf
) names
2415 (let ((value (constant-value leaf
)))
2416 (car (if (functionp value
)
2421 (fdefinition name
)))
2425 :test
#'equal
))))))))
2427 (not (fun-lexically-notinline-p name
)))))))
2429 ;;; Return true if LVAR's only use is a call to one of the named functions
2430 ;;; (or any function if none are specified) with the specified number of
2431 ;;; of arguments (or any number if number is not specified)
2432 (defun lvar-matches (lvar &key fun-names arg-count
)
2433 (let ((use (lvar-uses lvar
)))
2434 (and (combination-p use
)
2436 (multiple-value-bind (name ok
)
2437 (combination-fun-source-name use nil
)
2438 (and ok
(member name fun-names
:test
#'eq
))))
2440 (= arg-count
(length (combination-args use
)))))))
2442 ;;; In (a (b lvar)) (lvar-matches-calls lvar '(b a)) would return T
2443 (defun lvar-matches-calls (lvar dest-fun-names
)
2444 (loop for fun in dest-fun-names
2445 for dest
= (principal-lvar-dest lvar
)
2446 when
(or (not (combination-p dest
))
2447 (neq fun
(combination-fun-source-name dest nil
)))
2449 do
(setf lvar
(combination-lvar dest
))
2450 finally
(return t
)))
2452 ;;; True if the optional has a rest-argument.
2453 (defun optional-rest-p (opt)
2454 (dolist (var (optional-dispatch-arglist opt
) nil
)
2455 (let* ((info (when (lambda-var-p var
)
2456 (lambda-var-arg-info var
)))
2458 (arg-info-kind info
))))
2459 (when (eq :rest kind
)
2462 ;;; Don't substitute single-ref variables on high-debug / low speed, to
2463 ;;; improve the debugging experience. ...but don't bother keeping those
2464 ;;; from system lambdas.
2465 (defun preserve-single-use-debug-var-p (call var
)
2466 (and (policy call
(eql preserve-single-use-debug-variables
3))
2467 (or (not (lambda-var-p var
))
2468 (not (lambda-system-lambda-p (lambda-var-home var
))))))
2470 ;;; The function should accept
2471 ;;; (lvar &key (arg-count (or null unsigned-byte)) (no-function-conversion boolean)
2472 ;;; (args argument-description*) (arg-lvars list-of-lvars))
2473 ;;; where argument-description is either a position into arg-lvars or
2474 ;;; (sequence position-into-arg-lvars)
2475 (defun map-callable-arguments (function combination
)
2476 (let* ((comination-name (lvar-fun-name (combination-fun combination
) t
))
2477 (type (info :function
:type comination-name
))
2478 (info (info :function
:info comination-name
)))
2479 (when (fun-info-callable-map info
)
2480 (multiple-value-bind (args unknown
) (resolve-key-args (combination-args combination
) type
)
2481 (apply (fun-info-callable-map info
)
2482 (lambda (lvar &rest rest
)
2484 (apply function lvar
:arg-lvars args
2485 :unknown-keys unknown
2489 ;;; Call (lambda (arg lambda-var type)), for a mv-combination ARG can
2490 ;;; be NIL when it produces multiple values.
2491 ;;; If REOPTIMIZE is T only the arguments for which LVAR-REOPTIMIZE is
2492 ;;; true will be examined, resetting LVAR-REOPTIMIZE to NIL before
2493 ;;; calling FUNCTION.
2494 (defun map-combination-arg-var (function combination
&key reoptimize
)
2495 (let ((args (basic-combination-args combination
))
2496 (vars (lambda-vars (combination-lambda combination
))))
2497 (flet ((reoptimize-p (arg)
2498 (cond ((not arg
) nil
)
2500 ((lvar-reoptimize arg
)
2501 (setf (lvar-reoptimize arg
) nil
)
2503 (cond ((combination-p combination
)
2504 (loop for arg in args
2506 when
(reoptimize-p arg
)
2508 (funcall function arg var
(lvar-type arg
))))
2510 (when (reoptimize-p (first args
))
2511 (loop with arg
= (first args
)
2513 for type in
(values-type-in (lvar-derived-type arg
)
2517 (and (singleton-p vars
)
2522 (loop for arg in args
2523 do
(multiple-value-bind (types length
) (values-types (lvar-derived-type arg
))
2524 (when (eq length
:unknown
)
2526 (if (reoptimize-p arg
)
2527 (loop with singleton-arg
= (and (= length
1)
2532 (funcall function singleton-arg
2534 (setf vars
(nthcdr length vars
))))))))))