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))
21 (let* ((cookie (lexenv-cookie (node-lexenv node)))
22 (safety (cookie-safety cookie))
23 (space (max (cookie-space cookie)
24 (cookie-cspeed cookie)))
25 (speed (cookie-speed cookie)))
27 (if (>= speed space) :fast :small)
28 (if (>= speed space) :fast-safe :safe))))
30 ;;; Return true if Policy is a safe policy.
31 #!-sb-fluid (declaim (inline policy-safe-p))
32 (defun policy-safe-p (policy)
33 (declare (type policies policy))
34 (or (eq policy :safe) (eq policy :fast-safe)))
36 ;;; Called when an unsafe policy indicates that no type check should be done
37 ;;; on CONT. We delete the type check unless it is :ERROR (indicating a
38 ;;; compile-time type error.)
39 #!-sb-fluid (declaim (inline flush-type-check))
40 (defun flush-type-check (cont)
41 (declare (type continuation cont))
42 (when (member (continuation-type-check cont) '(t :no-check))
43 (setf (continuation-%type-check cont) :deleted))
46 ;;; An annotated continuation's primitive-type.
47 #!-sb-fluid (declaim (inline continuation-ptype))
48 (defun continuation-ptype (cont)
49 (declare (type continuation cont))
50 (ir2-continuation-primitive-type (continuation-info cont)))
52 ;;; Return true if a constant Leaf is of a type which we can legally
53 ;;; directly reference in code. Named constants with arbitrary pointer values
54 ;;; cannot, since we must preserve EQLness.
55 (defun legal-immediate-constant-p (leaf)
56 (declare (type constant leaf))
57 (or (null (leaf-name leaf))
58 (typecase (constant-value leaf)
59 ((or number character) t)
60 (symbol (symbol-package (constant-value leaf)))
63 ;;; If Cont is used only by a Ref to a leaf that can be delayed, then return
64 ;;; the leaf, otherwise return NIL.
65 (defun continuation-delayed-leaf (cont)
66 (declare (type continuation cont))
67 (let ((use (continuation-use cont)))
69 (let ((leaf (ref-leaf use)))
71 (lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
72 (constant (if (legal-immediate-constant-p leaf) leaf nil))
73 ((or functional global-var) nil))))))
75 ;;; Annotate a normal single-value continuation. If its only use is a ref
76 ;;; that we are allowed to delay the evaluation of, then we mark the
77 ;;; continuation for delayed evaluation, otherwise we assign a TN to hold the
78 ;;; continuation's value. If the continuation has a type check, we make the TN
79 ;;; according to the proven type to ensure that the possibly erroneous value
80 ;;; can be represented.
81 (defun annotate-1-value-continuation (cont)
82 (declare (type continuation cont))
83 (let ((info (continuation-info cont)))
84 (assert (eq (ir2-continuation-kind info) :fixed))
86 ((continuation-delayed-leaf cont)
87 (setf (ir2-continuation-kind info) :delayed))
88 ((member (continuation-type-check cont) '(:deleted nil))
89 (setf (ir2-continuation-locs info)
90 (list (make-normal-tn (ir2-continuation-primitive-type info)))))
92 (setf (ir2-continuation-locs info)
95 (single-value-type (continuation-proven-type cont)))))))))
98 ;;; Make an IR2-Continuation corresponding to the continuation type and then
99 ;;; do Annotate-1-Value-Continuation. If Policy isn't a safe policy, then we
100 ;;; clear the type-check flag.
101 (defun annotate-ordinary-continuation (cont policy)
102 (declare (type continuation cont)
103 (type policies policy))
104 (let ((info (make-ir2-continuation
105 (primitive-type (continuation-type cont)))))
106 (setf (continuation-info cont) info)
107 (unless (policy-safe-p policy) (flush-type-check cont))
108 (annotate-1-value-continuation cont))
111 ;;; Annotate the function continuation for a full call. If the only
112 ;;; reference is to a global function and Delay is true, then we delay
113 ;;; the reference, otherwise we annotate for a single value.
115 ;;; Unlike for an argument, we only clear the type check flag when the policy
116 ;;; is unsafe, since the check for a valid function object must be done before
118 (defun annotate-function-continuation (cont policy &optional (delay t))
119 (declare (type continuation cont) (type policies policy))
120 (unless (policy-safe-p policy) (flush-type-check cont))
121 (let* ((ptype (primitive-type (continuation-type cont)))
122 (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil))
126 (continuation-proven-type cont)))))
127 (info (make-ir2-continuation ptype)))
128 (setf (continuation-info cont) info)
129 (let ((name (continuation-function-name cont t)))
131 (setf (ir2-continuation-kind info) :delayed)
132 (setf (ir2-continuation-locs info)
133 (list (make-normal-tn tn-ptype))))))
136 ;;; If TAIL-P is true, then we check to see whether the call can really
137 ;;; be a tail call by seeing if this function's return convention is :UNKNOWN.
138 ;;; If so, we move the call block succssor link from the return block to
139 ;;; the component tail (after ensuring that they are in separate blocks.)
140 ;;; This allows the return to be deleted when there are no non-tail uses.
141 (defun flush-full-call-tail-transfer (call)
142 (declare (type basic-combination call))
143 (let ((tails (and (node-tail-p call)
144 (lambda-tail-set (node-home-lambda call)))))
146 (cond ((eq (return-info-kind (tail-set-info tails)) :unknown)
147 (node-ends-block call)
148 (let ((block (node-block call)))
149 (unlink-blocks block (first (block-succ block)))
150 (link-blocks block (component-tail (block-component block)))))
152 (setf (node-tail-p call) nil)))))
155 ;;; We set the kind to :FULL or :FUNNY, depending on whether there is an
156 ;;; IR2-CONVERT method. If a funny function, then we inhibit tail recursion
157 ;;; and type check normally, since the IR2 convert method is going to want to
158 ;;; deliver values normally. We still annotate the function continuation,
159 ;;; since IR2tran might decide to call after all.
161 ;;; If not funny, we always flush arg type checks, but do it after
162 ;;; annotation when the policy is safe, since we don't want to choose the TNs
163 ;;; according to a type assertions that may not hold.
165 ;;; Note that args may already be annotated because template selection can
166 ;;; bail out to here.
167 (defun ltn-default-call (call policy)
168 (declare (type combination call) (type policies policy))
169 (let ((kind (basic-combination-kind call)))
170 (annotate-function-continuation (basic-combination-fun call) policy)
173 ((and (function-info-p kind)
174 (function-info-ir2-convert kind))
175 (setf (basic-combination-info call) :funny)
176 (setf (node-tail-p call) nil)
177 (dolist (arg (basic-combination-args call))
178 (unless (continuation-info arg)
179 (setf (continuation-info arg)
180 (make-ir2-continuation
182 (continuation-type arg)))))
183 (annotate-1-value-continuation arg)))
185 (let ((safe-p (policy-safe-p policy)))
186 (dolist (arg (basic-combination-args call))
187 (unless safe-p (flush-type-check arg))
188 (unless (continuation-info arg)
189 (setf (continuation-info arg)
190 (make-ir2-continuation
192 (continuation-type arg)))))
193 (annotate-1-value-continuation arg)
194 (when safe-p (flush-type-check arg))))
195 (when (eq kind :error)
196 (setf (basic-combination-kind call) :full))
197 (setf (basic-combination-info call) :full)
198 (flush-full-call-tail-transfer call))))
202 ;;; Annotate a continuation for unknown multiple values:
203 ;;; -- Delete any type check, regardless of policy, since we IR2 conversion
204 ;;; isn't prepared to check unknown-values continuations. If we delete a
205 ;;; type check when the policy is safe, then we emit a warning.
206 ;;; -- Add the continuation to the IR2-Block-Popped if it is used across a
208 ;;; -- Assign a :Unknown IR2-Continuation.
210 ;;; Note: it is critical that this be called only during LTN analysis of Cont's
211 ;;; DEST, and called in the order that the continuations are received.
212 ;;; Otherwise the IR2-Block-Popped and IR2-Component-Values-XXX will get all
214 (defun annotate-unknown-values-continuation (cont policy)
215 (declare (type continuation cont) (type policies policy))
216 (when (eq (continuation-type-check cont) t)
217 (let* ((dest (continuation-dest cont))
218 (*compiler-error-context* dest))
219 (when (and (policy-safe-p policy)
220 (policy dest (>= safety brevity)))
221 (compiler-note "unable to check type assertion in unknown-values ~
223 (continuation-asserted-type cont))))
224 (setf (continuation-%type-check cont) :deleted))
226 (let* ((block (node-block (continuation-dest cont)))
227 (use (continuation-use cont))
228 (2block (block-info block)))
229 (unless (and use (eq (node-block use) block))
230 (setf (ir2-block-popped 2block)
231 (nconc (ir2-block-popped 2block) (list cont)))))
233 (let ((2cont (make-ir2-continuation nil)))
234 (setf (ir2-continuation-kind 2cont) :unknown)
235 (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
236 (setf (continuation-info cont) 2cont))
240 ;;; Annotate Cont for a fixed, but arbitrary number of values, of the
241 ;;; specified primitive Types. If the continuation has a type check, we
242 ;;; annotate for the number of values indicated by Types, but only use proven
243 ;;; type information.
244 (defun annotate-fixed-values-continuation (cont policy types)
245 (declare (type continuation cont) (type policies policy) (list types))
246 (unless (policy-safe-p policy) (flush-type-check cont))
248 (let ((res (make-ir2-continuation nil)))
249 (if (member (continuation-type-check cont) '(:deleted nil))
250 (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
251 (let* ((proven (mapcar #'(lambda (x)
252 (make-normal-tn (primitive-type x)))
254 (continuation-proven-type cont))))
255 (num-proven (length proven))
256 (num-types (length types)))
257 (setf (ir2-continuation-locs res)
259 ((< num-proven num-types)
261 (make-n-tns (- num-types num-proven)
262 *backend-t-primitive-type*)))
263 ((> num-proven num-types)
264 (subseq proven 0 num-types))
267 (setf (continuation-info cont) res))
271 ;;;; node-specific analysis functions
273 ;;; Annotate the result continuation for a function. We use the Return-Info
274 ;;; computed by GTN to determine how to represent the return values within the
276 ;;; -- If the tail-set has a fixed values count, then use that many values.
277 ;;; -- If the actual uses of the result continuation in this function have a
278 ;;; fixed number of values (after intersection with the assertion), then use
279 ;;; that number. We throw out TAIL-P :FULL and :LOCAL calls, since we know
280 ;;; they will truly end up as TR calls. We can use the
281 ;;; BASIC-COMBINATION-INFO even though it is assigned by this phase, since
282 ;;; the initial value NIL doesn't look like a TR call.
284 ;;; If there are *no* non-tail-call uses, then it falls out that we annotate
285 ;;; for one value (type is NIL), but the return will end up being deleted.
287 ;;; In non-perverse code, the DFO walk will reach all uses of the result
288 ;;; continuation before it reaches the RETURN. In perverse code, we may
289 ;;; annotate for unknown values when we didn't have to.
290 ;;; -- Otherwise, we must annotate the continuation for unknown values.
291 (defun ltn-analyze-return (node policy)
292 (declare (type creturn node) (type policies policy))
293 (let* ((cont (return-result node))
294 (fun (return-lambda node))
295 (returns (tail-set-info (lambda-tail-set fun)))
296 (types (return-info-types returns)))
297 (if (eq (return-info-count returns) :unknown)
298 (collect ((res *empty-type* values-type-union))
299 (do-uses (use (return-result node))
300 (unless (and (node-tail-p use)
301 (basic-combination-p use)
302 (member (basic-combination-info use) '(:local :full)))
303 (res (node-derived-type use))))
305 (let ((int (values-type-intersection
307 (continuation-asserted-type cont))))
308 (multiple-value-bind (types kind)
309 (values-types (if (eq int *empty-type*) (res) int))
310 (if (eq kind :unknown)
311 (annotate-unknown-values-continuation cont policy)
312 (annotate-fixed-values-continuation
314 (mapcar #'primitive-type types))))))
315 (annotate-fixed-values-continuation cont policy types)))
319 ;;; Annotate the single argument continuation as a fixed-values
320 ;;; continuation. We look at the called lambda to determine number and type of
321 ;;; return values desired. It is assumed that only a function that
322 ;;; Looks-Like-An-MV-Bind will be converted to a local call.
323 (defun ltn-analyze-mv-bind (call policy)
324 (declare (type mv-combination call)
325 (type policies policy))
326 (setf (basic-combination-kind call) :local)
327 (setf (node-tail-p call) nil)
328 (annotate-fixed-values-continuation
329 (first (basic-combination-args call)) policy
330 (mapcar #'(lambda (var)
331 (primitive-type (basic-var-type var)))
335 (basic-combination-fun call))))))
338 ;;; We force all the argument continuations to use the unknown values
339 ;;; convention. The continuations are annotated in reverse order, since the
340 ;;; last argument is on top, thus must be popped first. We disallow delayed
341 ;;; evaluation of the function continuation to simplify IR2 conversion of MV
344 ;;; We could be cleverer when we know the number of values returned by the
345 ;;; continuations, but optimizations of MV-Call are probably unworthwhile.
347 ;;; We are also responsible for handling THROW, which is represented in IR1
348 ;;; as an mv-call to the %THROW funny function. We annotate the tag
349 ;;; continuation for a single value and the values continuation for unknown
351 (defun ltn-analyze-mv-call (call policy)
352 (declare (type mv-combination call))
353 (let ((fun (basic-combination-fun call))
354 (args (basic-combination-args call)))
355 (cond ((eq (continuation-function-name fun) '%throw)
356 (setf (basic-combination-info call) :funny)
357 (annotate-ordinary-continuation (first args) policy)
358 (annotate-unknown-values-continuation (second args) policy)
359 (setf (node-tail-p call) nil))
361 (setf (basic-combination-info call) :full)
362 (annotate-function-continuation (basic-combination-fun call)
364 (dolist (arg (reverse args))
365 (annotate-unknown-values-continuation arg policy))
366 (flush-full-call-tail-transfer call))))
370 ;;; Annotate the arguments as ordinary single-value continuations. And check
372 (defun ltn-analyze-local-call (call policy)
373 (declare (type combination call)
374 (type policies policy))
375 (setf (basic-combination-info call) :local)
377 (dolist (arg (basic-combination-args call))
379 (annotate-ordinary-continuation arg policy)))
381 (when (node-tail-p call)
382 (set-tail-local-call-successor call))
385 ;;; Make sure that a tail local call is linked directly to the bind
386 ;;; node. Usually it will be, but calls from XEPs and calls that might have
387 ;;; needed a cleanup after them won't have been swung over yet, since we
388 ;;; weren't sure they would really be TR until now. Also called by byte
390 (defun set-tail-local-call-successor (call)
391 (let ((caller (node-home-lambda call))
392 (callee (combination-lambda call)))
393 (assert (eq (lambda-tail-set caller)
394 (lambda-tail-set (lambda-home callee))))
395 (node-ends-block call)
396 (let ((block (node-block call)))
397 (unlink-blocks block (first (block-succ block)))
398 (link-blocks block (node-block (lambda-bind callee)))))
401 ;;; Annotate the value continuation.
402 (defun ltn-analyze-set (node policy)
403 (declare (type cset node) (type policies policy))
404 (setf (node-tail-p node) nil)
405 (annotate-ordinary-continuation (set-value node) policy)
408 ;;; If the only use of the Test continuation is a combination annotated with
409 ;;; a conditional template, then don't annotate the continuation so that IR2
410 ;;; conversion knows not to emit any code, otherwise annotate as an ordinary
411 ;;; continuation. Since we only use a conditional template if the call
412 ;;; immediately precedes the IF node in the same block, we know that any
413 ;;; predicate will already be annotated.
414 (defun ltn-analyze-if (node policy)
415 (declare (type cif node) (type policies policy))
416 (setf (node-tail-p node) nil)
417 (let* ((test (if-test node))
418 (use (continuation-use test)))
419 (unless (and (combination-p use)
420 (let ((info (basic-combination-info use)))
421 (and (template-p info)
422 (eq (template-result-types info) :conditional))))
423 (annotate-ordinary-continuation test policy)))
426 ;;; If there is a value continuation, then annotate it for unknown values.
427 ;;; In this case, the exit is non-local, since all other exits are deleted or
428 ;;; degenerate by this point.
429 (defun ltn-analyze-exit (node policy)
430 (setf (node-tail-p node) nil)
431 (let ((value (exit-value node)))
433 (annotate-unknown-values-continuation value policy)))
436 ;;; We need a special method for %Unwind-Protect that ignores the cleanup
437 ;;; function. We don't annotate either arg, since we don't need them at
440 ;;; [The default is o.k. for %Catch, since environment analysis converted the
441 ;;; reference to the escape function into a constant reference to the
443 (defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node policy)
445 (setf (basic-combination-info node) :funny)
446 (setf (node-tail-p node) nil))
448 ;;; Both of these functions need special LTN-annotate methods, since we only
449 ;;; want to clear the Type-Check in unsafe policies. If we allowed the call to
450 ;;; be annotated as a full call, then no type checking would be done.
452 ;;; We also need a special LTN annotate method for %Slot-Setter so that the
453 ;;; function is ignored. This is because the reference to a SETF function
454 ;;; can't be delayed, so IR2 conversion would have already emitted a call to
455 ;;; FDEFINITION by the time the IR2 convert method got control.
456 (defoptimizer (%slot-accessor ltn-annotate) ((struct) node policy)
457 (setf (basic-combination-info node) :funny)
458 (setf (node-tail-p node) nil)
459 (annotate-ordinary-continuation struct policy))
460 (defoptimizer (%slot-setter ltn-annotate) ((struct value) node policy)
461 (setf (basic-combination-info node) :funny)
462 (setf (node-tail-p node) nil)
463 (annotate-ordinary-continuation struct policy)
464 (annotate-ordinary-continuation value policy))
466 ;;;; known call annotation
468 ;;; Return true if Restr is satisfied by Type. If T-OK is true, then a T
469 ;;; restriction allows any operand type. This is also called by IR2tran when
470 ;;; it determines whether a result temporary needs to be made, and by
471 ;;; representation selection when it is deciding which move VOP to use.
472 ;;; Cont and TN are used to test for constant arguments.
473 #!-sb-fluid (declaim (inline operand-restriction-ok))
474 (defun operand-restriction-ok (restr type &key cont tn (t-ok t))
475 (declare (type (or (member *) cons) restr)
476 (type primitive-type type)
477 (type (or continuation null) cont)
478 (type (or tn null) tn))
483 (dolist (mem (rest restr) nil)
484 (when (or (and t-ok (eq mem *backend-t-primitive-type*))
489 (and (constant-continuation-p cont)
490 (funcall (second restr) (continuation-value cont))))
492 (and (eq (tn-kind tn) :constant)
493 (funcall (second restr) (tn-value tn))))
495 (error "Neither CONT nor TN supplied.")))))))
497 ;;; Check that the argument type restriction for Template are satisfied in
498 ;;; call. If an argument's TYPE-CHECK is :NO-CHECK and our policy is safe,
499 ;;; then only :SAFE templates are o.k.
500 (defun template-args-ok (template call safe-p)
501 (declare (type template template)
502 (type combination call))
503 (let ((mtype (template-more-args-type template)))
504 (do ((args (basic-combination-args call) (cdr args))
505 (types (template-arg-types template) (cdr types)))
507 (cond ((null args) t)
511 (unless (operand-restriction-ok mtype
512 (continuation-ptype arg))
514 (when (null args) (return nil))
515 (let ((arg (car args))
517 (when (and (eq (continuation-type-check arg) :no-check)
519 (not (eq (template-policy template) :safe)))
521 (unless (operand-restriction-ok type (continuation-ptype arg)
525 ;;; Check that Template can be used with the specifed Result-Type. Result
526 ;;; type checking is pretty different from argument type checking due to the
527 ;;; relaxed rules for values count. We succeed if for each required result,
528 ;;; there is a positional restriction on the value that is at least as good.
529 ;;; If we run out of result types before we run out of restrictions, then we
530 ;;; only succeed if the leftover restrictions are *. If we run out of
531 ;;; restrictions before we run out of result types, then we always win.
532 (defun template-results-ok (template result-type)
533 (declare (type template template)
534 (type ctype result-type))
535 (when (template-more-results-type template)
536 (error "~S has :MORE results with :TRANSLATE." (template-name template)))
537 (let ((types (template-result-types template)))
539 ((values-type-p result-type)
540 (do ((ltypes (append (args-type-required result-type)
541 (args-type-optional result-type))
543 (types types (rest types)))
545 (dolist (type types t)
548 (when (null types) (return t))
549 (let ((type (first types)))
550 (unless (operand-restriction-ok type
551 (primitive-type (first ltypes)))
554 (operand-restriction-ok (first types) (primitive-type result-type)))
557 ;;; Return true if Call is an ok use of Template according to Safe-P.
558 ;;; -- If the template has a Guard that isn't true, then we ignore the
559 ;;; template, not even considering it to be rejected.
560 ;;; -- If the argument type restrictions aren't satisfied, then we reject the
562 ;;; -- If the template is :Conditional, then we accept it only when the
563 ;;; destination of the value is an immediately following IF node.
564 ;;; -- If either the template is safe or the policy is unsafe (i.e. we can
565 ;;; believe output assertions), then we test against the intersection of the
566 ;;; node derived type and the continuation asserted type. Otherwise, we
567 ;;; just use the node type. If TYPE-CHECK is null, there is no point in
568 ;;; doing the intersection, since the node type must be a subtype of the
571 ;;; If the template is *not* ok, then the second value is a keyword indicating
572 ;;; which aspect failed.
573 (defun is-ok-template-use (template call safe-p)
574 (declare (type template template) (type combination call))
575 (let* ((guard (template-guard template))
576 (cont (node-cont call))
577 (atype (continuation-asserted-type cont))
578 (dtype (node-derived-type call)))
579 (cond ((and guard (not (funcall guard)))
581 ((not (template-args-ok template call safe-p))
583 (if (and safe-p (template-args-ok template call nil))
586 ((eq (template-result-types template) :conditional)
587 (let ((dest (continuation-dest cont)))
589 (immediately-used-p (if-test dest) call))
591 (values nil :conditional))))
592 ((template-results-ok
594 (if (and (or (eq (template-policy template) :safe)
596 (continuation-type-check cont))
597 (values-type-intersection dtype atype)
601 (values nil :result-types)))))
603 ;;; Use operand type information to choose a template from the list
604 ;;; Templates for a known Call. We return three values:
605 ;;; 1. The template we found.
606 ;;; 2. Some template that we rejected due to unsatisfied type restrictions, or
608 ;;; 3. The tail of Templates for templates we haven't examined yet.
610 ;;; We just call IS-OK-TEMPLATE-USE until it returns true.
611 (defun find-template (templates call safe-p)
612 (declare (list templates) (type combination call))
613 (do ((templates templates (rest templates))
616 (values nil rejected nil))
617 (let ((template (first templates)))
618 (when (is-ok-template-use template call safe-p)
619 (return (values template rejected (rest templates))))
620 (setq rejected template))))
622 ;;; Given a partially annotated known call and a translation policy, return
623 ;;; the appropriate template, or NIL if none can be found. We scan the
624 ;;; templates (ordered by increasing cost) looking for a template whose
625 ;;; restrictions are satisfied and that has our policy.
627 ;;; If we find a template that doesn't have our policy, but has a legal
628 ;;; alternate policy, then we also record that to return as a last resort. If
629 ;;; our policy is safe, then only safe policies are O.K., otherwise anything
632 ;;; If we find a template with :SAFE policy, then we return it, or any cheaper
633 ;;; fallback template. The theory behind this is that if it is cheapest, small
634 ;;; and safe, we can't lose. If it is not cheapest, then we use the fallback,
635 ;;; which won't have the desired policy, but :SAFE isn't desired either, so we
636 ;;; might as well go with the cheaper one. The main reason for doing this is
637 ;;; to make sure that cheap safe templates are used when they apply and the
638 ;;; current policy is something else. This is useful because :SAFE has the
639 ;;; additional semantics of implicit argument type checking, so we may be
640 ;;; forced to define a template with :SAFE policy when it is really small and
642 (defun find-template-for-policy (call policy)
643 (declare (type combination call)
644 (type policies policy))
645 (let ((safe-p (policy-safe-p policy))
646 (current (function-info-templates (basic-combination-kind call)))
650 (multiple-value-bind (template this-reject more)
651 (find-template current call safe-p)
653 (setq rejected this-reject))
656 (return (values fallback rejected)))
658 (let ((tpolicy (template-policy template)))
659 (cond ((eq tpolicy policy)
660 (return (values template rejected)))
662 (return (values (or fallback template) rejected)))
663 ((or (not safe-p) (eq tpolicy :fast-safe))
665 (setq fallback template)))))))))
667 (defvar *efficiency-note-limit* 2
669 "This is the maximum number of possible optimization alternatives will be
670 mentioned in a particular efficiency note. NIL means no limit.")
671 (declaim (type (or index null) *efficiency-note-limit*))
673 (defvar *efficiency-note-cost-threshold* 5
675 "This is the minumum cost difference between the chosen implementation and
676 the next alternative that justifies an efficiency note.")
677 (declaim (type index *efficiency-note-cost-threshold*))
679 ;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't figure
680 ;;; out any reason why Template was rejected. Users should never see these
681 ;;; messages, but they can happen in situations where the VM definition is
682 ;;; messed up somehow.
683 (defun strange-template-failure (template call policy frob)
684 (declare (type template template) (type combination call)
685 (type policies policy) (type function frob))
686 (funcall frob "This shouldn't happen! Bug?")
687 (multiple-value-bind (win why)
688 (is-ok-template-use template call (policy-safe-p policy))
692 (funcall frob "template guard failed"))
694 (funcall frob "The template isn't safe, yet we were counting on it."))
696 (funcall frob "argument types invalid")
697 (funcall frob "argument primitive types:~% ~S"
698 (mapcar #'(lambda (x)
700 (continuation-ptype x)))
701 (combination-args call)))
702 (funcall frob "argument type assertions:~% ~S"
703 (mapcar #'(lambda (x)
707 (:or `(:or .,(mapcar #'primitive-type-name
709 (:constant `(:constant ,(third x))))))
710 (template-arg-types template))))
712 (funcall frob "conditional in a non-conditional context"))
714 (funcall frob "result types invalid")))))
716 ;;; This function emits efficiency notes describing all of the templates
717 ;;; better (faster) than Template that we might have been able to use if there
718 ;;; were better type declarations. Template is null when we didn't find any
719 ;;; template, and thus must do a full call.
721 ;;; In order to be worth complaining about, a template must:
722 ;;; -- be allowed by its guard,
723 ;;; -- be safe if the current policy is safe,
724 ;;; -- have argument/result type restrictions consistent with the known type
725 ;;; information, e.g. we don't consider float templates when an operand is
726 ;;; known to be an integer,
727 ;;; -- be disallowed by the stricter operand subtype test (which resembles, but
728 ;;; is not identical to the test done by Find-Template.)
730 ;;; Note that there may not be any possibly applicable templates, since we are
731 ;;; called whenever any template is rejected. That template might have the
732 ;;; wrong policy or be inconsistent with the known type.
734 ;;; We go to some trouble to make the whole multi-line output into a single
735 ;;; call to Compiler-Note so that repeat messages are suppressed, etc.
736 (defun note-rejected-templates (call policy template)
737 (declare (type combination call) (type policies policy)
738 (type (or template null) template))
741 (let ((safe-p (policy-safe-p policy))
742 (verbose-p (policy call (= brevity 0)))
743 (max-cost (- (template-cost
745 (template-or-lose 'call-named)))
746 *efficiency-note-cost-threshold*)))
747 (dolist (try (function-info-templates (basic-combination-kind call)))
748 (when (> (template-cost try) max-cost) (return))
749 (let ((guard (template-guard try)))
750 (when (and (or (not guard) (funcall guard))
752 (policy-safe-p (template-policy try)))
754 (and (template-note try)
756 call (template-type try)
757 :argument-test #'types-intersect
758 :result-test #'values-types-intersect))))
764 (flet ((frob (string &rest stuff)
767 (dolist (loser (losers))
768 (when (and *efficiency-note-limit*
769 (>= (count) *efficiency-note-limit*))
772 (let* ((type (template-type loser))
773 (valid (valid-function-use call type))
774 (strict-valid (valid-function-use call type
776 (frob "unable to do ~A (cost ~D) because:"
777 (or (template-note loser) (template-name loser))
778 (template-cost loser))
780 ((and valid strict-valid)
781 (strange-template-failure loser call policy #'frob))
783 (assert (not (valid-function-use call type
784 :error-function #'frob
785 :warning-function #'frob))))
787 (assert (policy-safe-p policy))
788 (frob "can't trust output type assertion under safe policy")))
791 (let ((*compiler-error-context* call))
792 (compiler-note "~{~?~^~&~6T~}"
794 `("forced to do ~A (cost ~D)"
795 (,(or (template-note template)
796 (template-name template))
797 ,(template-cost template))
799 `("forced to do full call"
804 ;;; Flush type checks according to policy. If the policy is
805 ;;; unsafe, then we never do any checks. If our policy is safe, and
806 ;;; we are using a safe template, then we can also flush arg and
807 ;;; result type checks. Result type checks are only flushed when the
808 ;;; continuation as a single use. Result type checks are not flush if
809 ;;; the policy is safe because the selection of template for results
810 ;;; readers assumes the type check is done (uses the derived type
811 ;;; which is the intersection of the proven and asserted types).
812 (defun flush-type-checks-according-to-policy (call policy template)
813 (declare (type combination call) (type policies policy)
814 (type template template))
815 (let ((safe-op (eq (template-policy template) :safe)))
816 (when (or (not (policy-safe-p policy)) safe-op)
817 (dolist (arg (basic-combination-args call))
818 (flush-type-check arg)))
820 (let ((cont (node-cont call)))
821 (when (and (eq (continuation-use cont) call)
822 (not (policy-safe-p policy)))
823 (flush-type-check cont)))))
827 ;;; If a function has a special-case annotation method use that, otherwise
828 ;;; annotate the argument continuations and try to find a template
829 ;;; corresponding to the type signature. If there is none, convert a full call.
830 (defun ltn-analyze-known-call (call policy)
831 (declare (type combination call)
832 (type policies policy))
833 (let ((method (function-info-ltn-annotate (basic-combination-kind call)))
834 (args (basic-combination-args call)))
836 (funcall method call policy)
837 (return-from ltn-analyze-known-call (values)))
840 (setf (continuation-info arg)
841 (make-ir2-continuation (primitive-type (continuation-type arg)))))
843 (multiple-value-bind (template rejected)
844 (find-template-for-policy call policy)
845 ;; If we are unable to use some templates due to unsatisfied operand type
846 ;; restrictions and our policy enables efficiency notes, then we call
847 ;; Note-Rejected-Templates.
849 (policy call (> speed brevity)))
850 (note-rejected-templates call policy template))
851 ;; If we are forced to do a full call, we check to see whether the
852 ;; function called is the same as the current function. If so, we
853 ;; give a warning, as this is probably a botched interpreter stub.
855 (when (and (eq (continuation-function-name (combination-fun call))
857 (environment-function
858 (node-environment call))))
859 (let ((info (basic-combination-kind call)))
860 (not (or (function-info-ir2-convert info)
861 (ir1-attributep (function-info-attributes info)
863 (let ((*compiler-error-context* call))
864 (compiler-warning "recursive known function definition")))
865 (ltn-default-call call policy)
866 (return-from ltn-analyze-known-call (values)))
867 (setf (basic-combination-info call) template)
868 (setf (node-tail-p call) nil)
870 (flush-type-checks-according-to-policy call policy template)
873 (annotate-1-value-continuation arg))))
879 ;;; We make the main per-block code in for LTN into a macro so that it can
880 ;;; be shared between LTN-Analyze and LTN-Analyze-Block, yet can cache policy
881 ;;; across blocks in the normal (full component) case.
883 ;;; This code computes the policy and then dispatches to the appropriate
884 ;;; node-specific function.
886 ;;; Note: we deliberately don't use the DO-NODES macro, since the block can be
887 ;;; split out from underneath us, and DO-NODES would scan past the block end in that
890 '(do* ((node (continuation-next (block-start block))
891 (continuation-next cont))
892 (cont (node-cont node) (node-cont node))
893 ;; KLUDGE: Since LEXENV and POLICY seem to be only used
894 ;; inside this FROB, why not define them in here instead of
895 ;; requiring them to be defined externally both in
896 ;; LTN-ANALYZE and LTN-ANALYZE-BLOCK? Or perhaps just
897 ;; define this whole FROB as an inline function? (Right now
898 ;; I don't want to make even a small unnecessary change
899 ;; like this, but'd prefer to wait until the system runs so
900 ;; that I can test it immediately after the change.)
904 (unless (eq (node-lexenv node) lexenv)
905 (setq policy (translation-policy node))
906 (setq lexenv (node-lexenv node)))
911 (case (basic-combination-kind node)
912 (:local (ltn-analyze-local-call node policy))
913 ((:full :error) (ltn-default-call node policy))
915 (ltn-analyze-known-call node policy))))
917 (ltn-analyze-if node policy))
919 (ltn-analyze-return node policy))
922 (ltn-analyze-exit node policy))
923 (cset (ltn-analyze-set node policy))
925 (ecase (basic-combination-kind node)
926 (:local (ltn-analyze-mv-bind node policy))
927 ((:full :error) (ltn-analyze-mv-call node policy)))))
929 (when (eq node (block-last block))
932 ;;; Loop over the blocks in Component, doing stuff to nodes that receive
933 ;;; values. In addition to the stuff done by FROB, we also see whether there
934 ;;; are any unknown values receivers, making notations in the components
935 ;;; Generators and Receivers as appropriate.
937 ;;; If any unknown-values continations are received by this block (as
938 ;;; indicated by IR2-Block-Popped, then we add the block to the
939 ;;; IR2-Component-Values-Receivers.
941 ;;; This is where we allocate IR2 blocks because it is the first place we
943 (defun ltn-analyze (component)
944 (declare (type component component))
945 (let ((2comp (component-info component))
948 (do-blocks (block component)
949 (assert (not (block-info block)))
950 (let ((2block (make-ir2-block block)))
951 (setf (block-info block) 2block)
953 (let ((popped (ir2-block-popped 2block)))
955 (push block (ir2-component-values-receivers 2comp)))))))
958 ;;; This function is used to analyze blocks that must be added to the flow
959 ;;; graph after the normal LTN phase runs. Such code is constrained not to
960 ;;; use weird unknown values (and probably in lots of other ways).
961 (defun ltn-analyze-block (block)
962 (declare (type cblock block))
966 (assert (not (ir2-block-popped (block-info block))))