1 ;;;; This file contains miscellaneous utilities used for manipulating
2 ;;;; the IR1 representation.
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
17 (defun delete-lexenv-enclosing-cleanup (lexenv)
18 (declare (type lexenv lexenv
))
20 (lambda-call-lexenv (lexenv-lambda lexenv2
))))
22 (when (lexenv-cleanup lexenv2
)
23 (setf (lexenv-cleanup lexenv2
) nil
))))
25 ;;; Return the innermost cleanup enclosing NODE, or NIL if there is
26 ;;; none in its function. If NODE has no cleanup, but is in a LET,
27 ;;; then we must still check the environment that the call is in.
28 (defun node-enclosing-cleanup (node)
29 (declare (type node node
))
30 (do ((lexenv (node-lexenv node
)
31 (lambda-call-lexenv (lexenv-lambda lexenv
))))
33 (let ((cup (lexenv-cleanup lexenv
)))
34 (when cup
(return cup
)))))
36 (defun map-nested-cleanups (function block-or-node
&optional return-value
)
37 (declare (type (or node cblock
) block-or-node
))
38 (do ((cleanup (if (node-p block-or-node
)
39 (node-enclosing-cleanup block-or-node
)
40 (block-end-cleanup block-or-node
))
41 (node-enclosing-cleanup (cleanup-mess-up cleanup
))))
42 ((not cleanup
) return-value
)
43 (funcall function cleanup
)))
45 ;;; Convert the FORM in a block inserted between BLOCK1 and BLOCK2 as
46 ;;; an implicit MV-PROG1. The inserted block is returned. NODE is used
47 ;;; for IR1 context when converting the form. Note that the block is
48 ;;; not assigned a number, and is linked into the DFO at the
49 ;;; beginning. We indicate that we have trashed the DFO by setting
50 ;;; COMPONENT-REANALYZE. If CLEANUP is supplied, then convert with
52 (defun insert-cleanup-code (pred-blocks succ-block node form
&optional cleanup
)
53 (declare (type node node
) (type (or cleanup null
) cleanup
))
54 (setf (component-reanalyze (block-component (car pred-blocks
))) t
)
55 (with-ir1-environment-from-node node
56 (with-component-last-block (*current-component
*
57 (block-next (component-head *current-component
*)))
58 (let* ((start (make-ctran))
59 (block (ctran-starts-block start
))
62 (make-lexenv :cleanup cleanup
)
64 (loop for pred-block in pred-blocks
66 (change-block-successor pred-block succ-block block
))
67 (link-blocks block succ-block
)
68 (ir1-convert start next nil form
)
69 (setf (block-last block
) (ctran-use next
))
70 (setf (node-next (block-last block
)) nil
)
75 ;;; Return a list of all the nodes which use LVAR.
76 (defun find-uses (lvar)
77 (declare (type lvar lvar
) #-sb-xc-host
(values list
))
78 (ensure-list (lvar-uses lvar
)))
80 (defun principal-lvar (lvar)
81 (declare (type lvar lvar
))
83 (let ((use (lvar-uses lvar
)))
89 (defun principal-lvar-use (lvar)
91 (declare (type lvar lvar
))
92 (let ((use (lvar-uses lvar
)))
94 (plu (cast-value use
))
98 (defun principal-lvar-ref-use (lvar &optional casts
)
100 (labels ((recurse (lvar)
102 (let ((use (lvar-uses lvar
)))
105 (let ((lvar (lambda-var-ref-lvar use
)))
111 (recurse (cast-value use
)))
116 (defun principal-lvar-ref (lvar &optional casts
)
117 (labels ((recurse (lvar ref
)
119 (let ((use (lvar-uses lvar
)))
121 (recurse (lambda-var-ref-lvar use
) use
))
124 (recurse (cast-value use
) ref
))
130 (defun lvar-lambda-var (lvar)
131 (let ((ref (principal-lvar-ref lvar
)))
133 (lambda-var-p (ref-leaf ref
))
136 ;;; Look through casts and variables, m-v-bind+values
137 (defun map-all-uses (function lvar
)
138 (declare (dynamic-extent function
))
139 (labels ((recurse-lvar (lvar)
144 (let ((lvar (lambda-var-ref-lvar use
)))
147 ((let ((var (ref-leaf use
)))
148 (when (and (lambda-var-p var
)
149 (not (lambda-var-sets var
)))
150 (let ((fun (lambda-var-home var
)))
151 (when (functional-kind-eq fun mv-let
)
152 (let* ((fun (lambda-var-home var
))
153 (n-value (position-or-lose var
(lambda-vars fun
)))
154 (args (basic-combination-args (let-combination fun
))))
155 (when (singleton-p args
)
156 (let ((all-processed t
))
157 (do-uses (use (car args
))
158 (unless (when (and (combination-p use
)
159 (eq (lvar-fun-name (combination-fun use
))
161 (let ((lvar (nth n-value
(combination-args use
))))
165 (setf all-processed nil
)))
166 all-processed
))))))))
168 (funcall function use
)))))
171 (recurse-lvar (cast-value use
)))
173 (funcall function use
)))))
174 (recurse-lvar lvar
)))
176 (defun mv-principal-lvar-ref-use (lvar)
177 (labels ((recurse (lvar)
178 (let ((use (lvar-uses lvar
)))
180 (let ((var (ref-leaf use
)))
181 (if (and (lambda-var-p var
)
182 (null (lambda-var-sets var
)))
183 (functional-kind-case (lambda-var-home var
)
185 (let* ((fun (lambda-var-home var
))
186 (n-value (position-or-lose var
(lambda-vars fun
))))
187 (loop for arg in
(basic-combination-args (let-combination fun
))
188 for nvals
= (nth-value 1 (values-types (lvar-derived-type arg
)))
189 when
(eq nvals
:unknown
) return nil
190 when
(<= n-value nvals
) do
(return-from mv-principal-lvar-ref-use
191 (values (lvar-uses arg
) n-value
))
192 do
(decf n-value nvals
))
195 (recurse (let-var-initial-value var
)))
202 (defun map-lvar-dest-casts (fun lvar
)
205 (let ((dest (lvar-dest lvar
)))
208 (pld (cast-lvar dest
)))))))
211 (defun let-lvar-dest (lvar)
212 (let ((dest (lvar-dest (principal-lvar lvar
))))
213 (if (and (combination-p dest
)
214 (eq (basic-combination-kind dest
) :local
))
215 (let* ((fun (combination-lambda dest
))
216 (n (position-or-lose lvar
217 (combination-args dest
)))
218 (var (nth n
(lambda-vars fun
)))
219 (refs (leaf-refs var
)))
222 (let-lvar-dest (node-lvar (car refs
)))))
225 (defun lvar-dest-var (lvar)
227 (let ((dest (lvar-dest lvar
)))
228 (cond ((combination-p dest
)
229 (if (eq (basic-combination-kind dest
) :local
)
230 (let* ((fun (combination-lambda dest
))
231 (n (position-or-lose lvar
232 (combination-args dest
)))
233 (var (nth n
(lambda-vars fun
))))
235 (and (lvar-fun-is (combination-fun dest
) '(sb-vm::splat
))
236 (lvar-dest-var (node-lvar dest
)))))
238 (lvar-dest-var (node-lvar dest
)))))))
240 (defun immediately-used-let-dest (lvar node
&optional flushable
)
241 (let ((dest (lvar-dest lvar
)))
242 (when (almost-immediately-used-p lvar node
:flushable flushable
)
243 (if (and (combination-p dest
)
244 (eq (combination-kind dest
) :local
))
245 (let* ((fun (combination-lambda dest
))
246 (n (position-or-lose lvar
247 (combination-args dest
)))
248 (var (nth n
(lambda-vars fun
)))
249 (refs (leaf-refs var
)))
250 (loop for ref in refs
251 for lvar
= (node-lvar ref
)
252 when
(and lvar
(almost-immediately-used-p lvar
(lambda-bind fun
)))
253 do
(return (values (lvar-dest lvar
) lvar
))))
254 (values dest lvar
)))))
256 (defun mv-bind-dest (lvar nth-value
)
258 (let ((dest (lvar-dest lvar
)))
259 (when (and (mv-combination-p dest
)
260 (eq (basic-combination-kind dest
) :local
))
261 (let ((fun (combination-lambda dest
)))
262 (let* ((var (nth nth-value
(lambda-vars fun
)))
263 (refs (leaf-refs var
)))
266 (when (functional-kind-eq fun mv-let
)
267 (let-lvar-dest (node-lvar (car refs
)))))))))))
269 (defun combination-matches (name args combination
)
270 (and (combination-p combination
)
271 (let ((fun (combination-fun combination
)))
272 (when (eq (lvar-fun-name fun
) name
)
273 (loop for arg in
(combination-args combination
)
275 always
(or (eq arg arg-m
)
277 (and (constant-lvar-p arg
)
278 (eql (lvar-value arg
) arg-m
))))))))
280 (defun erase-lvar-type (lvar)
281 (setf (lvar-%derived-type lvar
) nil
)
282 (let ((dest (lvar-dest lvar
)))
284 (derive-node-type dest
*wild-type
* :from-scratch t
)
285 (erase-lvar-type (node-lvar dest
)))
286 ((and (basic-combination-p dest
)
287 (eq (basic-combination-kind dest
) :local
))
288 (let ((fun (combination-lambda dest
)))
290 (setf (lambda-var-type var
) *universal-type
*)
291 (loop for ref in
(leaf-refs var
)
292 do
(derive-node-type ref
*wild-type
* :from-scratch t
)
293 (erase-lvar-type (node-lvar ref
)))))
294 (if (functional-kind-eq fun mv-let
)
295 (mapc #'erase
(lambda-vars fun
))
297 (nth (position-or-lose lvar
298 (basic-combination-args dest
))
299 (lambda-vars fun
))))))))))
301 ;;; Update lvar use information so that NODE is no longer a use of its
304 ;;; Note: if you call this function, you may have to do a
305 ;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
308 ;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may
309 ;;; be given a new use.
310 (defun %delete-lvar-use
(node)
311 (declare (type node node
))
312 (let ((lvar (node-lvar node
)))
314 (if (listp (lvar-uses lvar
))
315 (let ((new-uses (delq1 node
(lvar-uses lvar
))))
316 (setf (lvar-uses lvar
)
317 (if (singleton-p new-uses
)
320 (setf (lvar-uses lvar
) nil
))
323 ;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete
324 ;;; its DEST's block, which must be unreachable.
325 (defun delete-lvar-use (node)
326 (declare (type node node
))
327 (let ((lvar (node-lvar node
)))
329 (%delete-lvar-use node
)
330 (if (null (lvar-uses lvar
))
331 (binding* ((dest (lvar-dest lvar
) :exit-if-null
)
332 (() (not (node-deleted dest
)) :exit-if-null
)
333 (block (node-block dest
)))
334 (mark-for-deletion block
))
335 (reoptimize-lvar lvar
))))
338 ;;; Update lvar use information so that NODE uses LVAR.
340 ;;; Note: if you call this function, you may have to do a
341 ;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
343 (defun add-lvar-use (node lvar
)
344 (declare (type node node
) (type (or lvar null
) lvar
))
345 (aver (not (node-lvar node
)))
347 (let ((uses (lvar-uses lvar
)))
348 (setf (lvar-uses lvar
)
355 (setf (node-lvar node
) lvar
)))
359 ;;; Return true if LVAR destination is executed immediately after
360 ;;; NODE. Cleanups are ignored.
361 (defun immediately-used-p (lvar node
&optional single-predecessor
)
362 (declare (type lvar lvar
) (type node node
))
363 (aver (eq (node-lvar node
) lvar
))
364 (let ((dest (lvar-dest lvar
)))
365 (acond ((node-next node
)
366 (eq (ctran-next it
) dest
))
368 (let ((succ (first (block-succ (node-block node
)))))
369 (and (not (and single-predecessor
370 (cdr (block-pred succ
))))
371 (eq (block-start succ
)
372 (node-prev dest
))))))))
374 ;;; Return true if LVAR destination is executed after node with only
375 ;;; uninteresting nodes intervening.
377 ;;; Uninteresting nodes are nodes in the same block which are either
378 ;;; REFs, ENCLOSEs, or external CASTs to the same destination.
379 (defun almost-immediately-used-p (lvar node
&key flushable
)
380 (declare (type lvar lvar
)
382 (unless (bind-p node
)
383 (aver (eq (node-lvar node
) lvar
)))
384 (let ((dest (lvar-dest lvar
))
388 (setf ctran
(node-next node
))
391 (setf node
(ctran-next ctran
))
393 (return-from almost-immediately-used-p t
)
398 (when (or (and (memq (cast-type-check node
) '(:external nil
))
399 (eq dest
(node-dest node
)))
401 (not (contains-hairy-type-p (cast-type-to-check node
))))
402 ;; If the types do not match then this
403 ;; cast is not related to the LVAR and
404 ;; wouldn't be affected if it's
405 ;; executed out of order.
406 (multiple-value-bind (res true
)
407 (values-subtypep (node-derived-type node
)
408 (lvar-derived-type lvar
))
414 (flushable-combination-p node
))
419 ;; Loops shouldn't cause a problem, either it will
420 ;; encounter a not "uninteresting" node, or the destination
421 ;; will be unreachable anyway.
422 (let ((start (block-start (first (block-succ (node-block node
))))))
425 (go :next-ctran
))))))))
427 ;;; Check that all the uses are almost immediately used and look through CASTs,
428 ;;; as they can be freely deleted removing the immediateness
429 (defun lvar-almost-immediately-used-p (lvar)
430 (do-uses (use lvar t
)
431 (unless (and (almost-immediately-used-p lvar use
)
432 (or (not (cast-p use
))
433 (lvar-almost-immediately-used-p (cast-value use
))))
436 (defun let-var-immediately-used-p (ref var lvar
)
437 (let ((bind (lambda-bind (lambda-var-home var
))))
439 (let* ((next-ctran (node-next bind
))
440 (next-node (and next-ctran
441 (ctran-next next-ctran
))))
442 (and (eq next-node ref
)
443 (lvar-almost-immediately-used-p lvar
))))))
447 (declaim (inline block-to-be-deleted-p
))
448 (defun block-to-be-deleted-p (block)
449 (declare (type cblock block
))
450 (or (block-delete-p block
)
451 (functional-kind-eq (block-home-lambda block
) deleted
)))
453 ;;; Checks whether NODE is in a block to be deleted
454 (declaim (inline node-to-be-deleted-p
))
455 (defun node-to-be-deleted-p (node)
456 (block-to-be-deleted-p (node-block node
)))
458 (defun lambda-block (lambda)
459 (declare (type clambda lambda
))
460 (node-block (lambda-bind lambda
)))
462 (defun lambda-component (lambda)
463 (declare (type clambda lambda
))
464 (block-component (lambda-block lambda
)))
466 (defun block-start-node (block)
467 (declare (type cblock block
))
468 (ctran-next (block-start block
)))
471 ;;;; lvar substitution
473 (defun update-lvar-dependencies (new old
)
476 (update-lvar-dependencies new
(lambda-var-ref-lvar old
)))
480 ;; Inlined functions will try to use the lvar in the lexenv
481 (loop for block in
(lexenv-blocks (node-lexenv node
))
482 for block-lvar
= (fourth block
)
483 when
(eq old block-lvar
)
484 do
(setf (fourth block
) new
))))
485 (propagate-lvar-annotations new old
))))
487 ;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be
488 ;;; NIL. We do not flush OLD's DEST.
489 (defun substitute-lvar (new old
)
490 (declare (type lvar old new
))
491 (aver (not (lvar-dest new
)))
492 (let ((dest (lvar-dest old
)))
495 (cif (setf (if-test dest
) new
))
496 (cset (setf (set-value dest
) new
))
497 (creturn (setf (return-result dest
) new
))
498 (exit (setf (exit-value dest
) new
))
500 (if (eq old
(basic-combination-fun dest
))
501 (setf (basic-combination-fun dest
) new
)
502 (setf (basic-combination-args dest
)
503 (nsubst new old
(basic-combination-args dest
)))))
504 (cast (setf (cast-value dest
) new
)))
506 (setf (lvar-dest old
) nil
)
507 (setf (lvar-dest new
) dest
))
510 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
511 ;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
512 (defun substitute-lvar-uses (new old propagate-dx
)
513 (declare (type lvar old
)
514 (type (or lvar null
) new
)
515 (type boolean propagate-dx
))
517 (update-lvar-dependencies new old
)
519 (%delete-lvar-use node
)
520 (add-lvar-use node new
))
521 (reoptimize-lvar new
)
523 (propagate-lvar-dx new old
)))
525 (update-lvar-dependencies new old
)
530 (defun propagate-lvar-dx (new old
)
531 (let ((dynamic-extent (lvar-dynamic-extent old
)))
533 (setf (lvar-dynamic-extent old
) nil
)
534 (setf (dynamic-extent-values dynamic-extent
)
535 (delq1 old
(dynamic-extent-values dynamic-extent
)))
536 (unless (lvar-dynamic-extent new
)
537 (setf (lvar-dynamic-extent new
) dynamic-extent
)
538 (push new
(dynamic-extent-values dynamic-extent
))))))
540 (defun lexenv-contains-lambda (lambda parent-lexenv
)
541 (loop for lexenv
= (lambda-lexenv lambda
)
542 then
(let ((lambda (lexenv-lambda lexenv
)))
544 (lambda-call-lexenv lambda
)))
547 (loop for parent
= lexenv then
(lexenv-parent parent
)
549 thereis
(eq parent parent-lexenv
))))
552 ;;; (dx-let ((x (let ((m (make-array)))
555 (defun propagate-ref-dx (new-ref old-lvar var
)
556 (let ((dynamic-extent (lvar-dynamic-extent old-lvar
))
557 (leaf (ref-leaf new-ref
)))
561 (when (and (functional-kind-eq (lambda-var-home leaf
) let
)
562 ;; Make sure the let is inside the dx let
563 (lexenv-contains-lambda (lambda-var-home leaf
)
564 (node-lexenv dynamic-extent
)))
565 (propagate-lvar-dx (let-var-initial-value leaf
) old-lvar
)))
567 (when (and (null (rest (leaf-refs leaf
)))
568 (lexenv-contains-lambda leaf
569 (node-lexenv dynamic-extent
)))
570 (let ((fun (functional-entry-fun leaf
)))
571 (setf (enclose-dynamic-extent (functional-enclose fun
))
573 (setf (leaf-dynamic-extent fun
) (leaf-dynamic-extent var
))
574 (setf (lvar-dynamic-extent old-lvar
) nil
)
575 (setf (dynamic-extent-values dynamic-extent
)
576 (delq1 old-lvar
(dynamic-extent-values dynamic-extent
)))))))
579 (defun node-dominates-p (node1 node2
)
580 (let ((block1 (node-block node1
))
581 (block2 (node-block node2
)))
582 (if (eq block1 block2
)
583 (do-nodes (node nil block1
)
584 (cond ((eq node node1
)
587 (return (eq node1
0)))))
588 (let ((component (block-component block1
)))
589 (unless (component-dominators-computed component
)
590 (find-dominators component
))
591 (dominates-p block1 block2
)))))
593 (defun set-slot-old-p (node nth-value
)
594 (flet ((pseudo-static-value-p (lvar)
598 (unless (and (ref-p use
)
599 (let ((leaf (ref-leaf use
)))
600 (or (and (constant-p leaf
)
602 (let ((value (constant-value leaf
)))
603 (or (sb-xc:typep value
'(or character sb-xc
:fixnum
#+64-bit single-float boolean
))
604 (and (eql (generation-of value
) sb-vm
:+pseudo-static-generation
+)
605 (or (not (sb-c::producing-fasl-file
))
607 (logtest sb-vm
::+symbol-initial-core
+ (get-header-data value
))))))))
610 (not (environment-closure (get-lambda-environment leaf
)))))))
615 (pseudo-static-value-p (set-value node
)))
616 ((combination-p node
)
617 (when (lvar-fun-is (combination-fun node
) '(initialize-vector))
618 (return-from set-slot-old-p t
))
619 (let ((args (combination-args node
)))
620 (when (lvar-fun-is (combination-fun node
) '(%%primitive
))
622 (let* ((object-lvar (first args
))
623 (value-lvar (nth nth-value args
))
624 (allocator (principal-lvar-ref-use object-lvar t
)))
625 (labels ((born-before-p (node)
629 (cond ((and (ref-p use
)
630 (let ((leaf (ref-leaf use
)))
631 (or (constant-p leaf
)
632 (when (and (lambda-var-p leaf
)
633 (not (lambda-var-sets leaf
)))
634 (let ((home (lambda-var-home leaf
)))
635 (and (functional-kind-eq home external optional
)
636 (let ((entry (if (functional-kind-eq home external
)
637 (main-entry (functional-entry-fun home
))
639 (node-home (node-home-lambda node
)))
640 (or (eq (lambda-environment node-home
)
641 (lambda-environment entry
))
642 (lexenv-contains-lambda node-home
643 (lambda-lexenv entry
))
646 (or (not (environment-closure (get-lambda-environment leaf
)))
647 (let ((enclose (xep-enclose leaf
)))
649 (node-dominates-p enclose node
)))))))))
650 ((not (node-dominates-p use node
))
654 (allocator-p (allocator)
655 (or (and (combination-p allocator
)
657 (lvar-fun-is (combination-fun allocator
) '(list* list %make-list
659 %make-structure-instance
662 %make-funcallable-instance
671 (and (lvar-fun-is (combination-fun allocator
) '(sb-vm::splat
))
672 (let ((allocator (principal-lvar-ref-use
673 (principal-lvar (first (combination-args allocator
))))))
674 (and (combination-p allocator
)
675 (lvar-fun-is (combination-fun allocator
) '(allocate-vector)))))
676 (let ((name (lvar-fun-name (combination-fun allocator
) t
)))
677 (typep (info :function
:source-transform name
)
678 '(cons * (eql :constructor
)))))))))
679 (or (and (allocator-p allocator
)
680 (born-before-p allocator
))
681 (pseudo-static-value-p value-lvar
)))))))))
683 ;;;; block starting/creation
685 ;;; Return the block that CTRAN is the start of, making a block if
686 ;;; necessary. This function is called by IR1 translators which may
687 ;;; cause a CTRAN to be used more than once. Every CTRAN which may be
688 ;;; used more than once must start a block by the time that anyone
689 ;;; does a USE-CTRAN on it.
691 ;;; We also throw the block into the next/prev list for the
692 ;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have
694 (defun ctran-starts-block (ctran)
695 (declare (type ctran ctran
))
696 (ecase (ctran-kind ctran
)
698 (aver (not (ctran-block ctran
)))
699 (let* ((next (component-last-block *current-component
*))
700 (prev (block-prev next
))
701 (new-block (make-block ctran
)))
702 (setf (block-next new-block
) next
703 (block-prev new-block
) prev
704 (block-prev next
) new-block
705 (block-next prev
) new-block
706 (ctran-block ctran
) new-block
707 (ctran-kind ctran
) :block-start
)
708 (aver (not (ctran-use ctran
)))
711 (ctran-block ctran
))))
713 ;;; Ensure that CTRAN is the start of a block so that the use set can
714 ;;; be freely manipulated.
715 (defun ensure-block-start (ctran)
716 (declare (type ctran ctran
))
717 (let ((kind (ctran-kind ctran
)))
721 (setf (ctran-block ctran
)
722 (make-block-key :start ctran
))
723 (setf (ctran-kind ctran
) :block-start
))
725 (node-ends-block (ctran-use ctran
)))))
731 ;;; Filter values of LVAR through the form produced by
732 ;;; FUNCTION. FUNCTION takes one argument and returns a form with the
733 ;;; argument spliced into the form exactly once. This argument is a
734 ;;; placeholder which will be replaced with LVAR once the form is
735 ;;; IR1 converted and the resulting code is spliced in before LVAR's
736 ;;; DEST. The new lvar which represents the value of the form is
737 ;;; called the "filtered" lvar.
738 (defun filter-lvar (lvar function
)
739 (declare (type lvar lvar
)
740 (type function function
))
741 (let* ((dest (lvar-dest lvar
))
742 (ctran (node-prev dest
))
743 ;; We pick an arbitrary unique leaf so that IR1-convert will
745 (placeholder (make-constant 0))
746 (form (funcall function placeholder
)))
747 (with-ir1-environment-from-node dest
748 (ensure-block-start ctran
)
749 (let* ((old-block (ctran-block ctran
))
750 (new-start (make-ctran))
751 (filtered-lvar (make-lvar))
752 (new-block (ctran-starts-block new-start
)))
753 ;; Splice in the new block before DEST, giving the new block
754 ;; all of DEST's predecessors.
755 (dolist (block (block-pred old-block
))
756 (change-block-successor block old-block new-block
))
757 (ir1-convert new-start ctran filtered-lvar form
)
759 ;; Replace PLACEHOLDER with the LVAR.
760 (let* ((refs (leaf-refs placeholder
))
763 (let ((victim (node-lvar node
)))
764 (aver (null (rest refs
))) ; PLACEHOLDER must be referenced exactly once.
765 (substitute-lvar filtered-lvar lvar
)
766 (substitute-lvar lvar victim
)
767 (flush-dest victim
)))
771 ;; The form may have introduced new local calls, for example,
772 ;; from LET bindings, so invoke local call analysis.
773 (locall-analyze-component *current-component
*))))
776 (defun insert-code (before form
)
777 (let ((ctran (node-prev before
)))
778 (with-ir1-environment-from-node before
779 (ensure-block-start ctran
)
780 (let* ((old-block (ctran-block ctran
))
781 (new-start (make-ctran))
782 (filtered-lvar (make-lvar))
783 (new-block (ctran-starts-block new-start
)))
784 ;; Splice in the new block before DEST, giving the new block
785 ;; all of DEST's predecessors.
786 (dolist (block (block-pred old-block
))
787 (change-block-successor block old-block new-block
))
788 (ir1-convert new-start ctran filtered-lvar form
)
789 ;; The form may have introduced new local calls, for example,
790 ;; from LET bindings, so invoke local call analysis.
791 (locall-analyze-component *current-component
*))))
794 ;;; Delete NODE and VALUE. It may result in some calls becoming tail.
795 (defun delete-filter (node lvar value
)
796 (aver (eq (lvar-dest value
) node
))
797 (aver (eq (node-lvar node
) lvar
))
798 (cond (lvar (collect ((merges))
799 (when (return-p (lvar-dest lvar
))
801 (when (and (basic-combination-p use
)
802 (not (node-to-be-deleted-p use
))
803 (eq (basic-combination-kind use
) :local
))
805 (substitute-lvar-uses lvar value
806 (eq (lvar-uses lvar
) node
))
807 (%delete-lvar-use node
)
810 (dolist (merge (merges))
811 (merge-tail-sets merge
)))))
812 (t (flush-dest value
)
813 (unlink-node node
))))
815 ;;; Make a CAST and insert it into IR1 before node NEXT.
817 (defun insert-cast-before (next lvar type policy
&optional context
)
818 (declare (type node next
) (type lvar lvar
) (type ctype type
))
819 (with-ir1-environment-from-node next
820 (%insert-cast-before next
(make-cast lvar type policy context
))))
822 (defun %insert-cast-before
(next cast
)
823 (declare (type node next
) (type cast cast
))
824 (let ((lvar (cast-value cast
)))
825 (insert-node-before next cast
)
826 (setf (lvar-dest lvar
) cast
)
827 (reoptimize-lvar lvar
)
830 (defun insert-cast-after (node lvar type policy
&optional context
)
831 (declare (type node node
) (type lvar lvar
) (type ctype type
))
832 (with-ir1-environment-from-node node
833 (let ((cast (make-cast lvar type policy context
)))
834 (let ((lvar (cast-value cast
)))
835 (insert-node-after node cast
)
836 (setf (lvar-dest lvar
) cast
)
837 (reoptimize-lvar lvar
)
840 (defun insert-ref-before (leaf node
)
841 (let ((ref (make-ref leaf
))
842 (lvar (make-lvar node
)))
843 (insert-node-before node ref
)
844 (push ref
(leaf-refs leaf
))
845 (setf (leaf-ever-used leaf
) t
)
849 ;;;; miscellaneous shorthand functions
851 ;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since
852 ;;; the LEXENV-LAMBDA may be deleted, we must chain up the
853 ;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't
854 ;;; deleted, and then return its home.
855 (declaim (maybe-inline node-home-lambda
))
856 (defun node-home-lambda (node)
857 (declare (type node node
))
858 (do ((fun (lexenv-lambda (node-lexenv node
))
859 (lexenv-lambda (lambda-call-lexenv fun
))))
860 ((not (functional-kind-eq fun deleted zombie
))
862 (when (eq (lambda-home fun
) fun
)
865 (declaim (maybe-inline node-environment
))
866 (defun node-environment (node)
867 (declare (type node node
) #-sb-xc-host
(inline node-home-lambda
))
868 (the environment
(lambda-environment (node-home-lambda node
))))
870 ;;; Return the enclosing cleanup for environment of the first or last
872 (defun block-start-cleanup (block)
873 (node-enclosing-cleanup (block-start-node block
)))
874 (defun block-end-cleanup (block)
875 (node-enclosing-cleanup (block-last block
)))
877 ;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL
878 ;;; if there is none.
880 ;;; There can legitimately be no home lambda in dead code early in the
881 ;;; IR1 conversion process, e.g. when IR1-converting the SETQ form in
882 ;;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
883 ;;; where the block is just a placeholder during parsing and doesn't
884 ;;; actually correspond to code which will be written anywhere.
885 (declaim (ftype (sfunction (cblock) (or clambda null
)) block-home-lambda-or-null
))
886 (defun block-home-lambda-or-null (block)
887 #-sb-xc-host
(declare (inline node-home-lambda
))
888 (if (node-p (block-last block
))
889 ;; This is the old CMU CL way of doing it.
890 (node-home-lambda (block-last block
))
891 ;; Now that SBCL uses this operation more aggressively than CMU
892 ;; CL did, the old CMU CL way of doing it can fail in two ways.
893 ;; 1. It can fail in a few cases even when a meaningful home
894 ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of
896 ;; 2. It can fail when converting a form which is born orphaned
897 ;; so that it never had a meaningful home lambda, e.g. a form
898 ;; which follows a RETURN-FROM or GO form.
899 (let ((pred-list (block-pred block
)))
900 ;; To deal with case 1, we reason that
901 ;; previous-in-target-execution-order blocks should be in the
902 ;; same lambda, and that they seem in practice to be
903 ;; previous-in-compilation-order blocks too, so we look back
904 ;; to find one which is sufficiently initialized to tell us
905 ;; what the home lambda is.
907 ;; We could get fancy about this, flooding through the
908 ;; graph of all the previous blocks, but in practice it
909 ;; seems to work just to grab the first previous block and
911 (node-home-lambda (block-last (first pred-list
)))
912 ;; In case 2, we end up with an empty PRED-LIST and
913 ;; have to punt: There's no home lambda.
916 ;;; Return the non-LET LAMBDA that holds BLOCK's code.
917 (defun block-home-lambda (block)
918 (declare (type cblock block
)
919 #-sb-xc-host
(inline node-home-lambda
))
920 (node-home-lambda (block-last block
)))
922 ;;; Return the IR1 environment for BLOCK.
923 (defun block-environment (block)
924 (declare (type cblock block
))
925 (lambda-environment (block-home-lambda block
)))
927 (declaim (inline node-stack-allocate-p
))
928 (defun node-stack-allocate-p (node)
929 (awhen (node-lvar node
)
930 (lvar-dynamic-extent it
)))
932 ;; If there's a possibility the variable might be unbound, then its
933 ;; references are unflushable.
934 (defun flushable-reference-p (node)
935 (let ((leaf (ref-leaf node
)))
936 (not (and (global-var-p leaf
)
937 (member (global-var-kind leaf
)
938 '(:special
:global
:unknown
))
939 (not (or (always-boundp (leaf-source-name leaf
))
940 (policy node
(< safety
3))))))))
942 (defun flushable-callable-arg-p (name arg-count
)
947 (let* ((info (info :function
:info name
))
948 (attributes (and info
949 (fun-info-attributes info
))))
951 (ir1-attributep attributes flushable
)
952 (not (ir1-attributep attributes call
))
953 (let ((type (global-ftype name
)))
955 (not (fun-type-p type
)) ;; Functions that accept anything, e.g. VALUES
956 (multiple-value-bind (min max
) (fun-type-arg-limits type
)
957 (cond ((and (not min
) (not max
))
961 ((and max
(> arg-count max
))
964 ;; Just check for T to ensure it won't signal type errors.
965 (not (find *universal-type
*
966 (fun-type-n-arg-types arg-count type
)
967 :test-not
#'eql
))))))))))))
969 (defun flushable-combination-args-p (combination info
)
971 (map-combination-args-and-types
972 (lambda (arg type lvars
&optional annotation
)
973 (declare (ignore type lvars
))
974 (case (car annotation
)
976 (let ((fun (or (lvar-fun-name arg t
)
977 (and (constant-lvar-p arg
)
980 (flushable-callable-arg-p fun
(length (cadr annotation
))))
983 (let* ((except (cddr annotation
)))
985 (constant-lvar-p arg
)
986 (memq (lvar-value arg
) except
))
993 (defun flushable-combination-p (call)
994 (declare (type combination call
))
995 (let ((kind (combination-kind call
))
996 (info (combination-fun-info call
)))
997 (or (when (and (eq kind
:known
) (fun-info-p info
))
998 (let ((attr (fun-info-attributes info
)))
999 (and (if (policy call
(= safety
3))
1000 (ir1-attributep attr flushable
)
1001 (ir1-attributep attr unsafely-flushable
))
1002 (flushable-combination-args-p call info
))))
1003 ;; Is it declared flushable locally?
1004 (let ((name (lvar-fun-name (combination-fun call
) t
)))
1005 (memq name
(lexenv-flushable (node-lexenv call
)))))))
1007 ;;;; DYNAMIC-EXTENT related
1009 ;;; Insert code to establish a dynamic extent around CALL, returning
1010 ;;; the dynamic extent.
1011 (defun insert-dynamic-extent (call)
1012 (let* ((dynamic-extent (with-ir1-environment-from-node call
1013 (make-dynamic-extent)))
1014 (cleanup (make-cleanup :kind
:dynamic-extent
1015 :mess-up dynamic-extent
)))
1016 (setf (dynamic-extent-cleanup dynamic-extent
) cleanup
)
1017 (insert-node-before call dynamic-extent
)
1018 (setf (node-lexenv call
)
1019 (make-lexenv :default
(node-lexenv call
)
1021 ;; Make CALL end its block, so that we have a place to
1022 ;; insert cleanup code.
1023 (node-ends-block call
)
1024 (push dynamic-extent
1025 (lambda-dynamic-extents (node-home-lambda dynamic-extent
)))
1028 (defun use-good-for-dx-p (use dynamic-extent
)
1031 (and (eq (combination-kind use
) :known
)
1032 (let ((info (combination-fun-info use
)))
1033 (or (awhen (fun-info-stack-allocate-result info
)
1035 (awhen (fun-info-result-arg info
)
1036 (lvar-good-for-dx-p (nth it
(combination-args use
))
1037 dynamic-extent
))))))
1039 (and (not (cast-type-check use
))
1040 (lvar-good-for-dx-p (cast-value use
) dynamic-extent
)))
1042 (let ((leaf (ref-leaf use
)))
1045 ;; LET lambda var with no SETS.
1046 (when (and (functional-kind-eq (lambda-var-home leaf
) let
)
1047 (not (lambda-var-sets leaf
))
1048 (lexenv-contains-lambda (lambda-var-home leaf
)
1049 (node-lexenv dynamic-extent
))
1050 ;; Check the other refs are good.
1051 (dolist (ref (leaf-refs leaf
) t
)
1052 (unless (eq use ref
)
1053 (when (not (ref-good-for-dx-p ref
))
1055 (lvar-good-for-dx-p (let-var-initial-value leaf
) dynamic-extent
)))
1057 (aver (functional-kind-eq leaf external
))
1058 (when (and (null (rest (leaf-refs leaf
)))
1059 (environment-closure (get-lambda-environment leaf
))
1060 (lexenv-contains-lambda leaf
1061 (node-lexenv dynamic-extent
)))
1062 (aver (eq use
(first (leaf-refs leaf
))))
1065 (defun lvar-good-for-dx-p (lvar dynamic-extent
)
1066 (aver (lvar-uses lvar
))
1067 (do-uses (use lvar nil
)
1068 (when (use-good-for-dx-p use dynamic-extent
)
1071 ;;; Check that REF delivers a value to a combination which is DX safe
1072 ;;; or whose result is that value and ends up being discarded.
1073 (defun ref-good-for-dx-p (ref)
1074 (let* ((lvar (ref-lvar ref
))
1075 (dest (when lvar
(lvar-dest lvar
))))
1076 (and (combination-p dest
)
1077 (case (combination-kind dest
)
1079 (awhen (combination-fun-info dest
)
1080 (or (ir1-attributep (fun-info-attributes it
) dx-safe
)
1081 (and (not (combination-lvar dest
))
1082 (awhen (fun-info-result-arg it
)
1083 (eql lvar
(nth it
(combination-args dest
))))))))
1085 (loop for arg in
(combination-args dest
)
1086 for var in
(lambda-vars (combination-lambda dest
))
1087 do
(when (eq arg lvar
)
1089 (dolist (ref (lambda-var-refs var
) t
)
1090 (unless (ref-good-for-dx-p ref
)
1092 finally
(sb-impl::unreachable
)))))))
1094 (defun lambda-var-ref-lvar (ref)
1095 (let ((var (ref-leaf ref
)))
1096 (when (and (lambda-var-p var
)
1097 (not (lambda-var-sets var
)))
1098 (let* ((fun (lambda-var-home var
))
1099 (vars (lambda-vars fun
))
1100 (refs (lambda-refs fun
))
1103 (ref-lvar (car refs
))))
1104 (combination (and lvar
1106 (when (and (combination-p combination
)
1107 (eq (combination-fun combination
) lvar
))
1109 for arg in
(combination-args combination
)
1113 ;;; Return the Top Level Form number of PATH, i.e. the ordinal number
1114 ;;; of its original source's top level form in its compilation unit.
1115 (defun source-path-tlf-number (path)
1116 (declare (list path
))
1119 ;;; Return the (reversed) list for the PATH in the original source
1120 ;;; (with the Top Level Form number last).
1121 (defun source-path-original-source (path)
1122 (declare (list path
) (inline member
)
1123 #-sb-xc-host
(values list
))
1124 (cddr (member 'original-source-start path
:test
#'eq
)))
1126 ;;; Return the Form Number of PATH's original source inside the Top
1127 ;;; Level Form that contains it. This is determined by the order that
1128 ;;; we walk the subforms of the top level source form.
1129 (defun source-path-form-number (path)
1130 (declare (type list path
) (inline member
)
1131 #-sb-xc-host
(values (or null index
)))
1132 (cadr (member 'original-source-start path
:test
#'eq
)))
1134 ;;; Return a list of all the enclosing forms not in the original
1135 ;;; source that converted to get to this form, with the immediate
1136 ;;; source for node at the start of the list.
1137 (defun source-path-forms (path)
1138 (subseq path
0 (position 'original-source-start path
)))
1140 ;;; Return the innermost source form for NODE.
1141 (defun node-source-form (node)
1142 (declare (type node node
))
1143 (let* ((path (node-source-path node
))
1144 (forms (source-path-forms path
)))
1147 (values (find-original-source path
)))))
1149 ;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise
1151 (defun lvar-source (lvar)
1152 (let ((use (lvar-uses lvar
)))
1155 (values (node-source-form use
) t
))))
1157 (defun common-suffix (x y
)
1158 (let ((mismatch (mismatch x y
:from-end t
)))
1163 ;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a
1164 ;;; singleton. Otherwise, return a list of the lowest common
1165 ;;; ancestor source form of all the uses (if it can be found),
1166 ;;; followed by all the uses' source forms.
1167 (defun lvar-all-sources (lvar)
1168 (let ((use (principal-lvar-use lvar
)))
1171 (path (node-source-path (first use
))))
1172 (dolist (use use
(cons (if (find 'original-source-start path
)
1173 (find-original-source path
)
1176 (pushnew (node-source-form use
) forms
)
1177 (setf path
(common-suffix path
1178 (node-source-path use
)))))
1179 (list (node-source-form use
)))))
1181 ;;; Return the LAMBDA that is CTRAN's home, or NIL if there is none.
1182 (declaim (ftype (sfunction (ctran) (or clambda null
))
1183 ctran-home-lambda-or-null
))
1184 (defun ctran-home-lambda-or-null (ctran)
1185 ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
1186 ;; implementation might not be quite right, or might be uglier than
1187 ;; necessary. It appears that the original Python never found a need
1188 ;; to do this operation. The obvious things based on
1189 ;; NODE-HOME-LAMBDA of CTRAN-USE usually work; then if that fails,
1190 ;; BLOCK-HOME-LAMBDA of CTRAN-BLOCK works, given that we
1191 ;; generalize it enough to grovel harder when the simple CMU CL
1192 ;; approach fails, and furthermore realize that in some exceptional
1193 ;; cases it might return NIL. -- WHN 2001-12-04
1194 (cond ((ctran-use ctran
)
1195 (node-home-lambda (ctran-use ctran
)))
1196 ((ctran-block ctran
)
1197 (block-home-lambda-or-null (ctran-block ctran
)))
1199 (bug "confused about home lambda for ~S" ctran
))))
1201 ;;; Return the LAMBDA that is CTRAN's home.
1202 (declaim (ftype (sfunction (ctran) clambda
) ctran-home-lambda
))
1203 (defun ctran-home-lambda (ctran)
1204 (ctran-home-lambda-or-null ctran
))
1206 (declaim (inline cast-single-value-p
))
1207 (defun cast-single-value-p (cast)
1208 (not (values-type-p (cast-asserted-type cast
))))
1210 (declaim (inline lvar-single-value-p
))
1211 (defun lvar-single-value-p (lvar)
1212 (or (not lvar
) (%lvar-single-value-p lvar
)))
1213 (defun %lvar-single-value-p
(lvar)
1214 (let ((dest (lvar-dest lvar
)))
1217 (lvar-single-value-p (node-lvar dest
)))
1221 (eq (basic-combination-fun dest
) lvar
))
1223 (and (cast-single-value-p dest
)
1224 (acond ((node-lvar dest
) (%lvar-single-value-p it
))
1228 (defun principal-lvar-end (lvar)
1229 (loop for prev
= lvar then
(node-lvar dest
)
1230 for dest
= (and prev
(lvar-dest prev
))
1232 finally
(return (values dest prev
))))
1234 (defun principal-lvar-single-valuify (lvar)
1235 (loop for prev
= lvar then
(node-lvar dest
)
1236 for dest
= (and prev
(lvar-dest prev
))
1237 while
(or (cast-p dest
)
1239 do
(setf (node-derived-type dest
)
1240 (make-short-values-type (list (single-value-type
1241 (node-derived-type dest
)))))
1242 (reoptimize-lvar prev
)))
1244 ;;; Return a new LEXENV just like DEFAULT except for the specified
1245 ;;; slot values. Values for the alist slots are APPENDed to the
1246 ;;; beginning of the current value, rather than replacing it entirely.
1247 (defun make-lexenv (&key
(default *lexenv
*)
1248 funs vars blocks tags
1250 (lambda (lexenv-lambda default
))
1251 (cleanup (lexenv-cleanup default
))
1252 (handled-conditions (lexenv-handled-conditions default
))
1253 (disabled-package-locks
1254 (lexenv-disabled-package-locks default
))
1255 (policy (lexenv-policy default
))
1256 (user-data (lexenv-user-data default
))
1259 (macrolet ((frob (var slot
)
1260 `(let ((old (,slot default
)))
1264 (internal-make-lexenv
1265 (frob funs lexenv-funs
)
1266 (frob vars lexenv-vars
)
1267 (frob blocks lexenv-blocks
)
1268 (frob tags lexenv-tags
)
1269 (frob type-restrictions lexenv-type-restrictions
)
1270 (frob flushable lexenv-flushable
)
1272 cleanup handled-conditions disabled-package-locks
1277 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
1279 (defun make-restricted-lexenv (lexenv &optional
(policy (lexenv-policy lexenv
)))
1280 (flet ((fun-good-p (fun)
1281 (destructuring-bind (name . thing
) fun
1282 (declare (ignore name
))
1286 (cons (aver (eq (car thing
) 'macro
))
1289 (destructuring-bind (name . thing
) var
1290 (declare (ignore name
))
1292 ;; The evaluator will mark lexicals with :BOGUS when it
1293 ;; translates an interpreter lexenv to a compiler
1295 ((or leaf
#+sb-eval
(member :bogus
)) nil
)
1296 (cons (aver (eq (car thing
) 'macro
))
1298 (heap-alien-info nil
)))))
1299 (internal-make-lexenv
1300 (remove-if-not #'fun-good-p
(lexenv-funs lexenv
))
1301 (remove-if-not #'var-good-p
(lexenv-vars lexenv
))
1304 (lexenv-type-restrictions lexenv
) ; XXX
1308 (lexenv-handled-conditions lexenv
)
1309 (lexenv-disabled-package-locks lexenv
)
1311 (lexenv-user-data lexenv
)
1314 ;;;; flow/DFO/component hackery
1316 ;;; Join BLOCK1 and BLOCK2.
1317 (defun link-blocks (block1 block2
)
1318 (declare (type cblock block1 block2
))
1319 (setf (block-succ block1
)
1320 (if (block-succ block1
)
1321 (%link-blocks block1 block2
)
1323 (push block1
(block-pred block2
))
1325 (defun %link-blocks
(block1 block2
)
1326 (declare (type cblock block1 block2
))
1327 (let ((succ1 (block-succ block1
)))
1328 (aver (not (memq block2 succ1
)))
1329 (cons block2 succ1
)))
1331 ;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2.
1332 (defun unlink-blocks (block1 block2
)
1333 (declare (type cblock block1 block2
))
1334 (let ((succ1 (block-succ block1
)))
1335 (if (eq block2
(car succ1
))
1336 (setf (block-succ block1
) (cdr succ1
))
1337 (do ((succ (cdr succ1
) (cdr succ
))
1339 ((eq (car succ
) block2
)
1340 (setf (cdr prev
) (cdr succ
)))
1343 (setf (block-pred block2
)
1344 (delq1 block1
(block-pred block2
)))
1347 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK
1348 ;;; and NEW. If BLOCK ends in an IF, then we have to fix up the
1349 ;;; consequent/alternative blocks to point to NEW.
1350 (defun change-block-successor (block old new
)
1351 (declare (type cblock new old block
))
1352 (unlink-blocks block old
)
1353 (let ((last (block-last block
))
1354 (comp (block-component block
)))
1355 (setf (component-reanalyze comp
) t
)
1358 (let* ((succ-left (block-succ block
))
1359 (new (if (and (eq new
(component-tail comp
))
1363 (unless (memq new succ-left
)
1364 (link-blocks block new
))
1365 (macrolet ((frob (slot)
1366 `(when (eq (,slot last
) old
)
1367 (setf (,slot last
) new
))))
1368 (frob if-consequent
)
1369 (frob if-alternative
)
1370 (when (eq (if-consequent last
)
1371 (if-alternative last
))
1372 (reoptimize-component (block-component block
) t
)))))
1374 (setf (jump-table-targets last
)
1375 (if (eq new
(component-tail comp
))
1376 (delete old
(jump-table-targets last
) :key
#'cdr
:test
#'eq
)
1378 (loop for
(index . target
) in
(jump-table-targets last
)
1379 collect
(cons index
(if (eq target old
)
1382 (unless (memq new
(block-succ block
))
1383 (link-blocks block new
)))))
1384 (unless (cdr (block-succ block
))
1385 (flush-dest (jump-table-index last
))
1386 (unlink-node last
)))
1388 (unless (memq new
(block-succ block
))
1389 (link-blocks block new
)))))
1393 (defun join-blocks-if-possible (component)
1394 (do-blocks (block component
)
1396 (and (singleton-p (block-succ block
))
1397 (join-successor-if-possible block t
)))))
1399 ;;; Try to join with a successor block. If we succeed, we return true,
1400 ;;; otherwise false.
1401 (defun join-successor-if-possible (block &optional local-calls
)
1402 (declare (type cblock block
))
1403 (let ((next (first (block-succ block
))))
1404 (when (block-start next
) ; NEXT is not an END-OF-COMPONENT marker
1405 (cond ( ;; We cannot combine with a successor block if:
1407 ;; the successor has more than one predecessor;
1408 (rest (block-pred next
))
1409 ;; the successor is the current block (infinite loop);
1411 ;; the next block has a different cleanup, and thus
1412 ;; we may want to insert cleanup code between the
1413 ;; two blocks at some point;
1414 (not (eq (block-end-cleanup block
)
1415 (block-start-cleanup next
)))
1416 ;; the next block has a different home lambda, and
1417 ;; thus the control transfer is a non-local exit.
1418 (not (eq (block-home-lambda block
)
1419 (block-home-lambda next
)))
1420 (neq (block-type-check block
)
1421 (block-type-check next
))
1422 (and (not local-calls
)
1423 (let ((last (block-last block
)))
1424 (and (combination-p last
)
1425 (eq (combination-kind last
) :local
)
1426 (functional-kind-eq (combination-lambda last
)
1427 nil assignment optional cleanup
)))))
1430 (join-blocks block next
)
1433 ;;; Join together two blocks. The code in BLOCK2 is moved into BLOCK1
1434 ;;; and BLOCK2 is deleted from the DFO. We combine the optimize flags
1435 ;;; for the two blocks so that any indicated optimization gets done.
1436 (defun join-blocks (block1 block2
)
1437 (declare (type cblock block1 block2
))
1438 (let* ((last1 (block-last block1
))
1439 (last2 (block-last block2
))
1440 (succ (block-succ block2
))
1441 (start2 (block-start block2
)))
1442 (do ((ctran start2
(node-next (ctran-next ctran
))))
1444 (setf (ctran-block ctran
) block1
))
1446 (unlink-blocks block1 block2
)
1447 (dolist (block succ
)
1448 (unlink-blocks block2 block
)
1449 (link-blocks block1 block
))
1451 (setf (ctran-kind start2
) :inside-block
)
1452 (setf (node-next last1
) start2
)
1453 (setf (ctran-use start2
) last1
)
1454 (setf (block-last block1
) last2
))
1456 (setf (block-flags block1
)
1457 (attributes-union (block-flags block1
)
1458 (block-flags block2
)))
1460 (let ((next (block-next block2
))
1461 (prev (block-prev block2
)))
1462 (setf (block-next prev
) next
)
1463 (setf (block-prev next
) prev
))
1467 ;;; Utility: return T if both argument cblocks are equivalent. For now,
1468 ;;; detect only blocks that read the same leaf into the same lvar, and
1469 ;;; continue to the same block.
1470 (defun blocks-equivalent-p (x y
)
1471 (declare (type cblock x y
))
1472 (let ((ref-x (single-ref-block-p x
))
1473 (ref-y (single-ref-block-p y
)))
1476 (equal (block-succ x
) (block-succ y
))
1477 (eq (ref-lvar ref-x
) (ref-lvar ref-y
))
1478 (let ((leaf-x (ref-leaf ref-x
))
1479 (leaf-y (ref-leaf ref-y
)))
1480 (or (eq leaf-x leaf-y
)
1481 (and (constant-p leaf-x
)
1483 (eq (constant-value leaf-x
)
1484 (constant-value leaf-y
)))))
1485 (eq (node-enclosing-cleanup ref-x
)
1486 (node-enclosing-cleanup ref-y
)))))
1488 (defun single-ref-block-p (block)
1489 (let ((start (block-start block
)))
1491 (let ((node (ctran-next start
)))
1493 (eq (block-last block
) node
)
1497 (defun if-test-redundant-p (test con alt
)
1498 (let ((ref-alt (single-ref-block-p alt
))
1499 (ref-con (single-ref-block-p con
))
1500 (ref-test (lvar-uses test
)))
1501 (and (ref-p ref-test
)
1504 (equal (block-succ alt
) (block-succ con
))
1505 (eq (ref-lvar ref-alt
) (ref-lvar ref-con
))
1506 (eq (ref-leaf ref-con
) (ref-leaf ref-test
))
1507 (and (constant-p (ref-leaf ref-alt
))
1508 (null (constant-value (ref-leaf ref-alt
))))
1509 (eq (node-enclosing-cleanup ref-alt
)
1510 (node-enclosing-cleanup ref-con
)))))
1512 ;;; If a block consisting of a single ref is equivalent to another
1513 ;;; block with the same ref and the have the same successor it can be
1516 ;;; Removing more is tricky, debugging will suffer, and code relying
1517 ;;; on constraint propagation will break, e.g.
1518 ;;; (if (simple-vector-p x) (aref x 0) (aref x 0)))
1519 ;;; 344d4d778 contains some code that handles combinations and casts.
1520 (defun remove-equivalent-blocks (block)
1521 (let ((pred (block-pred block
)))
1523 (loop for
(block1 . rest
) on pred
1524 when
(and (not (block-delete-p block1
))
1525 (single-ref-block-p block1
))
1527 (loop for block2 in rest
1528 when
(and (not (block-delete-p block1
))
1529 (blocks-equivalent-p block1 block2
))
1531 (let* ((ref1 (block-start-node block1
))
1532 (ref2 (block-start-node block2
))
1533 (type1 (node-derived-type ref1
))
1534 (type2 (node-derived-type ref2
)))
1535 ;; Constraint propagation may have given the
1536 ;; references different types. Join them back.
1537 (unless (eq type1 type2
)
1538 (derive-node-type ref1
1539 (values-type-union type1 type2
)
1541 (loop for pred in
(block-pred block2
)
1543 (change-block-successor pred block2 block1
))
1544 (delete-block block2 t
))))))
1546 ;;; Unlink a block from the next/prev chain. We also null out the
1548 (declaim (inline remove-from-dfo
))
1549 (defun remove-from-dfo (block)
1550 (declare (type cblock block
))
1551 (let ((next (block-next block
))
1552 (prev (block-prev block
)))
1553 (setf (block-component block
) nil
)
1554 (setf (block-next prev
) next
)
1555 (setf (block-prev next
) prev
))
1558 ;;; Add BLOCK to the next/prev chain following AFTER. We also set the
1559 ;;; COMPONENT to be the same as for AFTER.
1560 (declaim (inline add-to-dfo
))
1561 (defun add-to-dfo (block after
)
1562 (declare (type cblock block after
))
1563 (let ((next (block-next after
))
1564 (comp (block-component after
)))
1565 (aver (not (eq (component-kind comp
) :deleted
)))
1566 (setf (block-component block
) comp
)
1567 (setf (block-next after
) block
)
1568 (setf (block-prev block
) after
)
1569 (setf (block-next block
) next
)
1570 (setf (block-prev next
) block
))
1573 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
1574 ;;; the head and tail which are set to T.
1575 (defun clear-flags (component)
1576 (declare (type component component
))
1577 (let ((head (component-head component
))
1578 (tail (component-tail component
)))
1579 (setf (block-flag head
) t
)
1580 (setf (block-flag tail
) t
)
1581 (do-blocks (block component
)
1582 (setf (block-flag block
) nil
)))
1585 ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially
1586 ;;; true in the head and tail blocks.
1587 (defun make-empty-component ()
1588 #-sb-xc-host
(declare (values component
))
1589 (let* ((head (make-block-key :start nil
:component nil
))
1590 (tail (make-block-key :start nil
:component nil
))
1591 (res (make-component head tail
)))
1592 (setf (block-flag head
) t
)
1593 (setf (block-flag tail
) t
)
1594 (setf (block-component head
) res
)
1595 (setf (block-component tail
) res
)
1596 (setf (block-next head
) tail
)
1597 (setf (block-prev tail
) head
)
1600 ;;; Make NODE the LAST node in its block, splitting the block if necessary.
1601 ;;; The new block is added to the DFO immediately following NODE's block.
1602 ;;; Returns the new block if it's created.
1603 (defun node-ends-block (node)
1604 (declare (type node node
))
1605 (let* ((block (node-block node
))
1606 (start (node-next node
))
1607 (last (block-last block
)))
1608 (unless (eq last node
)
1609 (aver (and (eq (ctran-kind start
) :inside-block
)
1610 (not (block-delete-p block
))))
1611 (let* ((succ (block-succ block
))
1613 (make-block-key :start start
1614 :component
(block-component block
)
1615 :succ succ
:last last
)))
1616 (setf (block-type-check new-block
)
1617 (block-type-check block
))
1618 (setf (ctran-kind start
) :block-start
)
1619 (setf (ctran-use start
) nil
)
1620 (setf (block-last block
) node
)
1621 (setf (node-next node
) nil
)
1623 (setf (block-pred b
)
1624 (nsubstitute new-block block
(block-pred b
)
1626 (setf (block-succ block
) ())
1627 (link-blocks block new-block
)
1628 (add-to-dfo new-block block
)
1629 (setf (component-reanalyze (block-component block
)) t
)
1631 (do ((ctran start
(node-next (ctran-next ctran
))))
1633 (setf (ctran-block ctran
) new-block
))
1639 (declaim (start-block delete-ref delete-functional flush-node flush-dest
1640 delete-lvar delete-block delete-block-lazily delete-lambda
1643 ;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
1644 (defun delete-lambda-var (leaf)
1645 (declare (type lambda-var leaf
))
1647 (setf (lambda-var-deleted leaf
) t
)
1648 ;; Iterate over all local calls flushing the corresponding argument,
1649 ;; allowing the computation of the argument to be deleted. We also
1650 ;; mark the LET for reoptimization, since it may be that we have
1651 ;; deleted its last variable.
1652 (let* ((fun (lambda-var-home leaf
))
1653 (n (position leaf
(lambda-vars fun
))))
1654 (dolist (ref (leaf-refs fun
))
1655 (let* ((lvar (node-lvar ref
))
1656 (dest (and lvar
(lvar-dest lvar
))))
1657 (when (and (basic-combination-p dest
)
1658 (eq (basic-combination-fun dest
) lvar
)
1659 (eq (basic-combination-kind dest
) :local
))
1660 (cond ((mv-combination-p dest
)
1661 ;; Let FLUSH-DEAD-CODE deal with it
1662 ;; since it's a bit tricky to delete multiple-valued
1663 ;; args and existing code doesn't expect to see NIL in
1664 ;; mv-combination-args.
1665 (reoptimize-node dest
)
1666 (setf (block-flush-p (node-block dest
)) t
))
1668 (let* ((args (basic-combination-args dest
))
1670 (reoptimize-lvar arg
)
1672 (setf (elt args n
) nil
))))))))
1674 ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
1675 ;; too much difficulty, since we can efficiently implement
1676 ;; write-only variables. We iterate over the SETs, marking their
1677 ;; blocks for dead code flushing, since we can delete SETs whose
1679 (dolist (set (lambda-var-sets leaf
))
1680 (setf (block-flush-p (node-block set
)) t
))
1684 ;;; Delete a function that has no references. This need only be called
1685 ;;; on functions that never had any references, since otherwise
1686 ;;; DELETE-REF will handle the deletion.
1687 (defun delete-functional (fun)
1688 (aver (and (null (leaf-refs fun
))
1689 (not (functional-entry-fun fun
))))
1691 (optional-dispatch (delete-optional-dispatch fun
))
1692 (clambda (delete-lambda fun
)))
1695 (defun lambda-ever-used-p (lambda)
1696 (let ((optional-dispatch (lambda-optional-dispatch lambda
)))
1697 (if optional-dispatch
1698 (or (leaf-ever-used optional-dispatch
)
1699 ;; Warn only for the main entry
1700 (not (eq (optional-dispatch-main-entry optional-dispatch
)
1702 (leaf-ever-used lambda
))))
1704 ;;; Deal with deleting the last reference to a CLAMBDA, which means
1705 ;;; that the lambda is unreachable, so that its body may be
1706 ;;; deleted. We set FUNCTIONAL-KIND to :DELETED and rely on
1707 ;;; IR1-OPTIMIZE to delete its blocks.
1708 (defun delete-lambda (clambda)
1709 (declare (type clambda clambda
))
1710 (let ((original-kind (functional-kind clambda
))
1711 (bind (lambda-bind clambda
)))
1712 (aver (not (logtest original-kind
(functional-kind-attributes deleted toplevel
))))
1713 (aver (not (functional-has-external-references-p clambda
)))
1714 (aver (or (eql original-kind
(functional-kind-attributes zombie
)) bind
))
1715 (setf (functional-kind clambda
) (functional-kind-attributes deleted
))
1716 (setf (lambda-bind clambda
) nil
)
1718 ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
1719 ;; that we're using the old value of the KIND slot, not the
1720 ;; current slot value, which has now been set to :DELETED.)
1722 ((eql original-kind
(functional-kind-attributes zombie
)))
1723 ((logtest original-kind
(functional-kind-attributes let mv-let assignment
))
1724 (let ((bind-block (node-block bind
)))
1725 (mark-for-deletion bind-block
))
1726 (let ((home (lambda-home clambda
)))
1727 (setf (lambda-lets home
) (delete clambda
(lambda-lets home
)))))
1729 ;; Function has no reachable references.
1730 (dolist (ref (lambda-refs clambda
))
1731 (mark-for-deletion (node-block ref
)))
1732 ;; If the function isn't a LET, we unlink the function head
1733 ;; and tail from the component head and tail to indicate that
1734 ;; the code is unreachable. We also delete the function from
1735 ;; COMPONENT-LAMBDAS (it won't be there before local call
1736 ;; analysis, but no matter.) If the lambda was never
1737 ;; referenced, we give a note.
1738 (let* ((bind-block (node-block bind
))
1739 (component (block-component bind-block
))
1740 (return (lambda-return clambda
))
1741 (return-block (and return
(node-block return
))))
1742 (unless (lambda-ever-used-p clambda
)
1743 (let ((*compiler-error-context
* bind
))
1744 (compiler-notify 'code-deletion-note
1745 :format-control
"deleting unused function~:[.~;~:*~% ~S~]"
1746 :format-arguments
(list (leaf-debug-name clambda
)))))
1747 (unless (block-delete-p bind-block
)
1748 (unlink-blocks (component-head component
) bind-block
))
1749 (when (and return-block
(not (block-delete-p return-block
)))
1750 (mark-for-deletion return-block
)
1751 (unlink-blocks return-block
(component-tail component
)))
1752 (setf (component-reanalyze component
) t
)
1753 (let ((tails (lambda-tail-set clambda
)))
1754 (setf (tail-set-funs tails
)
1755 (delete clambda
(tail-set-funs tails
)))
1756 (setf (lambda-tail-set clambda
) nil
))
1757 (setf (component-lambdas component
)
1758 (delq1 clambda
(component-lambdas component
))))))
1760 ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
1761 ;; ENTRY-FUN so that people will know that it is not an entry
1763 (when (eql original-kind
(functional-kind-attributes external
))
1764 (let ((fun (functional-entry-fun clambda
)))
1765 (setf (functional-entry-fun fun
) nil
)
1766 (when (optional-dispatch-p fun
)
1767 (delete-optional-dispatch fun
)))))
1771 ;;; Deal with deleting the last reference to an OPTIONAL-DISPATCH. We
1772 ;;; have to be a bit more careful than with lambdas, since DELETE-REF
1773 ;;; is used both before and after local call analysis. Afterward, all
1774 ;;; references to still-existing OPTIONAL-DISPATCHes have been moved
1775 ;;; to the XEP, leaving it with no references at all. So we look at
1776 ;;; the XEP to see whether an optional-dispatch is still really being
1777 ;;; used. But before local call analysis, there are no XEPs, and all
1778 ;;; references are direct.
1780 ;;; When we do delete the OPTIONAL-DISPATCH, we grovel all of its
1781 ;;; entry-points, making them be normal lambdas, and then deleting the
1782 ;;; ones with no references. This deletes any e-p lambdas that were
1783 ;;; either never referenced, or couldn't be deleted when the last
1784 ;;; reference was deleted (due to their :OPTIONAL kind.)
1786 ;;; Note that the last optional entry point may alias the main entry,
1787 ;;; so when we process the main entry, its KIND may have been changed
1788 ;;; to NIL or even converted to a LETlike value.
1789 (defun delete-optional-dispatch (leaf)
1790 (declare (type optional-dispatch leaf
))
1791 (let ((entry (functional-entry-fun leaf
)))
1793 (or (leaf-refs entry
)
1794 (functional-kind-eq entry external
)))
1795 (aver (or (not entry
) (functional-kind-eq entry deleted
)))
1796 (setf (functional-kind leaf
) (functional-kind-attributes deleted
))
1799 (unless (functional-kind-eq fun deleted
)
1800 (aver (functional-kind-eq fun optional
))
1801 (setf (functional-kind fun
) (functional-kind-attributes nil
))
1803 (or (maybe-let-convert fun
)
1804 (maybe-convert-to-assignment fun
)
1805 (reoptimize-lambda fun
))
1806 (delete-lambda fun
)))))
1807 (dolist (ep (optional-dispatch-entry-points leaf
))
1808 (when (promise-ready-p ep
)
1810 (when (optional-dispatch-more-entry leaf
)
1811 (frob (optional-dispatch-more-entry leaf
)))
1812 (let ((main (optional-dispatch-main-entry leaf
)))
1814 (setf (functional-entry-fun entry
) main
)
1815 (setf (functional-entry-fun main
) entry
))
1816 (when (functional-kind-eq main optional
)
1821 ;; Trigger PROPAGATE-LOCAL-CALL-ARGS
1822 (defun reoptimize-lambda (fun)
1823 (loop for ref in
(leaf-refs fun
)
1824 for dest
= (node-dest ref
)
1825 when
(basic-combination-p dest
)
1826 do
(reoptimize-node dest
)
1827 (loop for arg in
(basic-combination-args dest
)
1828 do
(reoptimize-lvar arg
))))
1830 ;;; Do stuff to delete the semantic attachments of a REF node. When
1831 ;;; this leaves zero or one reference, we do a type dispatch off of
1832 ;;; the leaf to determine if a special action is appropriate.
1833 (defun delete-ref (ref)
1834 (declare (type ref ref
))
1835 (let* ((leaf (ref-leaf ref
))
1836 (refs (delq1 ref
(leaf-refs leaf
)))
1837 (home (node-home-lambda ref
)))
1838 (setf (leaf-refs leaf
) refs
)
1839 (when (and (typep leaf
'(or clambda lambda-var
))
1840 (not (find home refs
:key
#'node-home-lambda
)))
1841 ;; It was the last reference from this lambda, remove it
1842 (sset-delete leaf
(lambda-calls-or-closes home
)))
1845 (clambda (or (maybe-let-convert leaf
)
1846 (maybe-convert-to-assignment leaf
)
1847 (reoptimize-lambda leaf
)))
1848 (lambda-var (reoptimize-lambda-var leaf
)))
1851 (delete-lambda-var leaf
))
1853 (functional-kind-ecase leaf
1854 ((nil let mv-let assignment escape cleanup
)
1855 (delete-lambda leaf
))
1857 (unless (functional-has-external-references-p leaf
)
1858 (delete-lambda leaf
)))
1859 ((deleted zombie optional
))))
1861 (unless (functional-kind-eq leaf deleted
)
1862 (delete-optional-dispatch leaf
))))))
1866 ;;; This function is called to unlink a node from its LVAR;
1867 ;;; we assume that the LVAR's USE list has already been updated,
1868 ;;; and that we only have to mark the node as up for dead code
1869 ;;; elimination, and to clear it LVAR slot.
1870 (defun flush-node (node)
1871 (declare (type node node
))
1872 (let* ((prev (node-prev node
))
1873 (block (ctran-block prev
)))
1874 (reoptimize-component (block-component block
) t
)
1875 (setf (block-flush-p block
) t
))
1876 (setf (node-lvar node
) nil
))
1878 ;;; This function is called by people who delete nodes; it provides a
1879 ;;; way to indicate that the value of a lvar is no longer used. We
1880 ;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses
1881 ;;; of LVAR and set COMPONENT-REOPTIMIZE.
1882 (defun flush-dest (lvar)
1883 (declare (type (or lvar null
) lvar
))
1885 (setf (lvar-dest lvar
) nil
)
1888 (setf (lvar-uses lvar
) nil
))
1891 ;;; Queue the block for deletion
1892 (defun delete-block-lazily (block)
1893 (declare (type cblock block
))
1894 (unless (block-delete-p block
)
1895 (setf (block-delete-p block
) t
)
1896 (push block
(component-delete-blocks (block-component block
)))))
1898 ;;; Do a graph walk backward from BLOCK, marking all predecessor
1899 ;;; blocks with the DELETE-P flag.
1900 (defun mark-for-deletion (block)
1901 (declare (type cblock block
))
1902 (let* ((component (block-component block
))
1903 (head (component-head component
)))
1904 (labels ((helper (block)
1905 (delete-block-lazily block
)
1906 (dolist (pred (block-pred block
))
1907 (unless (or (block-delete-p pred
)
1910 (unless (block-delete-p block
)
1912 (setf (component-reanalyze component
) t
))))
1915 ;;; This function does what is necessary to eliminate the code in it
1916 ;;; from the IR1 representation. This involves unlinking it from its
1917 ;;; predecessors and successors and deleting various node-specific
1918 ;;; semantic information. BLOCK must be already removed from
1919 ;;; COMPONENT-DELETE-BLOCKS.
1920 (defun delete-block (block &optional silent
)
1921 (declare (type cblock block
))
1922 (unless (block-component block
)
1924 (return-from delete-block
))
1925 #+high-security
(aver (not (memq block
(component-delete-blocks (block-component block
)))))
1927 (note-block-deletion block
))
1928 (setf (block-delete-p block
) t
)
1930 (dolist (b (block-pred block
))
1931 (unlink-blocks b block
)
1932 ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
1933 ;; broken when successors were deleted without setting the
1934 ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
1935 ;; doesn't happen again.
1936 (aver (not (and (null (block-succ b
))
1937 (not (block-delete-p b
))
1938 (not (eq b
(component-head (block-component b
))))))))
1939 (dolist (b (block-succ block
))
1940 (unlink-blocks block b
))
1942 (do-nodes-carefully (node block
)
1943 (when (valued-node-p node
)
1944 (delete-lvar-use node
))
1946 (ref (delete-ref node
))
1947 (cif (flush-dest (if-test node
)))
1948 (jump-table (flush-dest (jump-table-index node
)))
1949 ;; The next two cases serve to maintain the invariant that a LET
1950 ;; always has a well-formed COMBINATION, REF and BIND. We delete
1951 ;; the lambda whenever we delete any of these, but we must be
1952 ;; careful that this LET has not already been partially deleted.
1954 (when (and (eq (basic-combination-kind node
) :local
)
1955 ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
1956 (lvar-uses (basic-combination-fun node
)))
1957 (let ((fun (combination-lambda node
)))
1958 ;; If our REF was the second-to-last ref, and has been
1959 ;; deleted, then FUN may be a LET for some other
1961 (when (and (functional-letlike-p fun
)
1962 (eq (let-combination fun
) node
))
1963 (delete-lambda fun
))))
1964 (flush-dest (basic-combination-fun node
))
1965 (dolist (arg (basic-combination-args node
))
1966 (when arg
(flush-dest arg
))))
1968 (let ((lambda (bind-lambda node
)))
1969 (unless (functional-kind-eq lambda deleted
)
1970 (delete-lambda lambda
))))
1972 (let ((value (exit-value node
))
1973 (entry (exit-entry node
)))
1977 (setf (entry-exits entry
)
1978 (delq1 node
(entry-exits entry
))))))
1980 (dolist (exit (entry-exits node
))
1981 (mark-for-deletion (node-block exit
)))
1982 (let ((home (node-home-lambda node
)))
1983 (setf (lambda-entries home
) (delq1 node
(lambda-entries home
)))))
1985 (flush-dest (return-result node
))
1986 (delete-return node
))
1988 (flush-dest (set-value node
))
1989 (let ((var (set-var node
)))
1990 (setf (basic-var-sets var
)
1991 (delete node
(basic-var-sets var
)))))
1993 (flush-dest (cast-value node
)))
1997 (remove-from-dfo block
)
2000 (declaim (end-block))
2002 ;;; Do stuff to indicate that the return node NODE is being deleted.
2003 (defun delete-return (node)
2004 (declare (type creturn node
))
2005 (let* ((fun (return-lambda node
))
2006 (tail-set (lambda-tail-set fun
)))
2007 (aver (lambda-return fun
))
2008 (setf (lambda-return fun
) nil
)
2009 (when (and tail-set
(not (find-if #'lambda-return
2010 (tail-set-funs tail-set
))))
2011 (setf (tail-set-type tail-set
) *empty-type
*)))
2014 ;;; If any of the VARS in FUN was never referenced and was not
2015 ;;; declared IGNORE, then complain.
2016 (defun note-unreferenced-vars (vars policy
)
2018 (unless (or (eq (leaf-ever-used var
) t
) (lambda-var-ignorep var
))
2019 (let ((*lexenv
* (if (node-p *compiler-error-context
*)
2020 (node-lexenv *compiler-error-context
*)
2022 (*compiler-error-context
*
2023 (or (get-source-path (lambda-var-source-form var
))
2024 *compiler-error-context
*)))
2025 (unless (policy policy
(= inhibit-warnings
3))
2026 ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
2027 ;; requires this to be no more than a STYLE-WARNING.
2028 ;; There's no reason to accept this kind of equivocation
2029 ;; when compiling our own code, though.
2030 (#-sb-xc-host compiler-style-warn
#+sb-xc-host warn
2031 (if (eq (leaf-ever-used var
) 'set
)
2032 "The variable ~S is assigned but never read."
2033 "The variable ~S is defined but never used.")
2034 (leaf-debug-name var
))))
2035 (setf (leaf-ever-used var
) t
)))) ; to avoid repeated warnings? -- WHN
2037 (defun note-unreferenced-fun-vars (fun)
2038 (declare (type clambda fun
))
2039 (let ((*compiler-error-context
* (lambda-bind fun
)))
2040 (note-unreferenced-vars (lambda-vars fun
)
2041 *compiler-error-context
*))
2044 ;;; Note that something interesting has happened to VAR.
2045 (defun reoptimize-lambda-var (var)
2046 (declare (type lambda-var var
))
2047 (let ((fun (lambda-var-home var
)))
2048 ;; We only deal with LET variables, marking the corresponding
2049 ;; initial value arg as needing to be reoptimized.
2050 (when (and (functional-kind-eq fun let
)
2052 (do ((args (basic-combination-args
2053 (lvar-dest (node-lvar (first (leaf-refs fun
)))))
2055 (vars (lambda-vars fun
) (cdr vars
)))
2056 ((eq (car vars
) var
)
2057 (reoptimize-lvar (car args
))))))
2060 ;;; Return true if we can find OBJ in FORM, NIL otherwise. We bound
2061 ;;; our recursion so that we don't get lost in circular structures. We
2062 ;;; ignore the car of forms if they are a symbol (to prevent confusing
2063 ;;; function referencess with variables), and we also ignore anything
2065 (defun present-in-form (obj form depth
)
2066 (declare (type (integer 0 20) depth
))
2067 (cond ((= depth
20) nil
)
2071 (let ((first (car form
))
2073 (if (member first
'(quote function
))
2075 (or (and (not (symbolp first
))
2076 (present-in-form obj first depth
))
2077 (do ((l (cdr form
) (cdr l
))
2079 ((or (atom l
) (> n
100))
2081 (declare (fixnum n
))
2082 (when (present-in-form obj
(car l
) depth
)
2085 ;;; This function is called on a block immediately before we delete
2086 ;;; it. We check to see whether any of the code about to die appeared
2087 ;;; in the original source, and emit a note if so.
2089 ;;; If the block was in a lambda is now deleted, then we ignore the
2090 ;;; whole block, since this case is picked off in DELETE-LAMBDA. We
2091 ;;; also ignore the deletion of CRETURN nodes, since it is somewhat
2092 ;;; reasonable for a function to not return, and there is a different
2093 ;;; note for that case anyway.
2095 ;;; If the actual source is an atom, then we use a bunch of heuristics
2096 ;;; to guess whether this reference really appeared in the original
2098 ;;; -- If a symbol, it must be interned and not a keyword.
2099 ;;; -- It must not be an easily introduced constant (T or NIL, a fixnum
2100 ;;; or a character.)
2101 ;;; -- The atom must be "present" in the original source form, and
2102 ;;; present in all intervening actual source forms.
2103 (defun note-block-deletion (block)
2104 (let ((home (block-home-lambda block
)))
2105 (unless (or (functional-kind-eq home deleted
)
2106 (block-delete-p (lambda-block home
)))
2107 (do-nodes (node nil block
)
2108 (let* ((path (node-source-path node
))
2109 (ctran-path (ctran-source-path (node-prev node
))))
2110 (flet ((visible-p (path)
2111 (let ((first (first path
)))
2112 (or (eq first
'original-source-start
)
2114 (or (not (symbolp first
))
2115 (let ((pkg (cl:symbol-package first
)))
2116 (and pkg
(neq pkg
*keyword-package
*))))
2117 (not (member first
'(t nil
)))
2118 (not (cl:typep first
'(or fixnum character
2119 #+64-bit single-float
)))
2121 (present-in-form first x
0))
2122 (source-path-forms path
))
2123 (present-in-form first
(find-original-source path
)
2125 (cond ((and ctran-path
2126 (visible-p ctran-path
))
2127 (push (cons ctran-path
(node-lexenv node
))
2128 (deleted-source-paths *compilation
*))
2130 ((and (not (return-p node
))
2131 ;; CASTs are just value filters and do not
2132 ;; represent code and they can be moved around
2133 ;; making CASTs from the original source code
2134 ;; appear in code inserted by the compiler, generating
2135 ;; false deletion notes.
2136 ;; And if a block with the original source gets
2137 ;; deleted the node that produces the value for
2138 ;; the CAST will get a note, no need to note
2141 ;; Nothing interesting in BIND nodes
2143 ;; Try to get the outer deleted node.
2144 (not (and (valued-node-p node
)
2145 (let ((dest (node-dest node
)))
2147 (node-to-be-deleted-p dest
)
2148 (node-source-inside-p node dest
)))))
2150 (push (cons path
(node-lexenv node
))
2151 (deleted-source-paths *compilation
*))
2155 (defun node-source-inside-p (inner-node outer-node
)
2156 (tailp (source-path-original-source (node-source-path outer-node
))
2157 (source-path-original-source (node-source-path inner-node
))))
2159 (defun report-code-deletion ()
2160 (let ((forms (make-hash-table :test
#'equal
))
2162 ;; Report only the outermost form
2163 (loop for pair in
(shiftf (deleted-source-paths *compilation
*) nil
)
2166 (when (eq (car path
) 'original-source-start
)
2167 (setf (gethash (source-path-original-source path
) forms
) path
))
2168 (push pair reversed-path
))
2169 (loop for
(path . lexenv
) in reversed-path
2170 for original
= (source-path-original-source path
)
2171 when
(loop for outer on
(if (eq (car path
) 'original-source-start
)
2174 never
(gethash outer forms
))
2176 (let ((*current-path
* path
)
2178 (compiler-notify 'code-deletion-note
2179 :format-control
"deleting unreachable code"
2180 :format-arguments nil
)))))
2182 (defun maybe-reoptimize-previous-node (ctran block
)
2183 (flet ((maybe-reoptimize (node)
2184 (when (basic-combination-p node
)
2185 (let ((fun-info (basic-combination-fun-info node
)))
2187 (ir1-attributep (fun-info-attributes fun-info
)
2188 reoptimize-when-unlinking
))
2189 (reoptimize-node node
))))))
2190 (case (ctran-kind ctran
)
2192 (maybe-reoptimize (ctran-use ctran
)))
2194 (dolist (pred (block-pred block
))
2195 (maybe-reoptimize (block-last pred
)))))))
2197 ;;; Delete a node from a block, deleting the block if there are no
2198 ;;; nodes left. We remove the node from the uses of its LVAR.
2200 ;;; If the node is the last node, there must be exactly one successor.
2201 ;;; We link all of our precedessors to the successor and unlink the
2202 ;;; block. In this case, we return T, otherwise NIL. If no nodes are
2203 ;;; left, and the block is a successor of itself, then we replace the
2204 ;;; only node with a degenerate exit node. This provides a way to
2205 ;;; represent the bodyless infinite loop, given the prohibition on
2206 ;;; empty blocks in IR1.
2207 (defun unlink-node (node)
2208 (declare (type node node
))
2209 (when (valued-node-p node
)
2210 (delete-lvar-use node
))
2211 (let* ((ctran (node-next node
))
2212 (next (and ctran
(ctran-next ctran
)))
2213 (prev (node-prev node
))
2214 (block (ctran-block prev
))
2215 (prev-kind (ctran-kind prev
))
2216 (last (block-last block
)))
2217 (maybe-reoptimize-previous-node prev block
)
2218 (cond ((or (eq prev-kind
:inside-block
)
2219 (and (eq prev-kind
:block-start
)
2220 (not (eq node last
))))
2221 (cond ((eq node last
)
2222 (setf (block-last block
) (ctran-use prev
))
2223 (setf (node-next (ctran-use prev
)) nil
))
2225 (setf (ctran-next prev
) next
)
2226 (setf (node-prev next
) prev
)
2227 (unless (ctran-source-path prev
)
2228 (setf (ctran-source-path prev
) (ctran-source-path ctran
)))
2230 (reoptimize-lvar (if-test next
)))))
2231 (setf (node-prev node
) nil
)
2234 (aver (eq prev-kind
:block-start
))
2235 (aver (eq node last
))
2236 (let* ((succ (block-succ block
))
2237 (next (first succ
)))
2238 (aver (singleton-p succ
))
2240 ((eq block
(first succ
))
2241 (with-ir1-environment-from-node node
2242 (let ((exit (make-exit)))
2243 (setf (ctran-next prev
) nil
)
2244 (link-node-to-previous-ctran exit prev
)
2245 (setf (block-last block
) exit
)))
2246 (setf (node-prev node
) nil
)
2249 (aver (eq (block-start-cleanup block
)
2250 (block-end-cleanup block
)))
2251 (unlink-blocks block next
)
2252 (dolist (pred (block-pred block
))
2253 (change-block-successor pred block next
))
2254 (when (block-delete-p block
)
2255 (let ((component (block-component block
)))
2256 (setf (component-delete-blocks component
)
2257 (delq1 block
(component-delete-blocks component
)))))
2258 (remove-from-dfo block
)
2259 (setf (block-delete-p block
) t
)
2260 (setf (node-prev node
) nil
)
2263 ;;; Return true if CTRAN has been deleted, false if it is still a valid
2265 (defun ctran-deleted-p (ctran)
2266 (declare (type ctran ctran
))
2267 (let ((block (ctran-block ctran
)))
2268 (or (not (block-component block
))
2269 (block-delete-p block
))))
2271 ;;; Return true if NODE has been deleted, false if it is still a valid
2273 (defun node-deleted (node)
2274 (declare (type node node
))
2275 (let ((prev (node-prev node
)))
2277 (ctran-deleted-p prev
))))
2279 ;;; Delete all the blocks and functions in COMPONENT. We scan first
2280 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
2281 ;;; triggered by deletion.
2282 (defun delete-component (component)
2283 (declare (type component component
))
2284 (aver (null (component-new-functionals component
)))
2285 (setf (component-kind component
) :deleted
)
2286 (do-blocks (block component
)
2287 (delete-block-lazily block
))
2288 (dolist (fun (component-lambdas component
))
2289 (unless (functional-kind-eq fun deleted
)
2290 (setf (functional-kind fun
) (functional-kind-attributes nil
))
2291 (setf (functional-entry-fun fun
) nil
)
2292 (setf (leaf-refs fun
) nil
)
2293 (delete-functional fun
)))
2294 (clean-component component
)
2297 ;;; Remove all pending blocks to be deleted. Return the nearest live
2298 ;;; block after or equal to BLOCK.
2299 (defun clean-component (component &optional block
)
2300 (loop while
(component-delete-blocks component
)
2301 ;; actual deletion of a block may queue new blocks
2302 do
(let ((current (pop (component-delete-blocks component
))))
2303 (when (eq block current
)
2304 (setq block
(block-next block
)))
2305 (delete-block current
)))
2308 ;;; Convert code of the form
2309 ;;; (FOO ... (FUN ...) ...)
2311 ;;; (FOO ... ... ...).
2312 ;;; In other words, replace the function combination FUN by its
2313 ;;; arguments. If there are any problems with doing this, use GIVE-UP
2314 ;;; to blow out of whatever transform called this. Note, as the number
2315 ;;; of arguments changes, the transform must be prepared to return a
2316 ;;; lambda with a new lambda-list with the correct number of
2318 (defun splice-fun-args (lvar fun num-args
&optional
(give-up t
))
2319 "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed
2320 directly to the LVAR-DEST of LVAR, which must be a combination. If FUN
2321 is :ANY, the function name is not checked."
2322 (declare (type lvar lvar
)
2324 (type (or index null
) num-args
))
2327 (give-up-ir1-transform)
2328 (return-from splice-fun-args nil
))))
2329 (let ((outside (lvar-dest lvar
))
2330 (inside (lvar-uses lvar
)))
2331 (aver (combination-p outside
))
2332 (unless (combination-p inside
)
2334 (let ((inside-fun (combination-fun inside
)))
2335 (unless (or (eq fun
:any
)
2336 (eq (lvar-fun-name inside-fun
) fun
))
2339 (let ((inside-args (combination-args inside
)))
2341 (unless (= (length inside-args
) num-args
)
2343 (let* ((outside-args (combination-args outside
))
2344 (arg-position (position lvar outside-args
))
2345 (before-args (subseq outside-args
0 arg-position
))
2346 (after-args (subseq outside-args
(1+ arg-position
))))
2347 (dolist (arg inside-args
)
2348 (setf (lvar-dest arg
) outside
))
2349 (setf (combination-args inside
) nil
)
2350 (setf (combination-args outside
)
2351 (append before-args inside-args after-args
))
2352 (change-ref-leaf (lvar-uses inside-fun
)
2353 (find-free-fun 'list
"???"))
2354 (setf (combination-fun-info inside
) (info :function
:info
'list
)
2355 (combination-kind inside
) :known
)
2356 (setf (node-derived-type inside
) *wild-type
*)
2360 ;;; Eliminate keyword arguments from the call (leaving the
2361 ;;; parameters in place.
2363 ;;; (FOO ... :BAR X :QUUX Y)
2367 ;;; SPECS is a list of (:KEYWORD PARAMETER) specifications.
2368 ;;; Returns the list of specified parameters names in the
2369 ;;; order they appeared in the call. N-POSITIONAL is the
2370 ;;; number of positional arguments in th call.
2371 (defun eliminate-keyword-args (call n-positional specs
)
2372 (let* ((specs (copy-tree specs
))
2373 (all (combination-args call
))
2374 (new-args (reverse (subseq all
0 n-positional
)))
2375 (key-args (subseq all n-positional
))
2378 (loop while key-args
2379 do
(let* ((key (pop key-args
))
2380 (val (pop key-args
))
2381 (keyword (if (constant-lvar-p key
)
2383 (give-up-ir1-transform)))
2384 (spec (or (assoc keyword specs
:test
#'eq
)
2385 (give-up-ir1-transform))))
2387 (push key flushed-keys
)
2388 (push (second spec
) parameters
)
2389 ;; In case of duplicate keys.
2390 (setf (second spec
) (gensym))))
2391 (dolist (key flushed-keys
)
2393 (setf (combination-args call
) (reverse new-args
))
2394 (reverse parameters
)))
2396 (defun extract-fun-args (lvar fun num-args
)
2397 (declare (type lvar lvar
)
2398 (type (or symbol list
) fun
)
2399 (type index num-args
))
2400 (let ((inside (lvar-uses lvar
)))
2401 (unless (combination-p inside
)
2402 (give-up-ir1-transform))
2403 (let ((inside-fun (combination-fun inside
)))
2404 (unless (member (lvar-fun-name inside-fun
) (ensure-list fun
))
2405 (give-up-ir1-transform))
2406 (let ((inside-args (combination-args inside
)))
2407 (unless (= (length inside-args
) num-args
)
2408 (give-up-ir1-transform))
2409 (values (lvar-fun-name inside-fun
) inside-args
)))))
2411 (defun flush-combination (combination)
2412 (declare (type combination combination
))
2413 (flush-dest (combination-fun combination
))
2414 (dolist (arg (combination-args combination
))
2416 (unlink-node combination
)
2419 (defun replace-combination-with-constant (constant combination
)
2420 (when (producing-fasl-file)
2421 (handler-case (maybe-emit-make-load-forms constant
)
2422 ((or compiler-error error
) ()
2423 (return-from replace-combination-with-constant
))))
2424 (with-ir1-environment-from-node combination
2425 (let* ((lvar (node-lvar combination
))
2426 (prev (node-prev combination
))
2427 (intermediate-ctran (make-ctran)))
2428 (%delete-lvar-use combination
)
2429 (setf (ctran-next prev
) nil
)
2430 (setf (node-prev combination
) nil
)
2431 (reference-constant prev intermediate-ctran lvar constant nil
)
2432 (link-node-to-previous-ctran combination intermediate-ctran
)
2433 (reoptimize-lvar lvar
)
2434 (flush-combination combination
)
2440 ;;; Change the LEAF that a REF refers to.
2441 (defun change-ref-leaf (ref leaf
&key recklessly
)
2442 (declare (type ref ref
) (type leaf leaf
))
2443 (unless (eq (ref-leaf ref
) leaf
)
2444 (push ref
(leaf-refs leaf
))
2445 (update-lvar-dependencies leaf ref
)
2447 (setf (ref-leaf ref
) leaf
2448 (ref-same-refs ref
) nil
)
2449 (setf (leaf-ever-used leaf
) t
)
2450 (let* ((ltype (leaf-type leaf
))
2451 (vltype (make-single-value-type ltype
)))
2452 (if (let* ((lvar (node-lvar ref
))
2453 (dest (and lvar
(lvar-dest lvar
))))
2454 (and (basic-combination-p dest
)
2455 (eq lvar
(basic-combination-fun dest
))
2456 (csubtypep ltype
(specifier-type 'function
))))
2457 (setf (node-derived-type ref
) vltype
)
2458 (derive-node-type ref vltype
:from-scratch recklessly
)))
2459 (reoptimize-lvar (node-lvar ref
)))
2462 ;;; Change all REFS for OLD-LEAF to NEW-LEAF.
2463 (defun substitute-leaf (new-leaf old-leaf
)
2464 (declare (type leaf new-leaf old-leaf
))
2465 (dolist (ref (leaf-refs old-leaf
))
2466 (change-ref-leaf ref new-leaf
))
2469 ;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
2470 ;;; whether to substitute
2471 (defun substitute-leaf-if (test new-leaf old-leaf
)
2472 (declare (type leaf new-leaf old-leaf
) (type function test
))
2473 (declare (dynamic-extent test
))
2474 (dolist (ref (leaf-refs old-leaf
))
2475 (when (funcall test ref
)
2476 (change-ref-leaf ref new-leaf
)))
2479 ;;; FIXME: This logic is incomplete, lacking PACKAGE, RANDOM-STATE,
2480 ;;; SIMPLE-VECTOR, HASH-TABLE, and PATHNAME, and all arrays of rank
2481 ;;; other than 1. SIMPLE-VECTOR, PATHNAME, and possibly RANDOM-STATE,
2482 ;;; could be worthwhile to handle.
2483 (defun coalescible-object-p (object)
2484 (labels ((cons-coalesce-p (x)
2485 (when (coalesce-tree-p x
)
2486 (labels ((descend (x)
2488 ((atom y
) (atom-colesce-p y
))
2489 ;; Don't just call file-coalesce-p, because
2490 ;; it'll invoke COALESCE-TREE-P repeatedly
2491 (let ((car (car y
)))
2492 (unless (if (consp car
)
2494 (atom-colesce-p car
))
2498 (sb-xc:typep x
'(or (unboxed-array (*)) number symbol instance character
))))
2500 (cons-coalesce-p object
)
2501 ;; Coalescing of SYMBOL, INSTANCE, CHARACTER is not useful -
2502 ;; if OBJECT is one of those, it would only be findable in the
2503 ;; EQL table. However, a coalescible objects with subparts
2504 ;; may contain those.
2505 (sb-xc:typep object
'(or (unboxed-array (*)) number
)))))
2507 ;;; Return a LEAF which represents the specified constant object.
2508 (defun find-constant (object)
2509 (let* ((namespace *ir1-namespace
*)
2510 (eql-constants (eql-constants namespace
))
2511 (file-compile-p (producing-fasl-file)))
2513 ;; CLHS 3.2.4.2.2: We are allowed to coalesce by similarity when
2515 ((and file-compile-p
(coalescible-object-p object
))
2516 (let ((similar-constants (similar-constants namespace
)))
2517 (or (gethash object eql-constants
)
2518 (get-similar object similar-constants
)
2519 (let ((new (make-constant object
)))
2520 (setf (gethash object eql-constants
) new
)
2521 (setf (gethash object similar-constants
) new
)))))
2523 ;; "The consequences are undefined if literal objects are destructively modified
2524 ;; For this purpose, the following operations are considered destructive:
2525 ;; array - Storing a new value into some element of the array ..."
2526 ;; so a string, once used as a literal in source, becomes logically immutable.
2528 (when (and (not file-compile-p
)
2529 (sb-xc:typep object
'(simple-array * (*))))
2530 (logically-readonlyize object nil
))
2531 (or (gethash object eql-constants
)
2532 (setf (gethash object eql-constants
)
2533 (make-constant object
)))))))
2535 ;;; Return true if X and Y are lvars whose only use is a
2536 ;;; reference to the same leaf, and the value of the leaf cannot
2538 (defun same-leaf-ref-p (x y
)
2539 (declare (type lvar x y
))
2540 (let ((x-use (principal-lvar-use x
))
2541 (y-use (principal-lvar-use y
)))
2542 (when (and (ref-p x-use
)
2544 (eq (ref-leaf x-use
) (ref-leaf y-use
))
2545 (or (constant-reference-p x-use
)
2546 (refs-unchanged-p x-use y-use
)))
2549 (defun refs-unchanged-p (ref1 ref2
)
2550 (let ((same (ref-same-refs ref1
)))
2553 (ref-same-refs ref2
)))))
2556 ;;; Return true if VAR would have to be closed over if environment
2557 ;;; analysis ran now (i.e. if there are any uses that have a different
2558 ;;; home lambda than VAR's home.)
2559 (defun closure-var-p (var)
2560 (declare (type lambda-var var
))
2561 (let ((home (lambda-var-home var
)))
2562 (cond ((functional-kind-eq home deleted
)
2564 (t (let ((home (lambda-home home
)))
2567 :key
#'node-home-lambda
2569 (or (frob (leaf-refs var
))
2570 (frob (basic-var-sets var
)))))))))
2572 ;;; If there is a non-local exit noted in ENTRY's environment that
2573 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
2574 (defun find-nlx-info (exit)
2575 (declare (type exit exit
))
2576 (let* ((entry (exit-entry exit
))
2577 (cleanup (entry-cleanup entry
))
2578 (block (first (block-succ (node-block exit
)))))
2579 (dolist (nlx (environment-nlx-info (node-environment entry
)) nil
)
2580 (when (and (eq (nlx-info-block nlx
) block
)
2581 (eq (nlx-info-cleanup nlx
) cleanup
))
2584 (defun nlx-info-lvar (nlx)
2585 (declare (type nlx-info nlx
))
2586 (node-lvar (block-last (nlx-info-target nlx
))))
2588 ;;;; functional hackery
2590 (defun main-entry (functional)
2591 (declare (type functional functional
) #-sb-xc-host
(values clambda
))
2592 (etypecase functional
2593 (clambda functional
)
2595 (optional-dispatch-main-entry functional
))))
2597 ;;; RETURN true if FUNCTIONAL is a thing that can be treated like
2598 ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
2599 ;;; optional with null default and no SUPPLIED-P. There must be a
2600 ;;; &REST arg with no references.
2601 (defun looks-like-an-mv-bind (functional)
2602 (declare (type functional functional
)
2603 #-sb-xc-host
(values boolean
))
2604 (and (optional-dispatch-p functional
)
2605 (do ((arg (optional-dispatch-arglist functional
) (cdr arg
)))
2607 (let ((info (lambda-var-arg-info (car arg
))))
2608 (unless info
(return nil
))
2609 (case (arg-info-kind info
)
2611 (when (or (arg-info-supplied-p info
) (arg-info-default info
))
2614 (return (and (null (cdr arg
))
2615 (null (leaf-refs (car arg
)))
2616 ;; Type checking will require reading the
2617 ;; variable, but it's done in one of the
2618 ;; dispatch functions making it invisible
2620 (or (neq (leaf-where-from (car arg
)) :declared
)
2621 (values (csubtypep (specifier-type 'list
)
2622 (leaf-type (car arg
))))))))
2626 (defun call-all-args-fixed-p (call)
2627 (loop for arg in
(basic-combination-args call
)
2628 always
(numberp (nth-value 1 (values-types
2629 (lvar-derived-type arg
))))))
2631 ;;; Return true if function is an external entry point. This is true
2632 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
2633 ;;; (:TOPLEVEL kind.)
2634 (declaim (inline xep-p
))
2636 (declare (type functional fun
))
2637 (functional-kind-eq fun external toplevel
))
2639 ;;; If LVAR's only use is a non-notinline global function reference,
2640 ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
2641 ;;; is true, then we don't care if the leaf is NOTINLINE.
2642 (defun lvar-fun-name (lvar &optional notinline-ok
)
2643 (declare (type lvar lvar
))
2644 (let ((use (principal-lvar-use lvar
)))
2646 (let ((leaf (ref-leaf use
)))
2647 (if (and (global-var-p leaf
)
2648 (eq (global-var-kind leaf
) :global-function
)
2649 (or (not (defined-fun-p leaf
))
2650 (not (eq (defined-fun-inlinep leaf
) 'notinline
))
2652 (leaf-source-name leaf
)
2656 ;;; As above, but allow a quoted symbol also,
2657 ;;; in which case we don't check for notinline-ness,
2658 ;;; so be careful how you use this.
2659 ;;; Also note that Case 2 in LVAR-FUN-IS for dealing with #.#'NAME
2660 ;;; has no equivalent here.
2661 (defun lvar-fun-name* (lvar)
2662 (if (constant-lvar-p lvar
) (lvar-value lvar
) (lvar-fun-name lvar
)))
2664 (defun lvar-fun-debug-name (lvar)
2665 (declare (type lvar lvar
))
2666 (let ((uses (lvar-uses lvar
)))
2668 (leaf-debug-name (ref-leaf use
))))
2671 (mapcar #'name1 uses
)))))
2673 ;;; Return the source name of a combination -- or signals an error
2674 ;;; if the function leaf is anonymous.
2675 (defun combination-fun-source-name (combination &optional
(errorp t
))
2676 (let ((uses (principal-lvar-use (combination-fun combination
)))
2678 (cond ((and (ref-p uses
)
2679 (leaf-has-source-name-p (setf leaf
(ref-leaf uses
))))
2680 (values (leaf-source-name leaf
) t
))
2682 (aver (not "COMBINATION-FUN is not a ref to a nameful leaf")))
2684 (values nil nil
)))))
2686 (defun combination-fun-debug-name (combination)
2687 (let ((uses (principal-lvar-use (basic-combination-fun combination
))))
2689 (let ((leaf (ref-leaf uses
)))
2692 (functional-debug-name leaf
))
2694 (and (leaf-has-source-name-p leaf
)
2695 (leaf-source-name leaf
))))))))
2697 ;;; Return the COMBINATION node that is the call to the LET FUN.
2698 (defun let-combination (fun)
2699 (declare (type clambda fun
))
2700 (aver (functional-letlike-p fun
))
2701 (lvar-dest (node-lvar (first (leaf-refs fun
)))))
2703 ;;; Return the initial value lvar for a LET variable, or NIL if there
2705 (defun let-var-initial-value (var)
2706 (declare (type lambda-var var
))
2707 (let ((fun (lambda-var-home var
)))
2708 (elt (combination-args (let-combination fun
))
2709 (position-or-lose var
(lambda-vars fun
)))))
2711 ;;; Return the LAMBDA that is called by the local CALL.
2712 (defun combination-lambda (call)
2713 (declare (type basic-combination call
))
2714 (aver (eq (basic-combination-kind call
) :local
))
2715 (ref-leaf (lvar-uses (basic-combination-fun call
))))
2717 (defun register-inline-expansion (leaf call
)
2718 (let* ((name (leaf-%source-name leaf
))
2719 (calls (basic-combination-inline-expansions call
))
2720 (recursive (memq name calls
)))
2722 (incf (cadr recursive
))
2725 (list* name
1 calls
)))))
2727 ;;; Check whether NODE's component has exceeded its inline expansion
2728 ;;; limit, and warn if so, returning NIL.
2729 (defun inline-expansion-ok (combination leaf
)
2730 (let* ((name (leaf-%source-name leaf
))
2731 (expansions (memq name
2732 (basic-combination-inline-expansions combination
)))
2733 (expanded (cadr expansions
)))
2734 (cond ((not expanded
))
2735 ((> expanded
*inline-expansion-limit
*) nil
)
2736 ((= expanded
*inline-expansion-limit
*)
2737 (let ((*compiler-error-context
* combination
))
2738 (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded ~
2740 *inline-expansion-limit
* name
))
2741 (incf (cadr expansions
))
2745 ;;; Make sure that FUNCTIONAL is not let-converted or deleted.
2746 (defun assure-functional-live-p (functional)
2747 (declare (type functional functional
))
2748 (when (functional-kind-eq functional
2749 ;; looks LET-converted
2750 let mv-let assignment
2751 ;; It's possible for a LET-converted function to end up
2752 ;; deleted later. In that case, for the purposes of this
2753 ;; analysis, it is LET-converted: LET-converted functionals
2754 ;; are too badly trashed to expand them inline, and deleted
2755 ;; LET-converted functionals are even worse.
2757 (throw 'locall-already-let-converted functional
)))
2759 (defun assure-leaf-live-p (leaf)
2762 (when (lambda-var-deleted leaf
)
2763 (throw 'locall-already-let-converted leaf
)))
2765 (assure-functional-live-p leaf
))))
2767 (defun call-full-like-p (call)
2768 (declare (type basic-combination call
))
2769 (let ((kind (basic-combination-kind call
)))
2771 (eq kind
:unknown-keys
)
2772 ;; It has an ir2-converter, but needs to behave like a full call.
2773 (eq (lvar-fun-name (basic-combination-fun call
) t
)
2774 '%coerce-callable-for-call
)
2775 (and (eq kind
:known
)
2776 (let ((info (basic-combination-fun-info call
)))
2778 (not (fun-info-ir2-convert info
))
2779 (not (fun-info-ltn-annotate info
))
2780 (dolist (template (fun-info-templates info
) t
)
2781 (when (eq (template-ltn-policy template
) :fast-safe
)
2782 (when (valid-fun-use call
(template-type template
))
2787 ;;; Apply a function to some arguments, returning a list of the values
2788 ;;; resulting of the evaluation. If an error is signalled during the
2789 ;;; application, then return the condition and NIL as the
2791 (defun careful-call (function args
)
2792 (declare (type (or symbol function
) function
)
2794 (handler-case (values (multiple-value-list (apply function args
)) t
)
2795 ;; When cross-compiling, being "careful" is the wrong thing - our code should
2796 ;; not allowed malformed or out-of-order definitions to proceed as if all is well.
2799 (values condition nil
))))
2801 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
2804 ((deffrob (basic careful compiler transform
)
2806 (defun ,careful
(specifier)
2807 (handler-case (,basic specifier
)
2809 (values nil condition
))))
2810 (defun ,compiler
(specifier)
2811 (handler-case (,basic specifier
)
2812 (simple-error (condition)
2813 (apply #'compiler-warn
2814 (simple-condition-format-control condition
)
2815 (simple-condition-format-arguments condition
)))
2817 (compiler-warn "~a" condition
))))
2818 (defun ,transform
(specifier)
2819 (multiple-value-bind (type condition
) (,careful specifier
)
2821 (give-up-ir1-transform
2822 (princ-to-string condition
))))))))
2823 (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type
)
2824 (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type
))
2827 ;;;; utilities used at run-time for parsing &KEY args in IR1
2829 ;;; This function is used by the result of PARSE-DEFTRANSFORM to find
2830 ;;; the lvar for the value of the &KEY argument KEY in the list of
2831 ;;; lvars ARGS. It returns the lvar if the keyword is present, or NIL
2832 ;;; otherwise. The legality and constantness of the keywords should
2833 ;;; already have been checked.
2834 (defun find-keyword-lvar (args key
)
2835 (declare (type list args
) (type keyword key
))
2836 (do ((arg args
(cddr arg
)))
2838 (when (eq (lvar-value (first arg
)) key
)
2839 (return (second arg
)))))
2841 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
2842 ;;; verify that alternating lvars in ARGS are constant and that there
2843 ;;; is an even number of args.
2844 (defun check-key-args-constant (args)
2845 (declare (type list args
) #-sb-xc-host
(values boolean
))
2846 (do ((arg args
(cddr arg
)))
2848 (unless (and (rest arg
)
2849 (constant-lvar-p (first arg
)))
2852 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
2853 ;;; verify that the list of lvars ARGS is a well-formed &KEY arglist
2854 ;;; and that only keywords present in the list KEYS are supplied.
2855 (defun check-transform-keys (args keys
)
2856 (declare (list args keys
) #-sb-xc-host
(values boolean
))
2857 (and (check-key-args-constant args
)
2858 (do ((arg args
(cddr arg
)))
2860 (unless (member (lvar-value (first arg
)) keys
)
2865 ;;; Called by the expansion of the EVENT macro.
2866 (defun %event
(info node
)
2867 (declare (type event-info info
) (type (or node null
) node
))
2868 (incf (event-info-count info
))
2869 (when (and (>= (event-info-level info
) *event-note-threshold
*)
2870 (policy (or node
*lexenv
*)
2871 (= inhibit-warnings
0)))
2872 (let ((*compiler-error-context
* node
))
2873 (compiler-notify (event-info-description info
))))
2875 (let ((action (event-info-action info
)))
2876 (when action
(funcall action node
))))
2879 (defun make-cast (value type policy
&optional context
)
2880 (declare (type lvar value
)
2882 (type policy policy
))
2883 (when (fun-type-p type
)
2884 ;; FUN-TYPE will be weakined into FUNCTION,
2885 ;; but we still want to check the full type at compile time.
2886 (add-annotation value
2887 (make-lvar-function-annotation
2889 :context
(shiftf context nil
))))
2890 (%make-cast
:asserted-type type
2891 :type-to-check
(maybe-weaken-check type policy
)
2893 :derived-type
(coerce-to-values type
)
2896 (defun note-single-valuified-lvar (lvar)
2897 (declare (type (or lvar null
) lvar
))
2899 (let ((use (lvar-uses lvar
)))
2901 (let ((leaf (ref-leaf use
)))
2902 (when (and (lambda-var-p leaf
)
2903 (null (rest (leaf-refs leaf
))))
2904 (reoptimize-lambda-var leaf
))))
2905 ((or (listp use
) (combination-p use
))
2906 (do-uses (node lvar
)
2907 (setf (node-reoptimize node
) t
)
2908 (setf (block-reoptimize (node-block node
)) t
)
2909 (reoptimize-component (node-component node
) :maybe
)))))))
2911 ;;; Return true if LVAR's only use is a reference to a global function
2912 ;;; designator with one of the specified NAMES, that hasn't been
2913 ;;; declared NOTINLINE.
2914 (defun lvar-fun-is (lvar names
)
2915 (declare (type lvar lvar
) (list names
))
2916 (let ((use (principal-lvar-use lvar
)))
2918 (let* ((*lexenv
* (node-lexenv use
))
2919 (leaf (ref-leaf use
))
2921 (cond ((global-var-p leaf
)
2923 (and (eq (global-var-kind leaf
) :global-function
)
2924 (car (member (leaf-source-name leaf
) names
2927 (let ((value (constant-value leaf
)))
2928 (car (if (functionp value
)
2933 (fdefinition name
)))
2937 :test
#'equal
))))))))
2939 (not (fun-lexically-notinline-p name
)))
2942 ;;; Return true if LVAR's only use is a call to one of the named functions
2943 ;;; (or any function if none are specified) with the specified number of
2944 ;;; of arguments (or any number if number is not specified)
2945 (defun lvar-matches (lvar &key fun-names arg-count
(notinline t
))
2946 (let ((use (lvar-uses lvar
)))
2947 (and (combination-p use
)
2949 (multiple-value-bind (name ok
)
2950 (combination-fun-source-name use nil
)
2953 (fun-lexically-notinline-p name
(node-lexenv use
))))
2954 (member name fun-names
:test
#'eq
))))
2956 (= arg-count
(length (combination-args use
)))))))
2958 ;;; In (a (b lvar)) (lvar-matches-calls lvar '(b a)) would return T
2959 (defun lvar-matches-calls (lvar dest-fun-names
)
2960 (loop for fun in dest-fun-names
2961 for dest
= (principal-lvar-end lvar
)
2962 when
(or (not (combination-p dest
))
2963 (neq fun
(combination-fun-source-name dest nil
)))
2965 do
(setf lvar
(combination-lvar dest
))
2966 finally
(return t
)))
2968 ;;; Don't substitute single-ref variables on high-debug / low speed,
2969 ;;; to improve the debugging experience, unless it is a special
2970 ;;; variable or a temporary variable used for hairy function entries.
2971 (defun preserve-single-use-debug-var-p (node var
)
2972 (and (policy node
(eql preserve-single-use-debug-variables
3))
2973 (not (lambda-var-specvar var
))
2974 (not (and (combination-p node
)
2975 (typep (leaf-debug-name (combination-lambda node
))
2976 '(cons (member hairy-function-entry
) t
))))))
2978 ;;; Call (lambda (arg lambda-var type)), for a mv-combination ARG can
2979 ;;; be NIL when it produces multiple values.
2980 ;;; If REOPTIMIZE is T only the arguments for which LVAR-REOPTIMIZE is
2981 ;;; true will be examined, resetting LVAR-REOPTIMIZE to NIL before
2982 ;;; calling FUNCTION.
2983 (defun map-combination-arg-var (function combination
&key reoptimize
)
2984 (let ((args (basic-combination-args combination
))
2985 (vars (lambda-vars (combination-lambda combination
))))
2986 (flet ((reoptimize-p (arg)
2987 (cond ((not arg
) nil
)
2989 ((lvar-reoptimize arg
)
2990 (setf (lvar-reoptimize arg
) nil
)
2992 (cond ((combination-p combination
)
2993 (loop for arg in args
2995 when
(reoptimize-p arg
)
2997 (funcall function arg var
(lvar-type arg
))))
2999 (when (reoptimize-p (first args
))
3000 (loop with arg
= (first args
)
3002 for type in
(values-type-in (lvar-derived-type arg
)
3006 (and (singleton-p vars
)
3011 (loop for arg in args
3012 do
(multiple-value-bind (types length
) (values-types (lvar-derived-type arg
))
3013 (when (eq length
:unknown
)
3015 (if (reoptimize-p arg
)
3016 (loop with singleton-arg
= (and (= length
1)
3021 (funcall function singleton-arg
3023 (setf vars
(nthcdr length vars
))))))))))
3025 (defun if-type-check (if)
3026 (let ((test (lvar-uses (if-test if
))))
3027 (when (combination-p test
)
3028 (let ((name (combination-fun-source-name test nil
)))
3029 (values (gethash name
*backend-predicate-types
*)
3030 (car (combination-args test
)))))))
3033 (defun proper-or-circular-list-p (x)
3035 (let ((rabbit (cdr x
))
3037 (flet ((pop-rabbit ()
3038 (when (eql rabbit turtle
) ; circular
3039 (return-from proper-or-circular-list-p t
))
3041 (return-from proper-or-circular-list-p
(null rabbit
)))
3048 (defun proper-or-dotted-list-p (x)
3050 (let ((rabbit (cdr x
))
3052 (flet ((pop-rabbit ()
3053 (when (eql rabbit turtle
) ; circular
3054 (return-from proper-or-dotted-list-p nil
))
3056 (return-from proper-or-dotted-list-p t
))
3063 (defun map-lambda-var-refs-from-calls (function lambda-var
)
3064 (when (not (lambda-var-sets lambda-var
))
3065 (let* ((home (lambda-var-home lambda-var
))
3066 (vars (lambda-vars home
)))
3067 (dolist (ref (lambda-refs home
))
3068 (let* ((lvar (node-lvar ref
))
3069 (combination (and lvar
3071 (when (and (combination-p combination
)
3072 (eq (combination-kind combination
) :local
)
3073 (eq (combination-fun combination
)
3076 for arg in
(combination-args combination
)
3077 when
(eq v lambda-var
)
3078 do
(funcall function combination arg
))))))))
3080 (defun map-leaf-refs (function leaf
)
3082 (labels ((recur (leaf)
3083 (dolist (ref (leaf-refs leaf
))
3084 (let* ((lvar (node-lvar ref
))
3087 (cond ((and (combination-p dest
)
3088 (eq (combination-kind dest
) :local
))
3089 (let ((lambda (combination-lambda dest
)))
3090 (when (cond ((functional-kind-eq lambda let
))
3091 ((memq dest seen-calls
)
3094 (push dest seen-calls
)))
3095 (loop for v in
(lambda-vars lambda
)
3096 for arg in
(combination-args dest
)
3099 ((and (combination-p dest
)
3100 (lvar-fun-is (combination-fun dest
) '(values))
3101 (let ((mv (node-dest dest
)))
3102 (when (and (mv-combination-p mv
)
3103 (eq (basic-combination-kind mv
) :local
))
3104 (let ((fun (combination-lambda mv
)))
3105 (when (and (functional-p fun
)
3106 (functional-kind-eq fun mv-let
))
3107 (let* ((arg (position lvar
(combination-args dest
)))
3108 (var (and arg
(nth arg
(lambda-vars fun
)))))
3112 (funcall function dest
)))))))
3115 (defun propagate-lvar-annotations-to-refs (lvar var
)
3116 (when (lvar-annotations lvar
)
3117 (dolist (ref (leaf-refs var
))
3118 (when (node-lvar ref
)
3119 (propagate-lvar-annotations (node-lvar ref
) lvar
3122 (defun propagate-lvar-annotations (new old
&optional
(propagate-dependencies t
))
3123 (when propagate-dependencies
3124 (loop for dep in
(lvar-dependent-annotations old
)
3125 do
(nsubst new old
(lvar-dependent-annotation-deps dep
))
3128 (pushnew dep
(lvar-dependent-annotations new
) :test
#'eq
))
3129 (loop for dep in
(lvar-dependent-nodes old
)
3132 (pushnew dep
(lvar-dependent-nodes new
) :test
#'eq
)))
3135 (lvar-annotations new
)
3136 (cond ((not (lvar-annotations new
))
3137 (lvar-annotations old
))
3138 ((not (lvar-annotations old
))
3139 (lvar-annotations new
))
3141 ;; Get only the outermost annotation, avoiding multiple
3142 ;; warnings coming from source transforms.
3143 (let ((all (union (lvar-annotations old
) (lvar-annotations new
))))
3144 (loop for annotation in all
3145 for type
= (type-of annotation
)
3146 for source-path
= (lvar-annotation-source-path annotation
)
3147 when
(or (eq (car source-path
) 'original-source-start
)
3148 (loop for other in all
3149 for other-source-path
= (lvar-annotation-source-path other
)
3150 never
(and (not (eq annotation other
))
3151 (eq type
(type-of other
))
3152 (or (eq (car other-source-path
) 'original-source-start
)
3153 (member (car other-source-path
)
3155 collect annotation
)))))))
3157 (defun lvar-constants (lvar)
3158 (named-let recurse
((lvar lvar
) (seen nil
))
3159 (let* ((uses (lvar-uses lvar
))
3160 (lvar (or (and (ref-p uses
)
3161 (let ((ref (principal-lvar-ref lvar
)))
3164 (lambda-var-ref-lvar ref
)
3167 (cond ((constant-lvar-p lvar
)
3168 (values :values
(list (lvar-value lvar
))))
3169 ((constant-lvar-uses-p lvar
)
3170 (values :values
(lvar-uses-values lvar
)))
3172 (let* ((ref (principal-lvar-ref lvar
))
3175 (when (lambda-var-p leaf
)
3176 (let ((seen (or seen
(alloc-xset)))
3178 (add-to-xset lvar seen
)
3179 (map-lambda-var-refs-from-calls
3181 (unless (xset-member-p lvar seen
)
3182 (add-to-xset lvar seen
)
3183 (multiple-value-bind (type values
) (recurse lvar seen
)
3186 (push (cons call values
) constants
))
3188 (setf constants
(nconc values constants
)))))))
3191 (values :calls constants
))))))))))
3193 (defun lambda-var-original-name (leaf)
3194 (let ((home (lambda-var-home leaf
)))
3195 (if (functional-kind-eq home external
)
3196 (let* ((entry (functional-entry-fun home
))
3197 (p (1- (or (position leaf
(lambda-vars home
))
3198 (bug "can't find leaf")))))
3200 (if (optional-dispatch-p entry
)
3201 (elt (optional-dispatch-arglist entry
) p
)
3202 (elt (lambda-vars entry
) p
))))
3203 (leaf-debug-name leaf
))))
3205 (defun process-lvar-modified-annotation (lvar annotation
)
3206 (loop for annot in
(lvar-annotations lvar
)
3207 when
(lvar-lambda-var-annotation-p annot
)
3208 do
(let ((lambda-var (lvar-lambda-var-annotation-lambda-var annot
)))
3209 (when (and (lambda-var-constant lambda-var
)
3210 (not (lambda-var-sets lambda-var
)))
3211 (warn 'sb-kernel
::macro-arg-modified
3212 :fun-name
(lvar-modified-annotation-caller annotation
)
3213 :variable
(lambda-var-original-name lambda-var
))
3214 (return-from process-lvar-modified-annotation
))))
3215 (multiple-value-bind (type values
) (lvar-constants lvar
)
3216 (labels ((modifiable-p (value)
3219 (not (typep value
'(vector * 0))))
3220 (hash-table-p value
)))
3222 (when (every #'modifiable-p values
)
3223 (warn 'constant-modified
3224 :fun-name
(lvar-modified-annotation-caller annotation
)
3231 (loop for
(call . values
) in values
3232 do
(let ((*compiler-error-context
* call
))
3236 (defun improper-sequence-p (annotation value
)
3240 (not (proper-list-p value
))))
3242 (and (typep value
'sequence
)
3243 (not (proper-sequence-p value
))))
3244 (proper-or-circular-list
3246 (not (proper-or-circular-list-p value
))))
3247 (proper-or-dotted-list
3249 (not (proper-or-dotted-list-p value
))))))
3251 (defun process-lvar-proper-sequence-annotation (lvar annotation
)
3252 (multiple-value-bind (type values
) (lvar-constants lvar
)
3253 (let ((kind (lvar-proper-sequence-annotation-kind annotation
)))
3254 (labels ((bad-p (value)
3255 (improper-sequence-p kind value
))
3257 (when (every #'bad-p values
)
3258 (if (singleton-p values
)
3261 "~@<~2I~_~S ~Iis not a proper ~a.~@:>"
3262 :format-arguments
(list (car values
)
3263 (if (eq kind
'proper-sequence
)
3268 "~@<~2I~_~{~s~^, ~} ~Iare not proper ~as.~@:>"
3269 :format-arguments
(list values
3270 (if (eq kind
'proper-sequence
)
3278 (loop for
(call . values
) in values
3279 do
(let ((*compiler-error-context
* call
))
3283 (defun process-lvar-hook-annotation (lvar annotation
)
3284 (when (constant-lvar-p lvar
)
3285 (funcall (lvar-hook-hook annotation
)
3289 (defun process-lvar-type-annotation (lvar annotation
)
3290 (let* ((uses (lvar-uses lvar
))
3291 (context (lvar-type-annotation-context annotation
))
3292 (condition (typecase context
3293 (defstruct-slot-description
3294 (if (policy (if (consp uses
)
3298 'slot-initform-type-style-warning
3302 (type (lvar-type-annotation-type annotation
)))
3303 (cond ((not (types-equal-or-intersect (lvar-type lvar
) type
))
3304 (if (symbolp condition
)
3305 (%compile-time-type-error-warn annotation
(type-specifier type
)
3306 (type-specifier (lvar-type lvar
))
3307 (let ((path (lvar-annotation-source-path annotation
)))
3308 (if (eq (car path
) 'detail
)
3311 (if (eq (car path
) 'original-source-start
)
3312 (find-original-source path
)
3314 :condition condition
)
3315 (setf (sb-kernel::dsd-bits condition
)
3316 (logior sb-kernel
::dsd-default-error
3317 (sb-kernel::dsd-bits condition
)))))
3319 (let ((condition (case condition
3320 (type-warning 'type-style-warning
)
3323 (loop for use in uses
3324 for dtype
= (node-derived-type use
)
3325 unless
(values-types-equal-or-intersect dtype type
)
3328 (loop for bad-use in bad
3329 for path
= (source-path-before-transforms bad-use
)
3330 ;; Are all uses from the same transform bad?
3332 (loop for use in uses
3333 always
(or (memq use bad
)
3334 (neq path
(source-path-before-transforms use
)))))
3336 (if (symbolp condition
)
3337 (%compile-time-type-error-warn bad-use
3338 (type-specifier type
)
3339 (type-specifier (node-derived-type bad-use
))
3340 (list (node-source-form bad-use
))
3341 :condition condition
)
3342 (setf (sb-kernel::dsd-bits condition
)
3343 (logior sb-kernel
::dsd-default-error
3344 (sb-kernel::dsd-bits condition
)))))))))))
3346 (defun process-lvar-sequence-bounds-annotation (lvar annotation
)
3347 (destructuring-bind (start end
) (lvar-dependent-annotation-deps annotation
)
3348 (check-sequence-ranges lvar start end annotation
)))
3350 (defun process-annotations (lvar)
3351 (unless (and (combination-p (lvar-dest lvar
))
3353 (combination-fun (lvar-dest lvar
))
3354 ;; KLUDGE: after some type derivation and merging with other types
3355 ;; a path can emerge which is erronous and has a bad constant,
3356 ;; but another value can still be good.
3357 ;; see compiler.pure/generate-type-checks-on-dead-blocks
3358 '(%type-check-error %type-check-error
/c
)))
3359 (loop for annot in
(lvar-annotations lvar
)
3360 unless
(lvar-annotation-fired annot
)
3362 (let ((*compiler-error-context
* annot
))
3363 (when (typecase annot
3364 (lvar-modified-annotation
3365 (process-lvar-modified-annotation lvar annot
))
3366 (lvar-proper-sequence-annotation
3367 (process-lvar-proper-sequence-annotation lvar annot
))
3369 (process-lvar-hook-annotation lvar annot
))
3370 (lvar-function-designator-annotation
3371 (check-function-designator-lvar lvar annot
))
3372 (lvar-function-annotation
3373 (check-function-lvar lvar annot
))
3374 (lvar-type-annotation
3375 (process-lvar-type-annotation lvar annot
))
3376 (lvar-sequence-bounds-annotation
3377 (process-lvar-sequence-bounds-annotation lvar annot
)))
3378 (setf (lvar-annotation-fired annot
) t
))))))
3380 (defun add-annotation (lvar annotation
)
3381 (unless (eq (lvar-annotations lvar
)
3382 (pushnew annotation
(lvar-annotations lvar
)
3384 (when (typep annotation
'lvar-dependent-annotation
)
3385 (loop for lvar in
(lvar-dependent-annotation-deps annotation
)
3387 do
(push annotation
(lvar-dependent-annotations lvar
))))
3388 (unless (lvar-annotation-source-path annotation
)
3389 (setf (lvar-annotation-source-path annotation
)
3390 (if (boundp '*current-path
*)
3392 (node-source-path (lvar-dest lvar
)))))
3393 (unless (lvar-annotation-lexenv annotation
)
3394 (setf (lvar-annotation-lexenv annotation
)
3397 (node-lexenv (lvar-dest lvar
)))
3401 (defun compiling-p (environment)
3402 (and (boundp 'sb-c
:*compilation
*)
3404 (not (typep environment
'sb-interpreter
:basic-env
))
3406 (not (typep environment
'sb-eval
::eval-lexenv
))))
3408 ;;; Return T if SYMBOL will always have a value in its TLS cell that is
3409 ;;; not EQ to NO-TLS-VALUE-MARKER-WIDETAG. As an optimization, set and ref
3410 ;;; are permitted (but not required) to avoid checking for it.
3411 ;;; This will be true of all C interface symbols, 'struct thread' slots,
3412 ;;; and any variable defined by DEFINE-THREAD-LOCAL.
3414 ;;; Or if there's a binding around NODE.
3415 (defun sb-vm::symbol-always-has-tls-value-p
(symbol node
)
3416 (let ((symbol (if (symbolp symbol
)
3418 (let ((tn (if (tn-p symbol
)
3420 (tn-ref-tn symbol
))))
3422 ((constant sb-vm
::immediate
)
3425 (return-from sb-vm
::symbol-always-has-tls-value-p
)))))))
3426 (or (typep (info :variable
:wired-tls symbol
)
3427 '(or (eql :always-thread-local
) fixnum
))
3429 (do-nested-cleanups (cleanup node
)
3430 (when (eq (cleanup-kind cleanup
) :special-bind
)
3431 (let* ((node (cleanup-mess-up cleanup
))
3432 (args (when (basic-combination-p node
)
3433 (basic-combination-args node
))))
3435 (eq (leaf-source-name (lvar-value (car args
))) symbol
))
3438 (defun internal-name-p (name)
3439 (and #-sb-xc-host
(fboundp name
)
3440 (named-let internal-p
((what name
))
3442 (list (every #'internal-p what
))
3444 (let ((pkg (sb-xc:symbol-package what
)))
3445 (or (and pkg
(system-package-p pkg
))
3446 (eq pkg
*cl-package
*))))
3449 (defun cast-mismatch-from-inlined-p (cast node
)
3450 (let* ((path (node-source-path node
))
3451 (transformed (memq 'transformed path
))
3453 (cond ((and transformed
3454 (not (eq (memq 'transformed
(node-source-path cast
))
3457 (memq 'inlined path
))
3458 (not (eq (memq 'inlined
(node-source-path cast
))
3461 (defun source-path-before-transforms (node)
3462 (let* ((path (node-source-path node
))
3463 (first (position-if (lambda (x) (memq x
'(transformed inlined
)))
3466 (nthcdr (+ first
2) path
))))