1 ;;;; This file contains miscellaneous utilities used for manipulating
2 ;;;; the IR1 representation.
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
17 ;;; Return the innermost cleanup enclosing NODE, or NIL if there is
18 ;;; none in its function. If NODE has no cleanup, but is in a LET,
19 ;;; then we must still check the environment that the call is in.
20 (defun node-enclosing-cleanup (node)
21 (declare (type node node
))
22 (do ((lexenv (node-lexenv node
)
23 (lambda-call-lexenv (lexenv-lambda lexenv
))))
25 (let ((cup (lexenv-cleanup lexenv
)))
26 (when cup
(return cup
)))))
28 ;;; Convert the FORM in a block inserted between BLOCK1 and BLOCK2 as
29 ;;; an implicit MV-PROG1. The inserted block is returned. NODE is used
30 ;;; for IR1 context when converting the form. Note that the block is
31 ;;; not assigned a number, and is linked into the DFO at the
32 ;;; beginning. We indicate that we have trashed the DFO by setting
33 ;;; COMPONENT-REANALYZE. If CLEANUP is supplied, then convert with
35 (defun insert-cleanup-code (block1 block2 node form
&optional cleanup
)
36 (declare (type cblock block1 block2
) (type node node
)
37 (type (or cleanup null
) cleanup
))
38 (setf (component-reanalyze (block-component block1
)) t
)
39 (with-ir1-environment-from-node node
40 (with-component-last-block (*current-component
*
41 (block-next (component-head *current-component
*)))
42 (let* ((start (make-ctran))
43 (block (ctran-starts-block start
))
46 (make-lexenv :cleanup cleanup
)
48 (change-block-successor block1 block2 block
)
49 (link-blocks block block2
)
50 (ir1-convert start next nil form
)
51 (setf (block-last block
) (ctran-use next
))
52 (setf (node-next (block-last block
)) nil
)
57 ;;; Return a list of all the nodes which use LVAR.
58 (declaim (ftype (sfunction (lvar) list
) find-uses
))
59 (defun find-uses (lvar)
60 (let ((uses (lvar-uses lvar
)))
65 (declaim (ftype (sfunction (lvar) lvar
) principal-lvar
))
66 (defun principal-lvar (lvar)
68 (let ((use (lvar-uses lvar
)))
74 (defun principal-lvar-use (lvar)
76 (declare (type lvar lvar
))
77 (let ((use (lvar-uses lvar
)))
79 (plu (cast-value use
))
83 (defun principal-lvar-dest (lvar)
85 (declare (type lvar lvar
))
86 (let ((dest (lvar-dest lvar
)))
88 (pld (cast-lvar dest
))
92 ;;; Update lvar use information so that NODE is no longer a use of its
95 ;;; Note: if you call this function, you may have to do a
96 ;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
98 (declaim (ftype (sfunction (node) (values))
101 ;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may
102 ;;; be given a new use.
103 (defun %delete-lvar-use
(node)
104 (let ((lvar (node-lvar node
)))
106 (if (listp (lvar-uses lvar
))
107 (let ((new-uses (delq node
(lvar-uses lvar
))))
108 (setf (lvar-uses lvar
)
109 (if (singleton-p new-uses
)
112 (setf (lvar-uses lvar
) nil
))
115 ;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete
116 ;;; its DEST's block, which must be unreachable.
117 (defun delete-lvar-use (node)
118 (let ((lvar (node-lvar node
)))
120 (%delete-lvar-use node
)
121 (if (null (lvar-uses lvar
))
122 (binding* ((dest (lvar-dest lvar
) :exit-if-null
)
123 (() (not (node-deleted dest
)) :exit-if-null
)
124 (block (node-block dest
)))
125 (mark-for-deletion block
))
126 (reoptimize-lvar lvar
))))
129 ;;; Update lvar use information so that NODE uses LVAR.
131 ;;; Note: if you call this function, you may have to do a
132 ;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
134 (declaim (ftype (sfunction (node (or lvar null
)) (values)) add-lvar-use
))
135 (defun add-lvar-use (node lvar
)
136 (aver (not (node-lvar node
)))
138 (let ((uses (lvar-uses lvar
)))
139 (setf (lvar-uses lvar
)
146 (setf (node-lvar node
) lvar
)))
150 ;;; Return true if LVAR destination is executed immediately after
151 ;;; NODE. Cleanups are ignored.
152 (defun immediately-used-p (lvar node
)
153 (declare (type lvar lvar
) (type node node
))
154 (aver (eq (node-lvar node
) lvar
))
155 (let ((dest (lvar-dest lvar
)))
156 (acond ((node-next node
)
157 (eq (ctran-next it
) dest
))
158 (t (eq (block-start (first (block-succ (node-block node
))))
159 (node-prev dest
))))))
161 ;;; Returns the defined (usually untrusted) type of the combination,
162 ;;; or NIL if we couldn't figure it out.
163 (defun combination-defined-type (combination)
164 (let ((use (principal-lvar-use (basic-combination-fun combination
))))
165 (or (when (ref-p use
)
166 (let ((type (leaf-defined-type (ref-leaf use
))))
167 (when (fun-type-p type
)
168 (fun-type-returns type
))))
171 ;;; Return true if LVAR destination is executed after node with only
172 ;;; uninteresting nodes intervening.
174 ;;; Uninteresting nodes are nodes in the same block which are either
175 ;;; REFs, external CASTs to the same destination, or known combinations
176 ;;; that never unwind.
177 (defun almost-immediately-used-p (lvar node
)
178 (declare (type lvar lvar
)
180 (aver (eq (node-lvar node
) lvar
))
181 (let ((dest (lvar-dest lvar
)))
184 (let ((ctran (node-next node
)))
186 (setf node
(ctran-next ctran
))
188 (return-from almost-immediately-used-p t
)
193 (when (and (eq :external
(cast-type-check node
))
194 (eq dest
(node-dest node
)))
197 ;; KLUDGE: Unfortunately we don't have an attribute for
198 ;; "never unwinds", so we just special case
199 ;; %ALLOCATE-CLOSURES: it is easy to run into with eg.
200 ;; FORMAT and a non-constant first argument.
201 (when (eq '%allocate-closures
(combination-fun-source-name node nil
))
204 (when (eq (block-start (first (block-succ (node-block node
))))
206 (return-from almost-immediately-used-p t
))))))))
208 ;;;; lvar substitution
210 ;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be
211 ;;; NIL. We do not flush OLD's DEST.
212 (defun substitute-lvar (new old
)
213 (declare (type lvar old new
))
214 (aver (not (lvar-dest new
)))
215 (let ((dest (lvar-dest old
)))
218 (cif (setf (if-test dest
) new
))
219 (cset (setf (set-value dest
) new
))
220 (creturn (setf (return-result dest
) new
))
221 (exit (setf (exit-value dest
) new
))
223 (if (eq old
(basic-combination-fun dest
))
224 (setf (basic-combination-fun dest
) new
)
225 (setf (basic-combination-args dest
)
226 (nsubst new old
(basic-combination-args dest
)))))
227 (cast (setf (cast-value dest
) new
)))
229 (setf (lvar-dest old
) nil
)
230 (setf (lvar-dest new
) dest
)
231 (flush-lvar-externally-checkable-type new
))
234 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
235 ;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
236 (defun substitute-lvar-uses (new old propagate-dx
)
237 (declare (type lvar old
)
238 (type (or lvar null
) new
)
239 (type boolean propagate-dx
))
243 (%delete-lvar-use node
)
244 (add-lvar-use node new
))
245 (reoptimize-lvar new
)
246 (awhen (and propagate-dx
(lvar-dynamic-extent old
))
247 (setf (lvar-dynamic-extent old
) nil
)
248 (unless (lvar-dynamic-extent new
)
249 (setf (lvar-dynamic-extent new
) it
)
250 (setf (cleanup-info it
) (subst new old
(cleanup-info it
)))))
251 (when (lvar-dynamic-extent new
)
253 (node-ends-block node
))))
254 (t (flush-dest old
)))
258 ;;;; block starting/creation
260 ;;; Return the block that CTRAN is the start of, making a block if
261 ;;; necessary. This function is called by IR1 translators which may
262 ;;; cause a CTRAN to be used more than once. Every CTRAN which may be
263 ;;; used more than once must start a block by the time that anyone
264 ;;; does a USE-CTRAN on it.
266 ;;; We also throw the block into the next/prev list for the
267 ;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have
269 (defun ctran-starts-block (ctran)
270 (declare (type ctran ctran
))
271 (ecase (ctran-kind ctran
)
273 (aver (not (ctran-block ctran
)))
274 (let* ((next (component-last-block *current-component
*))
275 (prev (block-prev next
))
276 (new-block (make-block ctran
)))
277 (setf (block-next new-block
) next
278 (block-prev new-block
) prev
279 (block-prev next
) new-block
280 (block-next prev
) new-block
281 (ctran-block ctran
) new-block
282 (ctran-kind ctran
) :block-start
)
283 (aver (not (ctran-use ctran
)))
286 (ctran-block ctran
))))
288 ;;; Ensure that CTRAN is the start of a block so that the use set can
289 ;;; be freely manipulated.
290 (defun ensure-block-start (ctran)
291 (declare (type ctran ctran
))
292 (let ((kind (ctran-kind ctran
)))
296 (setf (ctran-block ctran
)
297 (make-block-key :start ctran
))
298 (setf (ctran-kind ctran
) :block-start
))
300 (node-ends-block (ctran-use ctran
)))))
303 ;;; CTRAN must be the last ctran in an incomplete block; finish the
304 ;;; block and start a new one if necessary.
305 (defun start-block (ctran)
306 (declare (type ctran ctran
))
307 (aver (not (ctran-next ctran
)))
308 (ecase (ctran-kind ctran
)
310 (let ((block (ctran-block ctran
))
311 (node (ctran-use ctran
)))
312 (aver (not (block-last block
)))
314 (setf (block-last block
) node
)
315 (setf (node-next node
) nil
)
316 (setf (ctran-use ctran
) nil
)
317 (setf (ctran-kind ctran
) :unused
)
318 (setf (ctran-block ctran
) nil
)
319 (link-blocks block
(ctran-starts-block ctran
))))
324 ;;; Filter values of LVAR through FORM, which must be an ordinary/mv
325 ;;; call. Exactly one argument must be 'DUMMY, which will be replaced
326 ;;; with LVAR. In case of an ordinary call the function should not
327 ;;; have return type NIL. We create a new "filtered" lvar.
329 ;;; TODO: remove preconditions.
330 (defun filter-lvar (lvar form
)
331 (declare (type lvar lvar
) (type list form
))
332 (let* ((dest (lvar-dest lvar
))
333 (ctran (node-prev dest
)))
334 (with-ir1-environment-from-node dest
336 (ensure-block-start ctran
)
337 (let* ((old-block (ctran-block ctran
))
338 (new-start (make-ctran))
339 (filtered-lvar (make-lvar))
340 (new-block (ctran-starts-block new-start
)))
342 ;; Splice in the new block before DEST, giving the new block
343 ;; all of DEST's predecessors.
344 (dolist (block (block-pred old-block
))
345 (change-block-successor block old-block new-block
))
347 (ir1-convert new-start ctran filtered-lvar form
)
349 ;; KLUDGE: Comments at the head of this function in CMU CL
350 ;; said that somewhere in here we
351 ;; Set the new block's start and end cleanups to the *start*
352 ;; cleanup of PREV's block. This overrides the incorrect
353 ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
354 ;; Unfortunately I can't find any code which corresponds to this.
355 ;; Perhaps it was a stale comment? Or perhaps I just don't
356 ;; understand.. -- WHN 19990521
358 ;; Replace 'DUMMY with the LVAR. (We can find 'DUMMY because
359 ;; no LET conversion has been done yet.) The [mv-]combination
360 ;; code from the call in the form will be the use of the new
361 ;; check lvar. We substitute exactly one argument.
362 (let* ((node (lvar-use filtered-lvar
))
364 (dolist (arg (basic-combination-args node
) (aver victim
))
365 (let* ((arg (principal-lvar arg
))
368 (when (and (ref-p use
)
369 (constant-p (setf leaf
(ref-leaf use
)))
370 (eql (constant-value leaf
) 'dummy
))
373 (aver (eq (constant-value (ref-leaf (lvar-use victim
)))
376 (substitute-lvar filtered-lvar lvar
)
377 (substitute-lvar lvar victim
)
380 ;; Invoking local call analysis converts this call to a LET.
381 (locall-analyze-component *current-component
*))))
384 ;;; Delete NODE and VALUE. It may result in some calls becoming tail.
385 (defun delete-filter (node lvar value
)
386 (aver (eq (lvar-dest value
) node
))
387 (aver (eq (node-lvar node
) lvar
))
388 (cond (lvar (collect ((merges))
389 (when (return-p (lvar-dest lvar
))
391 (when (and (basic-combination-p use
)
392 (eq (basic-combination-kind use
) :local
))
394 (substitute-lvar-uses lvar value
395 (and lvar
(eq (lvar-uses lvar
) node
)))
396 (%delete-lvar-use node
)
399 (dolist (merge (merges))
400 (merge-tail-sets merge
)))))
401 (t (flush-dest value
)
402 (unlink-node node
))))
404 ;;; Make a CAST and insert it into IR1 before node NEXT.
405 (defun insert-cast-before (next lvar type policy
)
406 (declare (type node next
) (type lvar lvar
) (type ctype type
))
407 (with-ir1-environment-from-node next
408 (let* ((ctran (node-prev next
))
409 (cast (make-cast lvar type policy
))
410 (internal-ctran (make-ctran)))
411 (setf (ctran-next ctran
) cast
412 (node-prev cast
) ctran
)
413 (use-ctran cast internal-ctran
)
414 (link-node-to-previous-ctran next internal-ctran
)
415 (setf (lvar-dest lvar
) cast
)
416 (reoptimize-lvar lvar
)
417 (when (return-p next
)
418 (node-ends-block cast
))
419 (setf (block-attributep (block-flags (node-block cast
))
420 type-check type-asserted
)
424 ;;;; miscellaneous shorthand functions
426 ;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since
427 ;;; the LEXENV-LAMBDA may be deleted, we must chain up the
428 ;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't
429 ;;; deleted, and then return its home.
430 (defun node-home-lambda (node)
431 (declare (type node node
))
432 (do ((fun (lexenv-lambda (node-lexenv node
))
433 (lexenv-lambda (lambda-call-lexenv fun
))))
434 ((not (memq (functional-kind fun
) '(:deleted
:zombie
)))
436 (when (eq (lambda-home fun
) fun
)
439 #!-sb-fluid
(declaim (inline node-block
))
440 (defun node-block (node)
441 (ctran-block (node-prev node
)))
442 (declaim (ftype (sfunction (node) component
) node-component
))
443 (defun node-component (node)
444 (block-component (node-block node
)))
445 (declaim (ftype (sfunction (node) physenv
) node-physenv
))
446 (defun node-physenv (node)
447 (lambda-physenv (node-home-lambda node
)))
448 #!-sb-fluid
(declaim (inline node-dest
))
449 (defun node-dest (node)
450 (awhen (node-lvar node
) (lvar-dest it
)))
452 #!-sb-fluid
(declaim (inline node-stack-allocate-p
))
453 (defun node-stack-allocate-p (node)
454 (awhen (node-lvar node
)
455 (lvar-dynamic-extent it
)))
457 (defun flushable-combination-p (call)
458 (declare (type combination call
))
459 (let ((kind (combination-kind call
))
460 (info (combination-fun-info call
)))
461 (when (and (eq kind
:known
) (fun-info-p info
))
462 (let ((attr (fun-info-attributes info
)))
463 (when (and (not (ir1-attributep attr call
))
464 ;; FIXME: For now, don't consider potentially flushable
465 ;; calls flushable when they have the CALL attribute.
466 ;; Someday we should look at the functional args to
467 ;; determine if they have any side effects.
468 (if (policy call
(= safety
3))
469 (ir1-attributep attr flushable
)
470 (ir1-attributep attr unsafely-flushable
)))
473 ;;;; DYNAMIC-EXTENT related
475 (defun lambda-var-original-name (leaf)
476 (let ((home (lambda-var-home leaf
)))
477 (if (eq :external
(functional-kind home
))
478 (let* ((entry (functional-entry-fun home
))
479 (p (1- (position leaf
(lambda-vars home
)))))
481 (if (optional-dispatch-p entry
)
482 (elt (optional-dispatch-arglist entry
) p
)
483 (elt (lambda-vars entry
) p
))))
484 (leaf-debug-name leaf
))))
486 (defun note-no-stack-allocation (lvar &key flush
)
487 (do-uses (use (principal-lvar lvar
))
489 ;; Don't complain about not being able to stack allocate constants.
490 (and (ref-p use
) (constant-p (ref-leaf use
)))
491 ;; If we're flushing, don't complain if we can flush the combination.
492 (and flush
(combination-p use
) (flushable-combination-p use
))
493 ;; Don't report those with homes in :OPTIONAL -- we'd get doubled
495 (and (ref-p use
) (lambda-var-p (ref-leaf use
))
496 (eq :optional
(lambda-kind (lambda-var-home (ref-leaf use
))))))
497 ;; FIXME: For the first leg (lambda-bind (lambda-var-home ...))
498 ;; would be a far better description, but since we use
499 ;; *COMPILER-ERROR-CONTEXT* for muffling we can't -- as that node
500 ;; can have different handled conditions.
501 (let ((*compiler-error-context
* use
))
502 (if (and (ref-p use
) (lambda-var-p (ref-leaf use
)))
503 (compiler-notify "~@<could~2:I not stack allocate ~S in: ~S~:@>"
504 (lambda-var-original-name (ref-leaf use
))
505 (find-original-source (node-source-path use
)))
506 (compiler-notify "~@<could~2:I not stack allocate: ~S~:@>"
507 (find-original-source (node-source-path use
))))))))
509 (defun use-good-for-dx-p (use dx
&optional component
)
510 ;; FIXME: Can casts point to LVARs in other components?
511 ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the
512 ;; PRINCIPAL-LVAR is always in the same component as the original one. It
513 ;; would be either good to have an explanation of why casts don't point
514 ;; across components, or an explanation of when they do it. ...in the
515 ;; meanwhile AVER that our assumption holds true.
516 (aver (or (not component
) (eq component
(node-component use
))))
517 (or (dx-combination-p use dx
)
519 (not (cast-type-check use
))
520 (lvar-good-for-dx-p (cast-value use
) dx component
))
521 (and (trivial-lambda-var-ref-p use
)
522 (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use
))))
524 (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use
) dx component
))))))
526 (defun lvar-good-for-dx-p (lvar dx
&optional component
)
527 (let ((uses (lvar-uses lvar
)))
531 (use-good-for-dx-p use dx component
))
533 (use-good-for-dx-p uses dx component
))))
535 (defun known-dx-combination-p (use dx
)
536 (and (eq (combination-kind use
) :known
)
537 (let ((info (combination-fun-info use
)))
538 (or (awhen (fun-info-stack-allocate-result info
)
540 (awhen (fun-info-result-arg info
)
541 (let ((args (combination-args use
)))
542 (lvar-good-for-dx-p (if (zerop it
)
547 (defun dx-combination-p (use dx
)
548 (and (combination-p use
)
550 ;; Known, and can do DX.
551 (known-dx-combination-p use dx
)
552 ;; Possibly a not-yet-eliminated lambda which ends up returning the
553 ;; results of an actual known DX combination.
554 (let* ((fun (combination-fun use
))
555 (ref (principal-lvar-use fun
))
556 (clambda (when (ref-p ref
)
558 (creturn (when (lambda-p clambda
)
559 (lambda-return clambda
)))
560 (result-use (when (return-p creturn
)
561 (principal-lvar-use (return-result creturn
)))))
562 ;; FIXME: We should be able to deal with multiple uses here as well.
563 (and (dx-combination-p result-use dx
)
564 (combination-args-flow-cleanly-p use result-use dx
))))))
566 (defun combination-args-flow-cleanly-p (combination1 combination2 dx
)
567 (labels ((recurse (combination)
568 (or (eq combination combination2
)
569 (if (known-dx-combination-p combination dx
)
570 (let ((dest (lvar-dest (combination-lvar combination
))))
571 (and (combination-p dest
)
573 (let* ((fun1 (combination-fun combination
))
574 (ref1 (principal-lvar-use fun1
))
575 (clambda1 (when (ref-p ref1
) (ref-leaf ref1
))))
576 (when (lambda-p clambda1
)
577 (dolist (var (lambda-vars clambda1
) t
)
578 (dolist (var-ref (lambda-var-refs var
))
579 (let ((dest (principal-lvar-dest (ref-lvar var-ref
))))
580 (unless (and (combination-p dest
) (recurse dest
))
581 (return-from combination-args-flow-cleanly-p nil
)))))))))))
582 (recurse combination1
)))
584 (defun ref-good-for-dx-p (ref)
585 (let* ((lvar (ref-lvar ref
))
586 (dest (when lvar
(lvar-dest lvar
))))
587 (and (combination-p dest
)
588 (eq :known
(combination-kind dest
))
589 (awhen (combination-fun-info dest
)
590 (or (ir1-attributep (fun-info-attributes it
) dx-safe
)
591 (and (not (combination-lvar dest
))
592 (awhen (fun-info-result-arg it
)
593 (eql lvar
(nth it
(combination-args dest
))))))))))
595 (defun trivial-lambda-var-ref-p (use)
597 (let ((var (ref-leaf use
)))
598 ;; lambda-var, no SETS, not explicitly indefinite-extent.
599 (when (and (lambda-var-p var
) (not (lambda-var-sets var
))
600 (neq :indefinite
(lambda-var-extent var
)))
601 (let ((home (lambda-var-home var
))
602 (refs (lambda-var-refs var
)))
603 ;; bound by a non-XEP system lambda, no other REFS that aren't
604 ;; DX-SAFE, or are result-args when the result is discarded.
605 (when (and (lambda-system-lambda-p home
)
606 (neq :external
(lambda-kind home
))
608 (unless (or (eq use ref
) (ref-good-for-dx-p ref
))
610 ;; the LAMBDA this var is bound by has only a single REF, going
612 (let* ((lambda-refs (lambda-refs home
))
613 (primary (car lambda-refs
)))
615 (not (cdr lambda-refs
))
616 (combination-p (lvar-dest (ref-lvar primary
)))))))))))
618 (defun trivial-lambda-var-ref-lvar (use)
619 (let* ((this (ref-leaf use
))
620 (fun (lambda-var-home this
))
621 (vars (lambda-vars fun
))
622 (combination (lvar-dest (ref-lvar (car (lambda-refs fun
)))))
623 (args (combination-args combination
)))
624 (aver (= (length vars
) (length args
)))
625 (loop for var in vars
630 ;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends.
631 (defun handle-nested-dynamic-extent-lvars (dx lvar
&optional recheck-component
)
632 (let ((uses (lvar-uses lvar
)))
633 ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS.
634 ;; Uses of mupltiple-use LVARs already end their blocks, so we just need
635 ;; to process uses of single-use LVARs.
637 (node-ends-block uses
))
638 ;; If this LVAR's USE is good for DX, it is either a CAST, or it
639 ;; must be a regular combination whose arguments are potentially DX as well.
640 (flet ((recurse (use)
643 (handle-nested-dynamic-extent-lvars
644 dx
(cast-value use
) recheck-component
))
646 (loop for arg in
(combination-args use
)
647 ;; deleted args show up as NIL here
649 (lvar-good-for-dx-p arg dx recheck-component
))
650 append
(handle-nested-dynamic-extent-lvars
651 dx arg recheck-component
)))
653 (let* ((other (trivial-lambda-var-ref-lvar use
)))
654 (unless (eq other lvar
)
655 (handle-nested-dynamic-extent-lvars
656 dx other recheck-component
)))))))
659 (loop for use in uses
660 when
(use-good-for-dx-p use dx recheck-component
)
662 (when (use-good-for-dx-p uses dx recheck-component
)
667 (declaim (inline block-to-be-deleted-p
))
668 (defun block-to-be-deleted-p (block)
669 (or (block-delete-p block
)
670 (eq (functional-kind (block-home-lambda block
)) :deleted
)))
672 ;;; Checks whether NODE is in a block to be deleted
673 (declaim (inline node-to-be-deleted-p
))
674 (defun node-to-be-deleted-p (node)
675 (block-to-be-deleted-p (node-block node
)))
677 (declaim (ftype (sfunction (clambda) cblock
) lambda-block
))
678 (defun lambda-block (clambda)
679 (node-block (lambda-bind clambda
)))
680 (declaim (ftype (sfunction (clambda) component
) lambda-component
))
681 (defun lambda-component (clambda)
682 (block-component (lambda-block clambda
)))
684 (declaim (ftype (sfunction (cblock) node
) block-start-node
))
685 (defun block-start-node (block)
686 (ctran-next (block-start block
)))
688 ;;; Return the enclosing cleanup for environment of the first or last
690 (defun block-start-cleanup (block)
691 (node-enclosing-cleanup (block-start-node block
)))
692 (defun block-end-cleanup (block)
693 (node-enclosing-cleanup (block-last block
)))
695 ;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL
696 ;;; if there is none.
698 ;;; There can legitimately be no home lambda in dead code early in the
699 ;;; IR1 conversion process, e.g. when IR1-converting the SETQ form in
700 ;;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
701 ;;; where the block is just a placeholder during parsing and doesn't
702 ;;; actually correspond to code which will be written anywhere.
703 (declaim (ftype (sfunction (cblock) (or clambda null
)) block-home-lambda-or-null
))
704 (defun block-home-lambda-or-null (block)
705 (if (node-p (block-last block
))
706 ;; This is the old CMU CL way of doing it.
707 (node-home-lambda (block-last block
))
708 ;; Now that SBCL uses this operation more aggressively than CMU
709 ;; CL did, the old CMU CL way of doing it can fail in two ways.
710 ;; 1. It can fail in a few cases even when a meaningful home
711 ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of
713 ;; 2. It can fail when converting a form which is born orphaned
714 ;; so that it never had a meaningful home lambda, e.g. a form
715 ;; which follows a RETURN-FROM or GO form.
716 (let ((pred-list (block-pred block
)))
717 ;; To deal with case 1, we reason that
718 ;; previous-in-target-execution-order blocks should be in the
719 ;; same lambda, and that they seem in practice to be
720 ;; previous-in-compilation-order blocks too, so we look back
721 ;; to find one which is sufficiently initialized to tell us
722 ;; what the home lambda is.
724 ;; We could get fancy about this, flooding through the
725 ;; graph of all the previous blocks, but in practice it
726 ;; seems to work just to grab the first previous block and
728 (node-home-lambda (block-last (first pred-list
)))
729 ;; In case 2, we end up with an empty PRED-LIST and
730 ;; have to punt: There's no home lambda.
733 ;;; Return the non-LET LAMBDA that holds BLOCK's code.
734 (declaim (ftype (sfunction (cblock) clambda
) block-home-lambda
))
735 (defun block-home-lambda (block)
736 (block-home-lambda-or-null block
))
738 ;;; Return the IR1 physical environment for BLOCK.
739 (declaim (ftype (sfunction (cblock) physenv
) block-physenv
))
740 (defun block-physenv (block)
741 (lambda-physenv (block-home-lambda block
)))
743 ;;; Return the Top Level Form number of PATH, i.e. the ordinal number
744 ;;; of its original source's top level form in its compilation unit.
745 (defun source-path-tlf-number (path)
746 (declare (list path
))
749 ;;; Return the (reversed) list for the PATH in the original source
750 ;;; (with the Top Level Form number last).
751 (defun source-path-original-source (path)
752 (declare (list path
) (inline member
))
753 (cddr (member 'original-source-start path
:test
#'eq
)))
755 ;;; Return the Form Number of PATH's original source inside the Top
756 ;;; Level Form that contains it. This is determined by the order that
757 ;;; we walk the subforms of the top level source form.
758 (defun source-path-form-number (path)
759 (declare (list path
) (inline member
))
760 (cadr (member 'original-source-start path
:test
#'eq
)))
762 ;;; Return a list of all the enclosing forms not in the original
763 ;;; source that converted to get to this form, with the immediate
764 ;;; source for node at the start of the list.
765 (defun source-path-forms (path)
766 (subseq path
0 (position 'original-source-start path
)))
768 (defun tree-some (predicate tree
)
769 (let ((seen (make-hash-table)))
770 (labels ((walk (tree)
771 (cond ((funcall predicate tree
))
773 (not (gethash tree seen
)))
774 (setf (gethash tree seen
) t
)
775 (or (walk (car tree
))
776 (walk (cdr tree
)))))))
779 ;;; Return the innermost source form for NODE.
780 (defun node-source-form (node)
781 (declare (type node node
))
782 (let* ((path (node-source-path node
))
783 (forms (remove-if (lambda (x)
784 (tree-some #'leaf-p x
))
785 (source-path-forms path
))))
786 ;; another option: if first form includes a leaf, return
787 ;; find-original-source instead.
790 (values (find-original-source path
)))))
792 ;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise
794 (defun lvar-source (lvar)
795 (let ((use (lvar-uses lvar
)))
798 (values (node-source-form use
) t
))))
800 (defun common-suffix (x y
)
801 (let ((mismatch (mismatch x y
:from-end t
)))
806 ;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a
807 ;;; singleton. Otherwise, return a list of the lowest common
808 ;;; ancestor source form of all the uses (if it can be found),
809 ;;; followed by all the uses' source forms.
810 (defun lvar-all-sources (lvar)
811 (let ((use (lvar-uses lvar
)))
814 (path (node-source-path (first use
))))
815 (dolist (use use
(cons (if (find 'original-source-start path
)
816 (find-original-source path
)
819 (pushnew (node-source-form use
) forms
)
820 (setf path
(common-suffix path
821 (node-source-path use
)))))
822 (list (node-source-form use
)))))
824 ;;; Return the unique node, delivering a value to LVAR.
825 #!-sb-fluid
(declaim (inline lvar-use
))
826 (defun lvar-use (lvar)
827 (the (not list
) (lvar-uses lvar
)))
829 #!-sb-fluid
(declaim (inline lvar-has-single-use-p
))
830 (defun lvar-has-single-use-p (lvar)
831 (typep (lvar-uses lvar
) '(not list
)))
833 ;;; Return the LAMBDA that is CTRAN's home, or NIL if there is none.
834 (declaim (ftype (sfunction (ctran) (or clambda null
))
835 ctran-home-lambda-or-null
))
836 (defun ctran-home-lambda-or-null (ctran)
837 ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
838 ;; implementation might not be quite right, or might be uglier than
839 ;; necessary. It appears that the original Python never found a need
840 ;; to do this operation. The obvious things based on
841 ;; NODE-HOME-LAMBDA of CTRAN-USE usually work; then if that fails,
842 ;; BLOCK-HOME-LAMBDA of CTRAN-BLOCK works, given that we
843 ;; generalize it enough to grovel harder when the simple CMU CL
844 ;; approach fails, and furthermore realize that in some exceptional
845 ;; cases it might return NIL. -- WHN 2001-12-04
846 (cond ((ctran-use ctran
)
847 (node-home-lambda (ctran-use ctran
)))
849 (block-home-lambda-or-null (ctran-block ctran
)))
851 (bug "confused about home lambda for ~S" ctran
))))
853 ;;; Return the LAMBDA that is CTRAN's home.
854 (declaim (ftype (sfunction (ctran) clambda
) ctran-home-lambda
))
855 (defun ctran-home-lambda (ctran)
856 (ctran-home-lambda-or-null ctran
))
858 (declaim (inline cast-single-value-p
))
859 (defun cast-single-value-p (cast)
860 (not (values-type-p (cast-asserted-type cast
))))
862 #!-sb-fluid
(declaim (inline lvar-single-value-p
))
863 (defun lvar-single-value-p (lvar)
865 (let ((dest (lvar-dest lvar
)))
870 (eq (basic-combination-fun dest
) lvar
))
873 (declare (notinline lvar-single-value-p
))
874 (and (cast-single-value-p dest
)
875 (lvar-single-value-p (node-lvar dest
)))))
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
923 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
925 (defun make-restricted-lexenv (lexenv)
926 (flet ((fun-good-p (fun)
927 (destructuring-bind (name . thing
) fun
928 (declare (ignore name
))
932 (cons (aver (eq (car thing
) 'macro
))
935 (destructuring-bind (name . thing
) var
936 (declare (ignore name
))
938 ;; The evaluator will mark lexicals with :BOGUS when it
939 ;; translates an interpreter lexenv to a compiler
941 ((or leaf
#!+sb-eval
(member :bogus
)) nil
)
942 (cons (aver (eq (car thing
) 'macro
))
944 (heap-alien-info nil
)))))
945 (internal-make-lexenv
946 (remove-if-not #'fun-good-p
(lexenv-funs lexenv
))
947 (remove-if-not #'var-good-p
(lexenv-vars lexenv
))
950 (lexenv-type-restrictions lexenv
) ; XXX
953 (lexenv-handled-conditions lexenv
)
954 (lexenv-disabled-package-locks lexenv
)
955 (lexenv-policy lexenv
)
956 (lexenv-user-data lexenv
))))
958 ;;;; flow/DFO/component hackery
960 ;;; Join BLOCK1 and BLOCK2.
961 (defun link-blocks (block1 block2
)
962 (declare (type cblock block1 block2
))
963 (setf (block-succ block1
)
964 (if (block-succ block1
)
965 (%link-blocks block1 block2
)
967 (push block1
(block-pred block2
))
969 (defun %link-blocks
(block1 block2
)
970 (declare (type cblock block1 block2
))
971 (let ((succ1 (block-succ block1
)))
972 (aver (not (memq block2 succ1
)))
973 (cons block2 succ1
)))
975 ;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If
976 ;;; this leaves a successor with a single predecessor that ends in an
977 ;;; IF, then set BLOCK-TEST-MODIFIED so that any test constraint will
978 ;;; now be able to be propagated to the successor.
979 (defun unlink-blocks (block1 block2
)
980 (declare (type cblock block1 block2
))
981 (let ((succ1 (block-succ block1
)))
982 (if (eq block2
(car succ1
))
983 (setf (block-succ block1
) (cdr succ1
))
984 (do ((succ (cdr succ1
) (cdr succ
))
986 ((eq (car succ
) block2
)
987 (setf (cdr prev
) (cdr succ
)))
990 (let ((new-pred (delq block1
(block-pred block2
))))
991 (setf (block-pred block2
) new-pred
)
992 (when (singleton-p new-pred
)
993 (let ((pred-block (first new-pred
)))
994 (when (if-p (block-last pred-block
))
995 (setf (block-test-modified pred-block
) t
)))))
998 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK
999 ;;; and NEW. If BLOCK ends in an IF, then we have to fix up the
1000 ;;; consequent/alternative blocks to point to NEW. We also set
1001 ;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to
1002 ;;; the new successor.
1003 (defun change-block-successor (block old new
)
1004 (declare (type cblock new old block
))
1005 (unlink-blocks block old
)
1006 (let ((last (block-last block
))
1007 (comp (block-component block
)))
1008 (setf (component-reanalyze comp
) t
)
1011 (setf (block-test-modified block
) t
)
1012 (let* ((succ-left (block-succ block
))
1013 (new (if (and (eq new
(component-tail comp
))
1017 (unless (memq new succ-left
)
1018 (link-blocks block new
))
1019 (macrolet ((frob (slot)
1020 `(when (eq (,slot last
) old
)
1021 (setf (,slot last
) new
))))
1022 (frob if-consequent
)
1023 (frob if-alternative
)
1024 (when (eq (if-consequent last
)
1025 (if-alternative last
))
1026 (reoptimize-component (block-component block
) :maybe
)))))
1028 (unless (memq new
(block-succ block
))
1029 (link-blocks block new
)))))
1033 ;;; Unlink a block from the next/prev chain. We also null out the
1035 (declaim (ftype (sfunction (cblock) (values)) remove-from-dfo
))
1036 (defun remove-from-dfo (block)
1037 (let ((next (block-next block
))
1038 (prev (block-prev block
)))
1039 (setf (block-component block
) nil
)
1040 (setf (block-next prev
) next
)
1041 (setf (block-prev next
) prev
))
1044 ;;; Add BLOCK to the next/prev chain following AFTER. We also set the
1045 ;;; COMPONENT to be the same as for AFTER.
1046 (defun add-to-dfo (block after
)
1047 (declare (type cblock block after
))
1048 (let ((next (block-next after
))
1049 (comp (block-component after
)))
1050 (aver (not (eq (component-kind comp
) :deleted
)))
1051 (setf (block-component block
) comp
)
1052 (setf (block-next after
) block
)
1053 (setf (block-prev block
) after
)
1054 (setf (block-next block
) next
)
1055 (setf (block-prev next
) block
))
1058 ;;; List all NLX-INFOs which BLOCK can exit to.
1060 ;;; We hope that no cleanup actions are performed in the middle of
1061 ;;; BLOCK, so it is enough to look only at cleanups in the block
1062 ;;; end. The tricky thing is a special cleanup block; all its nodes
1063 ;;; have the same cleanup info, corresponding to the start, so the
1064 ;;; same approach returns safe result.
1065 (defun map-block-nlxes (fun block
&optional dx-cleanup-fun
)
1066 (loop for cleanup
= (block-end-cleanup block
)
1067 then
(node-enclosing-cleanup (cleanup-mess-up cleanup
))
1069 do
(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
)))
1317 (unless (and entry
(leaf-refs entry
))
1318 (aver (or (not entry
) (eq (functional-kind entry
) :deleted
)))
1319 (setf (functional-kind leaf
) :deleted
)
1322 (unless (eq (functional-kind fun
) :deleted
)
1323 (aver (eq (functional-kind fun
) :optional
))
1324 (setf (functional-kind fun
) nil
)
1325 (let ((refs (leaf-refs fun
)))
1327 (delete-lambda fun
))
1329 (or (maybe-let-convert fun
)
1330 (maybe-convert-to-assignment fun
)))
1332 (maybe-convert-to-assignment fun
)))))))
1334 (dolist (ep (optional-dispatch-entry-points leaf
))
1335 (when (promise-ready-p ep
)
1337 (when (optional-dispatch-more-entry leaf
)
1338 (frob (optional-dispatch-more-entry leaf
)))
1339 (let ((main (optional-dispatch-main-entry leaf
)))
1341 (setf (functional-entry-fun entry
) main
)
1342 (setf (functional-entry-fun main
) entry
))
1343 (when (eq (functional-kind main
) :optional
)
1348 (defun note-local-functional (fun)
1349 (declare (type functional fun
))
1350 (when (and (leaf-has-source-name-p fun
)
1351 (eq (leaf-source-name fun
) (functional-debug-name fun
)))
1352 (let ((name (leaf-source-name fun
)))
1353 (let ((defined-fun (gethash name
*free-funs
*)))
1354 (when (and defined-fun
1355 (defined-fun-p defined-fun
)
1356 (eq (defined-fun-functional defined-fun
) fun
))
1357 (remhash name
*free-funs
*))))))
1359 ;;; Return functional for DEFINED-FUN which has been converted in policy
1360 ;;; corresponding to the current one, or NIL if no such functional exists.
1362 ;;; Also check that the parent of the functional is visible in the current
1364 (defun defined-fun-functional (defined-fun)
1365 (let ((functionals (defined-fun-functionals defined-fun
)))
1367 (let* ((sample (car functionals
))
1368 (there (lambda-parent (if (lambda-p sample
)
1370 (optional-dispatch-main-entry sample
)))))
1372 (labels ((lookup (here)
1373 (unless (eq here there
)
1375 (lookup (lambda-parent here
))
1376 ;; We looked up all the way up, and didn't find the parent
1377 ;; of the functional -- therefore it is nested in a lambda
1378 ;; we don't see, so return nil.
1379 (return-from defined-fun-functional nil
)))))
1380 (lookup (lexenv-lambda *lexenv
*)))))
1381 ;; Now find a functional whose policy matches the current one, if we already
1383 (let ((policy (lexenv-%policy
*lexenv
*)))
1384 (dolist (functional functionals
)
1385 (when (equal policy
(lexenv-%policy
(functional-lexenv functional
)))
1386 (return functional
)))))))
1388 ;;; Do stuff to delete the semantic attachments of a REF node. When
1389 ;;; this leaves zero or one reference, we do a type dispatch off of
1390 ;;; the leaf to determine if a special action is appropriate.
1391 (defun delete-ref (ref)
1392 (declare (type ref ref
))
1393 (let* ((leaf (ref-leaf ref
))
1394 (refs (delq ref
(leaf-refs leaf
))))
1395 (setf (leaf-refs leaf
) refs
)
1400 (delete-lambda-var leaf
))
1402 (ecase (functional-kind leaf
)
1403 ((nil :let
:mv-let
:assignment
:escape
:cleanup
)
1404 (aver (null (functional-entry-fun leaf
)))
1405 (delete-lambda leaf
))
1407 (unless (functional-has-external-references-p leaf
)
1408 (delete-lambda leaf
)))
1409 ((:deleted
:zombie
:optional
))))
1411 (unless (eq (functional-kind leaf
) :deleted
)
1412 (delete-optional-dispatch leaf
)))))
1415 (clambda (or (maybe-let-convert leaf
)
1416 (maybe-convert-to-assignment leaf
)))
1417 (lambda-var (reoptimize-lambda-var leaf
))))
1420 (clambda (maybe-convert-to-assignment leaf
))))))
1424 ;;; This function is called to unlink a node from its LVAR;
1425 ;;; we assume that the LVAR's USE list has already been updated,
1426 ;;; and that we only have to mark the node as up for dead code
1427 ;;; elimination, and to clear it LVAR slot.
1428 (defun flush-node (node)
1429 (declare (type node node
))
1430 (let* ((prev (node-prev node
))
1431 (block (ctran-block prev
)))
1432 (reoptimize-component (block-component block
) t
)
1433 (setf (block-attributep (block-flags block
)
1434 flush-p type-asserted type-check
)
1436 (setf (node-lvar node
) nil
))
1438 ;;; This function is called by people who delete nodes; it provides a
1439 ;;; way to indicate that the value of a lvar is no longer used. We
1440 ;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses
1441 ;;; of LVAR and set COMPONENT-REOPTIMIZE.
1442 (defun flush-dest (lvar)
1443 (declare (type (or lvar null
) lvar
))
1445 (when (lvar-dynamic-extent lvar
)
1446 (note-no-stack-allocation lvar
:flush t
))
1447 (setf (lvar-dest lvar
) nil
)
1448 (flush-lvar-externally-checkable-type lvar
)
1451 (setf (lvar-uses lvar
) nil
))
1454 (defun delete-dest (lvar)
1456 (let* ((dest (lvar-dest lvar
))
1457 (prev (node-prev dest
)))
1458 (let ((block (ctran-block prev
)))
1459 (unless (block-delete-p block
)
1460 (mark-for-deletion block
))))))
1462 ;;; Queue the block for deletion
1463 (defun delete-block-lazily (block)
1464 (declare (type cblock block
))
1465 (unless (block-delete-p block
)
1466 (setf (block-delete-p block
) t
)
1467 (push block
(component-delete-blocks (block-component block
)))))
1469 ;;; Do a graph walk backward from BLOCK, marking all predecessor
1470 ;;; blocks with the DELETE-P flag.
1471 (defun mark-for-deletion (block)
1472 (declare (type cblock block
))
1473 (let* ((component (block-component block
))
1474 (head (component-head component
)))
1475 (labels ((helper (block)
1476 (delete-block-lazily block
)
1477 (dolist (pred (block-pred block
))
1478 (unless (or (block-delete-p pred
)
1481 (unless (block-delete-p block
)
1483 (setf (component-reanalyze component
) t
))))
1486 ;;; This function does what is necessary to eliminate the code in it
1487 ;;; from the IR1 representation. This involves unlinking it from its
1488 ;;; predecessors and successors and deleting various node-specific
1489 ;;; semantic information. BLOCK must be already removed from
1490 ;;; COMPONENT-DELETE-BLOCKS.
1491 (defun delete-block (block &optional silent
)
1492 (declare (type cblock block
))
1493 (aver (block-component block
)) ; else block is already deleted!
1494 #!+high-security
(aver (not (memq block
(component-delete-blocks (block-component block
)))))
1496 (note-block-deletion block
))
1497 (setf (block-delete-p block
) t
)
1499 (dolist (b (block-pred block
))
1500 (unlink-blocks b block
)
1501 ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
1502 ;; broken when successors were deleted without setting the
1503 ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
1504 ;; doesn't happen again.
1505 (aver (not (and (null (block-succ b
))
1506 (not (block-delete-p b
))
1507 (not (eq b
(component-head (block-component b
))))))))
1508 (dolist (b (block-succ block
))
1509 (unlink-blocks block b
))
1511 (do-nodes-carefully (node block
)
1512 (when (valued-node-p node
)
1513 (delete-lvar-use node
))
1515 (ref (delete-ref node
))
1516 (cif (flush-dest (if-test node
)))
1517 ;; The next two cases serve to maintain the invariant that a LET
1518 ;; always has a well-formed COMBINATION, REF and BIND. We delete
1519 ;; the lambda whenever we delete any of these, but we must be
1520 ;; careful that this LET has not already been partially deleted.
1522 (when (and (eq (basic-combination-kind node
) :local
)
1523 ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
1524 (lvar-uses (basic-combination-fun node
)))
1525 (let ((fun (combination-lambda node
)))
1526 ;; If our REF was the second-to-last ref, and has been
1527 ;; deleted, then FUN may be a LET for some other
1529 (when (and (functional-letlike-p fun
)
1530 (eq (let-combination fun
) node
))
1531 (delete-lambda fun
))))
1532 (flush-dest (basic-combination-fun node
))
1533 (dolist (arg (basic-combination-args node
))
1534 (when arg
(flush-dest arg
))))
1536 (let ((lambda (bind-lambda node
)))
1537 (unless (eq (functional-kind lambda
) :deleted
)
1538 (delete-lambda lambda
))))
1540 (let ((value (exit-value node
))
1541 (entry (exit-entry node
)))
1545 (setf (entry-exits entry
)
1546 (delq node
(entry-exits entry
))))))
1548 (dolist (exit (entry-exits node
))
1549 (mark-for-deletion (node-block exit
)))
1550 (let ((home (node-home-lambda node
)))
1551 (setf (lambda-entries home
) (delq node
(lambda-entries home
)))))
1553 (flush-dest (return-result node
))
1554 (delete-return node
))
1556 (flush-dest (set-value node
))
1557 (let ((var (set-var node
)))
1558 (setf (basic-var-sets var
)
1559 (delete node
(basic-var-sets var
)))))
1561 (flush-dest (cast-value node
)))))
1563 (remove-from-dfo block
)
1566 ;;; Do stuff to indicate that the return node NODE is being deleted.
1567 (defun delete-return (node)
1568 (declare (type creturn node
))
1569 (let* ((fun (return-lambda node
))
1570 (tail-set (lambda-tail-set fun
)))
1571 (aver (lambda-return fun
))
1572 (setf (lambda-return fun
) nil
)
1573 (when (and tail-set
(not (find-if #'lambda-return
1574 (tail-set-funs tail-set
))))
1575 (setf (tail-set-type tail-set
) *empty-type
*)))
1578 ;;; If any of the VARS in FUN was never referenced and was not
1579 ;;; declared IGNORE, then complain.
1580 (defun note-unreferenced-vars (fun)
1581 (declare (type clambda fun
))
1582 (dolist (var (lambda-vars fun
))
1583 (unless (or (leaf-ever-used var
)
1584 (lambda-var-ignorep var
))
1585 (let ((*compiler-error-context
* (lambda-bind fun
)))
1586 (unless (policy *compiler-error-context
* (= inhibit-warnings
3))
1587 ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
1588 ;; requires this to be no more than a STYLE-WARNING.
1590 (compiler-style-warn "The variable ~S is defined but never used."
1591 (leaf-debug-name var
))
1592 ;; There's no reason to accept this kind of equivocation
1593 ;; when compiling our own code, though.
1595 (warn "The variable ~S is defined but never used."
1596 (leaf-debug-name var
)))
1597 (setf (leaf-ever-used var
) t
)))) ; to avoid repeated warnings? -- WHN
1600 (defvar *deletion-ignored-objects
* '(t nil
))
1602 ;;; Return true if we can find OBJ in FORM, NIL otherwise. We bound
1603 ;;; our recursion so that we don't get lost in circular structures. We
1604 ;;; ignore the car of forms if they are a symbol (to prevent confusing
1605 ;;; function referencess with variables), and we also ignore anything
1607 (defun present-in-form (obj form depth
)
1608 (declare (type (integer 0 20) depth
))
1609 (cond ((= depth
20) nil
)
1613 (let ((first (car form
))
1615 (if (member first
'(quote function
))
1617 (or (and (not (symbolp first
))
1618 (present-in-form obj first depth
))
1619 (do ((l (cdr form
) (cdr l
))
1621 ((or (atom l
) (> n
100))
1623 (declare (fixnum n
))
1624 (when (present-in-form obj
(car l
) depth
)
1627 ;;; This function is called on a block immediately before we delete
1628 ;;; it. We check to see whether any of the code about to die appeared
1629 ;;; in the original source, and emit a note if so.
1631 ;;; If the block was in a lambda is now deleted, then we ignore the
1632 ;;; whole block, since this case is picked off in DELETE-LAMBDA. We
1633 ;;; also ignore the deletion of CRETURN nodes, since it is somewhat
1634 ;;; reasonable for a function to not return, and there is a different
1635 ;;; note for that case anyway.
1637 ;;; If the actual source is an atom, then we use a bunch of heuristics
1638 ;;; to guess whether this reference really appeared in the original
1640 ;;; -- If a symbol, it must be interned and not a keyword.
1641 ;;; -- It must not be an easily introduced constant (T or NIL, a fixnum
1642 ;;; or a character.)
1643 ;;; -- The atom must be "present" in the original source form, and
1644 ;;; present in all intervening actual source forms.
1645 (defun note-block-deletion (block)
1646 (let ((home (block-home-lambda block
)))
1647 (unless (eq (functional-kind home
) :deleted
)
1648 (do-nodes (node nil block
)
1649 (let* ((path (node-source-path node
))
1650 (first (first path
)))
1651 (when (or (eq first
'original-source-start
)
1653 (or (not (symbolp first
))
1654 (let ((pkg (symbol-package first
)))
1656 (not (eq pkg
(symbol-package :end
))))))
1657 (not (member first
*deletion-ignored-objects
*))
1658 (not (typep first
'(or fixnum character
)))
1660 (present-in-form first x
0))
1661 (source-path-forms path
))
1662 (present-in-form first
(find-original-source path
)
1664 (unless (return-p node
)
1665 (let ((*compiler-error-context
* node
))
1666 (compiler-notify 'code-deletion-note
1667 :format-control
"deleting unreachable code"
1668 :format-arguments nil
)))
1672 ;;; Delete a node from a block, deleting the block if there are no
1673 ;;; nodes left. We remove the node from the uses of its LVAR.
1675 ;;; If the node is the last node, there must be exactly one successor.
1676 ;;; We link all of our precedessors to the successor and unlink the
1677 ;;; block. In this case, we return T, otherwise NIL. If no nodes are
1678 ;;; left, and the block is a successor of itself, then we replace the
1679 ;;; only node with a degenerate exit node. This provides a way to
1680 ;;; represent the bodyless infinite loop, given the prohibition on
1681 ;;; empty blocks in IR1.
1682 (defun unlink-node (node)
1683 (declare (type node node
))
1684 (when (valued-node-p node
)
1685 (delete-lvar-use node
))
1687 (let* ((ctran (node-next node
))
1688 (next (and ctran
(ctran-next ctran
)))
1689 (prev (node-prev node
))
1690 (block (ctran-block prev
))
1691 (prev-kind (ctran-kind prev
))
1692 (last (block-last block
)))
1694 (setf (block-type-asserted block
) t
)
1695 (setf (block-test-modified block
) t
)
1697 (cond ((or (eq prev-kind
:inside-block
)
1698 (and (eq prev-kind
:block-start
)
1699 (not (eq node last
))))
1700 (cond ((eq node last
)
1701 (setf (block-last block
) (ctran-use prev
))
1702 (setf (node-next (ctran-use prev
)) nil
))
1704 (setf (ctran-next prev
) next
)
1705 (setf (node-prev next
) prev
)
1706 (when (if-p next
) ; AOP wanted
1707 (reoptimize-lvar (if-test next
)))))
1708 (setf (node-prev node
) nil
)
1711 (aver (eq prev-kind
:block-start
))
1712 (aver (eq node last
))
1713 (let* ((succ (block-succ block
))
1714 (next (first succ
)))
1715 (aver (singleton-p succ
))
1717 ((eq block
(first succ
))
1718 (with-ir1-environment-from-node node
1719 (let ((exit (make-exit)))
1720 (setf (ctran-next prev
) nil
)
1721 (link-node-to-previous-ctran exit prev
)
1722 (setf (block-last block
) exit
)))
1723 (setf (node-prev node
) nil
)
1726 (aver (eq (block-start-cleanup block
)
1727 (block-end-cleanup block
)))
1728 (unlink-blocks block next
)
1729 (dolist (pred (block-pred block
))
1730 (change-block-successor pred block next
))
1731 (when (block-delete-p block
)
1732 (let ((component (block-component block
)))
1733 (setf (component-delete-blocks component
)
1734 (delq block
(component-delete-blocks component
)))))
1735 (remove-from-dfo block
)
1736 (setf (block-delete-p block
) t
)
1737 (setf (node-prev node
) nil
)
1740 ;;; Return true if CTRAN has been deleted, false if it is still a valid
1742 (defun ctran-deleted-p (ctran)
1743 (declare (type ctran ctran
))
1744 (let ((block (ctran-block ctran
)))
1745 (or (not (block-component block
))
1746 (block-delete-p block
))))
1748 ;;; Return true if NODE has been deleted, false if it is still a valid
1750 (defun node-deleted (node)
1751 (declare (type node node
))
1752 (let ((prev (node-prev node
)))
1754 (ctran-deleted-p prev
))))
1756 ;;; Delete all the blocks and functions in COMPONENT. We scan first
1757 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
1758 ;;; triggered by deletion.
1759 (defun delete-component (component)
1760 (declare (type component component
))
1761 (aver (null (component-new-functionals component
)))
1762 (setf (component-kind component
) :deleted
)
1763 (do-blocks (block component
)
1764 (delete-block-lazily block
))
1765 (dolist (fun (component-lambdas component
))
1766 (unless (eq (functional-kind fun
) :deleted
)
1767 (setf (functional-kind fun
) nil
)
1768 (setf (functional-entry-fun fun
) nil
)
1769 (setf (leaf-refs fun
) nil
)
1770 (delete-functional fun
)))
1771 (clean-component component
)
1774 ;;; Remove all pending blocks to be deleted. Return the nearest live
1775 ;;; block after or equal to BLOCK.
1776 (defun clean-component (component &optional block
)
1777 (loop while
(component-delete-blocks component
)
1778 ;; actual deletion of a block may queue new blocks
1779 do
(let ((current (pop (component-delete-blocks component
))))
1780 (when (eq block current
)
1781 (setq block
(block-next block
)))
1782 (delete-block current
)))
1785 ;;; Convert code of the form
1786 ;;; (FOO ... (FUN ...) ...)
1788 ;;; (FOO ... ... ...).
1789 ;;; In other words, replace the function combination FUN by its
1790 ;;; arguments. If there are any problems with doing this, use GIVE-UP
1791 ;;; to blow out of whatever transform called this. Note, as the number
1792 ;;; of arguments changes, the transform must be prepared to return a
1793 ;;; lambda with a new lambda-list with the correct number of
1795 (defun splice-fun-args (lvar fun num-args
)
1797 "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed
1798 directly to the LVAR-DEST of LVAR, which must be a combination. If FUN
1799 is :ANY, the function name is not checked."
1800 (declare (type lvar lvar
)
1802 (type index num-args
))
1803 (let ((outside (lvar-dest lvar
))
1804 (inside (lvar-uses lvar
)))
1805 (aver (combination-p outside
))
1806 (unless (combination-p inside
)
1807 (give-up-ir1-transform))
1808 (let ((inside-fun (combination-fun inside
)))
1809 (unless (or (eq fun
:any
)
1810 (eq (lvar-fun-name inside-fun
) fun
))
1811 (give-up-ir1-transform))
1812 (let ((inside-args (combination-args inside
)))
1813 (unless (= (length inside-args
) num-args
)
1814 (give-up-ir1-transform))
1815 (let* ((outside-args (combination-args outside
))
1816 (arg-position (position lvar outside-args
))
1817 (before-args (subseq outside-args
0 arg-position
))
1818 (after-args (subseq outside-args
(1+ arg-position
))))
1819 (dolist (arg inside-args
)
1820 (setf (lvar-dest arg
) outside
)
1821 (flush-lvar-externally-checkable-type arg
))
1822 (setf (combination-args inside
) nil
)
1823 (setf (combination-args outside
)
1824 (append before-args inside-args after-args
))
1825 (change-ref-leaf (lvar-uses inside-fun
)
1826 (find-free-fun 'list
"???"))
1827 (setf (combination-fun-info inside
) (info :function
:info
'list
)
1828 (combination-kind inside
) :known
)
1829 (setf (node-derived-type inside
) *wild-type
*)
1833 ;;; Eliminate keyword arguments from the call (leaving the
1834 ;;; parameters in place.
1836 ;;; (FOO ... :BAR X :QUUX Y)
1840 ;;; SPECS is a list of (:KEYWORD PARAMETER) specifications.
1841 ;;; Returns the list of specified parameters names in the
1842 ;;; order they appeared in the call. N-POSITIONAL is the
1843 ;;; number of positional arguments in th call.
1844 (defun eliminate-keyword-args (call n-positional specs
)
1845 (let* ((specs (copy-tree specs
))
1846 (all (combination-args call
))
1847 (new-args (reverse (subseq all
0 n-positional
)))
1848 (key-args (subseq all n-positional
))
1851 (loop while key-args
1852 do
(let* ((key (pop key-args
))
1853 (val (pop key-args
))
1854 (keyword (if (constant-lvar-p key
)
1856 (give-up-ir1-transform)))
1857 (spec (or (assoc keyword specs
:test
#'eq
)
1858 (give-up-ir1-transform))))
1860 (push key flushed-keys
)
1861 (push (second spec
) parameters
)
1862 ;; In case of duplicate keys.
1863 (setf (second spec
) (gensym))))
1864 (dolist (key flushed-keys
)
1866 (setf (combination-args call
) (reverse new-args
))
1867 (reverse parameters
)))
1869 (defun extract-fun-args (lvar fun num-args
)
1870 (declare (type lvar lvar
)
1871 (type (or symbol list
) fun
)
1872 (type index num-args
))
1873 (let ((fun (if (listp fun
) fun
(list fun
))))
1874 (let ((inside (lvar-uses lvar
)))
1875 (unless (combination-p inside
)
1876 (give-up-ir1-transform))
1877 (let ((inside-fun (combination-fun inside
)))
1878 (unless (member (lvar-fun-name inside-fun
) fun
)
1879 (give-up-ir1-transform))
1880 (let ((inside-args (combination-args inside
)))
1881 (unless (= (length inside-args
) num-args
)
1882 (give-up-ir1-transform))
1883 (values (lvar-fun-name inside-fun
) inside-args
))))))
1885 (defun flush-combination (combination)
1886 (declare (type combination combination
))
1887 (flush-dest (combination-fun combination
))
1888 (dolist (arg (combination-args combination
))
1890 (unlink-node combination
)
1896 ;;; Change the LEAF that a REF refers to.
1897 (defun change-ref-leaf (ref leaf
&key recklessly
)
1898 (declare (type ref ref
) (type leaf leaf
))
1899 (unless (eq (ref-leaf ref
) leaf
)
1900 (push ref
(leaf-refs leaf
))
1902 (setf (ref-leaf ref
) leaf
)
1903 (setf (leaf-ever-used leaf
) t
)
1904 (let* ((ltype (leaf-type leaf
))
1905 (vltype (make-single-value-type ltype
)))
1906 (if (let* ((lvar (node-lvar ref
))
1907 (dest (and lvar
(lvar-dest lvar
))))
1908 (and (basic-combination-p dest
)
1909 (eq lvar
(basic-combination-fun dest
))
1910 (csubtypep ltype
(specifier-type 'function
))))
1911 (setf (node-derived-type ref
) vltype
)
1912 (derive-node-type ref vltype
:from-scratch recklessly
)))
1913 (reoptimize-lvar (node-lvar ref
)))
1916 ;;; Change all REFS for OLD-LEAF to NEW-LEAF.
1917 (defun substitute-leaf (new-leaf old-leaf
)
1918 (declare (type leaf new-leaf old-leaf
))
1919 (dolist (ref (leaf-refs old-leaf
))
1920 (change-ref-leaf ref new-leaf
))
1923 ;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
1924 ;;; whether to substitute
1925 (defun substitute-leaf-if (test new-leaf old-leaf
)
1926 (declare (type leaf new-leaf old-leaf
) (type function test
))
1927 (dolist (ref (leaf-refs old-leaf
))
1928 (when (funcall test ref
)
1929 (change-ref-leaf ref new-leaf
)))
1932 ;;; Return a LEAF which represents the specified constant object. If
1933 ;;; the object is not in *CONSTANTS*, then we create a new constant
1934 ;;; LEAF and enter it. If we are producing a fasl file, make sure that
1935 ;;; MAKE-LOAD-FORM gets used on any parts of the constant that it
1938 ;;; We are allowed to coalesce things like EQUAL strings and bit-vectors
1939 ;;; when file-compiling, but not when using COMPILE.
1940 (defun find-constant (object &optional
(name nil namep
))
1941 (let ((faslp (producing-fasl-file)))
1942 (labels ((make-it ()
1945 (maybe-emit-make-load-forms object name
)
1946 (maybe-emit-make-load-forms object
)))
1947 (make-constant object
))
1948 (core-coalesce-p (x)
1949 ;; True for things which retain their identity under EQUAL,
1950 ;; so we can safely share the same CONSTANT leaf between
1951 ;; multiple references.
1952 (or (typep x
'(or symbol number character
))
1953 ;; Amusingly enough, we see CLAMBDAs --among other things--
1954 ;; here, from compiling things like %ALLOCATE-CLOSUREs forms.
1955 ;; No point in stuffing them in the hash-table.
1956 (and (typep x
'instance
)
1957 (not (or (leaf-p x
) (node-p x
))))))
1958 (file-coalesce-p (x)
1959 ;; CLHS 3.2.4.2.2: We are also allowed to coalesce various
1960 ;; other things when file-compiling.
1961 (or (core-coalesce-p x
)
1963 (if (eq +code-coverage-unmarked
+ (cdr x
))
1964 ;; These are already coalesced, and the CAR should
1965 ;; always be OK, so no need to check.
1967 (unless (maybe-cyclic-p x
) ; safe for EQUAL?
1969 ((atom y
) (file-coalesce-p y
))
1970 (unless (file-coalesce-p (car y
))
1972 ;; We *could* coalesce base-strings as well,
1973 ;; but we'd need a separate hash-table for
1974 ;; that, since we are not allowed to coalesce
1975 ;; base-strings with non-base-strings.
1978 ;; in the cross-compiler, we coalesce
1979 ;; all strings with the same contents,
1980 ;; because we will end up dumping them
1981 ;; as base-strings anyway. In the
1982 ;; real compiler, we're not allowed to
1983 ;; coalesce regardless of string
1984 ;; specialized element type, so we
1985 ;; KLUDGE by coalescing only character
1986 ;; strings (the common case) and
1987 ;; punting on the other types.
1991 (vector character
))))))
1993 (if faslp
(file-coalesce-p x
) (core-coalesce-p x
))))
1994 (if (and (boundp '*constants
*) (coalescep object
))
1995 (or (gethash object
*constants
*)
1996 (setf (gethash object
*constants
*)
2000 ;;; Return true if VAR would have to be closed over if environment
2001 ;;; analysis ran now (i.e. if there are any uses that have a different
2002 ;;; home lambda than VAR's home.)
2003 (defun closure-var-p (var)
2004 (declare (type lambda-var var
))
2005 (let ((home (lambda-var-home var
)))
2006 (cond ((eq (functional-kind home
) :deleted
)
2008 (t (let ((home (lambda-home home
)))
2011 :key
#'node-home-lambda
2013 (or (frob (leaf-refs var
))
2014 (frob (basic-var-sets var
)))))))))
2016 ;;; If there is a non-local exit noted in ENTRY's environment that
2017 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
2018 (defun find-nlx-info (exit)
2019 (declare (type exit exit
))
2020 (let* ((entry (exit-entry exit
))
2021 (cleanup (entry-cleanup entry
))
2022 (block (first (block-succ (node-block exit
)))))
2023 (dolist (nlx (physenv-nlx-info (node-physenv entry
)) nil
)
2024 (when (and (eq (nlx-info-block nlx
) block
)
2025 (eq (nlx-info-cleanup nlx
) cleanup
))
2028 (defun nlx-info-lvar (nlx)
2029 (declare (type nlx-info nlx
))
2030 (node-lvar (block-last (nlx-info-target nlx
))))
2032 ;;;; functional hackery
2034 (declaim (ftype (sfunction (functional) clambda
) main-entry
))
2035 (defun main-entry (functional)
2036 (etypecase functional
2037 (clambda functional
)
2039 (optional-dispatch-main-entry functional
))))
2041 ;;; RETURN true if FUNCTIONAL is a thing that can be treated like
2042 ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
2043 ;;; optional with null default and no SUPPLIED-P. There must be a
2044 ;;; &REST arg with no references.
2045 (declaim (ftype (sfunction (functional) boolean
) looks-like-an-mv-bind
))
2046 (defun looks-like-an-mv-bind (functional)
2047 (and (optional-dispatch-p functional
)
2048 (do ((arg (optional-dispatch-arglist functional
) (cdr arg
)))
2050 (let ((info (lambda-var-arg-info (car arg
))))
2051 (unless info
(return nil
))
2052 (case (arg-info-kind info
)
2054 (when (or (arg-info-supplied-p info
) (arg-info-default info
))
2057 (return (and (null (cdr arg
)) (null (leaf-refs (car arg
))))))
2061 ;;; Return true if function is an external entry point. This is true
2062 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
2063 ;;; (:TOPLEVEL kind.)
2065 (declare (type functional fun
))
2066 (not (null (member (functional-kind fun
) '(:external
:toplevel
)))))
2068 ;;; If LVAR's only use is a non-notinline global function reference,
2069 ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
2070 ;;; is true, then we don't care if the leaf is NOTINLINE.
2071 (defun lvar-fun-name (lvar &optional notinline-ok
)
2072 (declare (type lvar lvar
))
2073 (let ((use (lvar-uses lvar
)))
2075 (let ((leaf (ref-leaf use
)))
2076 (if (and (global-var-p leaf
)
2077 (eq (global-var-kind leaf
) :global-function
)
2078 (or (not (defined-fun-p leaf
))
2079 (not (eq (defined-fun-inlinep leaf
) :notinline
))
2081 (leaf-source-name leaf
)
2085 (defun lvar-fun-debug-name (lvar)
2086 (declare (type lvar lvar
))
2087 (let ((uses (lvar-uses lvar
)))
2089 (leaf-debug-name (ref-leaf use
))))
2092 (mapcar #'name1 uses
)))))
2094 ;;; Return the source name of a combination -- or signals an error
2095 ;;; if the function leaf is anonymous.
2096 (defun combination-fun-source-name (combination &optional
(errorp t
))
2097 (let ((leaf (ref-leaf (lvar-uses (combination-fun combination
)))))
2098 (if (or errorp
(leaf-has-source-name-p leaf
))
2099 (values (leaf-source-name leaf
) t
)
2102 ;;; Return the COMBINATION node that is the call to the LET FUN.
2103 (defun let-combination (fun)
2104 (declare (type clambda fun
))
2105 (aver (functional-letlike-p fun
))
2106 (lvar-dest (node-lvar (first (leaf-refs fun
)))))
2108 ;;; Return the initial value lvar for a LET variable, or NIL if there
2110 (defun let-var-initial-value (var)
2111 (declare (type lambda-var var
))
2112 (let ((fun (lambda-var-home var
)))
2113 (elt (combination-args (let-combination fun
))
2114 (position-or-lose var
(lambda-vars fun
)))))
2116 ;;; Return the LAMBDA that is called by the local CALL.
2117 (defun combination-lambda (call)
2118 (declare (type basic-combination call
))
2119 (aver (eq (basic-combination-kind call
) :local
))
2120 (ref-leaf (lvar-uses (basic-combination-fun call
))))
2122 (defvar *inline-expansion-limit
* 200
2124 "an upper limit on the number of inline function calls that will be expanded
2125 in any given code object (single function or block compilation)")
2127 ;;; Check whether NODE's component has exceeded its inline expansion
2128 ;;; limit, and warn if so, returning NIL.
2129 (defun inline-expansion-ok (node)
2130 (let ((expanded (incf (component-inline-expansions
2132 (node-block node
))))))
2133 (cond ((> expanded
*inline-expansion-limit
*) nil
)
2134 ((= expanded
*inline-expansion-limit
*)
2135 ;; FIXME: If the objective is to stop the recursive
2136 ;; expansion of inline functions, wouldn't it be more
2137 ;; correct to look back through surrounding expansions
2138 ;; (which are, I think, stored in the *CURRENT-PATH*, and
2139 ;; possibly stored elsewhere too) and suppress expansion
2140 ;; and print this warning when the function being proposed
2141 ;; for inline expansion is found there? (I don't like the
2142 ;; arbitrary numerical limit in principle, and I think
2143 ;; it'll be a nuisance in practice if we ever want the
2144 ;; compiler to be able to use WITH-COMPILATION-UNIT on
2145 ;; arbitrarily huge blocks of code. -- WHN)
2146 (let ((*compiler-error-context
* node
))
2147 (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
2148 probably trying to~% ~
2149 inline a recursive function."
2150 *inline-expansion-limit
*))
2154 ;;; Make sure that FUNCTIONAL is not let-converted or deleted.
2155 (defun assure-functional-live-p (functional)
2156 (declare (type functional functional
))
2158 ;; looks LET-converted
2159 (functional-somewhat-letlike-p functional
)
2160 ;; It's possible for a LET-converted function to end up
2161 ;; deleted later. In that case, for the purposes of this
2162 ;; analysis, it is LET-converted: LET-converted functionals
2163 ;; are too badly trashed to expand them inline, and deleted
2164 ;; LET-converted functionals are even worse.
2165 (memq (functional-kind functional
) '(:deleted
:zombie
))))
2166 (throw 'locall-already-let-converted functional
)))
2168 (defun assure-leaf-live-p (leaf)
2171 (when (lambda-var-deleted leaf
)
2172 (throw 'locall-already-let-converted leaf
)))
2174 (assure-functional-live-p leaf
))))
2177 (defun call-full-like-p (call)
2178 (declare (type combination call
))
2179 (let ((kind (basic-combination-kind call
)))
2181 (and (eq kind
:known
)
2182 (let ((info (basic-combination-fun-info call
)))
2184 (not (fun-info-ir2-convert info
))
2185 (dolist (template (fun-info-templates info
) t
)
2186 (when (eq (template-ltn-policy template
) :fast-safe
)
2187 (multiple-value-bind (val win
)
2188 (valid-fun-use call
(template-type template
))
2189 (when (or val
(not win
)) (return nil
)))))))))))
2193 ;;; Apply a function to some arguments, returning a list of the values
2194 ;;; resulting of the evaluation. If an error is signalled during the
2195 ;;; application, then we produce a warning message using WARN-FUN and
2196 ;;; return NIL as our second value to indicate this. NODE is used as
2197 ;;; the error context for any error message, and CONTEXT is a string
2198 ;;; that is spliced into the warning.
2199 (declaim (ftype (sfunction ((or symbol function
) list node function string
)
2200 (values list boolean
))
2202 (defun careful-call (function args node warn-fun context
)
2204 (multiple-value-list
2205 (handler-case (apply function args
)
2207 (let ((*compiler-error-context
* node
))
2208 (funcall warn-fun
"Lisp error during ~A:~%~A" context condition
)
2209 (return-from careful-call
(values nil nil
))))))
2212 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
2215 ((deffrob (basic careful compiler transform
)
2217 (defun ,careful
(specifier)
2218 (handler-case (,basic specifier
)
2219 (sb!kernel
::arg-count-error
(condition)
2220 (values nil
(list (format nil
"~A" condition
))))
2221 (simple-error (condition)
2222 (values nil
(list* (simple-condition-format-control condition
)
2223 (simple-condition-format-arguments condition
))))))
2224 (defun ,compiler
(specifier)
2225 (multiple-value-bind (type error-args
) (,careful specifier
)
2227 (apply #'compiler-error error-args
))))
2228 (defun ,transform
(specifier)
2229 (multiple-value-bind (type error-args
) (,careful specifier
)
2231 (apply #'give-up-ir1-transform
2233 (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type
)
2234 (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type
))
2237 ;;;; utilities used at run-time for parsing &KEY args in IR1
2239 ;;; This function is used by the result of PARSE-DEFTRANSFORM to find
2240 ;;; the lvar for the value of the &KEY argument KEY in the list of
2241 ;;; lvars ARGS. It returns the lvar if the keyword is present, or NIL
2242 ;;; otherwise. The legality and constantness of the keywords should
2243 ;;; already have been checked.
2244 (declaim (ftype (sfunction (list keyword
) (or lvar null
))
2246 (defun find-keyword-lvar (args key
)
2247 (do ((arg args
(cddr arg
)))
2249 (when (eq (lvar-value (first arg
)) key
)
2250 (return (second arg
)))))
2252 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
2253 ;;; verify that alternating lvars in ARGS are constant and that there
2254 ;;; is an even number of args.
2255 (declaim (ftype (sfunction (list) boolean
) check-key-args-constant
))
2256 (defun check-key-args-constant (args)
2257 (do ((arg args
(cddr arg
)))
2259 (unless (and (rest arg
)
2260 (constant-lvar-p (first arg
)))
2263 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
2264 ;;; verify that the list of lvars ARGS is a well-formed &KEY arglist
2265 ;;; and that only keywords present in the list KEYS are supplied.
2266 (declaim (ftype (sfunction (list list
) boolean
) check-transform-keys
))
2267 (defun check-transform-keys (args keys
)
2268 (and (check-key-args-constant args
)
2269 (do ((arg args
(cddr arg
)))
2271 (unless (member (lvar-value (first arg
)) keys
)
2276 ;;; Called by the expansion of the EVENT macro.
2277 (declaim (ftype (sfunction (event-info (or node null
)) *) %event
))
2278 (defun %event
(info node
)
2279 (incf (event-info-count info
))
2280 (when (and (>= (event-info-level info
) *event-note-threshold
*)
2281 (policy (or node
*lexenv
*)
2282 (= inhibit-warnings
0)))
2283 (let ((*compiler-error-context
* node
))
2284 (compiler-notify (event-info-description info
))))
2286 (let ((action (event-info-action info
)))
2287 (when action
(funcall action node
))))
2290 (defun make-cast (value type policy
)
2291 (declare (type lvar value
)
2293 (type policy policy
))
2294 (%make-cast
:asserted-type type
2295 :type-to-check
(maybe-weaken-check type policy
)
2297 :derived-type
(coerce-to-values type
)))
2299 (defun cast-type-check (cast)
2300 (declare (type cast cast
))
2301 (when (cast-reoptimize cast
)
2302 (ir1-optimize-cast cast t
))
2303 (cast-%type-check cast
))
2305 (defun note-single-valuified-lvar (lvar)
2306 (declare (type (or lvar null
) lvar
))
2308 (let ((use (lvar-uses lvar
)))
2310 (let ((leaf (ref-leaf use
)))
2311 (when (and (lambda-var-p leaf
)
2312 (null (rest (leaf-refs leaf
))))
2313 (reoptimize-lambda-var leaf
))))
2314 ((or (listp use
) (combination-p use
))
2315 (do-uses (node lvar
)
2316 (setf (node-reoptimize node
) t
)
2317 (setf (block-reoptimize (node-block node
)) t
)
2318 (reoptimize-component (node-component node
) :maybe
)))))))
2320 ;;; Return true if LVAR's only use is a reference to a global function
2321 ;;; designator with one of the specified NAMES, that hasn't been
2322 ;;; declared NOTINLINE.
2323 (defun lvar-fun-is (lvar names
)
2324 (declare (type lvar lvar
) (list names
))
2325 (let ((use (lvar-uses lvar
)))
2327 (let* ((*lexenv
* (node-lexenv use
))
2328 (leaf (ref-leaf use
))
2330 (cond ((global-var-p leaf
)
2332 (and (eq (global-var-kind leaf
) :global-function
)
2333 (car (member (leaf-source-name leaf
) names
2336 (let ((value (constant-value leaf
)))
2337 (car (if (functionp value
)
2342 (fdefinition name
)))
2346 :test
#'equal
))))))))
2348 (not (fun-lexically-notinline-p name
)))))))
2350 ;;; Return true if LVAR's only use is a call to one of the named functions
2351 ;;; (or any function if none are specified) with the specified number of
2352 ;;; of arguments (or any number if number is not specified)
2353 (defun lvar-matches (lvar &key fun-names arg-count
)
2354 (let ((use (lvar-uses lvar
)))
2355 (and (combination-p use
)
2357 (multiple-value-bind (name ok
)
2358 (combination-fun-source-name use nil
)
2359 (and ok
(member name fun-names
:test
#'eq
))))
2361 (= arg-count
(length (combination-args use
)))))))
2363 ;;; True if the optional has a rest-argument.
2364 (defun optional-rest-p (opt)
2365 (dolist (var (optional-dispatch-arglist opt
) nil
)
2366 (let* ((info (when (lambda-var-p var
)
2367 (lambda-var-arg-info var
)))
2369 (arg-info-kind info
))))
2370 (when (eq :rest kind
)
2373 ;;; Don't substitute single-ref variables on high-debug / low speed, to
2374 ;;; improve the debugging experience. ...but don't bother keeping those
2375 ;;; from system lambdas.
2376 (defun preserve-single-use-debug-var-p (call var
)
2377 (and (policy call
(eql preserve-single-use-debug-variables
3))
2378 (or (not (lambda-var-p var
))
2379 (not (lambda-system-lambda-p (lambda-var-home var
))))))