1 ;;;; This file contains the LTN pass in the compiler. LTN allocates
2 ;;;; expression evaluation TNs, makes nearly all the implementation
3 ;;;; policy decisions, and also does a few other miscellaneous things.
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
18 ;;; Return the policies keyword indicated by the node policy.
19 (defun translation-policy (node)
20 (declare (type node node))
22 (let ((eff-space (max space
23 ;; on the theory that if the code is
24 ;; smaller, it will take less time to
25 ;; compile (could lose if the smallest
26 ;; case is out of line, and must
27 ;; allocate many linkage registers):
30 (if (>= speed eff-space) :fast :small)
31 (if (>= speed eff-space) :fast-safe :safe)))))
33 ;;; Return true if POLICY is a safe policy.
34 #!-sb-fluid (declaim (inline policy-safe-p))
35 (defun policy-safe-p (policy)
36 (declare (type policies policy))
37 (or (eq policy :safe) (eq policy :fast-safe)))
39 ;;; Called when an unsafe policy indicates that no type check should
40 ;;; be done on CONT. We delete the type check unless it is :ERROR
41 ;;; (indicating a compile-time type error.)
42 #!-sb-fluid (declaim (inline flush-type-check))
43 (defun flush-type-check (cont)
44 (declare (type continuation cont))
45 (when (member (continuation-type-check cont) '(t :no-check))
46 (setf (continuation-%type-check cont) :deleted))
49 ;;; An annotated continuation's primitive-type.
50 #!-sb-fluid (declaim (inline continuation-ptype))
51 (defun continuation-ptype (cont)
52 (declare (type continuation cont))
53 (ir2-continuation-primitive-type (continuation-info cont)))
55 ;;; Return true if a constant LEAF is of a type which we can legally
56 ;;; directly reference in code. Named constants with arbitrary pointer
57 ;;; values cannot, since we must preserve EQLness.
58 (defun legal-immediate-constant-p (leaf)
59 (declare (type constant leaf))
60 (or (null (leaf-name leaf))
61 (typecase (constant-value leaf)
62 ((or number character) t)
63 (symbol (symbol-package (constant-value leaf)))
66 ;;; If CONT is used only by a REF to a leaf that can be delayed, then
67 ;;; return the leaf, otherwise return NIL.
68 (defun continuation-delayed-leaf (cont)
69 (declare (type continuation cont))
70 (let ((use (continuation-use cont)))
72 (let ((leaf (ref-leaf use)))
74 (lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
75 (constant (if (legal-immediate-constant-p leaf) leaf nil))
76 ((or functional global-var) nil))))))
78 ;;; Annotate a normal single-value continuation. If its only use is a
79 ;;; ref that we are allowed to delay the evaluation of, then we mark
80 ;;; the continuation for delayed evaluation, otherwise we assign a TN
81 ;;; to hold the continuation's value. If the continuation has a type
82 ;;; check, we make the TN according to the proven type to ensure that
83 ;;; the possibly erroneous value can be represented.
84 (defun annotate-1-value-continuation (cont)
85 (declare (type continuation cont))
86 (let ((info (continuation-info cont)))
87 (assert (eq (ir2-continuation-kind info) :fixed))
89 ((continuation-delayed-leaf cont)
90 (setf (ir2-continuation-kind info) :delayed))
91 ((member (continuation-type-check cont) '(:deleted nil))
92 (setf (ir2-continuation-locs info)
93 (list (make-normal-tn (ir2-continuation-primitive-type info)))))
95 (setf (ir2-continuation-locs info)
98 (single-value-type (continuation-proven-type cont)))))))))
101 ;;; Make an IR2-CONTINUATION corresponding to the continuation type
102 ;;; and then do ANNOTATE-1-VALUE-CONTINUATION. If POLICY-KEYWORD isn't
103 ;;; a safe policy keyword, then we clear the TYPE-CHECK flag.
104 (defun annotate-ordinary-continuation (cont policy-keyword)
105 (declare (type continuation cont)
106 (type policies policy-keyword))
107 (let ((info (make-ir2-continuation
108 (primitive-type (continuation-type cont)))))
109 (setf (continuation-info cont) info)
110 (unless (policy-safe-p policy-keyword)
111 (flush-type-check cont))
112 (annotate-1-value-continuation cont))
115 ;;; Annotate the function continuation for a full call. If the only
116 ;;; reference is to a global function and Delay is true, then we delay
117 ;;; the reference, otherwise we annotate for a single value.
119 ;;; Unlike for an argument, we only clear the type check flag when the
120 ;;; policy is unsafe, since the check for a valid function object must
121 ;;; be done before the call.
122 (defun annotate-function-continuation (cont policy &optional (delay t))
123 (declare (type continuation cont) (type policies policy))
124 (unless (policy-safe-p policy)
125 (flush-type-check cont))
126 (let* ((ptype (primitive-type (continuation-type cont)))
127 (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil))
131 (continuation-proven-type cont)))))
132 (info (make-ir2-continuation ptype)))
133 (setf (continuation-info cont) info)
134 (let ((name (continuation-function-name cont t)))
136 (setf (ir2-continuation-kind info) :delayed)
137 (setf (ir2-continuation-locs info)
138 (list (make-normal-tn tn-ptype))))))
141 ;;; If TAIL-P is true, then we check to see whether the call can really
142 ;;; be a tail call by seeing if this function's return convention is :UNKNOWN.
143 ;;; If so, we move the call block succssor link from the return block to
144 ;;; the component tail (after ensuring that they are in separate blocks.)
145 ;;; This allows the return to be deleted when there are no non-tail uses.
146 (defun flush-full-call-tail-transfer (call)
147 (declare (type basic-combination call))
148 (let ((tails (and (node-tail-p call)
149 (lambda-tail-set (node-home-lambda call)))))
151 (cond ((eq (return-info-kind (tail-set-info tails)) :unknown)
152 (node-ends-block call)
153 (let ((block (node-block call)))
154 (unlink-blocks block (first (block-succ block)))
155 (link-blocks block (component-tail (block-component block)))))
157 (setf (node-tail-p call) nil)))))
160 ;;; We set the kind to :FULL or :FUNNY, depending on whether there is an
161 ;;; IR2-CONVERT method. If a funny function, then we inhibit tail recursion
162 ;;; and type check normally, since the IR2 convert method is going to want to
163 ;;; deliver values normally. We still annotate the function continuation,
164 ;;; since IR2tran might decide to call after all.
166 ;;; If not funny, we always flush arg type checks, but do it after
167 ;;; annotation when the policy is safe, since we don't want to choose the TNs
168 ;;; according to a type assertions that may not hold.
170 ;;; Note that args may already be annotated because template selection can
171 ;;; bail out to here.
172 (defun ltn-default-call (call policy)
173 (declare (type combination call) (type policies policy))
174 (let ((kind (basic-combination-kind call)))
175 (annotate-function-continuation (basic-combination-fun call) policy)
178 ((and (function-info-p kind)
179 (function-info-ir2-convert kind))
180 (setf (basic-combination-info call) :funny)
181 (setf (node-tail-p call) nil)
182 (dolist (arg (basic-combination-args call))
183 (unless (continuation-info arg)
184 (setf (continuation-info arg)
185 (make-ir2-continuation
187 (continuation-type arg)))))
188 (annotate-1-value-continuation arg)))
190 (let ((safe-p (policy-safe-p policy)))
191 (dolist (arg (basic-combination-args call))
192 (unless safe-p (flush-type-check arg))
193 (unless (continuation-info arg)
194 (setf (continuation-info arg)
195 (make-ir2-continuation
197 (continuation-type arg)))))
198 (annotate-1-value-continuation arg)
199 (when safe-p (flush-type-check arg))))
200 (when (eq kind :error)
201 (setf (basic-combination-kind call) :full))
202 (setf (basic-combination-info call) :full)
203 (flush-full-call-tail-transfer call))))
207 ;;; Annotate a continuation for unknown multiple values:
208 ;;; -- Delete any type check, regardless of policy, since we IR2 conversion
209 ;;; isn't prepared to check unknown-values continuations. If we delete a
210 ;;; type check when the policy is safe, then we emit a warning.
211 ;;; -- Add the continuation to the IR2-Block-Popped if it is used across a
213 ;;; -- Assign a :Unknown IR2-Continuation.
215 ;;; Note: it is critical that this be called only during LTN analysis of Cont's
216 ;;; DEST, and called in the order that the continuations are received.
217 ;;; Otherwise the IR2-Block-Popped and IR2-Component-Values-XXX will get all
219 (defun annotate-unknown-values-continuation (cont policy)
220 (declare (type continuation cont) (type policies policy))
221 (when (eq (continuation-type-check cont) t)
222 (let* ((dest (continuation-dest cont))
223 (*compiler-error-context* dest))
224 (when (and (policy-safe-p policy)
225 (policy dest (>= safety inhibit-warnings)))
226 (compiler-note "unable to check type assertion in unknown-values ~
228 (continuation-asserted-type cont))))
229 (setf (continuation-%type-check cont) :deleted))
231 (let* ((block (node-block (continuation-dest cont)))
232 (use (continuation-use cont))
233 (2block (block-info block)))
234 (unless (and use (eq (node-block use) block))
235 (setf (ir2-block-popped 2block)
236 (nconc (ir2-block-popped 2block) (list cont)))))
238 (let ((2cont (make-ir2-continuation nil)))
239 (setf (ir2-continuation-kind 2cont) :unknown)
240 (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
241 (setf (continuation-info cont) 2cont))
245 ;;; Annotate Cont for a fixed, but arbitrary number of values, of the
246 ;;; specified primitive Types. If the continuation has a type check, we
247 ;;; annotate for the number of values indicated by Types, but only use proven
248 ;;; type information.
249 (defun annotate-fixed-values-continuation (cont policy types)
250 (declare (type continuation cont) (type policies policy) (list types))
251 (unless (policy-safe-p policy) (flush-type-check cont))
253 (let ((res (make-ir2-continuation nil)))
254 (if (member (continuation-type-check cont) '(:deleted nil))
255 (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
256 (let* ((proven (mapcar #'(lambda (x)
257 (make-normal-tn (primitive-type x)))
259 (continuation-proven-type cont))))
260 (num-proven (length proven))
261 (num-types (length types)))
262 (setf (ir2-continuation-locs res)
264 ((< num-proven num-types)
266 (make-n-tns (- num-types num-proven)
267 *backend-t-primitive-type*)))
268 ((> num-proven num-types)
269 (subseq proven 0 num-types))
272 (setf (continuation-info cont) res))
276 ;;;; node-specific analysis functions
278 ;;; Annotate the result continuation for a function. We use the Return-Info
279 ;;; computed by GTN to determine how to represent the return values within the
281 ;;; -- If the tail-set has a fixed values count, then use that many values.
282 ;;; -- If the actual uses of the result continuation in this function have a
283 ;;; fixed number of values (after intersection with the assertion), then use
284 ;;; that number. We throw out TAIL-P :FULL and :LOCAL calls, since we know
285 ;;; they will truly end up as TR calls. We can use the
286 ;;; BASIC-COMBINATION-INFO even though it is assigned by this phase, since
287 ;;; the initial value NIL doesn't look like a TR call.
289 ;;; If there are *no* non-tail-call uses, then it falls out that we annotate
290 ;;; for one value (type is NIL), but the return will end up being deleted.
292 ;;; In non-perverse code, the DFO walk will reach all uses of the result
293 ;;; continuation before it reaches the RETURN. In perverse code, we may
294 ;;; annotate for unknown values when we didn't have to.
295 ;;; -- Otherwise, we must annotate the continuation for unknown values.
296 (defun ltn-analyze-return (node policy)
297 (declare (type creturn node) (type policies policy))
298 (let* ((cont (return-result node))
299 (fun (return-lambda node))
300 (returns (tail-set-info (lambda-tail-set fun)))
301 (types (return-info-types returns)))
302 (if (eq (return-info-count returns) :unknown)
303 (collect ((res *empty-type* values-type-union))
304 (do-uses (use (return-result node))
305 (unless (and (node-tail-p use)
306 (basic-combination-p use)
307 (member (basic-combination-info use) '(:local :full)))
308 (res (node-derived-type use))))
310 (let ((int (values-type-intersection
312 (continuation-asserted-type cont))))
313 (multiple-value-bind (types kind)
314 (values-types (if (eq int *empty-type*) (res) int))
315 (if (eq kind :unknown)
316 (annotate-unknown-values-continuation cont policy)
317 (annotate-fixed-values-continuation
319 (mapcar #'primitive-type types))))))
320 (annotate-fixed-values-continuation cont policy types)))
324 ;;; Annotate the single argument continuation as a fixed-values
325 ;;; continuation. We look at the called lambda to determine number and type of
326 ;;; return values desired. It is assumed that only a function that
327 ;;; Looks-Like-An-MV-Bind will be converted to a local call.
328 (defun ltn-analyze-mv-bind (call policy)
329 (declare (type mv-combination call)
330 (type policies policy))
331 (setf (basic-combination-kind call) :local)
332 (setf (node-tail-p call) nil)
333 (annotate-fixed-values-continuation
334 (first (basic-combination-args call)) policy
335 (mapcar #'(lambda (var)
336 (primitive-type (basic-var-type var)))
340 (basic-combination-fun call))))))
343 ;;; We force all the argument continuations to use the unknown values
344 ;;; convention. The continuations are annotated in reverse order, since the
345 ;;; last argument is on top, thus must be popped first. We disallow delayed
346 ;;; evaluation of the function continuation to simplify IR2 conversion of MV
349 ;;; We could be cleverer when we know the number of values returned by the
350 ;;; continuations, but optimizations of MV-Call are probably unworthwhile.
352 ;;; We are also responsible for handling THROW, which is represented in IR1
353 ;;; as an mv-call to the %THROW funny function. We annotate the tag
354 ;;; continuation for a single value and the values continuation for unknown
356 (defun ltn-analyze-mv-call (call policy)
357 (declare (type mv-combination call))
358 (let ((fun (basic-combination-fun call))
359 (args (basic-combination-args call)))
360 (cond ((eq (continuation-function-name fun) '%throw)
361 (setf (basic-combination-info call) :funny)
362 (annotate-ordinary-continuation (first args) policy)
363 (annotate-unknown-values-continuation (second args) policy)
364 (setf (node-tail-p call) nil))
366 (setf (basic-combination-info call) :full)
367 (annotate-function-continuation (basic-combination-fun call)
369 (dolist (arg (reverse args))
370 (annotate-unknown-values-continuation arg policy))
371 (flush-full-call-tail-transfer call))))
375 ;;; Annotate the arguments as ordinary single-value continuations. And check
377 (defun ltn-analyze-local-call (call policy)
378 (declare (type combination call)
379 (type policies policy))
380 (setf (basic-combination-info call) :local)
382 (dolist (arg (basic-combination-args call))
384 (annotate-ordinary-continuation arg policy)))
386 (when (node-tail-p call)
387 (set-tail-local-call-successor call))
390 ;;; Make sure that a tail local call is linked directly to the bind
391 ;;; node. Usually it will be, but calls from XEPs and calls that might have
392 ;;; needed a cleanup after them won't have been swung over yet, since we
393 ;;; weren't sure they would really be TR until now. Also called by byte
395 (defun set-tail-local-call-successor (call)
396 (let ((caller (node-home-lambda call))
397 (callee (combination-lambda call)))
398 (assert (eq (lambda-tail-set caller)
399 (lambda-tail-set (lambda-home callee))))
400 (node-ends-block call)
401 (let ((block (node-block call)))
402 (unlink-blocks block (first (block-succ block)))
403 (link-blocks block (node-block (lambda-bind callee)))))
406 ;;; Annotate the value continuation.
407 (defun ltn-analyze-set (node policy)
408 (declare (type cset node) (type policies policy))
409 (setf (node-tail-p node) nil)
410 (annotate-ordinary-continuation (set-value node) policy)
413 ;;; If the only use of the Test continuation is a combination annotated with
414 ;;; a conditional template, then don't annotate the continuation so that IR2
415 ;;; conversion knows not to emit any code, otherwise annotate as an ordinary
416 ;;; continuation. Since we only use a conditional template if the call
417 ;;; immediately precedes the IF node in the same block, we know that any
418 ;;; predicate will already be annotated.
419 (defun ltn-analyze-if (node policy)
420 (declare (type cif node) (type policies policy))
421 (setf (node-tail-p node) nil)
422 (let* ((test (if-test node))
423 (use (continuation-use test)))
424 (unless (and (combination-p use)
425 (let ((info (basic-combination-info use)))
426 (and (template-p info)
427 (eq (template-result-types info) :conditional))))
428 (annotate-ordinary-continuation test policy)))
431 ;;; If there is a value continuation, then annotate it for unknown values.
432 ;;; In this case, the exit is non-local, since all other exits are deleted or
433 ;;; degenerate by this point.
434 (defun ltn-analyze-exit (node policy)
435 (setf (node-tail-p node) nil)
436 (let ((value (exit-value node)))
438 (annotate-unknown-values-continuation value policy)))
441 ;;; We need a special method for %Unwind-Protect that ignores the cleanup
442 ;;; function. We don't annotate either arg, since we don't need them at
445 ;;; [The default is o.k. for %Catch, since environment analysis converted the
446 ;;; reference to the escape function into a constant reference to the
448 (defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node policy)
450 (setf (basic-combination-info node) :funny)
451 (setf (node-tail-p node) nil))
453 ;;; Both of these functions need special LTN-annotate methods, since we only
454 ;;; want to clear the Type-Check in unsafe policies. If we allowed the call to
455 ;;; be annotated as a full call, then no type checking would be done.
457 ;;; We also need a special LTN annotate method for %Slot-Setter so that the
458 ;;; function is ignored. This is because the reference to a SETF function
459 ;;; can't be delayed, so IR2 conversion would have already emitted a call to
460 ;;; FDEFINITION by the time the IR2 convert method got control.
461 (defoptimizer (%slot-accessor ltn-annotate) ((struct) node policy)
462 (setf (basic-combination-info node) :funny)
463 (setf (node-tail-p node) nil)
464 (annotate-ordinary-continuation struct policy))
465 (defoptimizer (%slot-setter ltn-annotate) ((struct value) node policy)
466 (setf (basic-combination-info node) :funny)
467 (setf (node-tail-p node) nil)
468 (annotate-ordinary-continuation struct policy)
469 (annotate-ordinary-continuation value policy))
471 ;;;; known call annotation
473 ;;; Return true if Restr is satisfied by Type. If T-OK is true, then a T
474 ;;; restriction allows any operand type. This is also called by IR2tran when
475 ;;; it determines whether a result temporary needs to be made, and by
476 ;;; representation selection when it is deciding which move VOP to use.
477 ;;; Cont and TN are used to test for constant arguments.
478 #!-sb-fluid (declaim (inline operand-restriction-ok))
479 (defun operand-restriction-ok (restr type &key cont tn (t-ok t))
480 (declare (type (or (member *) cons) restr)
481 (type primitive-type type)
482 (type (or continuation null) cont)
483 (type (or tn null) tn))
488 (dolist (mem (rest restr) nil)
489 (when (or (and t-ok (eq mem *backend-t-primitive-type*))
494 (and (constant-continuation-p cont)
495 (funcall (second restr) (continuation-value cont))))
497 (and (eq (tn-kind tn) :constant)
498 (funcall (second restr) (tn-value tn))))
500 (error "Neither CONT nor TN supplied.")))))))
502 ;;; Check that the argument type restriction for Template are satisfied in
503 ;;; call. If an argument's TYPE-CHECK is :NO-CHECK and our policy is safe,
504 ;;; then only :SAFE templates are o.k.
505 (defun template-args-ok (template call safe-p)
506 (declare (type template template)
507 (type combination call))
508 (let ((mtype (template-more-args-type template)))
509 (do ((args (basic-combination-args call) (cdr args))
510 (types (template-arg-types template) (cdr types)))
512 (cond ((null args) t)
516 (unless (operand-restriction-ok mtype
517 (continuation-ptype arg))
519 (when (null args) (return nil))
520 (let ((arg (car args))
522 (when (and (eq (continuation-type-check arg) :no-check)
524 (not (eq (template-policy template) :safe)))
526 (unless (operand-restriction-ok type (continuation-ptype arg)
530 ;;; Check that Template can be used with the specifed Result-Type. Result
531 ;;; type checking is pretty different from argument type checking due to the
532 ;;; relaxed rules for values count. We succeed if for each required result,
533 ;;; there is a positional restriction on the value that is at least as good.
534 ;;; If we run out of result types before we run out of restrictions, then we
535 ;;; only succeed if the leftover restrictions are *. If we run out of
536 ;;; restrictions before we run out of result types, then we always win.
537 (defun template-results-ok (template result-type)
538 (declare (type template template)
539 (type ctype result-type))
540 (when (template-more-results-type template)
541 (error "~S has :MORE results with :TRANSLATE." (template-name template)))
542 (let ((types (template-result-types template)))
544 ((values-type-p result-type)
545 (do ((ltypes (append (args-type-required result-type)
546 (args-type-optional result-type))
548 (types types (rest types)))
550 (dolist (type types t)
553 (when (null types) (return t))
554 (let ((type (first types)))
555 (unless (operand-restriction-ok type
556 (primitive-type (first ltypes)))
559 (operand-restriction-ok (first types) (primitive-type result-type)))
562 ;;; Return true if Call is an ok use of Template according to Safe-P.
563 ;;; -- If the template has a Guard that isn't true, then we ignore the
564 ;;; template, not even considering it to be rejected.
565 ;;; -- If the argument type restrictions aren't satisfied, then we reject the
567 ;;; -- If the template is :Conditional, then we accept it only when the
568 ;;; destination of the value is an immediately following IF node.
569 ;;; -- If either the template is safe or the policy is unsafe (i.e. we can
570 ;;; believe output assertions), then we test against the intersection of the
571 ;;; node derived type and the continuation asserted type. Otherwise, we
572 ;;; just use the node type. If TYPE-CHECK is null, there is no point in
573 ;;; doing the intersection, since the node type must be a subtype of the
576 ;;; If the template is *not* ok, then the second value is a keyword indicating
577 ;;; which aspect failed.
578 (defun is-ok-template-use (template call safe-p)
579 (declare (type template template) (type combination call))
580 (let* ((guard (template-guard template))
581 (cont (node-cont call))
582 (atype (continuation-asserted-type cont))
583 (dtype (node-derived-type call)))
584 (cond ((and guard (not (funcall guard)))
586 ((not (template-args-ok template call safe-p))
588 (if (and safe-p (template-args-ok template call nil))
591 ((eq (template-result-types template) :conditional)
592 (let ((dest (continuation-dest cont)))
594 (immediately-used-p (if-test dest) call))
596 (values nil :conditional))))
597 ((template-results-ok
599 (if (and (or (eq (template-policy template) :safe)
601 (continuation-type-check cont))
602 (values-type-intersection dtype atype)
606 (values nil :result-types)))))
608 ;;; Use operand type information to choose a template from the list
609 ;;; Templates for a known Call. We return three values:
610 ;;; 1. The template we found.
611 ;;; 2. Some template that we rejected due to unsatisfied type restrictions, or
613 ;;; 3. The tail of Templates for templates we haven't examined yet.
615 ;;; We just call IS-OK-TEMPLATE-USE until it returns true.
616 (defun find-template (templates call safe-p)
617 (declare (list templates) (type combination call))
618 (do ((templates templates (rest templates))
621 (values nil rejected nil))
622 (let ((template (first templates)))
623 (when (is-ok-template-use template call safe-p)
624 (return (values template rejected (rest templates))))
625 (setq rejected template))))
627 ;;; Given a partially annotated known call and a translation policy, return
628 ;;; the appropriate template, or NIL if none can be found. We scan the
629 ;;; templates (ordered by increasing cost) looking for a template whose
630 ;;; restrictions are satisfied and that has our policy.
632 ;;; If we find a template that doesn't have our policy, but has a legal
633 ;;; alternate policy, then we also record that to return as a last resort. If
634 ;;; our policy is safe, then only safe policies are O.K., otherwise anything
637 ;;; If we find a template with :SAFE policy, then we return it, or any cheaper
638 ;;; fallback template. The theory behind this is that if it is cheapest, small
639 ;;; and safe, we can't lose. If it is not cheapest, then we use the fallback,
640 ;;; which won't have the desired policy, but :SAFE isn't desired either, so we
641 ;;; might as well go with the cheaper one. The main reason for doing this is
642 ;;; to make sure that cheap safe templates are used when they apply and the
643 ;;; current policy is something else. This is useful because :SAFE has the
644 ;;; additional semantics of implicit argument type checking, so we may be
645 ;;; forced to define a template with :SAFE policy when it is really small and
647 (defun find-template-for-policy (call policy)
648 (declare (type combination call)
649 (type policies policy))
650 (let ((safe-p (policy-safe-p policy))
651 (current (function-info-templates (basic-combination-kind call)))
655 (multiple-value-bind (template this-reject more)
656 (find-template current call safe-p)
658 (setq rejected this-reject))
661 (return (values fallback rejected)))
663 (let ((tpolicy (template-policy template)))
664 (cond ((eq tpolicy policy)
665 (return (values template rejected)))
667 (return (values (or fallback template) rejected)))
668 ((or (not safe-p) (eq tpolicy :fast-safe))
670 (setq fallback template)))))))))
672 (defvar *efficiency-note-limit* 2
674 "This is the maximum number of possible optimization alternatives will be
675 mentioned in a particular efficiency note. NIL means no limit.")
676 (declaim (type (or index null) *efficiency-note-limit*))
678 (defvar *efficiency-note-cost-threshold* 5
680 "This is the minumum cost difference between the chosen implementation and
681 the next alternative that justifies an efficiency note.")
682 (declaim (type index *efficiency-note-cost-threshold*))
684 ;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't figure
685 ;;; out any reason why Template was rejected. Users should never see these
686 ;;; messages, but they can happen in situations where the VM definition is
687 ;;; messed up somehow.
688 (defun strange-template-failure (template call policy frob)
689 (declare (type template template) (type combination call)
690 (type policies policy) (type function frob))
691 (funcall frob "This shouldn't happen! Bug?")
692 (multiple-value-bind (win why)
693 (is-ok-template-use template call (policy-safe-p policy))
697 (funcall frob "template guard failed"))
699 (funcall frob "The template isn't safe, yet we were counting on it."))
701 (funcall frob "argument types invalid")
702 (funcall frob "argument primitive types:~% ~S"
703 (mapcar #'(lambda (x)
705 (continuation-ptype x)))
706 (combination-args call)))
707 (funcall frob "argument type assertions:~% ~S"
708 (mapcar #'(lambda (x)
712 (:or `(:or .,(mapcar #'primitive-type-name
714 (:constant `(:constant ,(third x))))))
715 (template-arg-types template))))
717 (funcall frob "conditional in a non-conditional context"))
719 (funcall frob "result types invalid")))))
721 ;;; This function emits efficiency notes describing all of the templates
722 ;;; better (faster) than Template that we might have been able to use if there
723 ;;; were better type declarations. Template is null when we didn't find any
724 ;;; template, and thus must do a full call.
726 ;;; In order to be worth complaining about, a template must:
727 ;;; -- be allowed by its guard,
728 ;;; -- be safe if the current policy is safe,
729 ;;; -- have argument/result type restrictions consistent with the known type
730 ;;; information, e.g. we don't consider float templates when an operand is
731 ;;; known to be an integer,
732 ;;; -- be disallowed by the stricter operand subtype test (which resembles, but
733 ;;; is not identical to the test done by Find-Template.)
735 ;;; Note that there may not be any possibly applicable templates, since we are
736 ;;; called whenever any template is rejected. That template might have the
737 ;;; wrong policy or be inconsistent with the known type.
739 ;;; We go to some trouble to make the whole multi-line output into a single
740 ;;; call to Compiler-Note so that repeat messages are suppressed, etc.
741 (defun note-rejected-templates (call policy template)
742 (declare (type combination call) (type policies policy)
743 (type (or template null) template))
746 (let ((safe-p (policy-safe-p policy))
747 (verbose-p (policy call (= inhibit-warnings 0)))
748 (max-cost (- (template-cost
750 (template-or-lose 'call-named)))
751 *efficiency-note-cost-threshold*)))
752 (dolist (try (function-info-templates (basic-combination-kind call)))
753 (when (> (template-cost try) max-cost) (return))
754 (let ((guard (template-guard try)))
755 (when (and (or (not guard) (funcall guard))
757 (policy-safe-p (template-policy try)))
759 (and (template-note try)
761 call (template-type try)
762 :argument-test #'types-intersect
763 :result-test #'values-types-intersect))))
769 (flet ((frob (string &rest stuff)
772 (dolist (loser (losers))
773 (when (and *efficiency-note-limit*
774 (>= (count) *efficiency-note-limit*))
777 (let* ((type (template-type loser))
778 (valid (valid-function-use call type))
779 (strict-valid (valid-function-use call type
781 (frob "unable to do ~A (cost ~D) because:"
782 (or (template-note loser) (template-name loser))
783 (template-cost loser))
785 ((and valid strict-valid)
786 (strange-template-failure loser call policy #'frob))
788 (assert (not (valid-function-use call type
789 :error-function #'frob
790 :warning-function #'frob))))
792 (assert (policy-safe-p policy))
793 (frob "can't trust output type assertion under safe policy")))
796 (let ((*compiler-error-context* call))
797 (compiler-note "~{~?~^~&~6T~}"
799 `("forced to do ~A (cost ~D)"
800 (,(or (template-note template)
801 (template-name template))
802 ,(template-cost template))
804 `("forced to do full call"
809 ;;; Flush type checks according to policy. If the policy is
810 ;;; unsafe, then we never do any checks. If our policy is safe, and
811 ;;; we are using a safe template, then we can also flush arg and
812 ;;; result type checks. Result type checks are only flushed when the
813 ;;; continuation as a single use. Result type checks are not flush if
814 ;;; the policy is safe because the selection of template for results
815 ;;; readers assumes the type check is done (uses the derived type
816 ;;; which is the intersection of the proven and asserted types).
817 (defun flush-type-checks-according-to-policy (call policy template)
818 (declare (type combination call) (type policies policy)
819 (type template template))
820 (let ((safe-op (eq (template-policy template) :safe)))
821 (when (or (not (policy-safe-p policy)) safe-op)
822 (dolist (arg (basic-combination-args call))
823 (flush-type-check arg)))
825 (let ((cont (node-cont call)))
826 (when (and (eq (continuation-use cont) call)
827 (not (policy-safe-p policy)))
828 (flush-type-check cont)))))
832 ;;; If a function has a special-case annotation method use that, otherwise
833 ;;; annotate the argument continuations and try to find a template
834 ;;; corresponding to the type signature. If there is none, convert a full call.
835 (defun ltn-analyze-known-call (call policy)
836 (declare (type combination call)
837 (type policies policy))
838 (let ((method (function-info-ltn-annotate (basic-combination-kind call)))
839 (args (basic-combination-args call)))
841 (funcall method call policy)
842 (return-from ltn-analyze-known-call (values)))
845 (setf (continuation-info arg)
846 (make-ir2-continuation (primitive-type (continuation-type arg)))))
848 (multiple-value-bind (template rejected)
849 (find-template-for-policy call policy)
850 ;; If we are unable to use some templates due to unsatisfied operand type
851 ;; restrictions and our policy enables efficiency notes, then we call
852 ;; Note-Rejected-Templates.
854 (policy call (> speed inhibit-warnings)))
855 (note-rejected-templates call policy template))
856 ;; If we are forced to do a full call, we check to see whether the
857 ;; function called is the same as the current function. If so, we
858 ;; give a warning, as this is probably a botched interpreter stub.
860 (when (and (eq (continuation-function-name (combination-fun call))
862 (environment-function
863 (node-environment call))))
864 (let ((info (basic-combination-kind call)))
865 (not (or (function-info-ir2-convert info)
866 (ir1-attributep (function-info-attributes info)
868 (let ((*compiler-error-context* call))
869 (compiler-warning "recursive known function definition")))
870 (ltn-default-call call policy)
871 (return-from ltn-analyze-known-call (values)))
872 (setf (basic-combination-info call) template)
873 (setf (node-tail-p call) nil)
875 (flush-type-checks-according-to-policy call policy template)
878 (annotate-1-value-continuation arg))))
884 ;;; We make the main per-block code in for LTN into a macro so that it can
885 ;;; be shared between LTN-Analyze and LTN-Analyze-Block, yet can cache policy
886 ;;; across blocks in the normal (full component) case.
888 ;;; This code computes the policy and then dispatches to the appropriate
889 ;;; node-specific function.
891 ;;; Note: we deliberately don't use the DO-NODES macro, since the block can be
892 ;;; split out from underneath us, and DO-NODES would scan past the block end in that
895 '(do* ((node (continuation-next (block-start block))
896 (continuation-next cont))
897 (cont (node-cont node) (node-cont node))
898 ;; KLUDGE: Since LEXENV and POLICY seem to be only used
899 ;; inside this FROB, why not define them in here instead of
900 ;; requiring them to be defined externally both in
901 ;; LTN-ANALYZE and LTN-ANALYZE-BLOCK? Or perhaps just
902 ;; define this whole FROB as an inline function? (Right now
903 ;; I don't want to make even a small unnecessary change
904 ;; like this, but'd prefer to wait until the system runs so
905 ;; that I can test it immediately after the change.)
909 (unless (eq (node-lexenv node) lexenv)
910 (setq policy (translation-policy node))
911 (setq lexenv (node-lexenv node)))
916 (case (basic-combination-kind node)
917 (:local (ltn-analyze-local-call node policy))
918 ((:full :error) (ltn-default-call node policy))
920 (ltn-analyze-known-call node policy))))
922 (ltn-analyze-if node policy))
924 (ltn-analyze-return node policy))
927 (ltn-analyze-exit node policy))
928 (cset (ltn-analyze-set node policy))
930 (ecase (basic-combination-kind node)
931 (:local (ltn-analyze-mv-bind node policy))
932 ((:full :error) (ltn-analyze-mv-call node policy)))))
934 (when (eq node (block-last block))
937 ;;; Loop over the blocks in Component, doing stuff to nodes that receive
938 ;;; values. In addition to the stuff done by FROB, we also see whether there
939 ;;; are any unknown values receivers, making notations in the components
940 ;;; Generators and Receivers as appropriate.
942 ;;; If any unknown-values continations are received by this block (as
943 ;;; indicated by IR2-Block-Popped, then we add the block to the
944 ;;; IR2-Component-Values-Receivers.
946 ;;; This is where we allocate IR2 blocks because it is the first place we
948 (defun ltn-analyze (component)
949 (declare (type component component))
950 (let ((2comp (component-info component))
953 (do-blocks (block component)
954 (assert (not (block-info block)))
955 (let ((2block (make-ir2-block block)))
956 (setf (block-info block) 2block)
958 (let ((popped (ir2-block-popped 2block)))
960 (push block (ir2-component-values-receivers 2comp)))))))
963 ;;; This function is used to analyze blocks that must be added to the flow
964 ;;; graph after the normal LTN phase runs. Such code is constrained not to
965 ;;; use weird unknown values (and probably in lots of other ways).
966 (defun ltn-analyze-block (block)
967 (declare (type cblock block))
971 (assert (not (ir2-block-popped (block-info block))))