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 (awhen (lexenv-cleanup lexenv
)
28 (defun map-nested-cleanups (function block
&optional return-value
)
29 (declare (type cblock block
))
30 (do ((cleanup (block-end-cleanup block
)
31 (node-enclosing-cleanup (cleanup-mess-up cleanup
))))
32 ((not cleanup
) return-value
)
33 (funcall function cleanup
)))
35 ;;; Convert the FORM in a block inserted between BLOCK1 and BLOCK2 as
36 ;;; an implicit MV-PROG1. The inserted block is returned. NODE is used
37 ;;; for IR1 context when converting the form. Note that the block is
38 ;;; not assigned a number, and is linked into the DFO at the
39 ;;; beginning. We indicate that we have trashed the DFO by setting
40 ;;; COMPONENT-REANALYZE. If CLEANUP is supplied, then convert with
42 (defun insert-cleanup-code (block1 block2 node form
&optional cleanup
)
43 (declare (type cblock block1 block2
) (type node node
)
44 (type (or cleanup null
) cleanup
))
45 (setf (component-reanalyze (block-component block1
)) t
)
46 (with-ir1-environment-from-node node
47 (with-component-last-block (*current-component
*
48 (block-next (component-head *current-component
*)))
49 (let* ((start (make-ctran))
50 (block (ctran-starts-block start
))
53 (make-lexenv :cleanup cleanup
)
55 (change-block-successor block1 block2 block
)
56 (link-blocks block block2
)
57 (ir1-convert start next nil form
)
58 (setf (block-last block
) (ctran-use next
))
59 (setf (node-next (block-last block
)) nil
)
64 ;;; Return a list of all the nodes which use LVAR.
65 (declaim (ftype (sfunction (lvar) list
) find-uses
))
66 (defun find-uses (lvar)
67 (ensure-list (lvar-uses lvar
)))
69 (declaim (ftype (sfunction (lvar) lvar
) principal-lvar
))
70 (defun principal-lvar (lvar)
72 (let ((use (lvar-uses lvar
)))
78 (defun principal-lvar-use (lvar)
80 (declare (type lvar lvar
))
81 (let ((use (lvar-uses lvar
)))
83 (plu (cast-value use
))
87 (defun principal-lvar-dest (lvar)
89 (declare (type lvar lvar
))
90 (let ((dest (lvar-dest lvar
)))
92 (pld (cast-lvar dest
))
96 ;;; Update lvar use information so that NODE is no longer a use of its
99 ;;; Note: if you call this function, you may have to do a
100 ;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
102 (declaim (ftype (sfunction (node) (values))
105 ;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may
106 ;;; be given a new use.
107 (defun %delete-lvar-use
(node)
108 (let ((lvar (node-lvar node
)))
110 (if (listp (lvar-uses lvar
))
111 (let ((new-uses (delq node
(lvar-uses lvar
))))
112 (setf (lvar-uses lvar
)
113 (if (singleton-p new-uses
)
116 (setf (lvar-uses lvar
) nil
))
119 ;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete
120 ;;; its DEST's block, which must be unreachable.
121 (defun delete-lvar-use (node)
122 (let ((lvar (node-lvar node
)))
124 (%delete-lvar-use node
)
125 (if (null (lvar-uses lvar
))
126 (binding* ((dest (lvar-dest lvar
) :exit-if-null
)
127 (() (not (node-deleted dest
)) :exit-if-null
)
128 (block (node-block dest
)))
129 (mark-for-deletion block
))
130 (reoptimize-lvar lvar
))))
133 ;;; Update lvar use information so that NODE uses LVAR.
135 ;;; Note: if you call this function, you may have to do a
136 ;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
138 (declaim (ftype (sfunction (node (or lvar null
)) (values)) add-lvar-use
))
139 (defun add-lvar-use (node lvar
)
140 (aver (not (node-lvar node
)))
142 (let ((uses (lvar-uses lvar
)))
143 (setf (lvar-uses lvar
)
150 (setf (node-lvar node
) lvar
)))
154 ;;; Return true if LVAR destination is executed immediately after
155 ;;; NODE. Cleanups are ignored.
156 (defun immediately-used-p (lvar node
)
157 (declare (type lvar lvar
) (type node node
))
158 (aver (eq (node-lvar node
) lvar
))
159 (let ((dest (lvar-dest lvar
)))
160 (acond ((node-next node
)
161 (eq (ctran-next it
) dest
))
162 (t (eq (block-start (first (block-succ (node-block node
))))
163 (node-prev dest
))))))
165 ;;; Returns the defined (usually untrusted) type of the combination,
166 ;;; or NIL if we couldn't figure it out.
167 (defun combination-defined-type (combination)
168 (let ((use (principal-lvar-use (basic-combination-fun combination
))))
169 (or (when (ref-p use
)
170 (let ((type (leaf-defined-type (ref-leaf use
))))
171 (when (fun-type-p type
)
172 (fun-type-returns type
))))
175 ;;; Return true if LVAR destination is executed after node with only
176 ;;; uninteresting nodes intervening.
178 ;;; Uninteresting nodes are nodes in the same block which are either
179 ;;; REFs, external CASTs to the same destination, or known combinations
180 ;;; that never unwind.
181 (defun almost-immediately-used-p (lvar node
)
182 (declare (type lvar lvar
)
184 (aver (eq (node-lvar node
) lvar
))
185 (let ((dest (lvar-dest lvar
)))
188 (let ((ctran (node-next node
)))
190 (setf node
(ctran-next ctran
))
192 (return-from almost-immediately-used-p t
)
197 (when (and (eq :external
(cast-type-check node
))
198 (eq dest
(node-dest node
)))
201 ;; KLUDGE: Unfortunately we don't have an attribute for
202 ;; "never unwinds", so we just special case
203 ;; %ALLOCATE-CLOSURES: it is easy to run into with eg.
204 ;; FORMAT and a non-constant first argument.
205 (when (eq '%allocate-closures
(combination-fun-source-name node nil
))
208 (when (eq (block-start (first (block-succ (node-block node
))))
210 (return-from almost-immediately-used-p t
))))))))
212 ;;;; lvar substitution
214 ;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be
215 ;;; NIL. We do not flush OLD's DEST.
216 (defun substitute-lvar (new old
)
217 (declare (type lvar old new
))
218 (aver (not (lvar-dest new
)))
219 (let ((dest (lvar-dest old
)))
222 (cif (setf (if-test dest
) new
))
223 (cset (setf (set-value dest
) new
))
224 (creturn (setf (return-result dest
) new
))
225 (exit (setf (exit-value dest
) new
))
227 (if (eq old
(basic-combination-fun dest
))
228 (setf (basic-combination-fun dest
) new
)
229 (setf (basic-combination-args dest
)
230 (nsubst new old
(basic-combination-args dest
)))))
231 (cast (setf (cast-value dest
) new
)))
233 (setf (lvar-dest old
) nil
)
234 (setf (lvar-dest new
) dest
)
235 (flush-lvar-externally-checkable-type new
))
238 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
239 ;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
240 (defun substitute-lvar-uses (new old propagate-dx
)
241 (declare (type lvar old
)
242 (type (or lvar null
) new
)
243 (type boolean propagate-dx
))
247 (%delete-lvar-use node
)
248 (add-lvar-use node new
))
249 (reoptimize-lvar new
)
250 (awhen (and propagate-dx
(lvar-dynamic-extent old
))
251 (setf (lvar-dynamic-extent old
) nil
)
252 (unless (lvar-dynamic-extent new
)
253 (setf (lvar-dynamic-extent new
) it
)
254 (setf (cleanup-info it
) (subst new old
(cleanup-info it
)))))
255 (when (lvar-dynamic-extent new
)
257 (node-ends-block node
))))
258 (t (flush-dest old
)))
262 ;;;; block starting/creation
264 ;;; Return the block that CTRAN is the start of, making a block if
265 ;;; necessary. This function is called by IR1 translators which may
266 ;;; cause a CTRAN to be used more than once. Every CTRAN which may be
267 ;;; used more than once must start a block by the time that anyone
268 ;;; does a USE-CTRAN on it.
270 ;;; We also throw the block into the next/prev list for the
271 ;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have
273 (defun ctran-starts-block (ctran)
274 (declare (type ctran ctran
))
275 (ecase (ctran-kind ctran
)
277 (aver (not (ctran-block ctran
)))
278 (let* ((next (component-last-block *current-component
*))
279 (prev (block-prev next
))
280 (new-block (make-block ctran
)))
281 (setf (block-next new-block
) next
282 (block-prev new-block
) prev
283 (block-prev next
) new-block
284 (block-next prev
) new-block
285 (ctran-block ctran
) new-block
286 (ctran-kind ctran
) :block-start
)
287 (aver (not (ctran-use ctran
)))
290 (ctran-block ctran
))))
292 ;;; Ensure that CTRAN is the start of a block so that the use set can
293 ;;; be freely manipulated.
294 (defun ensure-block-start (ctran)
295 (declare (type ctran ctran
))
296 (let ((kind (ctran-kind ctran
)))
300 (setf (ctran-block ctran
)
301 (make-block-key :start ctran
))
302 (setf (ctran-kind ctran
) :block-start
))
304 (node-ends-block (ctran-use ctran
)))))
307 ;;; CTRAN must be the last ctran in an incomplete block; finish the
308 ;;; block and start a new one if necessary.
309 (defun start-block (ctran)
310 (declare (type ctran ctran
))
311 (aver (not (ctran-next ctran
)))
312 (ecase (ctran-kind ctran
)
314 (let ((block (ctran-block ctran
))
315 (node (ctran-use ctran
)))
316 (aver (not (block-last block
)))
318 (setf (block-last block
) node
)
319 (setf (node-next node
) nil
)
320 (setf (ctran-use ctran
) nil
)
321 (setf (ctran-kind ctran
) :unused
)
322 (setf (ctran-block ctran
) nil
)
323 (link-blocks block
(ctran-starts-block ctran
))))
328 ;;; Filter values of LVAR through FORM, which must be an ordinary/mv
329 ;;; call. Exactly one argument must be 'DUMMY, which will be replaced
330 ;;; with LVAR. In case of an ordinary call the function should not
331 ;;; have return type NIL. We create a new "filtered" lvar.
333 ;;; TODO: remove preconditions.
334 (defun filter-lvar (lvar form
)
335 (declare (type lvar lvar
) (type list form
))
336 (let* ((dest (lvar-dest lvar
))
337 (ctran (node-prev dest
)))
338 (with-ir1-environment-from-node dest
340 (ensure-block-start ctran
)
341 (let* ((old-block (ctran-block ctran
))
342 (new-start (make-ctran))
343 (filtered-lvar (make-lvar))
344 (new-block (ctran-starts-block new-start
)))
346 ;; Splice in the new block before DEST, giving the new block
347 ;; all of DEST's predecessors.
348 (dolist (block (block-pred old-block
))
349 (change-block-successor block old-block new-block
))
351 (ir1-convert new-start ctran filtered-lvar form
)
353 ;; KLUDGE: Comments at the head of this function in CMU CL
354 ;; said that somewhere in here we
355 ;; Set the new block's start and end cleanups to the *start*
356 ;; cleanup of PREV's block. This overrides the incorrect
357 ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
358 ;; Unfortunately I can't find any code which corresponds to this.
359 ;; Perhaps it was a stale comment? Or perhaps I just don't
360 ;; understand.. -- WHN 19990521
362 ;; Replace 'DUMMY with the LVAR. (We can find 'DUMMY because
363 ;; no LET conversion has been done yet.) The [mv-]combination
364 ;; code from the call in the form will be the use of the new
365 ;; check lvar. We substitute exactly one argument.
366 (let* ((node (lvar-use filtered-lvar
))
368 (dolist (arg (basic-combination-args node
) (aver victim
))
369 (let* ((arg (principal-lvar arg
))
372 (when (and (ref-p use
)
373 (constant-p (setf leaf
(ref-leaf use
)))
374 (eql (constant-value leaf
) 'dummy
))
377 (aver (eq (constant-value (ref-leaf (lvar-use victim
)))
380 (substitute-lvar filtered-lvar lvar
)
381 (substitute-lvar lvar victim
)
384 ;; Invoking local call analysis converts this call to a LET.
385 (locall-analyze-component *current-component
*))))
388 ;;; Delete NODE and VALUE. It may result in some calls becoming tail.
389 (defun delete-filter (node lvar value
)
390 (aver (eq (lvar-dest value
) node
))
391 (aver (eq (node-lvar node
) lvar
))
392 (cond (lvar (collect ((merges))
393 (when (return-p (lvar-dest lvar
))
395 (when (and (basic-combination-p use
)
396 (eq (basic-combination-kind use
) :local
))
398 (substitute-lvar-uses lvar value
399 (and lvar
(eq (lvar-uses lvar
) node
)))
400 (%delete-lvar-use node
)
403 (dolist (merge (merges))
404 (merge-tail-sets merge
)))))
405 (t (flush-dest value
)
406 (unlink-node node
))))
408 ;;; Make a CAST and insert it into IR1 before node NEXT.
409 (defun insert-cast-before (next lvar type policy
)
410 (declare (type node next
) (type lvar lvar
) (type ctype type
))
411 (with-ir1-environment-from-node next
412 (let* ((ctran (node-prev next
))
413 (cast (make-cast lvar type policy
))
414 (internal-ctran (make-ctran)))
415 (setf (ctran-next ctran
) cast
416 (node-prev cast
) ctran
)
417 (use-ctran cast internal-ctran
)
418 (link-node-to-previous-ctran next internal-ctran
)
419 (setf (lvar-dest lvar
) cast
)
420 (reoptimize-lvar lvar
)
421 (when (return-p next
)
422 (node-ends-block cast
))
423 (setf (block-attributep (block-flags (node-block cast
))
424 type-check type-asserted
)
428 ;;;; miscellaneous shorthand functions
430 ;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since
431 ;;; the LEXENV-LAMBDA may be deleted, we must chain up the
432 ;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't
433 ;;; deleted, and then return its home.
434 (defun node-home-lambda (node)
435 (declare (type node node
))
436 (do ((fun (lexenv-lambda (node-lexenv node
))
437 (lexenv-lambda (lambda-call-lexenv fun
))))
438 ((not (memq (functional-kind fun
) '(:deleted
:zombie
)))
440 (when (eq (lambda-home fun
) fun
)
443 (declaim (ftype (sfunction (node) component
) node-component
))
444 (defun node-component (node)
445 (block-component (node-block node
)))
446 (declaim (ftype (sfunction (node) physenv
) node-physenv
))
447 (defun node-physenv (node)
448 (lambda-physenv (node-home-lambda node
)))
450 #!-sb-fluid
(declaim (inline node-stack-allocate-p
))
451 (defun node-stack-allocate-p (node)
452 (awhen (node-lvar node
)
453 (lvar-dynamic-extent it
)))
455 (defun flushable-combination-p (call)
456 (declare (type combination call
))
457 (let ((kind (combination-kind call
))
458 (info (combination-fun-info call
)))
459 (when (and (eq kind
:known
) (fun-info-p info
))
460 (let ((attr (fun-info-attributes info
)))
461 (when (and (not (ir1-attributep attr call
))
462 ;; FIXME: For now, don't consider potentially flushable
463 ;; calls flushable when they have the CALL attribute.
464 ;; Someday we should look at the functional args to
465 ;; determine if they have any side effects.
466 (if (policy call
(= safety
3))
467 (ir1-attributep attr flushable
)
468 (ir1-attributep attr unsafely-flushable
)))
471 ;;;; DYNAMIC-EXTENT related
473 (defun lambda-var-original-name (leaf)
474 (let ((home (lambda-var-home leaf
)))
475 (if (eq :external
(functional-kind home
))
476 (let* ((entry (functional-entry-fun home
))
477 (p (1- (position leaf
(lambda-vars home
)))))
479 (if (optional-dispatch-p entry
)
480 (elt (optional-dispatch-arglist entry
) p
)
481 (elt (lambda-vars entry
) p
))))
482 (leaf-debug-name leaf
))))
484 (defun note-no-stack-allocation (lvar &key flush
)
485 (do-uses (use (principal-lvar lvar
))
487 ;; Don't complain about not being able to stack allocate constants.
488 (and (ref-p use
) (constant-p (ref-leaf use
)))
489 ;; If we're flushing, don't complain if we can flush the combination.
490 (and flush
(combination-p use
) (flushable-combination-p use
))
491 ;; Don't report those with homes in :OPTIONAL -- we'd get doubled
493 (and (ref-p use
) (lambda-var-p (ref-leaf use
))
494 (eq :optional
(lambda-kind (lambda-var-home (ref-leaf use
))))))
495 ;; FIXME: For the first leg (lambda-bind (lambda-var-home ...))
496 ;; would be a far better description, but since we use
497 ;; *COMPILER-ERROR-CONTEXT* for muffling we can't -- as that node
498 ;; can have different handled conditions.
499 (let ((*compiler-error-context
* use
))
500 (if (and (ref-p use
) (lambda-var-p (ref-leaf use
)))
501 (compiler-notify "~@<could~2:I not stack allocate ~S in: ~S~:@>"
502 (lambda-var-original-name (ref-leaf use
))
503 (find-original-source (node-source-path use
)))
504 (compiler-notify "~@<could~2:I not stack allocate: ~S~:@>"
505 (find-original-source (node-source-path use
))))))))
507 (defun use-good-for-dx-p (use dx
&optional component
)
508 ;; FIXME: Can casts point to LVARs in other components?
509 ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the
510 ;; PRINCIPAL-LVAR is always in the same component as the original one. It
511 ;; would be either good to have an explanation of why casts don't point
512 ;; across components, or an explanation of when they do it. ...in the
513 ;; meanwhile AVER that our assumption holds true.
514 (aver (or (not component
) (eq component
(node-component use
))))
515 (or (dx-combination-p use dx
)
517 (not (cast-type-check use
))
518 (lvar-good-for-dx-p (cast-value use
) dx component
))
519 (and (trivial-lambda-var-ref-p use
)
520 (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use
))))
522 (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use
) dx component
))))))
524 (defun lvar-good-for-dx-p (lvar dx
&optional component
)
525 (let ((uses (lvar-uses lvar
))) ; TODO use ENSURE-LIST? or is it too slow?
529 (use-good-for-dx-p use dx component
))
531 (use-good-for-dx-p uses dx component
))))
533 (defun known-dx-combination-p (use dx
)
534 (and (eq (combination-kind use
) :known
)
535 (let ((info (combination-fun-info use
)))
536 (or (awhen (fun-info-stack-allocate-result info
)
538 (awhen (fun-info-result-arg info
)
539 (let ((args (combination-args use
)))
540 (lvar-good-for-dx-p (if (zerop it
)
545 (defun dx-combination-p (use dx
)
546 (and (combination-p use
)
548 ;; Known, and can do DX.
549 (known-dx-combination-p use dx
)
550 ;; Possibly a not-yet-eliminated lambda which ends up returning the
551 ;; results of an actual known DX combination.
552 (let* ((fun (combination-fun use
))
553 (ref (principal-lvar-use fun
))
554 (clambda (when (ref-p ref
)
556 (creturn (when (lambda-p clambda
)
557 (lambda-return clambda
)))
558 (result-use (when (return-p creturn
)
559 (principal-lvar-use (return-result creturn
)))))
560 ;; FIXME: We should be able to deal with multiple uses here as well.
561 (and (dx-combination-p result-use dx
)
562 (combination-args-flow-cleanly-p use result-use dx
))))))
564 (defun combination-args-flow-cleanly-p (combination1 combination2 dx
)
565 (labels ((recurse (combination)
566 (or (eq combination combination2
)
567 (if (known-dx-combination-p combination dx
)
568 (let ((dest (lvar-dest (combination-lvar combination
))))
569 (and (combination-p dest
)
571 (let* ((fun1 (combination-fun combination
))
572 (ref1 (principal-lvar-use fun1
))
573 (clambda1 (when (ref-p ref1
) (ref-leaf ref1
))))
574 (when (lambda-p clambda1
)
575 (dolist (var (lambda-vars clambda1
) t
)
576 (dolist (var-ref (lambda-var-refs var
))
577 (let ((dest (principal-lvar-dest (ref-lvar var-ref
))))
578 (unless (and (combination-p dest
) (recurse dest
))
579 (return-from combination-args-flow-cleanly-p nil
)))))))))))
580 (recurse combination1
)))
582 (defun ref-good-for-dx-p (ref)
583 (let* ((lvar (ref-lvar ref
))
584 (dest (when lvar
(lvar-dest lvar
))))
585 (and (combination-p dest
)
586 (eq :known
(combination-kind dest
))
587 (awhen (combination-fun-info dest
)
588 (or (ir1-attributep (fun-info-attributes it
) dx-safe
)
589 (and (not (combination-lvar dest
))
590 (awhen (fun-info-result-arg it
)
591 (eql lvar
(nth it
(combination-args dest
))))))))))
593 (defun trivial-lambda-var-ref-p (use)
595 (let ((var (ref-leaf use
)))
596 ;; lambda-var, no SETS, not explicitly indefinite-extent.
597 (when (and (lambda-var-p var
) (not (lambda-var-sets var
))
598 (neq :indefinite
(lambda-var-extent var
)))
599 (let ((home (lambda-var-home var
))
600 (refs (lambda-var-refs var
)))
601 ;; bound by a non-XEP system lambda, no other REFS that aren't
602 ;; DX-SAFE, or are result-args when the result is discarded.
603 (when (and (lambda-system-lambda-p home
)
604 (neq :external
(lambda-kind home
))
606 (unless (or (eq use ref
) (ref-good-for-dx-p ref
))
608 ;; the LAMBDA this var is bound by has only a single REF, going
610 (let* ((lambda-refs (lambda-refs home
))
611 (primary (car lambda-refs
)))
613 (not (cdr lambda-refs
))
614 (combination-p (lvar-dest (ref-lvar primary
)))))))))))
616 (defun trivial-lambda-var-ref-lvar (use)
617 (let* ((this (ref-leaf use
))
618 (fun (lambda-var-home this
))
619 (vars (lambda-vars fun
))
620 (combination (lvar-dest (ref-lvar (car (lambda-refs fun
)))))
621 (args (combination-args combination
)))
622 (aver (= (length vars
) (length args
)))
623 (loop for var in vars
628 ;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends.
629 (defun handle-nested-dynamic-extent-lvars (dx lvar
&optional recheck-component
)
630 (let ((uses (lvar-uses lvar
)))
631 ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS.
632 ;; Uses of mupltiple-use LVARs already end their blocks, so we just need
633 ;; to process uses of single-use LVARs.
635 (node-ends-block uses
))
636 ;; If this LVAR's USE is good for DX, it is either a CAST, or it
637 ;; must be a regular combination whose arguments are potentially DX as well.
638 (flet ((recurse (use)
641 (handle-nested-dynamic-extent-lvars
642 dx
(cast-value use
) recheck-component
))
644 (loop for arg in
(combination-args use
)
645 ;; deleted args show up as NIL here
647 (lvar-good-for-dx-p arg dx recheck-component
))
648 append
(handle-nested-dynamic-extent-lvars
649 dx arg recheck-component
)))
651 (let* ((other (trivial-lambda-var-ref-lvar use
)))
652 (unless (eq other lvar
)
653 (handle-nested-dynamic-extent-lvars
654 dx other recheck-component
)))))))
656 (if (listp uses
) ; TODO use ENSURE-LIST? or is it too slow?
657 (loop for use in uses
658 when
(use-good-for-dx-p use dx recheck-component
)
660 (when (use-good-for-dx-p uses dx recheck-component
)
665 (declaim (inline block-to-be-deleted-p
))
666 (defun block-to-be-deleted-p (block)
667 (or (block-delete-p block
)
668 (eq (functional-kind (block-home-lambda block
)) :deleted
)))
670 ;;; Checks whether NODE is in a block to be deleted
671 (declaim (inline node-to-be-deleted-p
))
672 (defun node-to-be-deleted-p (node)
673 (block-to-be-deleted-p (node-block node
)))
675 (declaim (ftype (sfunction (clambda) cblock
) lambda-block
))
676 (defun lambda-block (clambda)
677 (node-block (lambda-bind clambda
)))
678 (declaim (ftype (sfunction (clambda) component
) lambda-component
))
679 (defun lambda-component (clambda)
680 (block-component (lambda-block clambda
)))
682 (declaim (ftype (sfunction (cblock) node
) block-start-node
))
683 (defun block-start-node (block)
684 (ctran-next (block-start block
)))
686 ;;; Return the enclosing cleanup for environment of the first or last
688 (defun block-start-cleanup (block)
689 (node-enclosing-cleanup (block-start-node block
)))
690 (defun block-end-cleanup (block)
691 (node-enclosing-cleanup (block-last block
)))
693 ;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL
694 ;;; if there is none.
696 ;;; There can legitimately be no home lambda in dead code early in the
697 ;;; IR1 conversion process, e.g. when IR1-converting the SETQ form in
698 ;;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
699 ;;; where the block is just a placeholder during parsing and doesn't
700 ;;; actually correspond to code which will be written anywhere.
701 (declaim (ftype (sfunction (cblock) (or clambda null
)) block-home-lambda-or-null
))
702 (defun block-home-lambda-or-null (block)
703 (if (node-p (block-last block
))
704 ;; This is the old CMU CL way of doing it.
705 (node-home-lambda (block-last block
))
706 ;; Now that SBCL uses this operation more aggressively than CMU
707 ;; CL did, the old CMU CL way of doing it can fail in two ways.
708 ;; 1. It can fail in a few cases even when a meaningful home
709 ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of
711 ;; 2. It can fail when converting a form which is born orphaned
712 ;; so that it never had a meaningful home lambda, e.g. a form
713 ;; which follows a RETURN-FROM or GO form.
714 (let ((pred-list (block-pred block
)))
715 ;; To deal with case 1, we reason that
716 ;; previous-in-target-execution-order blocks should be in the
717 ;; same lambda, and that they seem in practice to be
718 ;; previous-in-compilation-order blocks too, so we look back
719 ;; to find one which is sufficiently initialized to tell us
720 ;; what the home lambda is.
722 ;; We could get fancy about this, flooding through the
723 ;; graph of all the previous blocks, but in practice it
724 ;; seems to work just to grab the first previous block and
726 (node-home-lambda (block-last (first pred-list
)))
727 ;; In case 2, we end up with an empty PRED-LIST and
728 ;; have to punt: There's no home lambda.
731 ;;; Return the non-LET LAMBDA that holds BLOCK's code.
732 (declaim (ftype (sfunction (cblock) clambda
) block-home-lambda
))
733 (defun block-home-lambda (block)
734 (block-home-lambda-or-null block
))
736 ;;; Return the IR1 physical environment for BLOCK.
737 (declaim (ftype (sfunction (cblock) physenv
) block-physenv
))
738 (defun block-physenv (block)
739 (lambda-physenv (block-home-lambda block
)))
741 ;;; Return the Top Level Form number of PATH, i.e. the ordinal number
742 ;;; of its original source's top level form in its compilation unit.
743 (defun source-path-tlf-number (path)
744 (declare (list path
))
747 ;;; Return the (reversed) list for the PATH in the original source
748 ;;; (with the Top Level Form number last).
749 (defun source-path-original-source (path)
750 (declare (list path
) (inline member
))
751 (cddr (member 'original-source-start path
:test
#'eq
)))
753 ;;; Return the Form Number of PATH's original source inside the Top
754 ;;; Level Form that contains it. This is determined by the order that
755 ;;; we walk the subforms of the top level source form.
756 (defun source-path-form-number (path)
757 (declare (list path
) (inline member
))
758 (cadr (member 'original-source-start path
:test
#'eq
)))
760 ;;; Return a list of all the enclosing forms not in the original
761 ;;; source that converted to get to this form, with the immediate
762 ;;; source for node at the start of the list.
763 (defun source-path-forms (path)
764 (subseq path
0 (position 'original-source-start path
)))
766 (defun tree-some (predicate tree
)
767 (let ((seen (make-hash-table)))
768 (labels ((walk (tree)
769 (cond ((funcall predicate tree
))
771 (not (gethash tree seen
)))
772 (setf (gethash tree seen
) t
)
773 (or (walk (car tree
))
774 (walk (cdr tree
)))))))
777 ;;; Return the innermost source form for NODE.
778 (defun node-source-form (node)
779 (declare (type node node
))
780 (let* ((path (node-source-path node
))
781 (forms (remove-if (lambda (x)
782 (tree-some #'leaf-p x
))
783 (source-path-forms path
))))
784 ;; another option: if first form includes a leaf, return
785 ;; find-original-source instead.
788 (values (find-original-source path
)))))
790 ;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise
792 (defun lvar-source (lvar)
793 (let ((use (lvar-uses lvar
)))
796 (values (node-source-form use
) t
))))
798 (defun common-suffix (x y
)
799 (let ((mismatch (mismatch x y
:from-end t
)))
804 ;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a
805 ;;; singleton. Otherwise, return a list of the lowest common
806 ;;; ancestor source form of all the uses (if it can be found),
807 ;;; followed by all the uses' source forms.
808 (defun lvar-all-sources (lvar)
809 (let ((use (lvar-uses lvar
)))
812 (path (node-source-path (first use
))))
813 (dolist (use use
(cons (if (find 'original-source-start path
)
814 (find-original-source path
)
817 (pushnew (node-source-form use
) forms
)
818 (setf path
(common-suffix path
819 (node-source-path use
)))))
820 (list (node-source-form use
)))))
822 ;;; Return the LAMBDA that is CTRAN's home, or NIL if there is none.
823 (declaim (ftype (sfunction (ctran) (or clambda null
))
824 ctran-home-lambda-or-null
))
825 (defun ctran-home-lambda-or-null (ctran)
826 ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
827 ;; implementation might not be quite right, or might be uglier than
828 ;; necessary. It appears that the original Python never found a need
829 ;; to do this operation. The obvious things based on
830 ;; NODE-HOME-LAMBDA of CTRAN-USE usually work; then if that fails,
831 ;; BLOCK-HOME-LAMBDA of CTRAN-BLOCK works, given that we
832 ;; generalize it enough to grovel harder when the simple CMU CL
833 ;; approach fails, and furthermore realize that in some exceptional
834 ;; cases it might return NIL. -- WHN 2001-12-04
835 (cond ((ctran-use ctran
)
836 (node-home-lambda (ctran-use ctran
)))
838 (block-home-lambda-or-null (ctran-block ctran
)))
840 (bug "confused about home lambda for ~S" ctran
))))
842 ;;; Return the LAMBDA that is CTRAN's home.
843 (declaim (ftype (sfunction (ctran) clambda
) ctran-home-lambda
))
844 (defun ctran-home-lambda (ctran)
845 (ctran-home-lambda-or-null ctran
))
847 (declaim (inline cast-single-value-p
))
848 (defun cast-single-value-p (cast)
849 (not (values-type-p (cast-asserted-type cast
))))
851 #!-sb-fluid
(declaim (inline lvar-single-value-p
))
852 (defun lvar-single-value-p (lvar)
853 (or (not lvar
) (%lvar-single-value-p lvar
)))
854 (defun %lvar-single-value-p
(lvar)
855 (let ((dest (lvar-dest lvar
)))
860 (eq (basic-combination-fun dest
) lvar
))
862 (and (cast-single-value-p dest
)
863 (acond ((node-lvar dest
) (%lvar-single-value-p it
))
867 (defun principal-lvar-end (lvar)
868 (loop for prev
= lvar then
(node-lvar dest
)
869 for dest
= (and prev
(lvar-dest prev
))
871 finally
(return (values dest prev
))))
873 (defun principal-lvar-single-valuify (lvar)
874 (loop for prev
= lvar then
(node-lvar dest
)
875 for dest
= (and prev
(lvar-dest prev
))
877 do
(setf (node-derived-type dest
)
878 (make-short-values-type (list (single-value-type
879 (node-derived-type dest
)))))
880 (reoptimize-lvar prev
)))
882 ;;; Return a new LEXENV just like DEFAULT except for the specified
883 ;;; slot values. Values for the alist slots are APPENDed to the
884 ;;; beginning of the current value, rather than replacing it entirely.
885 (defun make-lexenv (&key
(default *lexenv
*)
886 funs vars blocks tags
888 (lambda (lexenv-lambda default
))
889 (cleanup (lexenv-cleanup default
))
890 (handled-conditions (lexenv-handled-conditions default
))
891 (disabled-package-locks
892 (lexenv-disabled-package-locks default
))
893 (policy (lexenv-policy default
))
894 (user-data (lexenv-user-data default
)))
895 (macrolet ((frob (var slot
)
896 `(let ((old (,slot default
)))
900 (internal-make-lexenv
901 (frob funs lexenv-funs
)
902 (frob vars lexenv-vars
)
903 (frob blocks lexenv-blocks
)
904 (frob tags lexenv-tags
)
905 (frob type-restrictions lexenv-type-restrictions
)
907 cleanup handled-conditions disabled-package-locks
912 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
914 (defun make-restricted-lexenv (lexenv)
915 (flet ((fun-good-p (fun)
916 (destructuring-bind (name . thing
) fun
917 (declare (ignore name
))
921 (cons (aver (eq (car thing
) 'macro
))
924 (destructuring-bind (name . thing
) var
925 (declare (ignore name
))
927 ;; The evaluator will mark lexicals with :BOGUS when it
928 ;; translates an interpreter lexenv to a compiler
930 ((or leaf
#!+sb-eval
(member :bogus
)) nil
)
931 (cons (aver (eq (car thing
) 'macro
))
933 (heap-alien-info nil
)))))
934 (internal-make-lexenv
935 (remove-if-not #'fun-good-p
(lexenv-funs lexenv
))
936 (remove-if-not #'var-good-p
(lexenv-vars lexenv
))
939 (lexenv-type-restrictions lexenv
) ; XXX
942 (lexenv-handled-conditions lexenv
)
943 (lexenv-disabled-package-locks lexenv
)
944 (lexenv-policy lexenv
)
945 (lexenv-user-data lexenv
)
948 ;;;; flow/DFO/component hackery
950 ;;; Join BLOCK1 and BLOCK2.
951 (defun link-blocks (block1 block2
)
952 (declare (type cblock block1 block2
))
953 (setf (block-succ block1
)
954 (if (block-succ block1
)
955 (%link-blocks block1 block2
)
957 (push block1
(block-pred block2
))
959 (defun %link-blocks
(block1 block2
)
960 (declare (type cblock block1 block2
))
961 (let ((succ1 (block-succ block1
)))
962 (aver (not (memq block2 succ1
)))
963 (cons block2 succ1
)))
965 ;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If
966 ;;; this leaves a successor with a single predecessor that ends in an
967 ;;; IF, then set BLOCK-TEST-MODIFIED so that any test constraint will
968 ;;; now be able to be propagated to the successor.
969 (defun unlink-blocks (block1 block2
)
970 (declare (type cblock block1 block2
))
971 (let ((succ1 (block-succ block1
)))
972 (if (eq block2
(car succ1
))
973 (setf (block-succ block1
) (cdr succ1
))
974 (do ((succ (cdr succ1
) (cdr succ
))
976 ((eq (car succ
) block2
)
977 (setf (cdr prev
) (cdr succ
)))
980 (let ((new-pred (delq block1
(block-pred block2
))))
981 (setf (block-pred block2
) new-pred
)
982 (when (singleton-p new-pred
)
983 (let ((pred-block (first new-pred
)))
984 (when (if-p (block-last pred-block
))
985 (setf (block-test-modified pred-block
) t
)))))
988 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK
989 ;;; and NEW. If BLOCK ends in an IF, then we have to fix up the
990 ;;; consequent/alternative blocks to point to NEW. We also set
991 ;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to
992 ;;; the new successor.
993 (defun change-block-successor (block old new
)
994 (declare (type cblock new old block
))
995 (unlink-blocks block old
)
996 (let ((last (block-last block
))
997 (comp (block-component block
)))
998 (setf (component-reanalyze comp
) t
)
1001 (setf (block-test-modified block
) t
)
1002 (let* ((succ-left (block-succ block
))
1003 (new (if (and (eq new
(component-tail comp
))
1007 (unless (memq new succ-left
)
1008 (link-blocks block new
))
1009 (macrolet ((frob (slot)
1010 `(when (eq (,slot last
) old
)
1011 (setf (,slot last
) new
))))
1012 (frob if-consequent
)
1013 (frob if-alternative
)
1014 (when (eq (if-consequent last
)
1015 (if-alternative last
))
1016 (reoptimize-component (block-component block
) :maybe
)))))
1018 (unless (memq new
(block-succ block
))
1019 (link-blocks block new
)))))
1023 ;;; Unlink a block from the next/prev chain. We also null out the
1025 (declaim (ftype (sfunction (cblock) (values)) remove-from-dfo
))
1026 (defun remove-from-dfo (block)
1027 (let ((next (block-next block
))
1028 (prev (block-prev block
)))
1029 (setf (block-component block
) nil
)
1030 (setf (block-next prev
) next
)
1031 (setf (block-prev next
) prev
))
1034 ;;; Add BLOCK to the next/prev chain following AFTER. We also set the
1035 ;;; COMPONENT to be the same as for AFTER.
1036 (defun add-to-dfo (block after
)
1037 (declare (type cblock block after
))
1038 (let ((next (block-next after
))
1039 (comp (block-component after
)))
1040 (aver (not (eq (component-kind comp
) :deleted
)))
1041 (setf (block-component block
) comp
)
1042 (setf (block-next after
) block
)
1043 (setf (block-prev block
) after
)
1044 (setf (block-next block
) next
)
1045 (setf (block-prev next
) block
))
1048 ;;; List all NLX-INFOs which BLOCK can exit to.
1050 ;;; We hope that no cleanup actions are performed in the middle of
1051 ;;; BLOCK, so it is enough to look only at cleanups in the block
1052 ;;; end. The tricky thing is a special cleanup block; all its nodes
1053 ;;; have the same cleanup info, corresponding to the start, so the
1054 ;;; same approach returns safe result.
1055 (defun map-block-nlxes (fun block
&optional dx-cleanup-fun
)
1056 (do-nested-cleanups (cleanup block
)
1057 (let ((mess-up (cleanup-mess-up cleanup
)))
1058 (case (cleanup-kind cleanup
)
1060 (aver (entry-p mess-up
))
1061 (loop for exit in
(entry-exits mess-up
)
1062 for nlx-info
= (exit-nlx-info exit
)
1063 do
(funcall fun nlx-info
)))
1064 ((:catch
:unwind-protect
)
1065 (aver (combination-p mess-up
))
1066 (let* ((arg-lvar (first (basic-combination-args mess-up
)))
1067 (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar
)))))
1068 (funcall fun nlx-info
)))
1070 (when dx-cleanup-fun
1071 (funcall dx-cleanup-fun cleanup
)))))))
1073 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
1074 ;;; the head and tail which are set to T.
1075 (declaim (ftype (sfunction (component) (values)) clear-flags
))
1076 (defun clear-flags (component)
1077 (let ((head (component-head component
))
1078 (tail (component-tail component
)))
1079 (setf (block-flag head
) t
)
1080 (setf (block-flag tail
) t
)
1081 (do-blocks (block component
)
1082 (setf (block-flag block
) nil
)))
1085 ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially
1086 ;;; true in the head and tail blocks.
1087 (declaim (ftype (sfunction () component
) make-empty-component
))
1088 (defun make-empty-component ()
1089 (let* ((head (make-block-key :start nil
:component nil
))
1090 (tail (make-block-key :start nil
:component nil
))
1091 (res (make-component head tail
)))
1092 (setf (block-flag head
) t
)
1093 (setf (block-flag tail
) t
)
1094 (setf (block-component head
) res
)
1095 (setf (block-component tail
) res
)
1096 (setf (block-next head
) tail
)
1097 (setf (block-prev tail
) head
)
1100 ;;; Make NODE the LAST node in its block, splitting the block if necessary.
1101 ;;; The new block is added to the DFO immediately following NODE's block.
1102 (defun node-ends-block (node)
1103 (declare (type node node
))
1104 (let* ((block (node-block node
))
1105 (start (node-next node
))
1106 (last (block-last block
)))
1107 (check-type last node
)
1108 (unless (eq last node
)
1109 (aver (and (eq (ctran-kind start
) :inside-block
)
1110 (not (block-delete-p block
))))
1111 (let* ((succ (block-succ block
))
1113 (make-block-key :start start
1114 :component
(block-component block
)
1115 :succ succ
:last last
)))
1116 (setf (ctran-kind start
) :block-start
)
1117 (setf (ctran-use start
) nil
)
1118 (setf (block-last block
) node
)
1119 (setf (node-next node
) nil
)
1121 (setf (block-pred b
)
1122 (cons new-block
(remove block
(block-pred b
)))))
1123 (setf (block-succ block
) ())
1124 (link-blocks block new-block
)
1125 (add-to-dfo new-block block
)
1126 (setf (component-reanalyze (block-component block
)) t
)
1128 (do ((ctran start
(node-next (ctran-next ctran
))))
1130 (setf (ctran-block ctran
) new-block
))
1132 (setf (block-type-asserted block
) t
)
1133 (setf (block-test-modified block
) t
))))
1138 ;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
1139 (defun delete-lambda-var (leaf)
1140 (declare (type lambda-var leaf
))
1142 (setf (lambda-var-deleted leaf
) t
)
1143 ;; Iterate over all local calls flushing the corresponding argument,
1144 ;; allowing the computation of the argument to be deleted. We also
1145 ;; mark the LET for reoptimization, since it may be that we have
1146 ;; deleted its last variable.
1147 (let* ((fun (lambda-var-home leaf
))
1148 (n (position leaf
(lambda-vars fun
))))
1149 (dolist (ref (leaf-refs fun
))
1150 (let* ((lvar (node-lvar ref
))
1151 (dest (and lvar
(lvar-dest lvar
))))
1152 (when (and (combination-p dest
)
1153 (eq (basic-combination-fun dest
) lvar
)
1154 (eq (basic-combination-kind dest
) :local
))
1155 (let* ((args (basic-combination-args dest
))
1157 (reoptimize-lvar arg
)
1159 (setf (elt args n
) nil
))))))
1161 ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
1162 ;; too much difficulty, since we can efficiently implement
1163 ;; write-only variables. We iterate over the SETs, marking their
1164 ;; blocks for dead code flushing, since we can delete SETs whose
1166 (dolist (set (lambda-var-sets leaf
))
1167 (setf (block-flush-p (node-block set
)) t
))
1171 ;;; Note that something interesting has happened to VAR.
1172 (defun reoptimize-lambda-var (var)
1173 (declare (type lambda-var var
))
1174 (let ((fun (lambda-var-home var
)))
1175 ;; We only deal with LET variables, marking the corresponding
1176 ;; initial value arg as needing to be reoptimized.
1177 (when (and (eq (functional-kind fun
) :let
)
1179 (do ((args (basic-combination-args
1180 (lvar-dest (node-lvar (first (leaf-refs fun
)))))
1182 (vars (lambda-vars fun
) (cdr vars
)))
1183 ((eq (car vars
) var
)
1184 (reoptimize-lvar (car args
))))))
1187 ;;; Delete a function that has no references. This need only be called
1188 ;;; on functions that never had any references, since otherwise
1189 ;;; DELETE-REF will handle the deletion.
1190 (defun delete-functional (fun)
1191 (aver (and (null (leaf-refs fun
))
1192 (not (functional-entry-fun fun
))))
1194 (optional-dispatch (delete-optional-dispatch fun
))
1195 (clambda (delete-lambda fun
)))
1198 ;;; Deal with deleting the last reference to a CLAMBDA, which means
1199 ;;; that the lambda is unreachable, so that its body may be
1200 ;;; deleted. We set FUNCTIONAL-KIND to :DELETED and rely on
1201 ;;; IR1-OPTIMIZE to delete its blocks.
1202 (defun delete-lambda (clambda)
1203 (declare (type clambda clambda
))
1204 (let ((original-kind (functional-kind clambda
))
1205 (bind (lambda-bind clambda
)))
1206 (aver (not (member original-kind
'(:deleted
:toplevel
))))
1207 (aver (not (functional-has-external-references-p clambda
)))
1208 (aver (or (eq original-kind
:zombie
) bind
))
1209 (setf (functional-kind clambda
) :deleted
)
1210 (setf (lambda-bind clambda
) nil
)
1212 (labels ((delete-children (lambda)
1213 (dolist (child (lambda-children lambda
))
1214 (cond ((eq (functional-kind child
) :deleted
)
1215 (delete-children child
))
1217 (delete-lambda child
))))
1218 (setf (lambda-children lambda
) nil
)
1219 (setf (lambda-parent lambda
) nil
)))
1220 (delete-children clambda
))
1222 ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
1223 ;; that we're using the old value of the KIND slot, not the
1224 ;; current slot value, which has now been set to :DELETED.)
1227 ((:let
:mv-let
:assignment
)
1228 (let ((bind-block (node-block bind
)))
1229 (mark-for-deletion bind-block
))
1230 (let ((home (lambda-home clambda
)))
1231 (setf (lambda-lets home
) (delete clambda
(lambda-lets home
))))
1232 ;; KLUDGE: In presence of NLEs we cannot always understand that
1233 ;; LET's BIND dominates its body [for a LET "its" body is not
1234 ;; quite its]; let's delete too dangerous for IR2 stuff. --
1236 (dolist (var (lambda-vars clambda
))
1237 (flet ((delete-node (node)
1238 (mark-for-deletion (node-block node
))))
1239 (mapc #'delete-node
(leaf-refs var
))
1240 (mapc #'delete-node
(lambda-var-sets var
)))))
1242 ;; Function has no reachable references.
1243 (dolist (ref (lambda-refs clambda
))
1244 (mark-for-deletion (node-block ref
)))
1245 ;; If the function isn't a LET, we unlink the function head
1246 ;; and tail from the component head and tail to indicate that
1247 ;; the code is unreachable. We also delete the function from
1248 ;; COMPONENT-LAMBDAS (it won't be there before local call
1249 ;; analysis, but no matter.) If the lambda was never
1250 ;; referenced, we give a note.
1251 (let* ((bind-block (node-block bind
))
1252 (component (block-component bind-block
))
1253 (return (lambda-return clambda
))
1254 (return-block (and return
(node-block return
))))
1255 (unless (leaf-ever-used clambda
)
1256 (let ((*compiler-error-context
* bind
))
1257 (compiler-notify 'code-deletion-note
1258 :format-control
"deleting unused function~:[.~;~:*~% ~S~]"
1259 :format-arguments
(list (leaf-debug-name clambda
)))))
1260 (unless (block-delete-p bind-block
)
1261 (unlink-blocks (component-head component
) bind-block
))
1262 (when (and return-block
(not (block-delete-p return-block
)))
1263 (mark-for-deletion return-block
)
1264 (unlink-blocks return-block
(component-tail component
)))
1265 (setf (component-reanalyze component
) t
)
1266 (let ((tails (lambda-tail-set clambda
)))
1267 (setf (tail-set-funs tails
)
1268 (delete clambda
(tail-set-funs tails
)))
1269 (setf (lambda-tail-set clambda
) nil
))
1270 (setf (component-lambdas component
)
1271 (delq clambda
(component-lambdas component
))))))
1273 ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
1274 ;; ENTRY-FUN so that people will know that it is not an entry
1276 (when (eq original-kind
:external
)
1277 (let ((fun (functional-entry-fun clambda
)))
1278 (setf (functional-entry-fun fun
) nil
)
1279 (when (optional-dispatch-p fun
)
1280 (delete-optional-dispatch fun
)))))
1284 ;;; Deal with deleting the last reference to an OPTIONAL-DISPATCH. We
1285 ;;; have to be a bit more careful than with lambdas, since DELETE-REF
1286 ;;; is used both before and after local call analysis. Afterward, all
1287 ;;; references to still-existing OPTIONAL-DISPATCHes have been moved
1288 ;;; to the XEP, leaving it with no references at all. So we look at
1289 ;;; the XEP to see whether an optional-dispatch is still really being
1290 ;;; used. But before local call analysis, there are no XEPs, and all
1291 ;;; references are direct.
1293 ;;; When we do delete the OPTIONAL-DISPATCH, we grovel all of its
1294 ;;; entry-points, making them be normal lambdas, and then deleting the
1295 ;;; ones with no references. This deletes any e-p lambdas that were
1296 ;;; either never referenced, or couldn't be deleted when the last
1297 ;;; reference was deleted (due to their :OPTIONAL kind.)
1299 ;;; Note that the last optional entry point may alias the main entry,
1300 ;;; so when we process the main entry, its KIND may have been changed
1301 ;;; to NIL or even converted to a LETlike value.
1302 (defun delete-optional-dispatch (leaf)
1303 (declare (type optional-dispatch leaf
))
1304 (let ((entry (functional-entry-fun leaf
)))
1305 (unless (and entry
(leaf-refs entry
))
1306 (aver (or (not entry
) (eq (functional-kind entry
) :deleted
)))
1307 (setf (functional-kind leaf
) :deleted
)
1310 (unless (eq (functional-kind fun
) :deleted
)
1311 (aver (eq (functional-kind fun
) :optional
))
1312 (setf (functional-kind fun
) nil
)
1313 (let ((refs (leaf-refs fun
)))
1315 (delete-lambda fun
))
1317 (or (maybe-let-convert fun
)
1318 (maybe-convert-to-assignment fun
)))
1320 (maybe-convert-to-assignment fun
)))))))
1322 (dolist (ep (optional-dispatch-entry-points leaf
))
1323 (when (promise-ready-p ep
)
1325 (when (optional-dispatch-more-entry leaf
)
1326 (frob (optional-dispatch-more-entry leaf
)))
1327 (let ((main (optional-dispatch-main-entry leaf
)))
1329 (setf (functional-entry-fun entry
) main
)
1330 (setf (functional-entry-fun main
) entry
))
1331 (when (eq (functional-kind main
) :optional
)
1336 (defun note-local-functional (fun)
1337 (declare (type functional fun
))
1338 (when (and (leaf-has-source-name-p fun
)
1339 (eq (leaf-source-name fun
) (functional-debug-name fun
)))
1340 (let ((name (leaf-source-name fun
)))
1341 (let ((defined-fun (gethash name
*free-funs
*)))
1342 (when (and defined-fun
1343 (defined-fun-p defined-fun
)
1344 (eq (defined-fun-functional defined-fun
) fun
))
1345 (remhash name
*free-funs
*))))))
1347 ;;; Return functional for DEFINED-FUN which has been converted in policy
1348 ;;; corresponding to the current one, or NIL if no such functional exists.
1350 ;;; Also check that the parent of the functional is visible in the current
1352 (defun defined-fun-functional (defined-fun)
1353 (let ((functionals (defined-fun-functionals defined-fun
)))
1355 (let* ((sample (car functionals
))
1356 (there (lambda-parent (if (lambda-p sample
)
1358 (optional-dispatch-main-entry sample
)))))
1360 (labels ((lookup (here)
1361 (unless (eq here there
)
1363 (lookup (lambda-parent here
))
1364 ;; We looked up all the way up, and didn't find the parent
1365 ;; of the functional -- therefore it is nested in a lambda
1366 ;; we don't see, so return nil.
1367 (return-from defined-fun-functional nil
)))))
1368 (lookup (lexenv-lambda *lexenv
*)))))
1369 ;; Now find a functional whose policy matches the current one, if we already
1371 (let ((policy (lexenv-%policy
*lexenv
*)))
1372 (dolist (functional functionals
)
1373 (when (policy= policy
(lexenv-%policy
(functional-lexenv functional
)))
1374 (return functional
)))))))
1376 ;;; Do stuff to delete the semantic attachments of a REF node. When
1377 ;;; this leaves zero or one reference, we do a type dispatch off of
1378 ;;; the leaf to determine if a special action is appropriate.
1379 (defun delete-ref (ref)
1380 (declare (type ref ref
))
1381 (let* ((leaf (ref-leaf ref
))
1382 (refs (delq ref
(leaf-refs leaf
))))
1383 (setf (leaf-refs leaf
) refs
)
1388 (delete-lambda-var leaf
))
1390 (ecase (functional-kind leaf
)
1391 ((nil :let
:mv-let
:assignment
:escape
:cleanup
)
1392 (aver (null (functional-entry-fun leaf
)))
1393 (delete-lambda leaf
))
1395 (unless (functional-has-external-references-p leaf
)
1396 (delete-lambda leaf
)))
1397 ((:deleted
:zombie
:optional
))))
1399 (unless (eq (functional-kind leaf
) :deleted
)
1400 (delete-optional-dispatch leaf
)))))
1403 (clambda (or (maybe-let-convert leaf
)
1404 (maybe-convert-to-assignment leaf
)))
1405 (lambda-var (reoptimize-lambda-var leaf
))))
1408 (clambda (maybe-convert-to-assignment leaf
))))))
1412 ;;; This function is called to unlink a node from its LVAR;
1413 ;;; we assume that the LVAR's USE list has already been updated,
1414 ;;; and that we only have to mark the node as up for dead code
1415 ;;; elimination, and to clear it LVAR slot.
1416 (defun flush-node (node)
1417 (declare (type node node
))
1418 (let* ((prev (node-prev node
))
1419 (block (ctran-block prev
)))
1420 (reoptimize-component (block-component block
) t
)
1421 (setf (block-attributep (block-flags block
)
1422 flush-p type-asserted type-check
)
1424 (setf (node-lvar node
) nil
))
1426 ;;; This function is called by people who delete nodes; it provides a
1427 ;;; way to indicate that the value of a lvar is no longer used. We
1428 ;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses
1429 ;;; of LVAR and set COMPONENT-REOPTIMIZE.
1430 (defun flush-dest (lvar)
1431 (declare (type (or lvar null
) lvar
))
1433 (when (lvar-dynamic-extent lvar
)
1434 (note-no-stack-allocation lvar
:flush t
))
1435 (setf (lvar-dest lvar
) nil
)
1436 (flush-lvar-externally-checkable-type lvar
)
1439 (setf (lvar-uses lvar
) nil
))
1442 (defun delete-dest (lvar)
1444 (let* ((dest (lvar-dest lvar
))
1445 (prev (node-prev dest
)))
1446 (let ((block (ctran-block prev
)))
1447 (unless (block-delete-p block
)
1448 (mark-for-deletion block
))))))
1450 ;;; Queue the block for deletion
1451 (defun delete-block-lazily (block)
1452 (declare (type cblock block
))
1453 (unless (block-delete-p block
)
1454 (setf (block-delete-p block
) t
)
1455 (push block
(component-delete-blocks (block-component block
)))))
1457 ;;; Do a graph walk backward from BLOCK, marking all predecessor
1458 ;;; blocks with the DELETE-P flag.
1459 (defun mark-for-deletion (block)
1460 (declare (type cblock block
))
1461 (let* ((component (block-component block
))
1462 (head (component-head component
)))
1463 (labels ((helper (block)
1464 (delete-block-lazily block
)
1465 (dolist (pred (block-pred block
))
1466 (unless (or (block-delete-p pred
)
1469 (unless (block-delete-p block
)
1471 (setf (component-reanalyze component
) t
))))
1474 ;;; This function does what is necessary to eliminate the code in it
1475 ;;; from the IR1 representation. This involves unlinking it from its
1476 ;;; predecessors and successors and deleting various node-specific
1477 ;;; semantic information. BLOCK must be already removed from
1478 ;;; COMPONENT-DELETE-BLOCKS.
1479 (defun delete-block (block &optional silent
)
1480 (declare (type cblock block
))
1481 (aver (block-component block
)) ; else block is already deleted!
1482 #!+high-security
(aver (not (memq block
(component-delete-blocks (block-component block
)))))
1484 (note-block-deletion block
))
1485 (setf (block-delete-p block
) t
)
1487 (dolist (b (block-pred block
))
1488 (unlink-blocks b block
)
1489 ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
1490 ;; broken when successors were deleted without setting the
1491 ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
1492 ;; doesn't happen again.
1493 (aver (not (and (null (block-succ b
))
1494 (not (block-delete-p b
))
1495 (not (eq b
(component-head (block-component b
))))))))
1496 (dolist (b (block-succ block
))
1497 (unlink-blocks block b
))
1499 (do-nodes-carefully (node block
)
1500 (when (valued-node-p node
)
1501 (delete-lvar-use node
))
1503 (ref (delete-ref node
))
1504 (cif (flush-dest (if-test node
)))
1505 ;; The next two cases serve to maintain the invariant that a LET
1506 ;; always has a well-formed COMBINATION, REF and BIND. We delete
1507 ;; the lambda whenever we delete any of these, but we must be
1508 ;; careful that this LET has not already been partially deleted.
1510 (when (and (eq (basic-combination-kind node
) :local
)
1511 ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
1512 (lvar-uses (basic-combination-fun node
)))
1513 (let ((fun (combination-lambda node
)))
1514 ;; If our REF was the second-to-last ref, and has been
1515 ;; deleted, then FUN may be a LET for some other
1517 (when (and (functional-letlike-p fun
)
1518 (eq (let-combination fun
) node
))
1519 (delete-lambda fun
))))
1520 (flush-dest (basic-combination-fun node
))
1521 (dolist (arg (basic-combination-args node
))
1522 (when arg
(flush-dest arg
))))
1524 (let ((lambda (bind-lambda node
)))
1525 (unless (eq (functional-kind lambda
) :deleted
)
1526 (delete-lambda lambda
))))
1528 (let ((value (exit-value node
))
1529 (entry (exit-entry node
)))
1533 (setf (entry-exits entry
)
1534 (delq node
(entry-exits entry
))))))
1536 (dolist (exit (entry-exits node
))
1537 (mark-for-deletion (node-block exit
)))
1538 (let ((home (node-home-lambda node
)))
1539 (setf (lambda-entries home
) (delq node
(lambda-entries home
)))))
1541 (flush-dest (return-result node
))
1542 (delete-return node
))
1544 (flush-dest (set-value node
))
1545 (let ((var (set-var node
)))
1546 (setf (basic-var-sets var
)
1547 (delete node
(basic-var-sets var
)))))
1549 (flush-dest (cast-value node
)))))
1551 (remove-from-dfo block
)
1554 ;;; Do stuff to indicate that the return node NODE is being deleted.
1555 (defun delete-return (node)
1556 (declare (type creturn node
))
1557 (let* ((fun (return-lambda node
))
1558 (tail-set (lambda-tail-set fun
)))
1559 (aver (lambda-return fun
))
1560 (setf (lambda-return fun
) nil
)
1561 (when (and tail-set
(not (find-if #'lambda-return
1562 (tail-set-funs tail-set
))))
1563 (setf (tail-set-type tail-set
) *empty-type
*)))
1566 ;;; If any of the VARS in FUN was never referenced and was not
1567 ;;; declared IGNORE, then complain.
1568 (defun note-unreferenced-vars (vars policy
)
1570 (unless (or (leaf-ever-used var
)
1571 (lambda-var-ignorep var
))
1572 (unless (policy policy
(= inhibit-warnings
3))
1573 ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
1574 ;; requires this to be no more than a STYLE-WARNING.
1576 (compiler-style-warn "The variable ~S is defined but never used."
1577 (leaf-debug-name var
))
1578 ;; There's no reason to accept this kind of equivocation
1579 ;; when compiling our own code, though.
1581 (warn "The variable ~S is defined but never used."
1582 (leaf-debug-name var
)))
1583 (setf (leaf-ever-used var
) t
)))) ; to avoid repeated warnings? -- WHN
1585 (defun note-unreferenced-fun-vars (fun)
1586 (declare (type clambda fun
))
1587 (let ((*compiler-error-context
* (lambda-bind fun
)))
1588 (note-unreferenced-vars (lambda-vars fun
)
1589 *compiler-error-context
*))
1592 (defvar *deletion-ignored-objects
* '(t nil
))
1594 ;;; Return true if we can find OBJ in FORM, NIL otherwise. We bound
1595 ;;; our recursion so that we don't get lost in circular structures. We
1596 ;;; ignore the car of forms if they are a symbol (to prevent confusing
1597 ;;; function referencess with variables), and we also ignore anything
1599 (defun present-in-form (obj form depth
)
1600 (declare (type (integer 0 20) depth
))
1601 (cond ((= depth
20) nil
)
1605 (let ((first (car form
))
1607 (if (member first
'(quote function
))
1609 (or (and (not (symbolp first
))
1610 (present-in-form obj first depth
))
1611 (do ((l (cdr form
) (cdr l
))
1613 ((or (atom l
) (> n
100))
1615 (declare (fixnum n
))
1616 (when (present-in-form obj
(car l
) depth
)
1619 ;;; This function is called on a block immediately before we delete
1620 ;;; it. We check to see whether any of the code about to die appeared
1621 ;;; in the original source, and emit a note if so.
1623 ;;; If the block was in a lambda is now deleted, then we ignore the
1624 ;;; whole block, since this case is picked off in DELETE-LAMBDA. We
1625 ;;; also ignore the deletion of CRETURN nodes, since it is somewhat
1626 ;;; reasonable for a function to not return, and there is a different
1627 ;;; note for that case anyway.
1629 ;;; If the actual source is an atom, then we use a bunch of heuristics
1630 ;;; to guess whether this reference really appeared in the original
1632 ;;; -- If a symbol, it must be interned and not a keyword.
1633 ;;; -- It must not be an easily introduced constant (T or NIL, a fixnum
1634 ;;; or a character.)
1635 ;;; -- The atom must be "present" in the original source form, and
1636 ;;; present in all intervening actual source forms.
1637 (defun note-block-deletion (block)
1638 (let ((home (block-home-lambda block
)))
1639 (unless (eq (functional-kind home
) :deleted
)
1640 (do-nodes (node nil block
)
1641 (let* ((path (node-source-path node
))
1642 (first (first path
)))
1643 (when (or (eq first
'original-source-start
)
1645 (or (not (symbolp first
))
1646 (let ((pkg (symbol-package first
)))
1648 (not (eq pkg
(symbol-package :end
))))))
1649 (not (member first
*deletion-ignored-objects
*))
1650 (not (typep first
'(or fixnum character
)))
1652 (present-in-form first x
0))
1653 (source-path-forms path
))
1654 (present-in-form first
(find-original-source path
)
1656 (unless (return-p node
)
1657 (let ((*compiler-error-context
* node
))
1658 (compiler-notify 'code-deletion-note
1659 :format-control
"deleting unreachable code"
1660 :format-arguments nil
)))
1664 ;;; Delete a node from a block, deleting the block if there are no
1665 ;;; nodes left. We remove the node from the uses of its LVAR.
1667 ;;; If the node is the last node, there must be exactly one successor.
1668 ;;; We link all of our precedessors to the successor and unlink the
1669 ;;; block. In this case, we return T, otherwise NIL. If no nodes are
1670 ;;; left, and the block is a successor of itself, then we replace the
1671 ;;; only node with a degenerate exit node. This provides a way to
1672 ;;; represent the bodyless infinite loop, given the prohibition on
1673 ;;; empty blocks in IR1.
1674 (defun unlink-node (node)
1675 (declare (type node node
))
1676 (when (valued-node-p node
)
1677 (delete-lvar-use node
))
1679 (let* ((ctran (node-next node
))
1680 (next (and ctran
(ctran-next ctran
)))
1681 (prev (node-prev node
))
1682 (block (ctran-block prev
))
1683 (prev-kind (ctran-kind prev
))
1684 (last (block-last block
)))
1686 (setf (block-type-asserted block
) t
)
1687 (setf (block-test-modified block
) t
)
1689 (cond ((or (eq prev-kind
:inside-block
)
1690 (and (eq prev-kind
:block-start
)
1691 (not (eq node last
))))
1692 (cond ((eq node last
)
1693 (setf (block-last block
) (ctran-use prev
))
1694 (setf (node-next (ctran-use prev
)) nil
))
1696 (setf (ctran-next prev
) next
)
1697 (setf (node-prev next
) prev
)
1698 (when (if-p next
) ; AOP wanted
1699 (reoptimize-lvar (if-test next
)))))
1700 (setf (node-prev node
) nil
)
1703 (aver (eq prev-kind
:block-start
))
1704 (aver (eq node last
))
1705 (let* ((succ (block-succ block
))
1706 (next (first succ
)))
1707 (aver (singleton-p succ
))
1709 ((eq block
(first succ
))
1710 (with-ir1-environment-from-node node
1711 (let ((exit (make-exit)))
1712 (setf (ctran-next prev
) nil
)
1713 (link-node-to-previous-ctran exit prev
)
1714 (setf (block-last block
) exit
)))
1715 (setf (node-prev node
) nil
)
1718 (aver (eq (block-start-cleanup block
)
1719 (block-end-cleanup block
)))
1720 (unlink-blocks block next
)
1721 (dolist (pred (block-pred block
))
1722 (change-block-successor pred block next
))
1723 (when (block-delete-p block
)
1724 (let ((component (block-component block
)))
1725 (setf (component-delete-blocks component
)
1726 (delq block
(component-delete-blocks component
)))))
1727 (remove-from-dfo block
)
1728 (setf (block-delete-p block
) t
)
1729 (setf (node-prev node
) nil
)
1732 ;;; Return true if CTRAN has been deleted, false if it is still a valid
1734 (defun ctran-deleted-p (ctran)
1735 (declare (type ctran ctran
))
1736 (let ((block (ctran-block ctran
)))
1737 (or (not (block-component block
))
1738 (block-delete-p block
))))
1740 ;;; Return true if NODE has been deleted, false if it is still a valid
1742 (defun node-deleted (node)
1743 (declare (type node node
))
1744 (let ((prev (node-prev node
)))
1746 (ctran-deleted-p prev
))))
1748 ;;; Delete all the blocks and functions in COMPONENT. We scan first
1749 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
1750 ;;; triggered by deletion.
1751 (defun delete-component (component)
1752 (declare (type component component
))
1753 (aver (null (component-new-functionals component
)))
1754 (setf (component-kind component
) :deleted
)
1755 (do-blocks (block component
)
1756 (delete-block-lazily block
))
1757 (dolist (fun (component-lambdas component
))
1758 (unless (eq (functional-kind fun
) :deleted
)
1759 (setf (functional-kind fun
) nil
)
1760 (setf (functional-entry-fun fun
) nil
)
1761 (setf (leaf-refs fun
) nil
)
1762 (delete-functional fun
)))
1763 (clean-component component
)
1766 ;;; Remove all pending blocks to be deleted. Return the nearest live
1767 ;;; block after or equal to BLOCK.
1768 (defun clean-component (component &optional block
)
1769 (loop while
(component-delete-blocks component
)
1770 ;; actual deletion of a block may queue new blocks
1771 do
(let ((current (pop (component-delete-blocks component
))))
1772 (when (eq block current
)
1773 (setq block
(block-next block
)))
1774 (delete-block current
)))
1777 ;;; Convert code of the form
1778 ;;; (FOO ... (FUN ...) ...)
1780 ;;; (FOO ... ... ...).
1781 ;;; In other words, replace the function combination FUN by its
1782 ;;; arguments. If there are any problems with doing this, use GIVE-UP
1783 ;;; to blow out of whatever transform called this. Note, as the number
1784 ;;; of arguments changes, the transform must be prepared to return a
1785 ;;; lambda with a new lambda-list with the correct number of
1787 (defun splice-fun-args (lvar fun num-args
)
1789 "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed
1790 directly to the LVAR-DEST of LVAR, which must be a combination. If FUN
1791 is :ANY, the function name is not checked."
1792 (declare (type lvar lvar
)
1794 (type index num-args
))
1795 (let ((outside (lvar-dest lvar
))
1796 (inside (lvar-uses lvar
)))
1797 (aver (combination-p outside
))
1798 (unless (combination-p inside
)
1799 (give-up-ir1-transform))
1800 (let ((inside-fun (combination-fun inside
)))
1801 (unless (or (eq fun
:any
)
1802 (eq (lvar-fun-name inside-fun
) fun
))
1803 (give-up-ir1-transform))
1804 (let ((inside-args (combination-args inside
)))
1805 (unless (= (length inside-args
) num-args
)
1806 (give-up-ir1-transform))
1807 (let* ((outside-args (combination-args outside
))
1808 (arg-position (position lvar outside-args
))
1809 (before-args (subseq outside-args
0 arg-position
))
1810 (after-args (subseq outside-args
(1+ arg-position
))))
1811 (dolist (arg inside-args
)
1812 (setf (lvar-dest arg
) outside
)
1813 (flush-lvar-externally-checkable-type arg
))
1814 (setf (combination-args inside
) nil
)
1815 (setf (combination-args outside
)
1816 (append before-args inside-args after-args
))
1817 (change-ref-leaf (lvar-uses inside-fun
)
1818 (find-free-fun 'list
"???"))
1819 (setf (combination-fun-info inside
) (info :function
:info
'list
)
1820 (combination-kind inside
) :known
)
1821 (setf (node-derived-type inside
) *wild-type
*)
1825 ;;; Eliminate keyword arguments from the call (leaving the
1826 ;;; parameters in place.
1828 ;;; (FOO ... :BAR X :QUUX Y)
1832 ;;; SPECS is a list of (:KEYWORD PARAMETER) specifications.
1833 ;;; Returns the list of specified parameters names in the
1834 ;;; order they appeared in the call. N-POSITIONAL is the
1835 ;;; number of positional arguments in th call.
1836 (defun eliminate-keyword-args (call n-positional specs
)
1837 (let* ((specs (copy-tree specs
))
1838 (all (combination-args call
))
1839 (new-args (reverse (subseq all
0 n-positional
)))
1840 (key-args (subseq all n-positional
))
1843 (loop while key-args
1844 do
(let* ((key (pop key-args
))
1845 (val (pop key-args
))
1846 (keyword (if (constant-lvar-p key
)
1848 (give-up-ir1-transform)))
1849 (spec (or (assoc keyword specs
:test
#'eq
)
1850 (give-up-ir1-transform))))
1852 (push key flushed-keys
)
1853 (push (second spec
) parameters
)
1854 ;; In case of duplicate keys.
1855 (setf (second spec
) (gensym))))
1856 (dolist (key flushed-keys
)
1858 (setf (combination-args call
) (reverse new-args
))
1859 (reverse parameters
)))
1861 (defun extract-fun-args (lvar fun num-args
)
1862 (declare (type lvar lvar
)
1863 (type (or symbol list
) fun
)
1864 (type index num-args
))
1865 (let ((inside (lvar-uses lvar
)))
1866 (unless (combination-p inside
)
1867 (give-up-ir1-transform))
1868 (let ((inside-fun (combination-fun inside
)))
1869 (unless (member (lvar-fun-name inside-fun
) (ensure-list fun
))
1870 (give-up-ir1-transform))
1871 (let ((inside-args (combination-args inside
)))
1872 (unless (= (length inside-args
) num-args
)
1873 (give-up-ir1-transform))
1874 (values (lvar-fun-name inside-fun
) inside-args
)))))
1876 (defun flush-combination (combination)
1877 (declare (type combination combination
))
1878 (flush-dest (combination-fun combination
))
1879 (dolist (arg (combination-args combination
))
1881 (unlink-node combination
)
1887 ;;; Change the LEAF that a REF refers to.
1888 (defun change-ref-leaf (ref leaf
&key recklessly
)
1889 (declare (type ref ref
) (type leaf leaf
))
1890 (unless (eq (ref-leaf ref
) leaf
)
1891 (push ref
(leaf-refs leaf
))
1893 (setf (ref-leaf ref
) leaf
)
1894 (setf (leaf-ever-used leaf
) t
)
1895 (let* ((ltype (leaf-type leaf
))
1896 (vltype (make-single-value-type ltype
)))
1897 (if (let* ((lvar (node-lvar ref
))
1898 (dest (and lvar
(lvar-dest lvar
))))
1899 (and (basic-combination-p dest
)
1900 (eq lvar
(basic-combination-fun dest
))
1901 (csubtypep ltype
(specifier-type 'function
))))
1902 (setf (node-derived-type ref
) vltype
)
1903 (derive-node-type ref vltype
:from-scratch recklessly
)))
1904 (reoptimize-lvar (node-lvar ref
)))
1907 ;;; Change all REFS for OLD-LEAF to NEW-LEAF.
1908 (defun substitute-leaf (new-leaf old-leaf
)
1909 (declare (type leaf new-leaf old-leaf
))
1910 (dolist (ref (leaf-refs old-leaf
))
1911 (change-ref-leaf ref new-leaf
))
1914 ;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
1915 ;;; whether to substitute
1916 (defun substitute-leaf-if (test new-leaf old-leaf
)
1917 (declare (type leaf new-leaf old-leaf
) (type function test
))
1918 (dolist (ref (leaf-refs old-leaf
))
1919 (when (funcall test ref
)
1920 (change-ref-leaf ref new-leaf
)))
1923 ;;; Return a LEAF which represents the specified constant object. If
1924 ;;; the object is not in *CONSTANTS*, then we create a new constant
1925 ;;; LEAF and enter it. If we are producing a fasl file, make sure that
1926 ;;; MAKE-LOAD-FORM gets used on any parts of the constant that it
1929 ;;; We are allowed to coalesce things like EQUAL strings and bit-vectors
1930 ;;; when file-compiling, but not when using COMPILE.
1931 (defun find-constant (object &optional
(name nil namep
))
1932 (let ((faslp (producing-fasl-file)))
1933 (labels ((make-it ()
1936 (maybe-emit-make-load-forms object name
)
1937 (maybe-emit-make-load-forms object
)))
1938 (make-constant object
))
1939 (core-coalesce-p (x)
1940 ;; True for things which retain their identity under EQUAL,
1941 ;; so we can safely share the same CONSTANT leaf between
1942 ;; multiple references.
1943 (or (typep x
'(or symbol number character
))
1944 ;; Amusingly enough, we see CLAMBDAs --among other things--
1945 ;; here, from compiling things like %ALLOCATE-CLOSUREs forms.
1946 ;; No point in stuffing them in the hash-table.
1947 (and (typep x
'instance
)
1948 (not (or (leaf-p x
) (node-p x
))))))
1949 (file-coalesce-p (x)
1950 ;; CLHS 3.2.4.2.2: We are also allowed to coalesce various
1951 ;; other things when file-compiling.
1952 (or (core-coalesce-p x
)
1954 (if (eq +code-coverage-unmarked
+ (cdr x
))
1955 ;; These are already coalesced, and the CAR should
1956 ;; always be OK, so no need to check.
1958 (unless (maybe-cyclic-p x
) ; safe for EQUAL?
1960 ((atom y
) (file-coalesce-p y
))
1961 (unless (file-coalesce-p (car y
))
1963 ;; We *could* coalesce base-strings as well,
1964 ;; but we'd need a separate hash-table for
1965 ;; that, since we are not allowed to coalesce
1966 ;; base-strings with non-base-strings.
1969 ;; in the cross-compiler, we coalesce
1970 ;; all strings with the same contents,
1971 ;; because we will end up dumping them
1972 ;; as base-strings anyway. In the
1973 ;; real compiler, we're not allowed to
1974 ;; coalesce regardless of string
1975 ;; specialized element type, so we
1976 ;; KLUDGE by coalescing only character
1977 ;; strings (the common case) and
1978 ;; punting on the other types.
1982 (vector character
))))))
1984 (if faslp
(file-coalesce-p x
) (core-coalesce-p x
))))
1985 (if (and (boundp '*constants
*) (coalescep object
))
1986 (or (gethash object
*constants
*)
1987 (setf (gethash object
*constants
*)
1991 ;;; Return true if VAR would have to be closed over if environment
1992 ;;; analysis ran now (i.e. if there are any uses that have a different
1993 ;;; home lambda than VAR's home.)
1994 (defun closure-var-p (var)
1995 (declare (type lambda-var var
))
1996 (let ((home (lambda-var-home var
)))
1997 (cond ((eq (functional-kind home
) :deleted
)
1999 (t (let ((home (lambda-home home
)))
2002 :key
#'node-home-lambda
2004 (or (frob (leaf-refs var
))
2005 (frob (basic-var-sets var
)))))))))
2007 ;;; If there is a non-local exit noted in ENTRY's environment that
2008 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
2009 (defun find-nlx-info (exit)
2010 (declare (type exit exit
))
2011 (let* ((entry (exit-entry exit
))
2012 (cleanup (entry-cleanup entry
))
2013 (block (first (block-succ (node-block exit
)))))
2014 (dolist (nlx (physenv-nlx-info (node-physenv entry
)) nil
)
2015 (when (and (eq (nlx-info-block nlx
) block
)
2016 (eq (nlx-info-cleanup nlx
) cleanup
))
2019 (defun nlx-info-lvar (nlx)
2020 (declare (type nlx-info nlx
))
2021 (node-lvar (block-last (nlx-info-target nlx
))))
2023 ;;;; functional hackery
2025 (declaim (ftype (sfunction (functional) clambda
) main-entry
))
2026 (defun main-entry (functional)
2027 (etypecase functional
2028 (clambda functional
)
2030 (optional-dispatch-main-entry functional
))))
2032 ;;; RETURN true if FUNCTIONAL is a thing that can be treated like
2033 ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
2034 ;;; optional with null default and no SUPPLIED-P. There must be a
2035 ;;; &REST arg with no references.
2036 (declaim (ftype (sfunction (functional) boolean
) looks-like-an-mv-bind
))
2037 (defun looks-like-an-mv-bind (functional)
2038 (and (optional-dispatch-p functional
)
2039 (do ((arg (optional-dispatch-arglist functional
) (cdr arg
)))
2041 (let ((info (lambda-var-arg-info (car arg
))))
2042 (unless info
(return nil
))
2043 (case (arg-info-kind info
)
2045 (when (or (arg-info-supplied-p info
) (arg-info-default info
))
2048 (return (and (null (cdr arg
)) (null (leaf-refs (car arg
))))))
2052 ;;; Return true if function is an external entry point. This is true
2053 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
2054 ;;; (:TOPLEVEL kind.)
2056 (declare (type functional fun
))
2057 (not (null (member (functional-kind fun
) '(:external
:toplevel
)))))
2059 ;;; If LVAR's only use is a non-notinline global function reference,
2060 ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
2061 ;;; is true, then we don't care if the leaf is NOTINLINE.
2062 (defun lvar-fun-name (lvar &optional notinline-ok
)
2063 (declare (type lvar lvar
))
2064 (let ((use (lvar-uses lvar
)))
2066 (let ((leaf (ref-leaf use
)))
2067 (if (and (global-var-p leaf
)
2068 (eq (global-var-kind leaf
) :global-function
)
2069 (or (not (defined-fun-p leaf
))
2070 (not (eq (defined-fun-inlinep leaf
) :notinline
))
2072 (leaf-source-name leaf
)
2076 (defun lvar-fun-debug-name (lvar)
2077 (declare (type lvar lvar
))
2078 (let ((uses (lvar-uses lvar
)))
2080 (leaf-debug-name (ref-leaf use
))))
2083 (mapcar #'name1 uses
)))))
2085 ;;; Return the source name of a combination -- or signals an error
2086 ;;; if the function leaf is anonymous.
2087 (defun combination-fun-source-name (combination &optional
(errorp t
))
2088 (let ((uses (principal-lvar-use (combination-fun combination
)))
2090 (cond ((and (ref-p uses
)
2091 (leaf-has-source-name-p (setf leaf
(ref-leaf uses
))))
2092 (values (leaf-source-name leaf
) t
))
2094 (aver (not "COMBINATION-FUN is not a ref to a nameful leaf")))
2096 (values nil nil
)))))
2098 (defun combination-fun-debug-name (combination)
2099 (leaf-debug-name (ref-leaf (lvar-uses (combination-fun combination
)))))
2101 ;;; Return the COMBINATION node that is the call to the LET FUN.
2102 (defun let-combination (fun)
2103 (declare (type clambda fun
))
2104 (aver (functional-letlike-p fun
))
2105 (lvar-dest (node-lvar (first (leaf-refs fun
)))))
2107 ;;; Return the initial value lvar for a LET variable, or NIL if there
2109 (defun let-var-initial-value (var)
2110 (declare (type lambda-var var
))
2111 (let ((fun (lambda-var-home var
)))
2112 (elt (combination-args (let-combination fun
))
2113 (position-or-lose var
(lambda-vars fun
)))))
2115 ;;; Return the LAMBDA that is called by the local CALL.
2116 (defun combination-lambda (call)
2117 (declare (type basic-combination call
))
2118 (aver (eq (basic-combination-kind call
) :local
))
2119 (ref-leaf (lvar-uses (basic-combination-fun call
))))
2121 (defvar *inline-expansion-limit
* 200
2123 "an upper limit on the number of inline function calls that will be expanded
2124 in any given code object (single function or block compilation)")
2126 ;;; Check whether NODE's component has exceeded its inline expansion
2127 ;;; limit, and warn if so, returning NIL.
2128 (defun inline-expansion-ok (node)
2129 (let ((expanded (incf (component-inline-expansions
2131 (node-block node
))))))
2132 (cond ((> expanded
*inline-expansion-limit
*) nil
)
2133 ((= expanded
*inline-expansion-limit
*)
2134 ;; FIXME: If the objective is to stop the recursive
2135 ;; expansion of inline functions, wouldn't it be more
2136 ;; correct to look back through surrounding expansions
2137 ;; (which are, I think, stored in the *CURRENT-PATH*, and
2138 ;; possibly stored elsewhere too) and suppress expansion
2139 ;; and print this warning when the function being proposed
2140 ;; for inline expansion is found there? (I don't like the
2141 ;; arbitrary numerical limit in principle, and I think
2142 ;; it'll be a nuisance in practice if we ever want the
2143 ;; compiler to be able to use WITH-COMPILATION-UNIT on
2144 ;; arbitrarily huge blocks of code. -- WHN)
2145 (let ((*compiler-error-context
* node
))
2146 (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
2147 probably trying to~% ~
2148 inline a recursive function."
2149 *inline-expansion-limit
*))
2153 ;;; Make sure that FUNCTIONAL is not let-converted or deleted.
2154 (defun assure-functional-live-p (functional)
2155 (declare (type functional functional
))
2157 ;; looks LET-converted
2158 (functional-somewhat-letlike-p functional
)
2159 ;; It's possible for a LET-converted function to end up
2160 ;; deleted later. In that case, for the purposes of this
2161 ;; analysis, it is LET-converted: LET-converted functionals
2162 ;; are too badly trashed to expand them inline, and deleted
2163 ;; LET-converted functionals are even worse.
2164 (memq (functional-kind functional
) '(:deleted
:zombie
))))
2165 (throw 'locall-already-let-converted functional
)))
2167 (defun assure-leaf-live-p (leaf)
2170 (when (lambda-var-deleted leaf
)
2171 (throw 'locall-already-let-converted leaf
)))
2173 (assure-functional-live-p leaf
))))
2176 (defun call-full-like-p (call)
2177 (declare (type basic-combination call
))
2178 (let ((kind (basic-combination-kind call
)))
2180 (and (eq kind
:known
)
2181 (let ((info (basic-combination-fun-info call
)))
2183 (not (fun-info-ir2-convert info
))
2184 (dolist (template (fun-info-templates info
) t
)
2185 (when (eq (template-ltn-policy template
) :fast-safe
)
2186 (multiple-value-bind (val win
)
2187 (valid-fun-use call
(template-type template
))
2188 (when (or val
(not win
)) (return nil
)))))))))))
2192 ;;; Apply a function to some arguments, returning a list of the values
2193 ;;; resulting of the evaluation. If an error is signalled during the
2194 ;;; application, then we produce a warning message using WARN-FUN and
2195 ;;; return NIL as our second value to indicate this. NODE is used as
2196 ;;; the error context for any error message, and CONTEXT is a string
2197 ;;; that is spliced into the warning.
2198 (declaim (ftype (sfunction ((or symbol function
) list node function string
)
2199 (values list boolean
))
2201 (defun careful-call (function args node warn-fun context
)
2203 (multiple-value-list
2204 (handler-case (apply function args
)
2206 (let ((*compiler-error-context
* node
))
2207 (funcall warn-fun
"Lisp error during ~A:~%~A" context condition
)
2208 (return-from careful-call
(values nil nil
))))))
2211 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
2214 ((deffrob (basic careful compiler transform
)
2216 (defun ,careful
(specifier)
2217 (handler-case (,basic specifier
)
2218 ((or sb
!kernel
::arg-count-error
2219 type-error
) (condition)
2220 (values nil
(list (princ-to-string 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
))))))