Fix (setf (schar hairy-simple-string-type))
[sbcl.git] / src / compiler / ir1util.lisp
blob32326b85fa13e7114ea1f195de181af52066e067
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
5 ;;;; more information.
6 ;;;;
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.
13 (in-package "SB!C")
15 ;;;; cleanup hackery
17 (defun lexenv-enclosing-cleanup (lexenv)
18 (declare (type lexenv lexenv))
19 (do ((lexenv2 lexenv
20 (lambda-call-lexenv (lexenv-lambda lexenv2))))
21 ((null lexenv2) nil)
22 (awhen (lexenv-cleanup lexenv2)
23 (return it))))
25 ;;; Return the innermost cleanup enclosing NODE, or NIL if there is
26 ;;; none in its function. If NODE has no cleanup, but is in a LET,
27 ;;; then we must still check the environment that the call is in.
28 (defun node-enclosing-cleanup (node)
29 (declare (type node node))
30 (lexenv-enclosing-cleanup (node-lexenv node)))
32 (defun map-nested-cleanups (function lexenv &optional return-value)
33 (declare (type lexenv lexenv))
34 (do ((cleanup (lexenv-enclosing-cleanup lexenv)
35 (node-enclosing-cleanup (cleanup-mess-up cleanup))))
36 ((not cleanup) return-value)
37 (funcall function cleanup)))
39 ;;; Convert the FORM in a block inserted between BLOCK1 and BLOCK2 as
40 ;;; an implicit MV-PROG1. The inserted block is returned. NODE is used
41 ;;; for IR1 context when converting the form. Note that the block is
42 ;;; not assigned a number, and is linked into the DFO at the
43 ;;; beginning. We indicate that we have trashed the DFO by setting
44 ;;; COMPONENT-REANALYZE. If CLEANUP is supplied, then convert with
45 ;;; that cleanup.
46 (defun insert-cleanup-code (pred-blocks succ-block node form &optional cleanup)
47 (declare (type node node) (type (or cleanup null) cleanup))
48 (setf (component-reanalyze (block-component (car pred-blocks))) t)
49 (with-ir1-environment-from-node node
50 (with-component-last-block (*current-component*
51 (block-next (component-head *current-component*)))
52 (let* ((start (make-ctran))
53 (block (ctran-starts-block start))
54 (next (make-ctran))
55 (*lexenv* (if cleanup
56 (make-lexenv :cleanup cleanup)
57 *lexenv*)))
58 (loop for pred-block in pred-blocks
60 (change-block-successor pred-block succ-block block))
61 (link-blocks block succ-block)
62 (ir1-convert start next nil form)
63 (setf (block-last block) (ctran-use next))
64 (setf (node-next (block-last block)) nil)
65 block))))
67 ;;;; lvar use hacking
69 ;;; Return a list of all the nodes which use LVAR.
70 (declaim (ftype (sfunction (lvar) list) find-uses))
71 (defun find-uses (lvar)
72 (ensure-list (lvar-uses lvar)))
74 (declaim (ftype (sfunction (lvar) lvar) principal-lvar))
75 (defun principal-lvar (lvar)
76 (labels ((pl (lvar)
77 (let ((use (lvar-uses lvar)))
78 (if (cast-p use)
79 (pl (cast-value use))
80 lvar))))
81 (pl lvar)))
83 (defun principal-lvar-use (lvar)
84 (labels ((plu (lvar)
85 (declare (type lvar lvar))
86 (let ((use (lvar-uses lvar)))
87 (if (cast-p use)
88 (plu (cast-value use))
89 use))))
90 (plu lvar)))
92 (defun principal-lvar-dest (lvar)
93 (labels ((pld (lvar)
94 (and lvar
95 (let ((dest (lvar-dest lvar)))
96 (if (cast-p dest)
97 (pld (cast-lvar dest))
98 dest)))))
99 (pld lvar)))
101 ;;; Update lvar use information so that NODE is no longer a use of its
102 ;;; LVAR.
104 ;;; Note: if you call this function, you may have to do a
105 ;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
106 ;;; changed.
107 (declaim (ftype (sfunction (node) (values))
108 delete-lvar-use
109 %delete-lvar-use))
110 ;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may
111 ;;; be given a new use.
112 (defun %delete-lvar-use (node)
113 (let ((lvar (node-lvar node)))
114 (when lvar
115 (if (listp (lvar-uses lvar))
116 (let ((new-uses (delq node (lvar-uses lvar))))
117 (setf (lvar-uses lvar)
118 (if (singleton-p new-uses)
119 (first new-uses)
120 new-uses)))
121 (setf (lvar-uses lvar) nil))
122 (flush-node node)))
123 (values))
124 ;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete
125 ;;; its DEST's block, which must be unreachable.
126 (defun delete-lvar-use (node)
127 (let ((lvar (node-lvar node)))
128 (when lvar
129 (%delete-lvar-use node)
130 (if (null (lvar-uses lvar))
131 (binding* ((dest (lvar-dest lvar) :exit-if-null)
132 (() (not (node-deleted dest)) :exit-if-null)
133 (block (node-block dest)))
134 (mark-for-deletion block))
135 (reoptimize-lvar lvar))))
136 (values))
138 ;;; Update lvar use information so that NODE uses LVAR.
140 ;;; Note: if you call this function, you may have to do a
141 ;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
142 ;;; changed.
143 (declaim (ftype (sfunction (node (or lvar null)) (values)) add-lvar-use))
144 (defun add-lvar-use (node lvar)
145 (aver (not (node-lvar node)))
146 (when lvar
147 (let ((uses (lvar-uses lvar)))
148 (setf (lvar-uses lvar)
149 (cond ((null uses)
150 node)
151 ((listp uses)
152 (cons node uses))
154 (list node uses))))
155 (setf (node-lvar node) lvar)))
157 (values))
159 ;;; Return true if LVAR destination is executed immediately after
160 ;;; NODE. Cleanups are ignored.
161 (defun immediately-used-p (lvar node)
162 (declare (type lvar lvar) (type node node))
163 (aver (eq (node-lvar node) lvar))
164 (let ((dest (lvar-dest lvar)))
165 (acond ((node-next node)
166 (eq (ctran-next it) dest))
167 (t (eq (block-start (first (block-succ (node-block node))))
168 (node-prev dest))))))
170 ;;; Returns the defined (usually untrusted) type of the combination,
171 ;;; or NIL if we couldn't figure it out.
172 (defun combination-defined-type (combination)
173 (let ((use (principal-lvar-use (basic-combination-fun combination))))
174 (or (when (ref-p use)
175 (let ((type (leaf-defined-type (ref-leaf use))))
176 (when (fun-type-p type)
177 (fun-type-returns type))))
178 *wild-type*)))
180 ;;; Return true if LVAR destination is executed after node with only
181 ;;; uninteresting nodes intervening.
183 ;;; Uninteresting nodes are nodes in the same block which are either
184 ;;; REFs, external CASTs to the same destination, or known combinations
185 ;;; that never unwind.
186 (defun almost-immediately-used-p (lvar node)
187 (declare (type lvar lvar)
188 (type node node))
189 (aver (eq (node-lvar node) lvar))
190 (let ((dest (lvar-dest lvar)))
191 (tagbody
192 :next
193 (let ((ctran (node-next node)))
194 (cond (ctran
195 (setf node (ctran-next ctran))
196 (if (eq node dest)
197 (return-from almost-immediately-used-p t)
198 (typecase node
199 (ref
200 (go :next))
201 (cast
202 (when (and (memq (cast-type-check node) '(:external nil))
203 (eq dest (node-dest node)))
204 (go :next)))
205 (combination
206 ;; KLUDGE: Unfortunately we don't have an attribute for
207 ;; "never unwinds", so we just special case
208 ;; %ALLOCATE-CLOSURES: it is easy to run into with eg.
209 ;; FORMAT and a non-constant first argument.
210 (when (eq '%allocate-closures (combination-fun-source-name node nil))
211 (go :next))))))
213 (when (eq (block-start (first (block-succ (node-block node))))
214 (node-prev dest))
215 (return-from almost-immediately-used-p t))))))))
217 ;;;; BLOCK UTILS
219 (declaim (inline block-to-be-deleted-p))
220 (defun block-to-be-deleted-p (block)
221 (or (block-delete-p block)
222 (eq (functional-kind (block-home-lambda block)) :deleted)))
224 ;;; Checks whether NODE is in a block to be deleted
225 (declaim (inline node-to-be-deleted-p))
226 (defun node-to-be-deleted-p (node)
227 (block-to-be-deleted-p (node-block node)))
229 (declaim (ftype (sfunction (clambda) cblock) lambda-block))
230 (defun lambda-block (clambda)
231 (node-block (lambda-bind clambda)))
232 (declaim (ftype (sfunction (clambda) component) lambda-component))
233 (defun lambda-component (clambda)
234 (block-component (lambda-block clambda)))
236 (declaim (ftype (sfunction (cblock) node) block-start-node))
237 (defun block-start-node (block)
238 (ctran-next (block-start block)))
240 ;;; Return the enclosing cleanup for environment of the first or last
241 ;;; node in BLOCK.
242 (defun block-start-cleanup (block)
243 (node-enclosing-cleanup (block-start-node block)))
244 (defun block-end-cleanup (block)
245 (node-enclosing-cleanup (block-last block)))
247 ;;; Return the lexenv of the last node in BLOCK.
248 (defun block-end-lexenv (block)
249 (node-lexenv (block-last block)))
251 ;;;; lvar substitution
253 (defun update-dependent-casts (new old)
254 (loop for cast in (lvar-dependent-casts old)
255 do (nsubst new old (dependent-cast-deps cast))
256 when (lvar-p new)
258 (push cast (lvar-dependent-casts new))))
260 ;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be
261 ;;; NIL. We do not flush OLD's DEST.
262 (defun substitute-lvar (new old)
263 (declare (type lvar old new))
264 (aver (not (lvar-dest new)))
265 (update-dependent-casts new old)
266 (let ((dest (lvar-dest old)))
267 (etypecase dest
268 ((or ref bind))
269 (cif (setf (if-test dest) new))
270 (cset (setf (set-value dest) new))
271 (creturn (setf (return-result dest) new))
272 (exit (setf (exit-value dest) new))
273 (basic-combination
274 (if (eq old (basic-combination-fun dest))
275 (setf (basic-combination-fun dest) new)
276 (setf (basic-combination-args dest)
277 (nsubst new old (basic-combination-args dest)))))
278 (cast (setf (cast-value dest) new)))
280 (setf (lvar-dest old) nil)
281 (setf (lvar-dest new) dest)
282 (flush-lvar-externally-checkable-type new))
283 (values))
285 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
286 ;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
287 (defun substitute-lvar-uses (new old propagate-dx)
288 (declare (type lvar old)
289 (type (or lvar null) new)
290 (type boolean propagate-dx))
291 (cond (new
292 (update-dependent-casts new old)
293 (do-uses (node old)
294 (%delete-lvar-use node)
295 (add-lvar-use node new))
296 (reoptimize-lvar new)
297 (awhen (and propagate-dx (lvar-dynamic-extent old))
298 (setf (lvar-dynamic-extent old) nil)
299 (unless (lvar-dynamic-extent new)
300 (setf (lvar-dynamic-extent new) it)
301 (setf (cleanup-info it) (subst new old (cleanup-info it)))))
302 (when (lvar-dynamic-extent new)
303 (do-uses (node new)
304 (unless (node-to-be-deleted-p node)
305 (node-ends-block node)))))
306 (t (flush-dest old)))
308 (values))
310 ;;;; block starting/creation
312 ;;; Return the block that CTRAN is the start of, making a block if
313 ;;; necessary. This function is called by IR1 translators which may
314 ;;; cause a CTRAN to be used more than once. Every CTRAN which may be
315 ;;; used more than once must start a block by the time that anyone
316 ;;; does a USE-CTRAN on it.
318 ;;; We also throw the block into the next/prev list for the
319 ;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have
320 ;;; made.
321 (defun ctran-starts-block (ctran)
322 (declare (type ctran ctran))
323 (ecase (ctran-kind ctran)
324 (:unused
325 (aver (not (ctran-block ctran)))
326 (let* ((next (component-last-block *current-component*))
327 (prev (block-prev next))
328 (new-block (make-block ctran)))
329 (setf (block-next new-block) next
330 (block-prev new-block) prev
331 (block-prev next) new-block
332 (block-next prev) new-block
333 (ctran-block ctran) new-block
334 (ctran-kind ctran) :block-start)
335 (aver (not (ctran-use ctran)))
336 new-block))
337 (:block-start
338 (ctran-block ctran))))
340 ;;; Ensure that CTRAN is the start of a block so that the use set can
341 ;;; be freely manipulated.
342 (defun ensure-block-start (ctran)
343 (declare (type ctran ctran))
344 (let ((kind (ctran-kind ctran)))
345 (ecase kind
346 ((:block-start))
347 ((:unused)
348 (setf (ctran-block ctran)
349 (make-block-key :start ctran))
350 (setf (ctran-kind ctran) :block-start))
351 ((:inside-block)
352 (node-ends-block (ctran-use ctran)))))
353 (values))
355 ;;; CTRAN must be the last ctran in an incomplete block; finish the
356 ;;; block and start a new one if necessary.
357 (defun start-block (ctran)
358 (declare (type ctran ctran))
359 (aver (not (ctran-next ctran)))
360 (ecase (ctran-kind ctran)
361 (:inside-block
362 (let ((block (ctran-block ctran))
363 (node (ctran-use ctran)))
364 (aver (not (block-last block)))
365 (aver node)
366 (setf (block-last block) node)
367 (setf (node-next node) nil)
368 (setf (ctran-use ctran) nil)
369 (setf (ctran-kind ctran) :unused)
370 (setf (ctran-block ctran) nil)
371 (link-blocks block (ctran-starts-block ctran))))
372 (:block-start)))
374 ;;;;
376 ;;; Filter values of LVAR through FORM, which must be an ordinary/mv
377 ;;; call. Exactly one argument must be 'DUMMY, which will be replaced
378 ;;; with LVAR. In case of an ordinary call the function should not
379 ;;; have return type NIL. We create a new "filtered" lvar.
381 ;;; TODO: remove preconditions.
382 (defun filter-lvar (lvar form)
383 (declare (type lvar lvar) (type list form))
384 (let* ((dest (lvar-dest lvar))
385 (ctran (node-prev dest)))
386 (with-ir1-environment-from-node dest
388 (ensure-block-start ctran)
389 (let* ((old-block (ctran-block ctran))
390 (new-start (make-ctran))
391 (filtered-lvar (make-lvar))
392 (new-block (ctran-starts-block new-start)))
394 ;; Splice in the new block before DEST, giving the new block
395 ;; all of DEST's predecessors.
396 (dolist (block (block-pred old-block))
397 (change-block-successor block old-block new-block))
399 (ir1-convert new-start ctran filtered-lvar form)
401 ;; KLUDGE: Comments at the head of this function in CMU CL
402 ;; said that somewhere in here we
403 ;; Set the new block's start and end cleanups to the *start*
404 ;; cleanup of PREV's block. This overrides the incorrect
405 ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
406 ;; Unfortunately I can't find any code which corresponds to this.
407 ;; Perhaps it was a stale comment? Or perhaps I just don't
408 ;; understand.. -- WHN 19990521
410 ;; Replace 'DUMMY with the LVAR. (We can find 'DUMMY because
411 ;; no LET conversion has been done yet.) The [mv-]combination
412 ;; code from the call in the form will be the use of the new
413 ;; check lvar. We substitute exactly one argument.
414 (let* ((node (lvar-use filtered-lvar))
415 victim)
416 (dolist (arg (basic-combination-args node) (aver victim))
417 (let* ((arg (principal-lvar arg))
418 (use (lvar-use arg))
419 leaf)
420 (when (and (ref-p use)
421 (constant-p (setf leaf (ref-leaf use)))
422 (eql (constant-value leaf) 'dummy))
423 (aver (not victim))
424 (setf victim arg))))
425 (aver (eq (constant-value (ref-leaf (lvar-use victim)))
426 'dummy))
428 (substitute-lvar filtered-lvar lvar)
429 (substitute-lvar lvar victim)
430 (flush-dest victim))
432 ;; Invoking local call analysis converts this call to a LET.
433 (locall-analyze-component *current-component*))))
434 (values))
436 ;;; Delete NODE and VALUE. It may result in some calls becoming tail.
437 (defun delete-filter (node lvar value)
438 (aver (eq (lvar-dest value) node))
439 (aver (eq (node-lvar node) lvar))
440 (cond (lvar (collect ((merges))
441 (when (return-p (lvar-dest lvar))
442 (do-uses (use value)
443 (when (and (basic-combination-p use)
444 (eq (basic-combination-kind use) :local))
445 (merges use))))
446 (substitute-lvar-uses lvar value
447 (and lvar (eq (lvar-uses lvar) node)))
448 (%delete-lvar-use node)
449 (prog1
450 (unlink-node node)
451 (dolist (merge (merges))
452 (merge-tail-sets merge)))))
453 (t (flush-dest value)
454 (unlink-node node))))
456 ;;; Make a CAST and insert it into IR1 before node NEXT.
458 (defun insert-cast-before (next lvar type policy &optional context)
459 (declare (type node next) (type lvar lvar) (type ctype type))
460 (with-ir1-environment-from-node next
461 (%insert-cast-before next (make-cast lvar type policy context))))
463 (defun %insert-cast-before (next cast)
464 (declare (type node next) (type cast cast))
465 (let* ((ctran (node-prev next))
466 (lvar (cast-value cast))
467 (internal-ctran (make-ctran)))
468 (setf (ctran-next ctran) cast
469 (node-prev cast) ctran)
470 (use-ctran cast internal-ctran)
471 (link-node-to-previous-ctran next internal-ctran)
472 (setf (lvar-dest lvar) cast)
473 (reoptimize-lvar lvar)
474 (when (return-p next)
475 (node-ends-block cast))
476 (setf (block-type-check (node-block cast)) t)
477 cast))
479 (defun insert-ref-before (leaf node)
480 (let* ((ref (make-ref leaf))
481 (lvar (make-lvar node))
482 (ctran (make-ctran))
483 (node-ctran (node-prev node)))
484 (push ref (leaf-refs leaf))
485 (setf (leaf-ever-used leaf) t)
486 (setf (ctran-next node-ctran) ref
487 (node-prev ref) node-ctran)
488 (use-ctran ref ctran)
489 (use-lvar ref lvar)
490 (link-node-to-previous-ctran node ctran)
491 lvar))
493 ;;;; miscellaneous shorthand functions
495 ;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since
496 ;;; the LEXENV-LAMBDA may be deleted, we must chain up the
497 ;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't
498 ;;; deleted, and then return its home.
499 (defun node-home-lambda (node)
500 (declare (type node node))
501 (do ((fun (lexenv-lambda (node-lexenv node))
502 (lexenv-lambda (lambda-call-lexenv fun))))
503 ((not (memq (functional-kind fun) '(:deleted :zombie)))
504 (lambda-home fun))
505 (when (eq (lambda-home fun) fun)
506 (return fun))))
508 (declaim (ftype (sfunction (node) component) node-component))
509 (defun node-component (node)
510 (block-component (node-block node)))
511 (declaim (ftype (sfunction (node) physenv) node-physenv))
512 (defun node-physenv (node)
513 (lambda-physenv (node-home-lambda node)))
515 #!-sb-fluid (declaim (inline node-stack-allocate-p))
516 (defun node-stack-allocate-p (node)
517 (awhen (node-lvar node)
518 (lvar-dynamic-extent it)))
520 (defun flushable-callable-arg-p (name arg-count)
521 (typecase name
522 (null
524 (symbol
525 (let* ((info (info :function :info name))
526 (attributes (and info
527 (fun-info-attributes info))))
528 (and info
529 (ir1-attributep attributes flushable)
530 (not (ir1-attributep attributes call))
531 (let ((type (proclaimed-ftype name)))
533 (not (fun-type-p type)) ;; Functions that accept anything, e.g. VALUES
534 (multiple-value-bind (min max) (fun-type-arg-limits type)
535 (cond ((and (not min) (not max))
536 nil)
537 ((< arg-count min)
538 nil)
539 ((and max (> arg-count max))
540 nil)
542 ;; Just check for T to ensure it won't signal type errors.
543 (not (find *universal-type*
544 (fun-type-n-arg-types arg-count type)
545 :test-not #'eql))))))))))))
547 (defun flushable-combination-args-p (combination info)
548 (block nil
549 (map-combination-args-and-types
550 (lambda (arg type lvars &optional annotation)
551 (declare (ignore type lvars))
552 (case (car annotation)
553 (function-designator
554 (let ((fun (or (lvar-fun-name arg t)
555 (and (constant-lvar-p arg)
556 (lvar-value arg)))))
557 (unless (and fun
558 (flushable-callable-arg-p fun (length (cadr annotation))))
559 (return))))
560 (inhibit-flushing
561 (let* ((except (cddr annotation)))
562 (unless (and except
563 (constant-lvar-p arg)
564 (memq (lvar-value arg) except))
565 (return))
566 nil))))
567 combination
568 info)
571 (defun flushable-combination-p (call)
572 (declare (type combination call))
573 (let ((kind (combination-kind call))
574 (info (combination-fun-info call)))
575 (or (when (and (eq kind :known) (fun-info-p info))
576 (let ((attr (fun-info-attributes info)))
577 (and (if (policy call (= safety 3))
578 (ir1-attributep attr flushable)
579 (ir1-attributep attr unsafely-flushable))
580 (flushable-combination-args-p call info))))
581 ;; Is it declared flushable locally?
582 (let ((name (lvar-fun-name (combination-fun call) t)))
583 (memq name (lexenv-flushable (node-lexenv call)))))))
585 ;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL
586 ;;; if there is none.
588 ;;; There can legitimately be no home lambda in dead code early in the
589 ;;; IR1 conversion process, e.g. when IR1-converting the SETQ form in
590 ;;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
591 ;;; where the block is just a placeholder during parsing and doesn't
592 ;;; actually correspond to code which will be written anywhere.
593 (declaim (ftype (sfunction (cblock) (or clambda null)) block-home-lambda-or-null))
594 (defun block-home-lambda-or-null (block)
595 (if (node-p (block-last block))
596 ;; This is the old CMU CL way of doing it.
597 (node-home-lambda (block-last block))
598 ;; Now that SBCL uses this operation more aggressively than CMU
599 ;; CL did, the old CMU CL way of doing it can fail in two ways.
600 ;; 1. It can fail in a few cases even when a meaningful home
601 ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of
602 ;; an IF.
603 ;; 2. It can fail when converting a form which is born orphaned
604 ;; so that it never had a meaningful home lambda, e.g. a form
605 ;; which follows a RETURN-FROM or GO form.
606 (let ((pred-list (block-pred block)))
607 ;; To deal with case 1, we reason that
608 ;; previous-in-target-execution-order blocks should be in the
609 ;; same lambda, and that they seem in practice to be
610 ;; previous-in-compilation-order blocks too, so we look back
611 ;; to find one which is sufficiently initialized to tell us
612 ;; what the home lambda is.
613 (if pred-list
614 ;; We could get fancy about this, flooding through the
615 ;; graph of all the previous blocks, but in practice it
616 ;; seems to work just to grab the first previous block and
617 ;; use it.
618 (node-home-lambda (block-last (first pred-list)))
619 ;; In case 2, we end up with an empty PRED-LIST and
620 ;; have to punt: There's no home lambda.
621 nil))))
623 ;;; Return the non-LET LAMBDA that holds BLOCK's code.
624 (declaim (ftype (sfunction (cblock) clambda) block-home-lambda))
625 (defun block-home-lambda (block)
626 (block-home-lambda-or-null block))
628 ;;; Return the IR1 physical environment for BLOCK.
629 (declaim (ftype (sfunction (cblock) physenv) block-physenv))
630 (defun block-physenv (block)
631 (lambda-physenv (block-home-lambda block)))
633 ;;;; DYNAMIC-EXTENT related
635 (defun lambda-var-original-name (leaf)
636 (let ((home (lambda-var-home leaf)))
637 (if (eq :external (functional-kind home))
638 (let* ((entry (functional-entry-fun home))
639 (p (1- (position leaf (lambda-vars home)))))
640 (leaf-debug-name
641 (if (optional-dispatch-p entry)
642 (elt (optional-dispatch-arglist entry) p)
643 (elt (lambda-vars entry) p))))
644 (leaf-debug-name leaf))))
646 (defun note-no-stack-allocation (lvar &key flush)
647 (do-uses (use (principal-lvar lvar))
648 (unless (or
649 ;; Don't complain about not being able to stack allocate constants.
650 (and (ref-p use) (constant-p (ref-leaf use)))
651 ;; If we're flushing, don't complain if we can flush the combination.
652 (and flush (combination-p use) (flushable-combination-p use))
653 ;; Don't report those with homes in :OPTIONAL -- we'd get doubled
654 ;; reports that way.
655 (and (ref-p use) (lambda-var-p (ref-leaf use))
656 (eq :optional (lambda-kind (lambda-var-home (ref-leaf use))))))
657 ;; FIXME: For the first leg (lambda-bind (lambda-var-home ...))
658 ;; would be a far better description, but since we use
659 ;; *COMPILER-ERROR-CONTEXT* for muffling we can't -- as that node
660 ;; can have different handled conditions.
661 (let ((*compiler-error-context* use))
662 (if (and (ref-p use) (lambda-var-p (ref-leaf use)))
663 (compiler-notify "~@<could~2:I not stack allocate ~S in: ~S~:@>"
664 (lambda-var-original-name (ref-leaf use))
665 (find-original-source (node-source-path use)))
666 (compiler-notify "~@<could~2:I not stack allocate: ~S~:@>"
667 (find-original-source (node-source-path use))))))))
669 (defun use-good-for-dx-p (use dx &optional component)
670 ;; FIXME: Can casts point to LVARs in other components?
671 ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the
672 ;; PRINCIPAL-LVAR is always in the same component as the original one. It
673 ;; would be either good to have an explanation of why casts don't point
674 ;; across components, or an explanation of when they do it. ...in the
675 ;; meanwhile AVER that our assumption holds true.
676 (aver (or (not component) (eq component (node-component use))))
677 (and (not (node-to-be-deleted-p use))
678 (or (dx-combination-p use dx)
679 (and (cast-p use)
680 (not (cast-type-check use))
681 (lvar-good-for-dx-p (cast-value use) dx component))
682 (and (trivial-lambda-var-ref-p use)
683 (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use))))
684 (or (eq use uses)
685 (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use) dx component)))))))
687 (defun lvar-good-for-dx-p (lvar dx &optional component)
688 (let ((uses (lvar-uses lvar)))
689 (cond
690 ((null uses)
691 nil)
692 ((consp uses)
693 (every (lambda (use)
694 (use-good-for-dx-p use dx component))
695 uses))
697 (use-good-for-dx-p uses dx component)))))
699 (defun known-dx-combination-p (use dx)
700 (and (eq (combination-kind use) :known)
701 (let ((info (combination-fun-info use)))
702 (or (awhen (fun-info-stack-allocate-result info)
703 (funcall it use dx))
704 (awhen (fun-info-result-arg info)
705 (lvar-good-for-dx-p (nth it (combination-args use))
706 dx))))))
708 ;;; Bound to NIL in RECHECK-DYNAMIC-EXTENT-LVARS, so that the
709 ;;; combinations that didn't get converted are not treated as dx-safe.
710 (defvar *dx-combination-p-check-local* t)
712 (defun dx-combination-p (use dx)
713 (let (seen)
714 (labels ((recurse (use)
715 (and (combination-p use)
716 (not (memq use seen))
718 ;; Known, and can do DX.
719 (known-dx-combination-p use dx)
720 ;; Possibly a not-yet-eliminated lambda which ends up returning the
721 ;; results of an actual known DX combination.
722 (and *dx-combination-p-check-local*
723 (let* ((fun (combination-fun use))
724 (ref (principal-lvar-use fun))
725 (clambda (when (ref-p ref)
726 (ref-leaf ref)))
727 (creturn (when (lambda-p clambda)
728 (lambda-return clambda)))
729 (result-use (when (return-p creturn)
730 (principal-lvar-use (return-result creturn)))))
731 ;; Unlikely to have enough recursive local
732 ;; functions to warrant a hash-table
733 (push use seen)
734 ;; FIXME: We should be able to deal with multiple uses here as well.
735 (and (recurse result-use)
736 (combination-args-flow-cleanly-p use result-use dx))))))))
737 (recurse use))))
739 (defun combination-args-flow-cleanly-p (combination1 combination2 dx)
740 (labels ((recurse (combination)
741 (or (eq combination combination2)
742 (if (known-dx-combination-p combination dx)
743 (let* ((lvar (combination-lvar combination))
744 (dest (and lvar
745 (lvar-dest lvar))))
746 (and (combination-p dest)
747 (recurse dest)))
748 (let* ((fun1 (combination-fun combination))
749 (ref1 (principal-lvar-use fun1))
750 (clambda1 (when (ref-p ref1) (ref-leaf ref1))))
751 (when (lambda-p clambda1)
752 (dolist (var (lambda-vars clambda1) t)
753 (dolist (var-ref (lambda-var-refs var))
754 (let* ((lvar (ref-lvar var-ref))
755 (dest (and lvar (principal-lvar-dest lvar))))
756 (unless (or (not dest)
757 (and (combination-p dest) (recurse dest)))
758 (return-from combination-args-flow-cleanly-p nil)))))))))))
759 (recurse combination1)))
761 (defun ref-good-for-dx-p (ref)
762 (let* ((lvar (ref-lvar ref))
763 (dest (when lvar (lvar-dest lvar))))
764 (and (combination-p dest)
765 (eq :known (combination-kind dest))
766 (awhen (combination-fun-info dest)
767 (or (ir1-attributep (fun-info-attributes it) dx-safe)
768 (and (not (combination-lvar dest))
769 (awhen (fun-info-result-arg it)
770 (eql lvar (nth it (combination-args dest))))))))))
772 (defun trivial-lambda-var-ref-p (use)
773 (and (ref-p use)
774 (let ((var (ref-leaf use)))
775 ;; lambda-var, no SETS, not explicitly indefinite-extent.
776 (when (and (lambda-var-p var) (not (lambda-var-sets var))
777 (neq :indefinite (lambda-var-extent var)))
778 (let ((home (lambda-var-home var))
779 (refs (lambda-var-refs var)))
780 ;; bound by a non-XEP system lambda, no other REFS that aren't
781 ;; DX-SAFE, or are result-args when the result is discarded.
782 (when (and (lambda-system-lambda-p home)
783 (neq :external (lambda-kind home))
784 (dolist (ref refs t)
785 (unless (or (eq use ref) (ref-good-for-dx-p ref))
786 (return nil))))
787 ;; the LAMBDA this var is bound by has only a single REF, going
788 ;; to a combination
789 (let* ((lambda-refs (lambda-refs home))
790 (primary (car lambda-refs)))
791 (and (ref-p primary)
792 (not (cdr lambda-refs))
793 (combination-p (lvar-dest (ref-lvar primary)))))))))))
795 (defun trivial-lambda-var-ref-lvar (use)
796 (let* ((this (ref-leaf use))
797 (fun (lambda-var-home this))
798 (vars (lambda-vars fun))
799 (combination (lvar-dest (ref-lvar (car (lambda-refs fun)))))
800 (args (combination-args combination)))
801 (aver (= (length vars) (length args)))
802 (loop for var in vars
803 for arg in args
804 when (eq var this)
805 return arg)))
807 (defun lambda-var-ref-lvar (ref)
808 (let ((var (ref-leaf ref)))
809 (when (and (lambda-var-p var)
810 (not (lambda-var-sets var)))
811 (let* ((fun (lambda-var-home var))
812 (vars (lambda-vars fun))
813 (lvar (ref-lvar (car (lambda-refs fun))))
814 (combination (and lvar
815 (lvar-dest lvar))))
816 (when (combination-p combination)
817 (loop for v in vars
818 for arg in (combination-args combination)
819 when (eq v var)
820 return arg))))))
822 ;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends.
823 (defun handle-nested-dynamic-extent-lvars (dx lvar &optional recheck-component)
824 (let ((uses (lvar-uses lvar)))
825 ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS.
826 ;; Uses of mupltiple-use LVARs already end their blocks, so we just need
827 ;; to process uses of single-use LVARs.
828 (when (node-p uses)
829 (when (node-to-be-deleted-p uses)
830 (return-from handle-nested-dynamic-extent-lvars))
831 (node-ends-block uses))
832 ;; If this LVAR's USE is good for DX, it is either a CAST, or it
833 ;; must be a regular combination whose arguments are potentially DX as well.
834 (flet ((recurse (use)
835 (etypecase use
836 (cast
837 (handle-nested-dynamic-extent-lvars
838 dx (cast-value use) recheck-component))
839 (combination
840 (loop for arg in (combination-args use)
841 ;; deleted args show up as NIL here
842 when (and arg
843 (lvar-good-for-dx-p arg dx recheck-component))
844 append (handle-nested-dynamic-extent-lvars
845 dx arg recheck-component)))
846 (ref
847 (let* ((other (trivial-lambda-var-ref-lvar use)))
848 (unless (eq other lvar)
849 (handle-nested-dynamic-extent-lvars
850 dx other recheck-component)))))))
851 (cons (cons dx lvar)
852 (if (listp uses)
853 (loop for use in uses
854 when (use-good-for-dx-p use dx recheck-component)
855 nconc (recurse use))
856 (when (use-good-for-dx-p uses dx recheck-component)
857 (recurse uses)))))))
859 ;;; Return the Top Level Form number of PATH, i.e. the ordinal number
860 ;;; of its original source's top level form in its compilation unit.
861 (defun source-path-tlf-number (path)
862 (declare (list path))
863 (car (last path)))
865 ;;; Return the (reversed) list for the PATH in the original source
866 ;;; (with the Top Level Form number last).
867 (declaim (ftype (sfunction (list) list) source-path-original-source))
868 (defun source-path-original-source (path)
869 (declare (list path) (inline member))
870 (cddr (member 'original-source-start path :test #'eq)))
872 ;;; Return the Form Number of PATH's original source inside the Top
873 ;;; Level Form that contains it. This is determined by the order that
874 ;;; we walk the subforms of the top level source form.
875 (declaim (ftype (sfunction (list) (or null index)) source-path-form-number))
876 (defun source-path-form-number (path)
877 (declare (inline member))
878 (cadr (member 'original-source-start path :test #'eq)))
880 ;;; Return a list of all the enclosing forms not in the original
881 ;;; source that converted to get to this form, with the immediate
882 ;;; source for node at the start of the list.
883 (defun source-path-forms (path)
884 (subseq path 0 (position 'original-source-start path)))
886 (defun tree-some (predicate tree)
887 (let ((seen (make-hash-table)))
888 (labels ((walk (tree)
889 (cond ((funcall predicate tree))
890 ((and (consp tree)
891 (not (gethash tree seen)))
892 (setf (gethash tree seen) t)
893 (or (walk (car tree))
894 (walk (cdr tree)))))))
895 (walk tree))))
897 ;;; Return the innermost source form for NODE.
898 (defun node-source-form (node)
899 (declare (type node node))
900 (let* ((path (node-source-path node))
901 (forms (remove-if (lambda (x)
902 (tree-some #'leaf-p x))
903 (source-path-forms path))))
904 ;; another option: if first form includes a leaf, return
905 ;; find-original-source instead.
906 (if forms
907 (first forms)
908 (values (find-original-source path)))))
910 ;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise
911 ;;; NIL, NIL.
912 (defun lvar-source (lvar)
913 (let ((use (lvar-uses lvar)))
914 (if (listp use)
915 (values nil nil)
916 (values (node-source-form use) t))))
918 (defun common-suffix (x y)
919 (let ((mismatch (mismatch x y :from-end t)))
920 (if mismatch
921 (subseq x mismatch)
922 x)))
924 ;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a
925 ;;; singleton. Otherwise, return a list of the lowest common
926 ;;; ancestor source form of all the uses (if it can be found),
927 ;;; followed by all the uses' source forms.
928 (defun lvar-all-sources (lvar)
929 (let ((use (principal-lvar-use lvar)))
930 (if (listp use)
931 (let ((forms '())
932 (path (node-source-path (first use))))
933 (dolist (use use (cons (if (find 'original-source-start path)
934 (find-original-source path)
935 "a hairy form")
936 forms))
937 (pushnew (node-source-form use) forms)
938 (setf path (common-suffix path
939 (node-source-path use)))))
940 (list (node-source-form use)))))
942 ;;; Return the LAMBDA that is CTRAN's home, or NIL if there is none.
943 (declaim (ftype (sfunction (ctran) (or clambda null))
944 ctran-home-lambda-or-null))
945 (defun ctran-home-lambda-or-null (ctran)
946 ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
947 ;; implementation might not be quite right, or might be uglier than
948 ;; necessary. It appears that the original Python never found a need
949 ;; to do this operation. The obvious things based on
950 ;; NODE-HOME-LAMBDA of CTRAN-USE usually work; then if that fails,
951 ;; BLOCK-HOME-LAMBDA of CTRAN-BLOCK works, given that we
952 ;; generalize it enough to grovel harder when the simple CMU CL
953 ;; approach fails, and furthermore realize that in some exceptional
954 ;; cases it might return NIL. -- WHN 2001-12-04
955 (cond ((ctran-use ctran)
956 (node-home-lambda (ctran-use ctran)))
957 ((ctran-block ctran)
958 (block-home-lambda-or-null (ctran-block ctran)))
960 (bug "confused about home lambda for ~S" ctran))))
962 ;;; Return the LAMBDA that is CTRAN's home.
963 (declaim (ftype (sfunction (ctran) clambda) ctran-home-lambda))
964 (defun ctran-home-lambda (ctran)
965 (ctran-home-lambda-or-null ctran))
967 (declaim (inline cast-single-value-p))
968 (defun cast-single-value-p (cast)
969 (not (values-type-p (cast-asserted-type cast))))
971 #!-sb-fluid (declaim (inline lvar-single-value-p))
972 (defun lvar-single-value-p (lvar)
973 (or (not lvar) (%lvar-single-value-p lvar)))
974 (defun %lvar-single-value-p (lvar)
975 (let ((dest (lvar-dest lvar)))
976 (typecase dest
977 ((or creturn exit)
978 nil)
979 (mv-combination
980 (eq (basic-combination-fun dest) lvar))
981 (cast
982 (and (cast-single-value-p dest)
983 (acond ((node-lvar dest) (%lvar-single-value-p it))
984 (t t))))
985 (t t))))
987 (defun principal-lvar-end (lvar)
988 (loop for prev = lvar then (node-lvar dest)
989 for dest = (and prev (lvar-dest prev))
990 while (cast-p dest)
991 finally (return (values dest prev))))
993 (defun principal-lvar-single-valuify (lvar)
994 (loop for prev = lvar then (node-lvar dest)
995 for dest = (and prev (lvar-dest prev))
996 while (cast-p dest)
997 do (setf (node-derived-type dest)
998 (make-short-values-type (list (single-value-type
999 (node-derived-type dest)))))
1000 (reoptimize-lvar prev)))
1002 ;;; Return a new LEXENV just like DEFAULT except for the specified
1003 ;;; slot values. Values for the alist slots are APPENDed to the
1004 ;;; beginning of the current value, rather than replacing it entirely.
1005 (defun make-lexenv (&key (default *lexenv*)
1006 funs vars blocks tags
1007 type-restrictions
1008 (lambda (lexenv-lambda default))
1009 (cleanup (lexenv-cleanup default))
1010 (handled-conditions (lexenv-handled-conditions default))
1011 (disabled-package-locks
1012 (lexenv-disabled-package-locks default))
1013 (policy (lexenv-policy default))
1014 (user-data (lexenv-user-data default))
1015 (flushable (lexenv-flushable default)))
1016 (macrolet ((frob (var slot)
1017 `(let ((old (,slot default)))
1018 (if ,var
1019 (append ,var old)
1020 old))))
1021 (internal-make-lexenv
1022 (frob funs lexenv-funs)
1023 (frob vars lexenv-vars)
1024 (frob blocks lexenv-blocks)
1025 (frob tags lexenv-tags)
1026 (frob type-restrictions lexenv-type-restrictions)
1027 (frob flushable lexenv-flushable)
1028 lambda
1029 cleanup handled-conditions disabled-package-locks
1030 policy
1031 user-data
1032 default)))
1034 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
1035 ;;; macroexpander
1036 (defun make-restricted-lexenv (lexenv)
1037 (flet ((fun-good-p (fun)
1038 (destructuring-bind (name . thing) fun
1039 (declare (ignore name))
1040 (etypecase thing
1041 (functional nil)
1042 (global-var t)
1043 (cons (aver (eq (car thing) 'macro))
1044 t))))
1045 (var-good-p (var)
1046 (destructuring-bind (name . thing) var
1047 (declare (ignore name))
1048 (etypecase thing
1049 ;; The evaluator will mark lexicals with :BOGUS when it
1050 ;; translates an interpreter lexenv to a compiler
1051 ;; lexenv.
1052 ((or leaf #!+sb-eval (member :bogus)) nil)
1053 (cons (aver (eq (car thing) 'macro))
1055 (heap-alien-info nil)))))
1056 (internal-make-lexenv
1057 (remove-if-not #'fun-good-p (lexenv-funs lexenv))
1058 (remove-if-not #'var-good-p (lexenv-vars lexenv))
1061 (lexenv-type-restrictions lexenv) ; XXX
1065 (lexenv-handled-conditions lexenv)
1066 (lexenv-disabled-package-locks lexenv)
1067 (lexenv-policy lexenv)
1068 (lexenv-user-data lexenv)
1069 lexenv)))
1071 ;;;; flow/DFO/component hackery
1073 ;;; Join BLOCK1 and BLOCK2.
1074 (defun link-blocks (block1 block2)
1075 (declare (type cblock block1 block2))
1076 (setf (block-succ block1)
1077 (if (block-succ block1)
1078 (%link-blocks block1 block2)
1079 (list block2)))
1080 (push block1 (block-pred block2))
1081 (values))
1082 (defun %link-blocks (block1 block2)
1083 (declare (type cblock block1 block2))
1084 (let ((succ1 (block-succ block1)))
1085 (aver (not (memq block2 succ1)))
1086 (cons block2 succ1)))
1088 ;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2.
1089 (defun unlink-blocks (block1 block2)
1090 (declare (type cblock block1 block2))
1091 (let ((succ1 (block-succ block1)))
1092 (if (eq block2 (car succ1))
1093 (setf (block-succ block1) (cdr succ1))
1094 (do ((succ (cdr succ1) (cdr succ))
1095 (prev succ1 succ))
1096 ((eq (car succ) block2)
1097 (setf (cdr prev) (cdr succ)))
1098 (aver succ))))
1100 (setf (block-pred block2)
1101 (delq block1 (block-pred block2)))
1102 (values))
1104 ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK
1105 ;;; and NEW. If BLOCK ends in an IF, then we have to fix up the
1106 ;;; consequent/alternative blocks to point to NEW.
1107 (defun change-block-successor (block old new)
1108 (declare (type cblock new old block))
1109 (unlink-blocks block old)
1110 (let ((last (block-last block))
1111 (comp (block-component block)))
1112 (setf (component-reanalyze comp) t)
1113 (typecase last
1114 (cif
1115 (let* ((succ-left (block-succ block))
1116 (new (if (and (eq new (component-tail comp))
1117 succ-left)
1118 (first succ-left)
1119 new)))
1120 (unless (memq new succ-left)
1121 (link-blocks block new))
1122 (macrolet ((frob (slot)
1123 `(when (eq (,slot last) old)
1124 (setf (,slot last) new))))
1125 (frob if-consequent)
1126 (frob if-alternative)
1127 (when (eq (if-consequent last)
1128 (if-alternative last))
1129 (reoptimize-component (block-component block) :maybe)))))
1131 (unless (memq new (block-succ block))
1132 (link-blocks block new)))))
1134 (values))
1136 ;;; Unlink a block from the next/prev chain. We also null out the
1137 ;;; COMPONENT.
1138 (declaim (ftype (sfunction (cblock) (values)) remove-from-dfo))
1139 (defun remove-from-dfo (block)
1140 (let ((next (block-next block))
1141 (prev (block-prev block)))
1142 (setf (block-component block) nil)
1143 (setf (block-next prev) next)
1144 (setf (block-prev next) prev))
1145 (values))
1147 ;;; Add BLOCK to the next/prev chain following AFTER. We also set the
1148 ;;; COMPONENT to be the same as for AFTER.
1149 (defun add-to-dfo (block after)
1150 (declare (type cblock block after))
1151 (let ((next (block-next after))
1152 (comp (block-component after)))
1153 (aver (not (eq (component-kind comp) :deleted)))
1154 (setf (block-component block) comp)
1155 (setf (block-next after) block)
1156 (setf (block-prev block) after)
1157 (setf (block-next block) next)
1158 (setf (block-prev next) block))
1159 (values))
1161 ;;; List all NLX-INFOs which BLOCK can exit to.
1163 ;;; We hope that no cleanup actions are performed in the middle of
1164 ;;; BLOCK, so it is enough to look only at cleanups in the block
1165 ;;; end. The tricky thing is a special cleanup block; all its nodes
1166 ;;; have the same cleanup info, corresponding to the start, so the
1167 ;;; same approach returns safe result.
1168 (defun map-block-nlxes (fun block &optional dx-cleanup-fun)
1169 (do-nested-cleanups (cleanup (block-end-lexenv block))
1170 (let ((mess-up (cleanup-mess-up cleanup)))
1171 (case (cleanup-kind cleanup)
1172 ((:block :tagbody)
1173 (aver (entry-p mess-up))
1174 (loop for exit in (entry-exits mess-up)
1175 for nlx-info = (exit-nlx-info exit)
1176 do (funcall fun nlx-info)))
1177 ((:catch :unwind-protect)
1178 (aver (combination-p mess-up))
1179 (let* ((arg-lvar (first (basic-combination-args mess-up)))
1180 (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar)))))
1181 (funcall fun nlx-info)))
1182 ((:dynamic-extent)
1183 (when dx-cleanup-fun
1184 (funcall dx-cleanup-fun cleanup)))))))
1186 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
1187 ;;; the head and tail which are set to T.
1188 (declaim (ftype (sfunction (component) (values)) clear-flags))
1189 (defun clear-flags (component)
1190 (let ((head (component-head component))
1191 (tail (component-tail component)))
1192 (setf (block-flag head) t)
1193 (setf (block-flag tail) t)
1194 (do-blocks (block component)
1195 (setf (block-flag block) nil)))
1196 (values))
1198 ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially
1199 ;;; true in the head and tail blocks.
1200 (declaim (ftype (sfunction () component) make-empty-component))
1201 (defun make-empty-component ()
1202 (let* ((head (make-block-key :start nil :component nil))
1203 (tail (make-block-key :start nil :component nil))
1204 (res (make-component head tail)))
1205 (setf (block-flag head) t)
1206 (setf (block-flag tail) t)
1207 (setf (block-component head) res)
1208 (setf (block-component tail) res)
1209 (setf (block-next head) tail)
1210 (setf (block-prev tail) head)
1211 res))
1213 ;;; Make NODE the LAST node in its block, splitting the block if necessary.
1214 ;;; The new block is added to the DFO immediately following NODE's block.
1215 ;;; Returns the new block if it's created.
1216 (defun node-ends-block (node)
1217 (declare (type node node))
1218 (let* ((block (node-block node))
1219 (start (node-next node))
1220 (last (block-last block)))
1221 (check-type last node)
1222 (unless (eq last node)
1223 (aver (and (eq (ctran-kind start) :inside-block)
1224 (not (block-delete-p block))))
1225 (let* ((succ (block-succ block))
1226 (new-block
1227 (make-block-key :start start
1228 :component (block-component block)
1229 :succ succ :last last)))
1230 (setf (ctran-kind start) :block-start)
1231 (setf (ctran-use start) nil)
1232 (setf (block-last block) node)
1233 (setf (node-next node) nil)
1234 (dolist (b succ)
1235 (setf (block-pred b)
1236 (cons new-block (remove block (block-pred b)))))
1237 (setf (block-succ block) ())
1238 (link-blocks block new-block)
1239 (add-to-dfo new-block block)
1240 (setf (component-reanalyze (block-component block)) t)
1242 (do ((ctran start (node-next (ctran-next ctran))))
1243 ((not ctran))
1244 (setf (ctran-block ctran) new-block))
1245 new-block))))
1247 ;;;; deleting stuff
1249 ;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
1250 (defun delete-lambda-var (leaf)
1251 (declare (type lambda-var leaf))
1253 (setf (lambda-var-deleted leaf) t)
1254 ;; Iterate over all local calls flushing the corresponding argument,
1255 ;; allowing the computation of the argument to be deleted. We also
1256 ;; mark the LET for reoptimization, since it may be that we have
1257 ;; deleted its last variable.
1258 (let* ((fun (lambda-var-home leaf))
1259 (n (position leaf (lambda-vars fun))))
1260 (dolist (ref (leaf-refs fun))
1261 (let* ((lvar (node-lvar ref))
1262 (dest (and lvar (lvar-dest lvar))))
1263 (when (and (basic-combination-p dest)
1264 (eq (basic-combination-fun dest) lvar)
1265 (eq (basic-combination-kind dest) :local))
1266 (if (mv-combination-p dest)
1267 ;; Let FLUSH-DEAD-CODE deal with it
1268 ;; since it's a bit tricky to delete multiple-valued
1269 ;; args and existing code doesn't expect to see NIL in
1270 ;; mv-combination-args.
1271 (setf (block-flush-p (node-block dest)) t)
1272 (let* ((args (basic-combination-args dest))
1273 (arg (elt args n)))
1274 (reoptimize-lvar arg)
1275 (flush-dest arg)
1276 (setf (elt args n) nil)))))))
1278 ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
1279 ;; too much difficulty, since we can efficiently implement
1280 ;; write-only variables. We iterate over the SETs, marking their
1281 ;; blocks for dead code flushing, since we can delete SETs whose
1282 ;; value is unused.
1283 (dolist (set (lambda-var-sets leaf))
1284 (setf (block-flush-p (node-block set)) t))
1286 (values))
1288 ;;; Note that something interesting has happened to VAR.
1289 (defun reoptimize-lambda-var (var)
1290 (declare (type lambda-var var))
1291 (let ((fun (lambda-var-home var)))
1292 ;; We only deal with LET variables, marking the corresponding
1293 ;; initial value arg as needing to be reoptimized.
1294 (when (and (eq (functional-kind fun) :let)
1295 (leaf-refs var))
1296 (do ((args (basic-combination-args
1297 (lvar-dest (node-lvar (first (leaf-refs fun)))))
1298 (cdr args))
1299 (vars (lambda-vars fun) (cdr vars)))
1300 ((eq (car vars) var)
1301 (reoptimize-lvar (car args))))))
1302 (values))
1304 ;;; Delete a function that has no references. This need only be called
1305 ;;; on functions that never had any references, since otherwise
1306 ;;; DELETE-REF will handle the deletion.
1307 (defun delete-functional (fun)
1308 (aver (and (null (leaf-refs fun))
1309 (not (functional-entry-fun fun))))
1310 (etypecase fun
1311 (optional-dispatch (delete-optional-dispatch fun))
1312 (clambda (delete-lambda fun)))
1313 (values))
1315 ;;; Deal with deleting the last reference to a CLAMBDA, which means
1316 ;;; that the lambda is unreachable, so that its body may be
1317 ;;; deleted. We set FUNCTIONAL-KIND to :DELETED and rely on
1318 ;;; IR1-OPTIMIZE to delete its blocks.
1319 (defun delete-lambda (clambda)
1320 (declare (type clambda clambda))
1321 (let ((original-kind (functional-kind clambda))
1322 (bind (lambda-bind clambda)))
1323 (aver (not (member original-kind '(:deleted :toplevel))))
1324 (aver (not (functional-has-external-references-p clambda)))
1325 (aver (or (eq original-kind :zombie) bind))
1326 (setf (functional-kind clambda) :deleted)
1327 (setf (lambda-bind clambda) nil)
1329 (labels ((delete-children (lambda)
1330 (dolist (child (lambda-children lambda))
1331 (cond ((eq (functional-kind child) :deleted)
1332 (delete-children child))
1333 ;; Can happen when all optional entries produce
1334 ;; errors, making the main entry unreachable,
1335 ;; but the XEP should not be deleted, as it can
1336 ;; still be reachable.
1337 ((and (eq (functional-kind child) :external)
1338 (eq (main-entry (functional-entry-fun child)) clambda)))
1340 (delete-lambda child))))
1341 (setf (lambda-children lambda) nil)
1342 (setf (lambda-parent lambda) nil)))
1343 (delete-children clambda))
1345 ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
1346 ;; that we're using the old value of the KIND slot, not the
1347 ;; current slot value, which has now been set to :DELETED.)
1348 (case original-kind
1349 (:zombie)
1350 ((:let :mv-let :assignment)
1351 (let ((bind-block (node-block bind)))
1352 (mark-for-deletion bind-block))
1353 (let ((home (lambda-home clambda)))
1354 (setf (lambda-lets home) (delete clambda (lambda-lets home))))
1355 ;; KLUDGE: In presence of NLEs we cannot always understand that
1356 ;; LET's BIND dominates its body [for a LET "its" body is not
1357 ;; quite its]; let's delete too dangerous for IR2 stuff. --
1358 ;; APD, 2004-01-01
1359 (dolist (var (lambda-vars clambda))
1360 (flet ((delete-node (node)
1361 (mark-for-deletion (node-block node))))
1362 (mapc #'delete-node (leaf-refs var))
1363 (mapc #'delete-node (lambda-var-sets var)))))
1365 ;; Function has no reachable references.
1366 (dolist (ref (lambda-refs clambda))
1367 (mark-for-deletion (node-block ref)))
1368 ;; If the function isn't a LET, we unlink the function head
1369 ;; and tail from the component head and tail to indicate that
1370 ;; the code is unreachable. We also delete the function from
1371 ;; COMPONENT-LAMBDAS (it won't be there before local call
1372 ;; analysis, but no matter.) If the lambda was never
1373 ;; referenced, we give a note.
1374 (let* ((bind-block (node-block bind))
1375 (component (block-component bind-block))
1376 (return (lambda-return clambda))
1377 (return-block (and return (node-block return))))
1378 (unless (leaf-ever-used clambda)
1379 (let ((*compiler-error-context* bind))
1380 (compiler-notify 'code-deletion-note
1381 :format-control "deleting unused function~:[.~;~:*~% ~S~]"
1382 :format-arguments (list (leaf-debug-name clambda)))))
1383 (unless (block-delete-p bind-block)
1384 (unlink-blocks (component-head component) bind-block))
1385 (when (and return-block (not (block-delete-p return-block)))
1386 (mark-for-deletion return-block)
1387 (unlink-blocks return-block (component-tail component)))
1388 (setf (component-reanalyze component) t)
1389 (let ((tails (lambda-tail-set clambda)))
1390 (setf (tail-set-funs tails)
1391 (delete clambda (tail-set-funs tails)))
1392 (setf (lambda-tail-set clambda) nil))
1393 (setf (component-lambdas component)
1394 (delq clambda (component-lambdas component))))))
1396 ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
1397 ;; ENTRY-FUN so that people will know that it is not an entry
1398 ;; point anymore.
1399 (when (eq original-kind :external)
1400 (let ((fun (functional-entry-fun clambda)))
1401 (setf (functional-entry-fun fun) nil)
1402 (when (optional-dispatch-p fun)
1403 (delete-optional-dispatch fun)))))
1405 (values))
1407 ;;; Deal with deleting the last reference to an OPTIONAL-DISPATCH. We
1408 ;;; have to be a bit more careful than with lambdas, since DELETE-REF
1409 ;;; is used both before and after local call analysis. Afterward, all
1410 ;;; references to still-existing OPTIONAL-DISPATCHes have been moved
1411 ;;; to the XEP, leaving it with no references at all. So we look at
1412 ;;; the XEP to see whether an optional-dispatch is still really being
1413 ;;; used. But before local call analysis, there are no XEPs, and all
1414 ;;; references are direct.
1416 ;;; When we do delete the OPTIONAL-DISPATCH, we grovel all of its
1417 ;;; entry-points, making them be normal lambdas, and then deleting the
1418 ;;; ones with no references. This deletes any e-p lambdas that were
1419 ;;; either never referenced, or couldn't be deleted when the last
1420 ;;; reference was deleted (due to their :OPTIONAL kind.)
1422 ;;; Note that the last optional entry point may alias the main entry,
1423 ;;; so when we process the main entry, its KIND may have been changed
1424 ;;; to NIL or even converted to a LETlike value.
1425 (defun delete-optional-dispatch (leaf)
1426 (declare (type optional-dispatch leaf))
1427 (let ((entry (functional-entry-fun leaf)))
1428 (unless (and entry
1429 (or (leaf-refs entry)
1430 (eq (functional-kind entry) :external)))
1431 (aver (or (not entry) (eq (functional-kind entry) :deleted)))
1432 (setf (functional-kind leaf) :deleted)
1434 (flet ((frob (fun)
1435 (unless (eq (functional-kind fun) :deleted)
1436 (aver (eq (functional-kind fun) :optional))
1437 (setf (functional-kind fun) nil)
1438 (let ((refs (leaf-refs fun)))
1439 (cond ((null refs)
1440 (delete-lambda fun))
1441 ((null (rest refs))
1442 (or (maybe-let-convert fun)
1443 (maybe-convert-to-assignment fun)))
1445 (maybe-convert-to-assignment fun)))))))
1447 (dolist (ep (optional-dispatch-entry-points leaf))
1448 (when (promise-ready-p ep)
1449 (frob (force ep))))
1450 (when (optional-dispatch-more-entry leaf)
1451 (frob (optional-dispatch-more-entry leaf)))
1452 (let ((main (optional-dispatch-main-entry leaf)))
1453 (when entry
1454 (setf (functional-entry-fun entry) main)
1455 (setf (functional-entry-fun main) entry))
1456 (when (eq (functional-kind main) :optional)
1457 (frob main))))))
1459 (values))
1461 ;;; This is called by locall-analyze-fun-1 after it convers a call to
1462 ;;; FUN into a local call.
1463 ;;; Presumably, the function can be no longer reused by new calls to
1464 ;;; FUN, so the whole thing has to be removed from *FREE-FUNS*
1465 (defun note-local-functional (fun)
1466 (declare (type functional fun))
1467 (when (and (leaf-has-source-name-p fun)
1468 (eq (leaf-source-name fun) (functional-debug-name fun)))
1469 (let* ((name (leaf-source-name fun))
1470 (defined-fun (gethash name *free-funs*)))
1471 (when (defined-fun-p defined-fun)
1472 (remhash name *free-funs*)))))
1474 ;;; Return functional for DEFINED-FUN which has been converted in policy
1475 ;;; corresponding to the current one, or NIL if no such functional exists.
1477 ;;; Also check that the parent of the functional is visible in the current
1478 ;;; environment and is in the current component.
1479 (defun defined-fun-functional (defined-fun)
1480 (let ((functionals (defined-fun-functionals defined-fun)))
1481 (when functionals
1482 (let* ((sample (car functionals))
1483 (there (lambda-parent (if (lambda-p sample)
1484 sample
1485 (optional-dispatch-main-entry sample)))))
1486 (when there
1487 (labels ((lookup (here)
1488 (unless (eq here there)
1489 (if here
1490 (lookup (lambda-parent here))
1491 ;; We looked up all the way up, and didn't find the parent
1492 ;; of the functional -- therefore it is nested in a lambda
1493 ;; we don't see, so return nil.
1494 (return-from defined-fun-functional nil)))))
1495 (lookup (lexenv-lambda *lexenv*)))))
1496 ;; Now find a functional whose policy matches the current one, if we already
1497 ;; have one.
1498 (let ((policy (lexenv-%policy *lexenv*)))
1499 (dolist (functional functionals)
1500 (when (and (not (memq (functional-kind functional) '(:deleted :zombie)))
1501 (policy= policy (lexenv-%policy (functional-lexenv functional)))
1502 ;; Is it in the same component
1503 (let ((home-lambda (lambda-home (main-entry functional))))
1504 (and (not (memq (functional-kind home-lambda) '(:deleted :zombie)))
1505 (eq (lambda-component home-lambda)
1506 *current-component*))))
1507 (return functional)))))))
1509 ;;; Do stuff to delete the semantic attachments of a REF node. When
1510 ;;; this leaves zero or one reference, we do a type dispatch off of
1511 ;;; the leaf to determine if a special action is appropriate.
1512 (defun delete-ref (ref)
1513 (declare (type ref ref))
1514 (let* ((leaf (ref-leaf ref))
1515 (refs (delq ref (leaf-refs leaf)))
1516 (home (node-home-lambda ref)))
1517 (setf (leaf-refs leaf) refs)
1518 (when (and (typep leaf '(or clambda lambda-var))
1519 (not (find home refs :key #'node-home-lambda)))
1520 ;; It was the last reference from this lambda, remove it
1521 (sset-delete leaf (lambda-calls-or-closes home)))
1522 (cond ((null refs)
1523 (typecase leaf
1524 (lambda-var
1525 (delete-lambda-var leaf))
1526 (clambda
1527 (ecase (functional-kind leaf)
1528 ((nil :let :mv-let :assignment :escape :cleanup)
1529 (aver (null (functional-entry-fun leaf)))
1530 (delete-lambda leaf))
1531 (:external
1532 (unless (functional-has-external-references-p leaf)
1533 (delete-lambda leaf)))
1534 ((:deleted :zombie :optional))))
1535 (optional-dispatch
1536 (unless (eq (functional-kind leaf) :deleted)
1537 (delete-optional-dispatch leaf)))))
1538 ((null (rest refs))
1539 (typecase leaf
1540 (clambda (or (maybe-let-convert leaf)
1541 (maybe-convert-to-assignment leaf)))
1542 (lambda-var (reoptimize-lambda-var leaf))))
1544 (typecase leaf
1545 (clambda (maybe-convert-to-assignment leaf))))))
1547 (values))
1549 ;;; This function is called to unlink a node from its LVAR;
1550 ;;; we assume that the LVAR's USE list has already been updated,
1551 ;;; and that we only have to mark the node as up for dead code
1552 ;;; elimination, and to clear it LVAR slot.
1553 (defun flush-node (node)
1554 (declare (type node node))
1555 (let* ((prev (node-prev node))
1556 (block (ctran-block prev)))
1557 (reoptimize-component (block-component block) t)
1558 (setf (block-attributep (block-flags block)
1559 flush-p type-check)
1561 (setf (node-lvar node) nil))
1563 ;;; This function is called by people who delete nodes; it provides a
1564 ;;; way to indicate that the value of a lvar is no longer used. We
1565 ;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses
1566 ;;; of LVAR and set COMPONENT-REOPTIMIZE.
1567 (defun flush-dest (lvar)
1568 (declare (type (or lvar null) lvar))
1569 (unless (null lvar)
1570 (when (lvar-dynamic-extent lvar)
1571 (note-no-stack-allocation lvar :flush t))
1572 (setf (lvar-dest lvar) nil)
1573 (flush-lvar-externally-checkable-type lvar)
1574 (do-uses (use lvar)
1575 (flush-node use))
1576 (setf (lvar-uses lvar) nil))
1577 (values))
1579 (defun delete-dest (lvar)
1580 (when lvar
1581 (let* ((dest (lvar-dest lvar))
1582 (prev (node-prev dest)))
1583 (let ((block (ctran-block prev)))
1584 (unless (block-delete-p block)
1585 (mark-for-deletion block))))))
1587 ;;; Queue the block for deletion
1588 (defun delete-block-lazily (block)
1589 (declare (type cblock block))
1590 (unless (block-delete-p block)
1591 (setf (block-delete-p block) t)
1592 (push block (component-delete-blocks (block-component block)))))
1594 ;;; Do a graph walk backward from BLOCK, marking all predecessor
1595 ;;; blocks with the DELETE-P flag.
1596 (defun mark-for-deletion (block)
1597 (declare (type cblock block))
1598 (let* ((component (block-component block))
1599 (head (component-head component)))
1600 (labels ((helper (block)
1601 (delete-block-lazily block)
1602 (dolist (pred (block-pred block))
1603 (unless (or (block-delete-p pred)
1604 (eq pred head))
1605 (helper pred)))))
1606 (unless (block-delete-p block)
1607 (helper block)
1608 (setf (component-reanalyze component) t))))
1609 (values))
1611 ;;; This function does what is necessary to eliminate the code in it
1612 ;;; from the IR1 representation. This involves unlinking it from its
1613 ;;; predecessors and successors and deleting various node-specific
1614 ;;; semantic information. BLOCK must be already removed from
1615 ;;; COMPONENT-DELETE-BLOCKS.
1616 (defun delete-block (block &optional silent)
1617 (declare (type cblock block))
1618 (unless (block-component block)
1619 ;; Already deleted
1620 (return-from delete-block))
1621 #!+high-security (aver (not (memq block (component-delete-blocks (block-component block)))))
1622 (unless silent
1623 (note-block-deletion block))
1624 (setf (block-delete-p block) t)
1626 (dolist (b (block-pred block))
1627 (unlink-blocks b block)
1628 ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
1629 ;; broken when successors were deleted without setting the
1630 ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
1631 ;; doesn't happen again.
1632 (aver (not (and (null (block-succ b))
1633 (not (block-delete-p b))
1634 (not (eq b (component-head (block-component b))))))))
1635 (dolist (b (block-succ block))
1636 (unlink-blocks block b))
1638 (do-nodes-carefully (node block)
1639 (when (valued-node-p node)
1640 (delete-lvar-use node))
1641 (etypecase node
1642 (ref (delete-ref node))
1643 (cif (flush-dest (if-test node)))
1644 ;; The next two cases serve to maintain the invariant that a LET
1645 ;; always has a well-formed COMBINATION, REF and BIND. We delete
1646 ;; the lambda whenever we delete any of these, but we must be
1647 ;; careful that this LET has not already been partially deleted.
1648 (basic-combination
1649 (when (and (eq (basic-combination-kind node) :local)
1650 ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
1651 (lvar-uses (basic-combination-fun node)))
1652 (let ((fun (combination-lambda node)))
1653 ;; If our REF was the second-to-last ref, and has been
1654 ;; deleted, then FUN may be a LET for some other
1655 ;; combination.
1656 (when (and (functional-letlike-p fun)
1657 (eq (let-combination fun) node))
1658 (delete-lambda fun))))
1659 (flush-dest (basic-combination-fun node))
1660 (dolist (arg (basic-combination-args node))
1661 (when arg (flush-dest arg))))
1662 (bind
1663 (let ((lambda (bind-lambda node)))
1664 (unless (eq (functional-kind lambda) :deleted)
1665 (delete-lambda lambda))))
1666 (exit
1667 (let ((value (exit-value node))
1668 (entry (exit-entry node)))
1669 (when value
1670 (flush-dest value))
1671 (when entry
1672 (setf (entry-exits entry)
1673 (delq node (entry-exits entry))))))
1674 (entry
1675 (dolist (exit (entry-exits node))
1676 (mark-for-deletion (node-block exit)))
1677 (let ((home (node-home-lambda node)))
1678 (setf (lambda-entries home) (delq node (lambda-entries home)))))
1679 (creturn
1680 (flush-dest (return-result node))
1681 (delete-return node))
1682 (cset
1683 (flush-dest (set-value node))
1684 (let ((var (set-var node)))
1685 (setf (basic-var-sets var)
1686 (delete node (basic-var-sets var)))))
1687 (dependent-cast
1688 (loop for dep in (dependent-cast-deps node)
1689 when (lvar-p dep)
1690 do (setf (lvar-dependent-casts dep)
1691 (delq node (lvar-dependent-casts dep))))
1692 (flush-dest (cast-value node)))
1693 (cast
1694 (flush-dest (cast-value node)))))
1696 (remove-from-dfo block)
1697 (values))
1699 ;;; Do stuff to indicate that the return node NODE is being deleted.
1700 (defun delete-return (node)
1701 (declare (type creturn node))
1702 (let ((fun (return-lambda node)))
1703 (when fun ;; could become replaced by MOVE-RETURN-STUFF
1704 (let ((tail-set (lambda-tail-set fun)))
1705 (aver (lambda-return fun))
1706 (setf (lambda-return fun) nil)
1707 (when (and tail-set (not (find-if #'lambda-return
1708 (tail-set-funs tail-set))))
1709 (setf (tail-set-type tail-set) *empty-type*)))))
1710 (values))
1712 ;;; If any of the VARS in FUN was never referenced and was not
1713 ;;; declared IGNORE, then complain.
1714 (defun note-unreferenced-vars (vars policy)
1715 (dolist (var vars)
1716 (unless (or (leaf-ever-used var)
1717 (lambda-var-ignorep var))
1718 (unless (policy policy (= inhibit-warnings 3))
1719 ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
1720 ;; requires this to be no more than a STYLE-WARNING.
1721 #-sb-xc-host
1722 (compiler-style-warn "The variable ~S is defined but never used."
1723 (leaf-debug-name var))
1724 ;; There's no reason to accept this kind of equivocation
1725 ;; when compiling our own code, though.
1726 #+sb-xc-host
1727 (warn "The variable ~S is defined but never used."
1728 (leaf-debug-name var)))
1729 (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
1731 (defun note-unreferenced-fun-vars (fun)
1732 (declare (type clambda fun))
1733 (let ((*compiler-error-context* (lambda-bind fun)))
1734 (note-unreferenced-vars (lambda-vars fun)
1735 *compiler-error-context*))
1736 (values))
1738 ;;; Return true if we can find OBJ in FORM, NIL otherwise. We bound
1739 ;;; our recursion so that we don't get lost in circular structures. We
1740 ;;; ignore the car of forms if they are a symbol (to prevent confusing
1741 ;;; function referencess with variables), and we also ignore anything
1742 ;;; inside ' or #'.
1743 (defun present-in-form (obj form depth)
1744 (declare (type (integer 0 20) depth))
1745 (cond ((= depth 20) nil)
1746 ((eq obj form) t)
1747 ((atom form) nil)
1749 (let ((first (car form))
1750 (depth (1+ depth)))
1751 (if (member first '(quote function))
1753 (or (and (not (symbolp first))
1754 (present-in-form obj first depth))
1755 (do ((l (cdr form) (cdr l))
1756 (n 0 (1+ n)))
1757 ((or (atom l) (> n 100))
1758 nil)
1759 (declare (fixnum n))
1760 (when (present-in-form obj (car l) depth)
1761 (return t)))))))))
1763 ;;; This function is called on a block immediately before we delete
1764 ;;; it. We check to see whether any of the code about to die appeared
1765 ;;; in the original source, and emit a note if so.
1767 ;;; If the block was in a lambda is now deleted, then we ignore the
1768 ;;; whole block, since this case is picked off in DELETE-LAMBDA. We
1769 ;;; also ignore the deletion of CRETURN nodes, since it is somewhat
1770 ;;; reasonable for a function to not return, and there is a different
1771 ;;; note for that case anyway.
1773 ;;; If the actual source is an atom, then we use a bunch of heuristics
1774 ;;; to guess whether this reference really appeared in the original
1775 ;;; source:
1776 ;;; -- If a symbol, it must be interned and not a keyword.
1777 ;;; -- It must not be an easily introduced constant (T or NIL, a fixnum
1778 ;;; or a character.)
1779 ;;; -- The atom must be "present" in the original source form, and
1780 ;;; present in all intervening actual source forms.
1781 (defun note-block-deletion (block)
1782 (let ((home (block-home-lambda block)))
1783 (unless (eq (functional-kind home) :deleted)
1784 (do-nodes (node nil block)
1785 (let* ((path (node-source-path node))
1786 (first (first path)))
1787 (when (and (not (return-p node))
1788 ;; CASTs are just value filters and do not
1789 ;; represent code and they can be moved around
1790 ;; making CASTs from the original source code
1791 ;; appear in code inserted by the compiler, generating
1792 ;; false deletion notes.
1793 ;; And if a block with the original source gets
1794 ;; deleted the node that produces the value for
1795 ;; the CAST will get a note, no need to note
1796 ;; twice.
1797 (not (cast-p node))
1798 ;; Nothing interesting in BIND nodes
1799 (not (bind-p node))
1800 (or (eq first 'original-source-start)
1801 (and (atom first)
1802 (or (not (symbolp first))
1803 (let ((pkg (symbol-package first)))
1804 (and pkg
1805 (not (eq pkg (symbol-package :end))))))
1806 (not (member first '(t nil)))
1807 (not (typep first '(or fixnum character)))
1808 (every (lambda (x)
1809 (present-in-form first x 0))
1810 (source-path-forms path))
1811 (present-in-form first (find-original-source path)
1812 0))))
1813 (let ((*compiler-error-context* node))
1814 (compiler-notify 'code-deletion-note
1815 :format-control "deleting unreachable code"
1816 :format-arguments nil))
1817 (return))))))
1818 (values))
1820 ;;; Delete a node from a block, deleting the block if there are no
1821 ;;; nodes left. We remove the node from the uses of its LVAR.
1823 ;;; If the node is the last node, there must be exactly one successor.
1824 ;;; We link all of our precedessors to the successor and unlink the
1825 ;;; block. In this case, we return T, otherwise NIL. If no nodes are
1826 ;;; left, and the block is a successor of itself, then we replace the
1827 ;;; only node with a degenerate exit node. This provides a way to
1828 ;;; represent the bodyless infinite loop, given the prohibition on
1829 ;;; empty blocks in IR1.
1830 (defun unlink-node (node)
1831 (declare (type node node))
1832 (when (valued-node-p node)
1833 (delete-lvar-use node))
1835 (let* ((ctran (node-next node))
1836 (next (and ctran (ctran-next ctran)))
1837 (prev (node-prev node))
1838 (block (ctran-block prev))
1839 (prev-kind (ctran-kind prev))
1840 (last (block-last block)))
1841 (cond ((or (eq prev-kind :inside-block)
1842 (and (eq prev-kind :block-start)
1843 (not (eq node last))))
1844 (cond ((eq node last)
1845 (setf (block-last block) (ctran-use prev))
1846 (setf (node-next (ctran-use prev)) nil))
1848 (setf (ctran-next prev) next)
1849 (setf (node-prev next) prev)
1850 (when (if-p next) ; AOP wanted
1851 (reoptimize-lvar (if-test next)))))
1852 (setf (node-prev node) nil)
1853 nil)
1855 (aver (eq prev-kind :block-start))
1856 (aver (eq node last))
1857 (let* ((succ (block-succ block))
1858 (next (first succ)))
1859 (aver (singleton-p succ))
1860 (cond
1861 ((eq block (first succ))
1862 (with-ir1-environment-from-node node
1863 (let ((exit (make-exit)))
1864 (setf (ctran-next prev) nil)
1865 (link-node-to-previous-ctran exit prev)
1866 (setf (block-last block) exit)))
1867 (setf (node-prev node) nil)
1868 nil)
1870 (aver (eq (block-start-cleanup block)
1871 (block-end-cleanup block)))
1872 (unlink-blocks block next)
1873 (dolist (pred (block-pred block))
1874 (change-block-successor pred block next))
1875 (when (block-delete-p block)
1876 (let ((component (block-component block)))
1877 (setf (component-delete-blocks component)
1878 (delq block (component-delete-blocks component)))))
1879 (remove-from-dfo block)
1880 (setf (block-delete-p block) t)
1881 (setf (node-prev node) nil)
1882 t)))))))
1884 ;;; Return true if CTRAN has been deleted, false if it is still a valid
1885 ;;; part of IR1.
1886 (defun ctran-deleted-p (ctran)
1887 (declare (type ctran ctran))
1888 (let ((block (ctran-block ctran)))
1889 (or (not (block-component block))
1890 (block-delete-p block))))
1892 ;;; Return true if NODE has been deleted, false if it is still a valid
1893 ;;; part of IR1.
1894 (defun node-deleted (node)
1895 (declare (type node node))
1896 (let ((prev (node-prev node)))
1897 (or (not prev)
1898 (ctran-deleted-p prev))))
1900 ;;; Delete all the blocks and functions in COMPONENT. We scan first
1901 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
1902 ;;; triggered by deletion.
1903 (defun delete-component (component)
1904 (declare (type component component))
1905 (aver (null (component-new-functionals component)))
1906 (setf (component-kind component) :deleted)
1907 (do-blocks (block component)
1908 (delete-block-lazily block))
1909 (dolist (fun (component-lambdas component))
1910 (unless (eq (functional-kind fun) :deleted)
1911 (setf (functional-kind fun) nil)
1912 (setf (functional-entry-fun fun) nil)
1913 (setf (leaf-refs fun) nil)
1914 (delete-functional fun)))
1915 (clean-component component)
1916 (values))
1918 ;;; Remove all pending blocks to be deleted. Return the nearest live
1919 ;;; block after or equal to BLOCK.
1920 (defun clean-component (component &optional block)
1921 (loop while (component-delete-blocks component)
1922 ;; actual deletion of a block may queue new blocks
1923 do (let ((current (pop (component-delete-blocks component))))
1924 (when (eq block current)
1925 (setq block (block-next block)))
1926 (delete-block current)))
1927 block)
1929 ;;; Convert code of the form
1930 ;;; (FOO ... (FUN ...) ...)
1931 ;;; to
1932 ;;; (FOO ... ... ...).
1933 ;;; In other words, replace the function combination FUN by its
1934 ;;; arguments. If there are any problems with doing this, use GIVE-UP
1935 ;;; to blow out of whatever transform called this. Note, as the number
1936 ;;; of arguments changes, the transform must be prepared to return a
1937 ;;; lambda with a new lambda-list with the correct number of
1938 ;;; arguments.
1939 (defun splice-fun-args (lvar fun num-args)
1940 "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed
1941 directly to the LVAR-DEST of LVAR, which must be a combination. If FUN
1942 is :ANY, the function name is not checked."
1943 (declare (type lvar lvar)
1944 (type symbol fun)
1945 (type index num-args))
1946 (let ((outside (lvar-dest lvar))
1947 (inside (lvar-uses lvar)))
1948 (aver (combination-p outside))
1949 (unless (combination-p inside)
1950 (give-up-ir1-transform))
1951 (let ((inside-fun (combination-fun inside)))
1952 (unless (or (eq fun :any)
1953 (eq (lvar-fun-name inside-fun) fun))
1954 (give-up-ir1-transform))
1955 (let ((inside-args (combination-args inside)))
1956 (unless (= (length inside-args) num-args)
1957 (give-up-ir1-transform))
1958 (let* ((outside-args (combination-args outside))
1959 (arg-position (position lvar outside-args))
1960 (before-args (subseq outside-args 0 arg-position))
1961 (after-args (subseq outside-args (1+ arg-position))))
1962 (dolist (arg inside-args)
1963 (setf (lvar-dest arg) outside)
1964 (flush-lvar-externally-checkable-type arg))
1965 (setf (combination-args inside) nil)
1966 (setf (combination-args outside)
1967 (append before-args inside-args after-args))
1968 (change-ref-leaf (lvar-uses inside-fun)
1969 (find-free-fun 'list "???"))
1970 (setf (combination-fun-info inside) (info :function :info 'list)
1971 (combination-kind inside) :known)
1972 (setf (node-derived-type inside) *wild-type*)
1973 (flush-dest lvar)
1974 inside-args)))))
1976 ;;; Eliminate keyword arguments from the call (leaving the
1977 ;;; parameters in place.
1979 ;;; (FOO ... :BAR X :QUUX Y)
1980 ;;; becomes
1981 ;;; (FOO ... X Y)
1983 ;;; SPECS is a list of (:KEYWORD PARAMETER) specifications.
1984 ;;; Returns the list of specified parameters names in the
1985 ;;; order they appeared in the call. N-POSITIONAL is the
1986 ;;; number of positional arguments in th call.
1987 (defun eliminate-keyword-args (call n-positional specs)
1988 (let* ((specs (copy-tree specs))
1989 (all (combination-args call))
1990 (new-args (reverse (subseq all 0 n-positional)))
1991 (key-args (subseq all n-positional))
1992 (parameters nil)
1993 (flushed-keys nil))
1994 (loop while key-args
1995 do (let* ((key (pop key-args))
1996 (val (pop key-args))
1997 (keyword (if (constant-lvar-p key)
1998 (lvar-value key)
1999 (give-up-ir1-transform)))
2000 (spec (or (assoc keyword specs :test #'eq)
2001 (give-up-ir1-transform))))
2002 (push val new-args)
2003 (push key flushed-keys)
2004 (push (second spec) parameters)
2005 ;; In case of duplicate keys.
2006 (setf (second spec) (gensym))))
2007 (dolist (key flushed-keys)
2008 (flush-dest key))
2009 (setf (combination-args call) (reverse new-args))
2010 (reverse parameters)))
2012 (defun extract-fun-args (lvar fun num-args)
2013 (declare (type lvar lvar)
2014 (type (or symbol list) fun)
2015 (type index num-args))
2016 (let ((inside (lvar-uses lvar)))
2017 (unless (combination-p inside)
2018 (give-up-ir1-transform))
2019 (let ((inside-fun (combination-fun inside)))
2020 (unless (member (lvar-fun-name inside-fun) (ensure-list fun))
2021 (give-up-ir1-transform))
2022 (let ((inside-args (combination-args inside)))
2023 (unless (= (length inside-args) num-args)
2024 (give-up-ir1-transform))
2025 (values (lvar-fun-name inside-fun) inside-args)))))
2027 (defun flush-combination (combination)
2028 (declare (type combination combination))
2029 (flush-dest (combination-fun combination))
2030 (dolist (arg (combination-args combination))
2031 (flush-dest arg))
2032 (unlink-node combination)
2033 (values))
2036 ;;;; leaf hackery
2038 ;;; Change the LEAF that a REF refers to.
2039 (defun change-ref-leaf (ref leaf &key recklessly)
2040 (declare (type ref ref) (type leaf leaf))
2041 (unless (eq (ref-leaf ref) leaf)
2042 (push ref (leaf-refs leaf))
2043 (delete-ref ref)
2044 (setf (ref-leaf ref) leaf)
2045 (setf (leaf-ever-used leaf) t)
2046 (let* ((ltype (leaf-type leaf))
2047 (vltype (make-single-value-type ltype)))
2048 (if (let* ((lvar (node-lvar ref))
2049 (dest (and lvar (lvar-dest lvar))))
2050 (and (basic-combination-p dest)
2051 (eq lvar (basic-combination-fun dest))
2052 (csubtypep ltype (specifier-type 'function))))
2053 (setf (node-derived-type ref) vltype)
2054 (derive-node-type ref vltype :from-scratch recklessly)))
2055 (reoptimize-lvar (node-lvar ref)))
2056 (values))
2058 ;;; Change all REFS for OLD-LEAF to NEW-LEAF.
2059 (defun substitute-leaf (new-leaf old-leaf)
2060 (declare (type leaf new-leaf old-leaf))
2061 (dolist (ref (leaf-refs old-leaf))
2062 (change-ref-leaf ref new-leaf))
2063 (values))
2065 ;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
2066 ;;; whether to substitute
2067 (defun substitute-leaf-if (test new-leaf old-leaf)
2068 (declare (type leaf new-leaf old-leaf) (type function test))
2069 (dolist (ref (leaf-refs old-leaf))
2070 (when (funcall test ref)
2071 (change-ref-leaf ref new-leaf)))
2072 (values))
2074 ;;; Return a LEAF which represents the specified constant object. If
2075 ;;; the object is not in *CONSTANTS*, then we create a new constant
2076 ;;; LEAF and enter it. If we are producing a fasl file, make sure that
2077 ;;; MAKE-LOAD-FORM gets used on any parts of the constant that it
2078 ;;; needs to be.
2080 ;;; We are allowed to coalesce things like EQUAL strings and bit-vectors
2081 ;;; when file-compiling, but not when using COMPILE.
2082 (defun find-constant (object &optional (name nil namep))
2083 (let ((faslp (producing-fasl-file)))
2084 (labels ((make-it ()
2085 (when faslp
2086 (if namep
2087 (maybe-emit-make-load-forms object name)
2088 (maybe-emit-make-load-forms object)))
2089 (make-constant object))
2090 (core-coalesce-p (x)
2091 ;; True for things which retain their identity under EQUAL,
2092 ;; so we can safely share the same CONSTANT leaf between
2093 ;; multiple references.
2094 (or (typep x '(or symbol number character))
2095 ;; Amusingly enough, we see CLAMBDAs --among other things--
2096 ;; here, from compiling things like %ALLOCATE-CLOSUREs forms.
2097 ;; No point in stuffing them in the hash-table.
2098 (and (typep x 'instance)
2099 (not (or (leaf-p x) (node-p x))))))
2100 (cons-coalesce-p (x)
2101 (if (eq +code-coverage-unmarked+ (cdr x))
2102 ;; These are already coalesced, and the CAR should
2103 ;; always be OK, so no need to check.
2105 (when (coalesce-tree-p x)
2106 (labels ((descend (x)
2107 (do ((y x (cdr y)))
2108 ((atom y) (atom-colesce-p y))
2109 ;; Don't just call file-coalesce-p, because it'll
2110 ;; invoke COALESCE-TREE-P repeatedly
2111 (let ((car (car y)))
2112 (unless (if (consp car)
2113 (descend car)
2114 (atom-colesce-p car))
2115 (return nil))))))
2116 (descend x)))))
2117 (atom-colesce-p (x)
2118 (or (core-coalesce-p x)
2119 ;; We *could* coalesce base-strings as well,
2120 ;; but we'd need a separate hash-table for
2121 ;; that, since we are not allowed to coalesce
2122 ;; base-strings with non-base-strings.
2123 (typep x
2124 '(or bit-vector
2125 ;; in the cross-compiler, we coalesce
2126 ;; all strings with the same contents,
2127 ;; because we will end up dumping them
2128 ;; as base-strings anyway. In the
2129 ;; real compiler, we're not allowed to
2130 ;; coalesce regardless of string
2131 ;; specialized element type, so we
2132 ;; KLUDGE by coalescing only character
2133 ;; strings (the common case) and
2134 ;; punting on the other types.
2135 #+sb-xc-host
2136 string
2137 #-sb-xc-host
2138 (vector character)))))
2139 (file-coalesce-p (x)
2140 ;; CLHS 3.2.4.2.2: We are also allowed to coalesce various
2141 ;; other things when file-compiling.
2142 (if (consp x)
2143 (cons-coalesce-p x)
2144 (atom-colesce-p x)))
2145 (coalescep (x)
2146 (if faslp (file-coalesce-p x) (core-coalesce-p x))))
2147 ;; When compiling to core we don't coalesce strings, because
2148 ;; "The functions eval and compile are required to ensure that literal objects
2149 ;; referenced within the resulting interpreted or compiled code objects are
2150 ;; the _same_ as the corresponding objects in the source code."
2151 ;; but in a dumped image, if gc_coalesce_string_literals is 1 then GC will
2152 ;; coalesce similar immutable strings to save memory,
2153 ;; even if not technically permitted. According to CLHS 3.7.1
2154 ;; "The consequences are undefined if literal objects are destructively modified
2155 ;; For this purpose, the following operations are considered destructive:
2156 ;; array - Storing a new value into some element of the array ..."
2157 ;; so a string, once used as a literal in source, becomes logically immutable.
2158 #-sb-xc-host
2159 (when (and (not faslp) (simple-string-p object))
2160 (logically-readonlyize object nil))
2161 (if (and (boundp '*constants*) (coalescep object))
2162 (ensure-gethash object *constants* (make-it))
2163 (make-it)))))
2165 ;;; Return true if VAR would have to be closed over if environment
2166 ;;; analysis ran now (i.e. if there are any uses that have a different
2167 ;;; home lambda than VAR's home.)
2168 (defun closure-var-p (var)
2169 (declare (type lambda-var var))
2170 (let ((home (lambda-var-home var)))
2171 (cond ((eq (functional-kind home) :deleted)
2172 nil)
2173 (t (let ((home (lambda-home home)))
2174 (flet ((frob (l)
2175 (find home l
2176 :key #'node-home-lambda
2177 :test #'neq)))
2178 (or (frob (leaf-refs var))
2179 (frob (basic-var-sets var)))))))))
2181 ;;; If there is a non-local exit noted in ENTRY's environment that
2182 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
2183 (defun find-nlx-info (exit)
2184 (declare (type exit exit))
2185 (let* ((entry (exit-entry exit))
2186 (cleanup (entry-cleanup entry))
2187 (block (first (block-succ (node-block exit)))))
2188 (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
2189 (when (and (eq (nlx-info-block nlx) block)
2190 (eq (nlx-info-cleanup nlx) cleanup))
2191 (return nlx)))))
2193 (defun nlx-info-lvar (nlx)
2194 (declare (type nlx-info nlx))
2195 (node-lvar (block-last (nlx-info-target nlx))))
2197 ;;;; functional hackery
2199 (declaim (ftype (sfunction (functional) clambda) main-entry))
2200 (defun main-entry (functional)
2201 (etypecase functional
2202 (clambda functional)
2203 (optional-dispatch
2204 (optional-dispatch-main-entry functional))))
2206 ;;; RETURN true if FUNCTIONAL is a thing that can be treated like
2207 ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
2208 ;;; optional with null default and no SUPPLIED-P. There must be a
2209 ;;; &REST arg with no references.
2210 (declaim (ftype (sfunction (functional) boolean) looks-like-an-mv-bind))
2211 (defun looks-like-an-mv-bind (functional)
2212 (and (optional-dispatch-p functional)
2213 (do ((arg (optional-dispatch-arglist functional) (cdr arg)))
2214 ((null arg) nil)
2215 (let ((info (lambda-var-arg-info (car arg))))
2216 (unless info (return nil))
2217 (case (arg-info-kind info)
2218 (:optional
2219 (when (or (arg-info-supplied-p info) (arg-info-default info))
2220 (return nil)))
2221 (:rest
2222 (return (and (null (cdr arg))
2223 (null (leaf-refs (car arg)))
2224 ;; Type checking will require reading the
2225 ;; variable, but it's done in one of the
2226 ;; dispatch functions making it invisible
2227 ;; to LEAF-REFS
2228 (or (neq (leaf-where-from (car arg)) :declared)
2229 (values (csubtypep (specifier-type 'list)
2230 (leaf-type (car arg))))))))
2232 (return nil)))))))
2234 (defun call-all-args-fixed-p (call)
2235 (loop for arg in (basic-combination-args call)
2236 always (numberp (nth-value 1 (values-types
2237 (lvar-derived-type arg))))))
2239 ;;; Return true if function is an external entry point. This is true
2240 ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas
2241 ;;; (:TOPLEVEL kind.)
2242 (defun xep-p (fun)
2243 (declare (type functional fun))
2244 (not (null (member (functional-kind fun) '(:external :toplevel)))))
2246 ;;; If LVAR's only use is a non-notinline global function reference,
2247 ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK
2248 ;;; is true, then we don't care if the leaf is NOTINLINE.
2249 (defun lvar-fun-name (lvar &optional notinline-ok)
2250 (declare (type lvar lvar))
2251 (let ((use (principal-lvar-use lvar)))
2252 (if (ref-p use)
2253 (let ((leaf (ref-leaf use)))
2254 (if (and (global-var-p leaf)
2255 (eq (global-var-kind leaf) :global-function)
2256 (or (not (defined-fun-p leaf))
2257 (not (eq (defined-fun-inlinep leaf) :notinline))
2258 notinline-ok))
2259 (leaf-source-name leaf)
2260 nil))
2261 nil)))
2263 ;;; As above, but allow a quoted symbol also,
2264 ;;; in which case we don't check for notinline-ness,
2265 ;;; so be careful how you use this.
2266 ;;; Also note that Case 2 in LVAR-FUN-IS for dealing with #.#'NAME
2267 ;;; has no equivalent here.
2268 (defun lvar-fun-name* (lvar)
2269 (if (constant-lvar-p lvar) (lvar-value lvar) (lvar-fun-name lvar)))
2271 (defun lvar-fun-debug-name (lvar)
2272 (declare (type lvar lvar))
2273 (let ((uses (lvar-uses lvar)))
2274 (flet ((name1 (use)
2275 (leaf-debug-name (ref-leaf use))))
2276 (if (ref-p uses)
2277 (name1 uses)
2278 (mapcar #'name1 uses)))))
2280 ;;; Return the source name of a combination -- or signals an error
2281 ;;; if the function leaf is anonymous.
2282 (defun combination-fun-source-name (combination &optional (errorp t))
2283 (let ((uses (principal-lvar-use (combination-fun combination)))
2284 leaf)
2285 (cond ((and (ref-p uses)
2286 (leaf-has-source-name-p (setf leaf (ref-leaf uses))))
2287 (values (leaf-source-name leaf) t))
2288 (errorp
2289 (aver (not "COMBINATION-FUN is not a ref to a nameful leaf")))
2291 (values nil nil)))))
2293 (defun combination-fun-debug-name (combination)
2294 (let ((uses (principal-lvar-use (combination-fun combination))))
2295 (when (ref-p uses)
2296 (let ((leaf (ref-leaf uses)))
2297 (typecase leaf
2298 (functional
2299 (functional-debug-name leaf))
2301 (and (leaf-has-source-name-p leaf)
2302 (leaf-source-name leaf))))))))
2304 ;;; Return the COMBINATION node that is the call to the LET FUN.
2305 (defun let-combination (fun)
2306 (declare (type clambda fun))
2307 (aver (functional-letlike-p fun))
2308 (lvar-dest (node-lvar (first (leaf-refs fun)))))
2310 ;;; Return the initial value lvar for a LET variable, or NIL if there
2311 ;;; is none.
2312 (defun let-var-initial-value (var)
2313 (declare (type lambda-var var))
2314 (let ((fun (lambda-var-home var)))
2315 (elt (combination-args (let-combination fun))
2316 (position-or-lose var (lambda-vars fun)))))
2318 ;;; Return the LAMBDA that is called by the local CALL.
2319 (defun combination-lambda (call)
2320 (declare (type basic-combination call))
2321 (aver (eq (basic-combination-kind call) :local))
2322 (ref-leaf (lvar-uses (basic-combination-fun call))))
2324 (defvar *inline-expansion-limit* 200
2325 "an upper limit on the number of inline function calls that will be expanded
2326 in any given code object (single function or block compilation)")
2328 ;;; Check whether NODE's component has exceeded its inline expansion
2329 ;;; limit, and warn if so, returning NIL.
2330 (defun inline-expansion-ok (node)
2331 (let ((expanded (incf (component-inline-expansions
2332 (block-component
2333 (node-block node))))))
2334 (cond ((> expanded *inline-expansion-limit*) nil)
2335 ((= expanded *inline-expansion-limit*)
2336 ;; FIXME: If the objective is to stop the recursive
2337 ;; expansion of inline functions, wouldn't it be more
2338 ;; correct to look back through surrounding expansions
2339 ;; (which are, I think, stored in the *CURRENT-PATH*, and
2340 ;; possibly stored elsewhere too) and suppress expansion
2341 ;; and print this warning when the function being proposed
2342 ;; for inline expansion is found there? (I don't like the
2343 ;; arbitrary numerical limit in principle, and I think
2344 ;; it'll be a nuisance in practice if we ever want the
2345 ;; compiler to be able to use WITH-COMPILATION-UNIT on
2346 ;; arbitrarily huge blocks of code. -- WHN)
2347 (let ((*compiler-error-context* node))
2348 (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
2349 probably trying to~% ~
2350 inline a recursive function."
2351 *inline-expansion-limit*))
2352 nil)
2353 (t t))))
2355 ;;; Make sure that FUNCTIONAL is not let-converted or deleted.
2356 (defun assure-functional-live-p (functional)
2357 (declare (type functional functional))
2358 (when (and (or
2359 ;; looks LET-converted
2360 (functional-somewhat-letlike-p functional)
2361 ;; It's possible for a LET-converted function to end up
2362 ;; deleted later. In that case, for the purposes of this
2363 ;; analysis, it is LET-converted: LET-converted functionals
2364 ;; are too badly trashed to expand them inline, and deleted
2365 ;; LET-converted functionals are even worse.
2366 (memq (functional-kind functional) '(:deleted :zombie))))
2367 (throw 'locall-already-let-converted functional)))
2369 (defun assure-leaf-live-p (leaf)
2370 (typecase leaf
2371 (lambda-var
2372 (when (lambda-var-deleted leaf)
2373 (throw 'locall-already-let-converted leaf)))
2374 (functional
2375 (assure-functional-live-p leaf))))
2378 (defun call-full-like-p (call)
2379 (declare (type basic-combination call))
2380 (let ((kind (basic-combination-kind call)))
2381 (or (eq kind :full)
2382 (and (eq kind :known)
2383 (let ((info (basic-combination-fun-info call)))
2384 (and
2385 (not (fun-info-ir2-convert info))
2386 (dolist (template (fun-info-templates info) t)
2387 (when (eq (template-ltn-policy template) :fast-safe)
2388 (multiple-value-bind (val win)
2389 (valid-fun-use call (template-type template))
2390 (when (or val (not win)) (return nil)))))))))))
2392 ;;;; careful call
2394 ;;; Apply a function to some arguments, returning a list of the values
2395 ;;; resulting of the evaluation. If an error is signalled during the
2396 ;;; application, then we produce a warning message using WARN-FUN and
2397 ;;; return NIL as our second value to indicate this. NODE is used as
2398 ;;; the error context for any error message, and CONTEXT is a string
2399 ;;; that is spliced into the warning.
2400 (declaim (ftype (sfunction ((or symbol function) list node function string)
2401 (values list boolean))
2402 careful-call))
2403 (defun careful-call (function args node warn-fun context)
2404 (values
2405 (multiple-value-list
2406 (handler-case (apply function args)
2407 (error (condition)
2408 (let ((*compiler-error-context* node))
2409 (funcall warn-fun "Lisp error during ~A:~%~A" context condition)
2410 (return-from careful-call (values nil nil))))))
2413 ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
2414 ;;; specifiers.
2415 (macrolet
2416 ((deffrob (basic careful compiler transform)
2417 `(progn
2418 (defun ,careful (specifier)
2419 (handler-case (,basic specifier)
2420 (error (condition)
2421 (values nil condition))))
2422 (defun ,compiler (specifier)
2423 (handler-case (,basic specifier)
2424 (simple-error (condition)
2425 (apply #'compiler-warn
2426 (simple-condition-format-control condition)
2427 (simple-condition-format-arguments condition)))
2428 (error (condition)
2429 (compiler-warn "~a" condition))))
2430 (defun ,transform (specifier)
2431 (multiple-value-bind (type condition) (,careful specifier)
2432 (or type
2433 (give-up-ir1-transform
2434 (princ-to-string condition))))))))
2435 (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type)
2436 (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type))
2439 ;;;; utilities used at run-time for parsing &KEY args in IR1
2441 ;;; This function is used by the result of PARSE-DEFTRANSFORM to find
2442 ;;; the lvar for the value of the &KEY argument KEY in the list of
2443 ;;; lvars ARGS. It returns the lvar if the keyword is present, or NIL
2444 ;;; otherwise. The legality and constantness of the keywords should
2445 ;;; already have been checked.
2446 (declaim (ftype (sfunction (list keyword) (or lvar null))
2447 find-keyword-lvar))
2448 (defun find-keyword-lvar (args key)
2449 (do ((arg args (cddr arg)))
2450 ((null arg) nil)
2451 (when (eq (lvar-value (first arg)) key)
2452 (return (second arg)))))
2454 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
2455 ;;; verify that alternating lvars in ARGS are constant and that there
2456 ;;; is an even number of args.
2457 (declaim (ftype (sfunction (list) boolean) check-key-args-constant))
2458 (defun check-key-args-constant (args)
2459 (do ((arg args (cddr arg)))
2460 ((null arg) t)
2461 (unless (and (rest arg)
2462 (constant-lvar-p (first arg)))
2463 (return nil))))
2465 ;;; This function is used by the result of PARSE-DEFTRANSFORM to
2466 ;;; verify that the list of lvars ARGS is a well-formed &KEY arglist
2467 ;;; and that only keywords present in the list KEYS are supplied.
2468 (declaim (ftype (sfunction (list list) boolean) check-transform-keys))
2469 (defun check-transform-keys (args keys)
2470 (and (check-key-args-constant args)
2471 (do ((arg args (cddr arg)))
2472 ((null arg) t)
2473 (unless (member (lvar-value (first arg)) keys)
2474 (return nil)))))
2476 ;;;; miscellaneous
2478 ;;; Called by the expansion of the EVENT macro.
2479 (declaim (ftype (sfunction (event-info (or node null)) *) %event))
2480 (defun %event (info node)
2481 (incf (event-info-count info))
2482 (when (and (>= (event-info-level info) *event-note-threshold*)
2483 (policy (or node *lexenv*)
2484 (= inhibit-warnings 0)))
2485 (let ((*compiler-error-context* node))
2486 (compiler-notify (event-info-description info))))
2488 (let ((action (event-info-action info)))
2489 (when action (funcall action node))))
2492 (defun make-cast (value type policy &optional context)
2493 (declare (type lvar value)
2494 (type ctype type)
2495 (type policy policy))
2496 (%make-cast :asserted-type type
2497 :type-to-check (maybe-weaken-check type policy)
2498 :value value
2499 :derived-type (coerce-to-values type)
2500 :context context))
2502 (defun note-single-valuified-lvar (lvar)
2503 (declare (type (or lvar null) lvar))
2504 (when lvar
2505 (let ((use (lvar-uses lvar)))
2506 (cond ((ref-p use)
2507 (let ((leaf (ref-leaf use)))
2508 (when (and (lambda-var-p leaf)
2509 (null (rest (leaf-refs leaf))))
2510 (reoptimize-lambda-var leaf))))
2511 ((or (listp use) (combination-p use))
2512 (do-uses (node lvar)
2513 (setf (node-reoptimize node) t)
2514 (setf (block-reoptimize (node-block node)) t)
2515 (reoptimize-component (node-component node) :maybe)))))))
2517 ;;; Return true if LVAR's only use is a reference to a global function
2518 ;;; designator with one of the specified NAMES, that hasn't been
2519 ;;; declared NOTINLINE.
2520 (defun lvar-fun-is (lvar names)
2521 (declare (type lvar lvar) (list names))
2522 (let ((use (principal-lvar-use lvar)))
2523 (and (ref-p use)
2524 (let* ((*lexenv* (node-lexenv use))
2525 (leaf (ref-leaf use))
2526 (name
2527 (cond ((global-var-p leaf)
2528 ;; Case 1: #'NAME
2529 (and (eq (global-var-kind leaf) :global-function)
2530 (car (member (leaf-source-name leaf) names
2531 :test #'equal))))
2532 ((constant-p leaf)
2533 (let ((value (constant-value leaf)))
2534 (car (if (functionp value)
2535 ;; Case 2: #.#'NAME
2536 (member value names
2537 :key (lambda (name)
2538 (and (fboundp name)
2539 (fdefinition name)))
2540 :test #'eq)
2541 ;; Case 3: 'NAME
2542 (member value names
2543 :test #'equal))))))))
2544 (and name
2545 (not (fun-lexically-notinline-p name)))))))
2547 ;;; Return true if LVAR's only use is a call to one of the named functions
2548 ;;; (or any function if none are specified) with the specified number of
2549 ;;; of arguments (or any number if number is not specified)
2550 (defun lvar-matches (lvar &key fun-names arg-count)
2551 (let ((use (lvar-uses lvar)))
2552 (and (combination-p use)
2553 (or (not fun-names)
2554 (multiple-value-bind (name ok)
2555 (combination-fun-source-name use nil)
2556 (and ok (member name fun-names :test #'eq))))
2557 (or (not arg-count)
2558 (= arg-count (length (combination-args use)))))))
2560 ;;; In (a (b lvar)) (lvar-matches-calls lvar '(b a)) would return T
2561 (defun lvar-matches-calls (lvar dest-fun-names)
2562 (loop for fun in dest-fun-names
2563 for dest = (principal-lvar-dest lvar)
2564 when (or (not (combination-p dest))
2565 (neq fun (combination-fun-source-name dest nil)))
2566 return nil
2567 do (setf lvar (combination-lvar dest))
2568 finally (return t)))
2570 ;;; True if the optional has a rest-argument.
2571 (defun optional-rest-p (opt)
2572 (dolist (var (optional-dispatch-arglist opt) nil)
2573 (let* ((info (when (lambda-var-p var)
2574 (lambda-var-arg-info var)))
2575 (kind (when info
2576 (arg-info-kind info))))
2577 (when (eq :rest kind)
2578 (return t)))))
2580 ;;; Don't substitute single-ref variables on high-debug / low speed, to
2581 ;;; improve the debugging experience. ...but don't bother keeping those
2582 ;;; from system lambdas.
2583 (defun preserve-single-use-debug-var-p (call var)
2584 (and (policy call (eql preserve-single-use-debug-variables 3))
2585 (or (not (lambda-var-p var))
2586 (not (lambda-system-lambda-p (lambda-var-home var))))))
2588 ;;; Call (lambda (arg lambda-var type)), for a mv-combination ARG can
2589 ;;; be NIL when it produces multiple values.
2590 ;;; If REOPTIMIZE is T only the arguments for which LVAR-REOPTIMIZE is
2591 ;;; true will be examined, resetting LVAR-REOPTIMIZE to NIL before
2592 ;;; calling FUNCTION.
2593 (defun map-combination-arg-var (function combination &key reoptimize)
2594 (let ((args (basic-combination-args combination))
2595 (vars (lambda-vars (combination-lambda combination))))
2596 (flet ((reoptimize-p (arg)
2597 (cond ((not arg) nil)
2598 ((not reoptimize))
2599 ((lvar-reoptimize arg)
2600 (setf (lvar-reoptimize arg) nil)
2601 t))))
2602 (cond ((combination-p combination)
2603 (loop for arg in args
2604 for var in vars
2605 when (reoptimize-p arg)
2607 (funcall function arg var (lvar-type arg))))
2608 ((singleton-p args)
2609 (when (reoptimize-p (first args))
2610 (loop with arg = (first args)
2611 for var in vars
2612 for type in (values-type-in (lvar-derived-type arg)
2613 (length vars))
2615 (funcall function
2616 (and (singleton-p vars)
2617 arg)
2619 type))))
2621 (loop for arg in args
2622 do (multiple-value-bind (types length) (values-types (lvar-derived-type arg))
2623 (when (eq length :unknown)
2624 (return))
2625 (if (reoptimize-p arg)
2626 (loop with singleton-arg = (and (= length 1)
2627 arg)
2628 for type in types
2629 while vars
2631 (funcall function singleton-arg
2632 (pop vars) type))
2633 (setf vars (nthcdr length vars))))))))))