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 LTN-POLICY indicated by the node policy.
20 ;;; FIXME: It would be tidier to use an LTN-POLICY object (an instance
21 ;;; of DEFSTRUCT LTN-POLICY) instead of a keyword, and have queries
22 ;;; like LTN-POLICY-SAFE-P become slot accessors. If we do this,
23 ;;; grep for and carefully review use of literal keywords, so that
25 ;;; (EQ (TEMPLATE-LTN-POLICY TEMPLATE) :SAFE)
26 ;;; don't get overlooked.
28 ;;; FIXME: Classic CMU CL went to some trouble to cache LTN-POLICY
29 ;;; values in LTN-ANALYZE so that they didn't have to be recomputed on
30 ;;; every block. I stripped that out (the whole DEFMACRO FROB thing)
31 ;;; because I found it too confusing. Thus, it might be that the
32 ;;; new uncached code spends an unreasonable amount of time in
33 ;;; this lookup function. This function should be profiled, and if
34 ;;; it's a significant contributor to runtime, we can cache it in
35 ;;; some more local way, e.g. by adding a CACHED-LTN-POLICY slot to
36 ;;; the NODE structure, and doing something like
37 ;;; (DEFUN NODE-LTN-POLICY (NODE)
38 ;;; (OR (NODE-CACHED-LTN-POLICY NODE)
39 ;;; (SETF (NODE-CACHED-LTN-POLICY NODE)
40 ;;; (NODE-UNCACHED-LTN-POLICY NODE)))
41 (defun node-ltn-policy (node)
42 (declare (type node node))
44 (let ((eff-space (max space
45 ;; on the theory that if the code is
46 ;; smaller, it will take less time to
47 ;; compile (could lose if the smallest
48 ;; case is out of line, and must
49 ;; allocate many linkage registers):
52 (if (>= speed eff-space) :fast :small)
53 (if (>= speed eff-space) :fast-safe :safe)))))
55 ;;; Return true if LTN-POLICY is a safe policy.
56 (defun ltn-policy-safe-p (ltn-policy)
58 ((:safe :fast-safe) t)
59 ((:small :fast) nil)))
61 ;;; an annotated continuation's primitive-type
62 #!-sb-fluid (declaim (inline continuation-ptype))
63 (defun continuation-ptype (cont)
64 (declare (type continuation cont))
65 (ir2-continuation-primitive-type (continuation-info cont)))
67 ;;; Return true if a constant LEAF is of a type which we can legally
68 ;;; directly reference in code. Named constants with arbitrary pointer
69 ;;; values cannot, since we must preserve EQLness.
70 (defun legal-immediate-constant-p (leaf)
71 (declare (type constant leaf))
72 (or (not (leaf-has-source-name-p leaf))
73 (typecase (constant-value leaf)
74 ((or number character) t)
75 (symbol (symbol-package (constant-value leaf)))
78 ;;; If CONT is used only by a REF to a leaf that can be delayed, then
79 ;;; return the leaf, otherwise return NIL.
80 (defun continuation-delayed-leaf (cont)
81 (declare (type continuation cont))
82 (let ((use (continuation-use cont)))
84 (let ((leaf (ref-leaf use)))
86 (lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
87 (constant (if (legal-immediate-constant-p leaf) leaf nil))
88 ((or functional global-var) nil))))))
90 ;;; Annotate a normal single-value continuation. If its only use is a
91 ;;; ref that we are allowed to delay the evaluation of, then we mark
92 ;;; the continuation for delayed evaluation, otherwise we assign a TN
93 ;;; to hold the continuation's value.
94 (defun annotate-1-value-continuation (cont)
95 (declare (type continuation cont))
96 (let ((info (continuation-info cont)))
97 (aver (eq (ir2-continuation-kind info) :fixed))
99 ((continuation-delayed-leaf cont)
100 (setf (ir2-continuation-kind info) :delayed))
101 (t (setf (ir2-continuation-locs info)
102 (list (make-normal-tn (ir2-continuation-primitive-type info)))))))
103 (ltn-annotate-casts cont)
106 ;;; Make an IR2-CONTINUATION corresponding to the continuation type
107 ;;; and then do ANNOTATE-1-VALUE-CONTINUATION.
108 (defun annotate-ordinary-continuation (cont)
109 (declare (type continuation cont))
110 (let ((info (make-ir2-continuation
111 (primitive-type (continuation-type cont)))))
112 (setf (continuation-info cont) info)
113 (annotate-1-value-continuation cont))
116 ;;; Annotate the function continuation for a full call. If the only
117 ;;; reference is to a global function and DELAY is true, then we delay
118 ;;; the reference, otherwise we annotate for a single value.
119 (defun annotate-fun-continuation (cont &optional (delay t))
120 (declare (type continuation cont))
121 (let* ((tn-ptype (primitive-type (continuation-type cont)))
122 (info (make-ir2-continuation tn-ptype)))
123 (setf (continuation-info cont) info)
124 (let ((name (continuation-fun-name cont t)))
126 (setf (ir2-continuation-kind info) :delayed)
127 (setf (ir2-continuation-locs info)
128 (list (make-normal-tn tn-ptype))))))
129 (ltn-annotate-casts cont)
132 ;;; If TAIL-P is true, then we check to see whether the call can really
133 ;;; be a tail call by seeing if this function's return convention is :UNKNOWN.
134 ;;; If so, we move the call block succssor link from the return block to
135 ;;; the component tail (after ensuring that they are in separate blocks.)
136 ;;; This allows the return to be deleted when there are no non-tail uses.
137 (defun flush-full-call-tail-transfer (call)
138 (declare (type basic-combination call))
139 (let ((tails (and (node-tail-p call)
140 (lambda-tail-set (node-home-lambda call)))))
142 (cond ((eq (return-info-kind (tail-set-info tails)) :unknown)
143 (node-ends-block call)
144 (let ((block (node-block call)))
145 (unlink-blocks block (first (block-succ block)))
146 (link-blocks block (component-tail (block-component block)))))
148 (setf (node-tail-p call) nil)))))
151 ;;; We set the kind to :FULL or :FUNNY, depending on whether there is
152 ;;; an IR2-CONVERT method. If a funny function, then we inhibit tail
153 ;;; recursion normally, since the IR2 convert method is going to want
154 ;;; to deliver values normally. We still annotate the function
155 ;;; continuation, since IR2tran might decide to call after all.
157 ;;; Note that args may already be annotated because template selection
158 ;;; can bail out to here.
159 (defun ltn-default-call (call)
160 (declare (type combination call))
161 (let ((kind (basic-combination-kind call)))
162 (annotate-fun-continuation (basic-combination-fun call))
165 ((and (fun-info-p kind)
166 (fun-info-ir2-convert kind))
167 (setf (basic-combination-info call) :funny)
168 (setf (node-tail-p call) nil)
169 (dolist (arg (basic-combination-args call))
170 (unless (continuation-info arg)
171 (setf (continuation-info arg)
172 (make-ir2-continuation
174 (continuation-type arg)))))
175 (annotate-1-value-continuation arg)))
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))
184 (when (eq kind :error)
185 (setf (basic-combination-kind call) :full))
186 (setf (basic-combination-info call) :full)
187 (flush-full-call-tail-transfer call))))
191 ;;; Annotate a continuation for unknown multiple values:
192 ;;; -- Add the continuation to the IR2-BLOCK-POPPED if it is used
193 ;;; across a block boundary.
194 ;;; -- Assign an :UNKNOWN IR2-CONTINUATION.
196 ;;; Note: it is critical that this be called only during LTN analysis
197 ;;; of CONT's DEST, and called in the order that the continuations are
198 ;;; received. Otherwise the IR2-BLOCK-POPPED and
199 ;;; IR2-COMPONENT-VALUES-FOO would get all messed up.
200 (defun annotate-unknown-values-continuation (cont)
201 (declare (type continuation cont))
203 (let ((2cont (make-ir2-continuation nil)))
204 (setf (ir2-continuation-kind 2cont) :unknown)
205 (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
206 (setf (continuation-info cont) 2cont))
208 ;; The CAST chain with corresponding continuations constitute the
209 ;; same "principal continuation", so we must preserve only inner
210 ;; annotation order and the order of the whole p.c. with other
211 ;; continiations. -- APD, 2002-02-27
212 (ltn-annotate-casts cont)
214 (let* ((block (node-block (continuation-dest cont)))
215 (use (continuation-use cont))
216 (2block (block-info block)))
217 (unless (and use (eq (node-block use) block))
218 (setf (ir2-block-popped 2block)
219 (nconc (ir2-block-popped 2block) (list cont)))))
223 ;;; Annotate CONT for a fixed, but arbitrary number of values, of the
224 ;;; specified primitive TYPES.
225 (defun annotate-fixed-values-continuation (cont types)
226 (declare (type continuation cont) (list types))
227 (let ((res (make-ir2-continuation nil)))
228 (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
229 (setf (continuation-info cont) res))
230 (ltn-annotate-casts cont)
233 ;;;; node-specific analysis functions
235 ;;; Annotate the result continuation for a function. We use the
236 ;;; RETURN-INFO computed by GTN to determine how to represent the
237 ;;; return values within the function:
238 ;;; * If the TAIL-SET has a fixed values count, then use that
240 ;;; * If the actual uses of the result continuation in this function
241 ;;; have a fixed number of values (after intersection with the
242 ;;; assertion), then use that number. We throw out TAIL-P :FULL
243 ;;; and :LOCAL calls, since we know they will truly end up as TR
244 ;;; calls. We can use the BASIC-COMBINATION-INFO even though it
245 ;;; is assigned by this phase, since the initial value NIL doesn't
246 ;;; look like a TR call.
247 ;;; If there are *no* non-tail-call uses, then it falls out
248 ;;; that we annotate for one value (type is NIL), but the return
249 ;;; will end up being deleted.
250 ;;; In non-perverse code, the DFO walk will reach all uses of
251 ;;; the result continuation before it reaches the RETURN. In
252 ;;; perverse code, we may annotate for unknown values when we
254 ;;; * Otherwise, we must annotate the continuation for unknown values.
255 (defun ltn-analyze-return (node)
256 (declare (type creturn node))
257 (let* ((cont (return-result node))
258 (fun (return-lambda node))
259 (returns (tail-set-info (lambda-tail-set fun)))
260 (types (return-info-types returns)))
261 (if (eq (return-info-count returns) :unknown)
262 (collect ((res *empty-type* values-type-union))
263 (do-uses (use (return-result node))
264 (unless (and (node-tail-p use)
265 (basic-combination-p use)
266 (member (basic-combination-info use) '(:local :full)))
267 (res (node-derived-type use))))
270 (multiple-value-bind (types kind)
271 (if (eq int *empty-type*)
272 (values nil :unknown)
274 (if (eq kind :unknown)
275 (annotate-unknown-values-continuation cont)
276 (annotate-fixed-values-continuation
277 cont (mapcar #'primitive-type types))))))
278 (annotate-fixed-values-continuation cont types)))
282 ;;; Annotate the single argument continuation as a fixed-values
283 ;;; continuation. We look at the called lambda to determine number and
284 ;;; type of return values desired. It is assumed that only a function
285 ;;; that LOOKS-LIKE-AN-MV-BIND will be converted to a local call.
286 (defun ltn-analyze-mv-bind (call)
287 (declare (type mv-combination call))
288 (setf (basic-combination-kind call) :local)
289 (setf (node-tail-p call) nil)
290 (annotate-fixed-values-continuation
291 (first (basic-combination-args call))
292 (mapcar (lambda (var)
293 (primitive-type (basic-var-type var)))
297 (basic-combination-fun call))))))
300 ;;; We force all the argument continuations to use the unknown values
301 ;;; convention. The continuations are annotated in reverse order,
302 ;;; since the last argument is on top, thus must be popped first. We
303 ;;; disallow delayed evaluation of the function continuation to
304 ;;; simplify IR2 conversion of MV call.
306 ;;; We could be cleverer when we know the number of values returned by
307 ;;; the continuations, but optimizations of MV call are probably
310 ;;; We are also responsible for handling THROW, which is represented
311 ;;; in IR1 as an MV call to the %THROW funny function. We annotate the
312 ;;; tag continuation for a single value and the values continuation
313 ;;; for unknown values.
314 (defun ltn-analyze-mv-call (call)
315 (declare (type mv-combination call))
316 (let ((fun (basic-combination-fun call))
317 (args (basic-combination-args call)))
318 (cond ((eq (continuation-fun-name fun) '%throw)
319 (setf (basic-combination-info call) :funny)
320 (annotate-ordinary-continuation (first args))
321 (annotate-unknown-values-continuation (second args))
322 (setf (node-tail-p call) nil))
324 (setf (basic-combination-info call) :full)
325 (annotate-fun-continuation (basic-combination-fun call)
327 (dolist (arg (reverse args))
328 (annotate-unknown-values-continuation arg))
329 (flush-full-call-tail-transfer call))))
333 ;;; Annotate the arguments as ordinary single-value continuations. And
334 ;;; check the successor.
335 (defun ltn-analyze-local-call (call)
336 (declare (type combination call))
337 (setf (basic-combination-info call) :local)
338 (dolist (arg (basic-combination-args call))
340 (annotate-ordinary-continuation arg)))
341 (when (node-tail-p call)
342 (set-tail-local-call-successor call))
345 ;;; Make sure that a tail local call is linked directly to the bind
346 ;;; node. Usually it will be, but calls from XEPs and calls that might have
347 ;;; needed a cleanup after them won't have been swung over yet, since we
348 ;;; weren't sure they would really be TR until now.
349 (defun set-tail-local-call-successor (call)
350 (let ((caller (node-home-lambda call))
351 (callee (combination-lambda call)))
352 (aver (eq (lambda-tail-set caller)
353 (lambda-tail-set (lambda-home callee))))
354 (node-ends-block call)
355 (let ((block (node-block call)))
356 (unlink-blocks block (first (block-succ block)))
357 (link-blocks block (lambda-block callee))))
360 ;;; Annotate the value continuation.
361 (defun ltn-analyze-set (node)
362 (declare (type cset node))
363 (setf (node-tail-p node) nil)
364 (annotate-ordinary-continuation (set-value node))
367 ;;; If the only use of the TEST continuation is a combination
368 ;;; annotated with a conditional template, then don't annotate the
369 ;;; continuation so that IR2 conversion knows not to emit any code,
370 ;;; otherwise annotate as an ordinary continuation. Since we only use
371 ;;; a conditional template if the call immediately precedes the IF
372 ;;; node in the same block, we know that any predicate will already be
374 (defun ltn-analyze-if (node)
375 (declare (type cif node))
376 (setf (node-tail-p node) nil)
377 (let* ((test (if-test node))
378 (use (continuation-use test)))
379 (unless (and (combination-p use)
380 (let ((info (basic-combination-info use)))
381 (and (template-p info)
382 (eq (template-result-types info) :conditional))))
383 (annotate-ordinary-continuation test)))
386 ;;; If there is a value continuation, then annotate it for unknown
387 ;;; values. In this case, the exit is non-local, since all other exits
388 ;;; are deleted or degenerate by this point.
389 (defun ltn-analyze-exit (node)
390 (setf (node-tail-p node) nil)
391 (let ((value (exit-value node)))
393 (annotate-unknown-values-continuation value)))
396 ;;; We need a special method for %UNWIND-PROTECT that ignores the
397 ;;; cleanup function. We don't annotate either arg, since we don't
398 ;;; need them at run-time.
400 ;;; (The default is o.k. for %CATCH, since environment analysis
401 ;;; converted the reference to the escape function into a constant
402 ;;; reference to the NLX-INFO.)
403 (defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup)
406 ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
407 (setf (basic-combination-info node) :funny)
408 (setf (node-tail-p node) nil))
410 ;;;; known call annotation
412 ;;; Return true if RESTR is satisfied by TYPE. If T-OK is true, then a
413 ;;; T restriction allows any operand type. This is also called by IR2
414 ;;; translation when it determines whether a result temporary needs to
415 ;;; be made, and by representation selection when it is deciding which
416 ;;; move VOP to use. CONT and TN are used to test for constant
418 (defun operand-restriction-ok (restr type &key cont tn (t-ok t))
419 (declare (type (or (member *) cons) restr)
420 (type primitive-type type)
421 (type (or continuation null) cont)
422 (type (or tn null) tn))
427 (dolist (mem (rest restr) nil)
428 (when (or (and t-ok (eq mem *backend-t-primitive-type*))
433 (and (constant-continuation-p cont)
434 (funcall (second restr) (continuation-value cont))))
436 (and (eq (tn-kind tn) :constant)
437 (funcall (second restr) (tn-value tn))))
439 (error "Neither CONT nor TN supplied.")))))))
441 ;;; Check that the argument type restriction for TEMPLATE are
442 ;;; satisfied in call. If an argument's TYPE-CHECK is :NO-CHECK and
443 ;;; our policy is safe, then only :SAFE templates are OK.
444 (defun template-args-ok (template call safe-p)
445 (declare (type template template)
446 (type combination call))
447 (let ((mtype (template-more-args-type template)))
448 (do ((args (basic-combination-args call) (cdr args))
449 (types (template-arg-types template) (cdr types)))
451 (cond ((null args) t)
455 (unless (operand-restriction-ok mtype
456 (continuation-ptype arg))
458 (when (null args) (return nil))
459 (let ((arg (car args))
461 (unless (operand-restriction-ok type (continuation-ptype arg)
465 ;;; Check that TEMPLATE can be used with the specifed RESULT-TYPE.
466 ;;; Result type checking is pretty different from argument type
467 ;;; checking due to the relaxed rules for values count. We succeed if
468 ;;; for each required result, there is a positional restriction on the
469 ;;; value that is at least as good. If we run out of result types
470 ;;; before we run out of restrictions, then we only succeed if the
471 ;;; leftover restrictions are *. If we run out of restrictions before
472 ;;; we run out of result types, then we always win.
473 (defun template-results-ok (template result-type)
474 (declare (type template template)
475 (type ctype result-type))
476 (when (template-more-results-type template)
477 (error "~S has :MORE results with :TRANSLATE." (template-name template)))
478 (let ((types (template-result-types template)))
480 ((values-type-p result-type)
481 (do ((ltypes (append (args-type-required result-type)
482 (args-type-optional result-type))
484 (types types (rest types)))
486 (dolist (type types t)
489 (when (null types) (return t))
490 (let ((type (first types)))
491 (unless (operand-restriction-ok type
492 (primitive-type (first ltypes)))
495 (operand-restriction-ok (first types) (primitive-type result-type)))
498 ;;; Return true if CALL is an ok use of TEMPLATE according to SAFE-P.
499 ;;; -- If the template has a GUARD that isn't true, then we ignore the
500 ;;; template, not even considering it to be rejected.
501 ;;; -- If the argument type restrictions aren't satisfied, then we
502 ;;; reject the template.
503 ;;; -- If the template is :CONDITIONAL, then we accept it only when the
504 ;;; destination of the value is an immediately following IF node.
505 ;;; -- If either the template is safe or the policy is unsafe (i.e. we
506 ;;; can believe output assertions), then we test against the
507 ;;; intersection of the node derived type and the continuation
508 ;;; asserted type. Otherwise, we just use the node type. If
509 ;;; TYPE-CHECK is null, there is no point in doing the intersection,
510 ;;; since the node type must be a subtype of the assertion.
512 ;;; If the template is *not* ok, then the second value is a keyword
513 ;;; indicating which aspect failed.
514 (defun is-ok-template-use (template call safe-p)
515 (declare (type template template) (type combination call))
516 (let* ((guard (template-guard template))
517 (cont (node-cont call))
518 (dtype (node-derived-type call)))
519 (cond ((and guard (not (funcall guard)))
521 ((not (template-args-ok template call safe-p))
523 (if (and safe-p (template-args-ok template call nil))
526 ((eq (template-result-types template) :conditional)
527 (let ((dest (continuation-dest cont)))
529 (immediately-used-p (if-test dest) call))
531 (values nil :conditional))))
532 ((template-results-ok template dtype)
535 (values nil :result-types)))))
537 ;;; Use operand type information to choose a template from the list
538 ;;; TEMPLATES for a known CALL. We return three values:
539 ;;; 1. The template we found.
540 ;;; 2. Some template that we rejected due to unsatisfied type restrictions, or
542 ;;; 3. The tail of Templates for templates we haven't examined yet.
544 ;;; We just call IS-OK-TEMPLATE-USE until it returns true.
545 (defun find-template (templates call safe-p)
546 (declare (list templates) (type combination call))
547 (do ((templates templates (rest templates))
550 (values nil rejected nil))
551 (let ((template (first templates)))
552 (when (is-ok-template-use template call safe-p)
553 (return (values template rejected (rest templates))))
554 (setq rejected template))))
556 ;;; Given a partially annotated known call and a translation policy,
557 ;;; return the appropriate template, or NIL if none can be found. We
558 ;;; scan the templates (ordered by increasing cost) looking for a
559 ;;; template whose restrictions are satisfied and that has our policy.
561 ;;; If we find a template that doesn't have our policy, but has a
562 ;;; legal alternate policy, then we also record that to return as a
563 ;;; last resort. If our policy is safe, then only safe policies are
564 ;;; O.K., otherwise anything goes.
566 ;;; If we find a template with :SAFE policy, then we return it, or any
567 ;;; cheaper fallback template. The theory behind this is that if it is
568 ;;; cheapest, small and safe, we can't lose. If it is not cheapest,
569 ;;; then we use the fallback, which won't have the desired policy, but
570 ;;; :SAFE isn't desired either, so we might as well go with the
571 ;;; cheaper one. The main reason for doing this is to make sure that
572 ;;; cheap safe templates are used when they apply and the current
573 ;;; policy is something else. This is useful because :SAFE has the
574 ;;; additional semantics of implicit argument type checking, so we may
575 ;;; be forced to define a template with :SAFE policy when it is really
576 ;;; small and fast as well.
577 (defun find-template-for-ltn-policy (call ltn-policy)
578 (declare (type combination call)
579 (type ltn-policy ltn-policy))
580 (let ((safe-p (ltn-policy-safe-p ltn-policy))
581 (current (fun-info-templates (basic-combination-kind call)))
585 (multiple-value-bind (template this-reject more)
586 (find-template current call safe-p)
588 (setq rejected this-reject))
591 (return (values fallback rejected)))
592 (let ((tcpolicy (template-ltn-policy template)))
593 (cond ((eq tcpolicy ltn-policy)
594 (return (values template rejected)))
596 (return (values (or fallback template) rejected)))
597 ((or (not safe-p) (eq tcpolicy :fast-safe))
599 (setq fallback template)))))))))
601 (defvar *efficiency-note-limit* 2
603 "This is the maximum number of possible optimization alternatives will be
604 mentioned in a particular efficiency note. NIL means no limit.")
605 (declaim (type (or index null) *efficiency-note-limit*))
607 (defvar *efficiency-note-cost-threshold* 5
609 "This is the minumum cost difference between the chosen implementation and
610 the next alternative that justifies an efficiency note.")
611 (declaim (type index *efficiency-note-cost-threshold*))
613 ;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't
614 ;;; figure out any reason why TEMPLATE was rejected. Users should
615 ;;; never see these messages, but they can happen in situations where
616 ;;; the VM definition is messed up somehow.
617 (defun strange-template-failure (template call ltn-policy frob)
618 (declare (type template template) (type combination call)
619 (type ltn-policy ltn-policy) (type function frob))
620 (funcall frob "This shouldn't happen! Bug?")
621 (multiple-value-bind (win why)
622 (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
626 (funcall frob "template guard failed"))
628 (funcall frob "The template isn't safe, yet we were counting on it."))
630 (funcall frob "argument types invalid")
631 (funcall frob "argument primitive types:~% ~S"
634 (continuation-ptype x)))
635 (combination-args call)))
636 (funcall frob "argument type assertions:~% ~S"
641 (:or `(:or .,(mapcar #'primitive-type-name
643 (:constant `(:constant ,(third x))))))
644 (template-arg-types template))))
646 (funcall frob "conditional in a non-conditional context"))
648 (funcall frob "result types invalid")))))
650 ;;; This function emits efficiency notes describing all of the
651 ;;; templates better (faster) than TEMPLATE that we might have been
652 ;;; able to use if there were better type declarations. Template is
653 ;;; null when we didn't find any template, and thus must do a full
656 ;;; In order to be worth complaining about, a template must:
657 ;;; -- be allowed by its guard,
658 ;;; -- be safe if the current policy is safe,
659 ;;; -- have argument/result type restrictions consistent with the
660 ;;; known type information, e.g. we don't consider float templates
661 ;;; when an operand is known to be an integer,
662 ;;; -- be disallowed by the stricter operand subtype test (which
663 ;;; resembles, but is not identical to the test done by
666 ;;; Note that there may not be any possibly applicable templates,
667 ;;; since we are called whenever any template is rejected. That
668 ;;; template might have the wrong policy or be inconsistent with the
671 ;;; We go to some trouble to make the whole multi-line output into a
672 ;;; single call to COMPILER-NOTIFY so that repeat messages are
674 (defun note-rejected-templates (call ltn-policy template)
675 (declare (type combination call) (type ltn-policy ltn-policy)
676 (type (or template null) template))
679 (let ((safe-p (ltn-policy-safe-p ltn-policy))
680 (verbose-p (policy call (= inhibit-warnings 0)))
681 (max-cost (- (template-cost
683 (template-or-lose 'call-named)))
684 *efficiency-note-cost-threshold*)))
685 (dolist (try (fun-info-templates (basic-combination-kind call)))
686 (when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner.
687 (let ((guard (template-guard try)))
688 (when (and (or (not guard) (funcall guard))
690 (ltn-policy-safe-p (template-ltn-policy try)))
692 (and (template-note try)
694 call (template-type try)
695 :argument-test #'types-equal-or-intersect
697 #'values-types-equal-or-intersect))))
703 (flet ((lose1 (string &rest stuff)
706 (dolist (loser (losers))
707 (when (and *efficiency-note-limit*
708 (>= (count) *efficiency-note-limit*))
711 (let* ((type (template-type loser))
712 (valid (valid-fun-use call type))
713 (strict-valid (valid-fun-use call type)))
714 (lose1 "unable to do ~A (cost ~W) because:"
715 (or (template-note loser) (template-name loser))
716 (template-cost loser))
718 ((and valid strict-valid)
719 (strange-template-failure loser call ltn-policy #'lose1))
721 (aver (not (valid-fun-use call type
723 :unwinnage-fun #'lose1))))
725 (aver (ltn-policy-safe-p ltn-policy))
726 (lose1 "can't trust output type assertion under safe policy")))
729 (let ((*compiler-error-context* call))
730 (compiler-notify "~{~?~^~&~6T~}"
732 `("forced to do ~A (cost ~W)"
733 (,(or (template-note template)
734 (template-name template))
735 ,(template-cost template))
737 `("forced to do full call"
742 ;;; If a function has a special-case annotation method use that,
743 ;;; otherwise annotate the argument continuations and try to find a
744 ;;; template corresponding to the type signature. If there is none,
745 ;;; convert a full call.
746 (defun ltn-analyze-known-call (call)
747 (declare (type combination call))
748 (let ((ltn-policy (node-ltn-policy call))
749 (method (fun-info-ltn-annotate (basic-combination-kind call)))
750 (args (basic-combination-args call)))
752 (funcall method call ltn-policy)
753 (return-from ltn-analyze-known-call (values)))
756 (setf (continuation-info arg)
757 (make-ir2-continuation (primitive-type (continuation-type arg)))))
759 (multiple-value-bind (template rejected)
760 (find-template-for-ltn-policy call ltn-policy)
761 ;; If we are unable to use some templates due to unsatisfied
762 ;; operand type restrictions and our policy enables efficiency
763 ;; notes, then we call NOTE-REJECTED-TEMPLATES.
765 (policy call (> speed inhibit-warnings)))
766 (note-rejected-templates call ltn-policy template))
767 ;; If we are forced to do a full call, we check to see whether
768 ;; the function called is the same as the current function. If
769 ;; so, we give a warning, as this is probably a botched attempt
770 ;; to implement an out-of-line version in terms of inline
771 ;; transforms or VOPs or whatever.
773 (when (let ((funleaf (physenv-lambda (node-physenv call))))
774 (and (leaf-has-source-name-p funleaf)
775 (eq (continuation-fun-name (combination-fun call))
776 (leaf-source-name funleaf))
777 (let ((info (basic-combination-kind call)))
778 (not (or (fun-info-ir2-convert info)
779 (ir1-attributep (fun-info-attributes info)
781 (let ((*compiler-error-context* call))
782 (compiler-warn "~@<recursion in known function definition~2I ~
783 ~_policy=~S ~_arg types=~S~:>"
784 (lexenv-policy (node-lexenv call))
785 (mapcar (lambda (arg)
786 (type-specifier (continuation-type arg)))
788 (ltn-default-call call)
789 (return-from ltn-analyze-known-call (values)))
790 (setf (basic-combination-info call) template)
791 (setf (node-tail-p call) nil)
794 (annotate-1-value-continuation arg))))
798 ;;; CASTs are merely continuation annotations than nodes. So we wait
799 ;;; until value consumer deside how values should be passed, and after
800 ;;; that we propagate this decision backwards through CAST chain. The
801 ;;; exception is a dangling CAST with a type check, which we process
803 (defun ltn-analyze-cast (cast)
804 (declare (type cast cast))
805 (setf (node-tail-p cast) nil)
806 (when (and (cast-type-check cast)
807 (not (continuation-dest (node-cont cast))))
809 (bug "IR2 type checking of unused values in not implemented.")
813 (defun ltn-annotate-casts (cont)
814 (declare (type continuation cont))
817 (ltn-annotate-cast node))))
819 (defun ltn-annotate-cast (cast)
820 (declare (type cast))
821 (let ((2cont (continuation-info (node-cont cast)))
822 (value (cast-value cast)))
825 (ecase (ir2-continuation-kind 2cont)
827 (annotate-unknown-values-continuation value))
829 (let* ((count (length (ir2-continuation-locs 2cont)))
830 (ctype (continuation-derived-type value)))
831 (multiple-value-bind (types rest)
832 (values-type-types ctype (specifier-type 'null))
833 (annotate-fixed-values-continuation
835 (mapcar #'primitive-type
836 (adjust-list types count rest))))))))
842 ;;; most of the guts of the two interface functions: Compute the
843 ;;; policy and dispatch to the appropriate node-specific function.
845 ;;; Note: we deliberately don't use the DO-NODES macro, since the
846 ;;; block can be split out from underneath us, and DO-NODES would scan
847 ;;; past the block end in that case.
848 (defun ltn-analyze-block (block)
849 (do* ((node (continuation-next (block-start block))
850 (continuation-next cont))
851 (cont (node-cont node) (node-cont node)))
853 (let ((dest (continuation-dest cont)))
854 (when (and (cast-p dest)
855 (not (cast-type-check dest))
856 (immediately-used-p cont node))
857 (derive-node-type node (cast-asserted-type dest))))
861 (case (basic-combination-kind node)
862 (:local (ltn-analyze-local-call node))
863 ((:full :error) (ltn-default-call node))
865 (ltn-analyze-known-call node))))
866 (cif (ltn-analyze-if node))
867 (creturn (ltn-analyze-return node))
869 (exit (ltn-analyze-exit node))
870 (cset (ltn-analyze-set node))
871 (cast (ltn-analyze-cast node))
873 (ecase (basic-combination-kind node)
875 (ltn-analyze-mv-bind node))
877 (ltn-analyze-mv-call node)))))
878 (when (eq node (block-last block))
881 ;;; Loop over the blocks in COMPONENT, doing stuff to nodes that
882 ;;; receive values. In addition to the stuff done by FROB, we also see
883 ;;; whether there are any unknown values receivers, making notations
884 ;;; in the components' GENERATORS and RECEIVERS as appropriate.
886 ;;; If any unknown-values continations are received by this block (as
887 ;;; indicated by IR2-BLOCK-POPPED), then we add the block to the
888 ;;; IR2-COMPONENT-VALUES-RECEIVERS.
890 ;;; This is where we allocate IR2 blocks because it is the first place
892 (defun ltn-analyze (component)
893 (declare (type component component))
894 (let ((2comp (component-info component)))
895 (do-blocks (block component)
896 (aver (not (block-info block)))
897 (let ((2block (make-ir2-block block)))
898 (setf (block-info block) 2block)
899 (ltn-analyze-block block)))
900 (do-blocks (block component)
901 (let ((2block (block-info block)))
902 (let ((popped (ir2-block-popped 2block)))
904 (push block (ir2-component-values-receivers 2comp)))))))
907 ;;; This function is used to analyze blocks that must be added to the
908 ;;; flow graph after the normal LTN phase runs. Such code is
909 ;;; constrained not to use weird unknown values (and probably in lots
911 (defun ltn-analyze-belated-block (block)
912 (declare (type cblock block))
913 (ltn-analyze-block block)
914 (aver (not (ir2-block-popped (block-info block))))