1.0.5.35: stack alignment on x86/Darwin, once more
[sbcl.git] / src / compiler / ltn.lisp
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.
4
5 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; more information.
7 ;;;;
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.
13
14 (in-package "SB!C")
15 \f
16 ;;;; utilities
17
18 ;;; Return the LTN-POLICY indicated by the node policy.
19 ;;;
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
24 ;;; things like
25 ;;;   (EQ (TEMPLATE-LTN-POLICY TEMPLATE) :SAFE)
26 ;;; don't get overlooked.
27 ;;;
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))
43   (policy 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):
50                                 compilation-speed)))
51             (if (zerop safety)
52                 (if (>= speed eff-space) :fast :small)
53                 (if (>= speed eff-space) :fast-safe :safe)))))
54
55 ;;; Return true if LTN-POLICY is a safe policy.
56 (defun ltn-policy-safe-p (ltn-policy)
57   (ecase ltn-policy
58     ((:safe :fast-safe) t)
59     ((:small :fast) nil)))
60
61 ;;; an annotated lvar's primitive-type
62 #!-sb-fluid (declaim (inline lvar-ptype))
63 (defun lvar-ptype (lvar)
64   (declare (type lvar lvar))
65   (ir2-lvar-primitive-type (lvar-info lvar)))
66
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 ;;;
71 ;;; FIXME: why not?  The values in a function's constant vector are
72 ;;; subject to being moved by the garbage collector.  Having arbitrary
73 ;;; values in said vector doesn't seem like a problem.
74 (defun legal-immediate-constant-p (leaf)
75   (declare (type constant leaf))
76   (or (not (leaf-has-source-name-p leaf))
77       ;; Specialized arrays are legal, too.  KLUDGE: this would be
78       ;; *much* cleaner if SIMPLE-UNBOXED-ARRAY was defined on the host.
79       #.(loop for saetp across sb!vm:*specialized-array-element-type-properties*
80               unless (eq t (sb!vm:saetp-specifier saetp))
81               collect `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) t) into cases
82               finally (return
83                         `(typecase (constant-value leaf)
84                            ((or number character) t)
85                            (symbol (symbol-package (constant-value leaf)))
86                            ,@cases
87                            (t nil))))))
88
89 ;;; If LVAR is used only by a REF to a leaf that can be delayed, then
90 ;;; return the leaf, otherwise return NIL.
91 (defun lvar-delayed-leaf (lvar)
92   (declare (type lvar lvar))
93   (let ((use (lvar-uses lvar)))
94     (and (ref-p use)
95          (let ((leaf (ref-leaf use)))
96            (etypecase leaf
97              (lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
98              (constant (if (legal-immediate-constant-p leaf) leaf nil))
99              ((or functional global-var) nil))))))
100
101 ;;; Annotate a normal single-value lvar. If its only use is a ref that
102 ;;; we are allowed to delay the evaluation of, then we mark the lvar
103 ;;; for delayed evaluation, otherwise we assign a TN to hold the
104 ;;; lvar's value.
105 (defun annotate-1-value-lvar (lvar)
106   (declare (type lvar lvar))
107   (let ((info (lvar-info lvar)))
108     (aver (eq (ir2-lvar-kind info) :fixed))
109     (cond
110      ((lvar-delayed-leaf lvar)
111       (setf (ir2-lvar-kind info) :delayed))
112      (t (let ((tn (make-normal-tn (ir2-lvar-primitive-type info))))
113           (setf (ir2-lvar-locs info) (list tn))
114           (when (lvar-dynamic-extent lvar)
115             (setf (ir2-lvar-stack-pointer info)
116                   (make-stack-pointer-tn)))))))
117   (ltn-annotate-casts lvar)
118   (values))
119
120 ;;; Make an IR2-LVAR corresponding to the lvar type and then do
121 ;;; ANNOTATE-1-VALUE-LVAR.
122 (defun annotate-ordinary-lvar (lvar)
123   (declare (type lvar lvar))
124   (let ((info (make-ir2-lvar
125                (primitive-type (lvar-type lvar)))))
126     (setf (lvar-info lvar) info)
127     (annotate-1-value-lvar lvar))
128   (values))
129
130 ;;; Annotate the function lvar for a full call. If the only reference
131 ;;; is to a global function and DELAY is true, then we delay the
132 ;;; reference, otherwise we annotate for a single value.
133 (defun annotate-fun-lvar (lvar &optional (delay t))
134   (declare (type lvar lvar))
135   (aver (not (lvar-dynamic-extent lvar)))
136   (let* ((tn-ptype (primitive-type (lvar-type lvar)))
137          (info (make-ir2-lvar tn-ptype)))
138     (setf (lvar-info lvar) info)
139     (let ((name (lvar-fun-name lvar t)))
140       (if (and delay name)
141           (setf (ir2-lvar-kind info) :delayed)
142           (setf (ir2-lvar-locs info)
143                 (list (make-normal-tn tn-ptype))))))
144   (ltn-annotate-casts lvar)
145   (values))
146
147 ;;; If TAIL-P is true, then we check to see whether the call can
148 ;;; really be a tail call by seeing if this function's return
149 ;;; convention is :UNKNOWN. If so, we move the call block successor
150 ;;; link from the return block to the component tail (after ensuring
151 ;;; that they are in separate blocks.) This allows the return to be
152 ;;; deleted when there are no non-tail uses.
153 (defun flush-full-call-tail-transfer (call)
154   (declare (type basic-combination call))
155   (let ((tails (and (node-tail-p call)
156                     (lambda-tail-set (node-home-lambda call)))))
157     (when tails
158       (cond ((eq (return-info-kind (tail-set-info tails)) :unknown)
159              (node-ends-block call)
160              (let ((block (node-block call)))
161                (unlink-blocks block (first (block-succ block)))
162                (link-blocks block (component-tail (block-component block)))))
163             (t
164              (setf (node-tail-p call) nil)))))
165   (values))
166
167 ;;; We set the kind to :FULL or :FUNNY, depending on whether there is
168 ;;; an IR2-CONVERT method. If a funny function, then we inhibit tail
169 ;;; recursion normally, since the IR2 convert method is going to want
170 ;;; to deliver values normally. We still annotate the function lvar,
171 ;;; since IR2tran might decide to call after all.
172 ;;;
173 ;;; Note that args may already be annotated because template selection
174 ;;; can bail out to here.
175 (defun ltn-default-call (call)
176   (declare (type combination call))
177   (let ((kind (basic-combination-kind call))
178         (info (basic-combination-fun-info call)))
179     (annotate-fun-lvar (basic-combination-fun call))
180
181     (dolist (arg (basic-combination-args call))
182       (unless (lvar-info arg)
183         (setf (lvar-info arg)
184               (make-ir2-lvar (primitive-type (lvar-type arg)))))
185       (annotate-1-value-lvar arg))
186
187     (cond
188       ((and (eq kind :known)
189             (fun-info-p info)
190             (fun-info-ir2-convert info))
191        (setf (basic-combination-info call) :funny)
192        (setf (node-tail-p call) nil))
193       (t
194        (when (eq kind :error)
195          (setf (basic-combination-kind call) :full))
196        (setf (basic-combination-info call) :full)
197        (flush-full-call-tail-transfer call))))
198
199   (values))
200
201 ;;; Annotate an lvar for unknown multiple values:
202 ;;; -- Add the lvar to the IR2-BLOCK-POPPED if it is used across a
203 ;;;    block boundary.
204 ;;; -- Assign an :UNKNOWN IR2-LVAR.
205 ;;;
206 ;;; Note: it is critical that this be called only during LTN analysis
207 ;;; of LVAR's DEST, and called in the order that the lvarss are
208 ;;; received. Otherwise the IR2-BLOCK-POPPED and
209 ;;; IR2-COMPONENT-VALUES-FOO would get all messed up.
210 (defun annotate-unknown-values-lvar (lvar)
211   (declare (type lvar lvar))
212
213   (aver (not (lvar-dynamic-extent lvar)))
214   (let ((2lvar (make-ir2-lvar nil)))
215     (setf (ir2-lvar-kind 2lvar) :unknown)
216     (setf (ir2-lvar-locs 2lvar) (make-unknown-values-locations))
217     (setf (lvar-info lvar) 2lvar))
218
219   ;; The CAST chain with corresponding lvars constitute the same
220   ;; "principal lvar", so we must preserve only inner annotation order
221   ;; and the order of the whole p.l. with other lvars. -- APD,
222   ;; 2003-02-27
223   (ltn-annotate-casts lvar)
224
225   (let* ((block (node-block (lvar-dest lvar)))
226          (use (lvar-uses lvar))
227          (2block (block-info block)))
228     (unless (and (not (listp use)) (eq (node-block use) block))
229       (setf (ir2-block-popped 2block)
230             (nconc (ir2-block-popped 2block) (list lvar)))))
231
232   (values))
233
234 ;;; Annotate LVAR for a fixed, but arbitrary number of values, of the
235 ;;; specified primitive TYPES.
236 (defun annotate-fixed-values-lvar (lvar types)
237   (declare (type lvar lvar) (list types))
238   (let ((info (make-ir2-lvar nil)))
239     (setf (ir2-lvar-locs info) (mapcar #'make-normal-tn types))
240     (setf (lvar-info lvar) info)
241     (when (lvar-dynamic-extent lvar)
242       (aver (proper-list-of-length-p types 1))
243       (setf (ir2-lvar-stack-pointer info)
244             (make-stack-pointer-tn))))
245   (ltn-annotate-casts lvar)
246   (values))
247 \f
248 ;;;; node-specific analysis functions
249
250 ;;; Annotate the result lvar for a function. We use the RETURN-INFO
251 ;;; computed by GTN to determine how to represent the return values
252 ;;; within the function:
253 ;;;  * If the TAIL-SET has a fixed values count, then use that many
254 ;;;    values.
255 ;;;  * If the actual uses of the result lvar in this function
256 ;;;    have a fixed number of values (after intersection with the
257 ;;;    assertion), then use that number. We throw out TAIL-P :FULL
258 ;;;    and :LOCAL calls, since we know they will truly end up as TR
259 ;;;    calls. We can use the BASIC-COMBINATION-INFO even though it
260 ;;;    is assigned by this phase, since the initial value NIL doesn't
261 ;;;    look like a TR call.
262 ;;;      If there are *no* non-tail-call uses, then it falls out
263 ;;;    that we annotate for one value (type is NIL), but the return
264 ;;;    will end up being deleted.
265 ;;;      In non-perverse code, the DFO walk will reach all uses of the
266 ;;;    result lvar before it reaches the RETURN. In perverse code, we
267 ;;;    may annotate for unknown values when we didn't have to.
268 ;;; * Otherwise, we must annotate the lvar for unknown values.
269 (defun ltn-analyze-return (node)
270   (declare (type creturn node))
271   (let* ((lvar (return-result node))
272          (fun (return-lambda node))
273          (returns (tail-set-info (lambda-tail-set fun)))
274          (types (return-info-types returns)))
275     (if (eq (return-info-count returns) :unknown)
276         (collect ((res *empty-type* values-type-union))
277           (do-uses (use (return-result node))
278             (unless (and (node-tail-p use)
279                          (basic-combination-p use)
280                          (member (basic-combination-info use) '(:local :full)))
281               (res (node-derived-type use))))
282
283           (let ((int (res)))
284             (multiple-value-bind (types kind)
285                 (if (eq int *empty-type*)
286                     (values nil :unknown)
287                     (values-types int))
288               (if (eq kind :unknown)
289                   (annotate-unknown-values-lvar lvar)
290                   (annotate-fixed-values-lvar
291                    lvar (mapcar #'primitive-type types))))))
292         (annotate-fixed-values-lvar lvar types)))
293
294   (values))
295
296 ;;; Annotate the single argument lvar as a fixed-values lvar. We look
297 ;;; at the called lambda to determine number and type of return values
298 ;;; desired. It is assumed that only a function that
299 ;;; LOOKS-LIKE-AN-MV-BIND will be converted to a local call.
300 (defun ltn-analyze-mv-bind (call)
301   (declare (type mv-combination call))
302   (setf (basic-combination-kind call) :local)
303   (setf (node-tail-p call) nil)
304   (annotate-fixed-values-lvar
305    (first (basic-combination-args call))
306    (mapcar (lambda (var)
307              (primitive-type (basic-var-type var)))
308            (lambda-vars
309             (ref-leaf (lvar-use (basic-combination-fun call))))))
310   (values))
311
312 ;;; We force all the argument lvars to use the unknown values
313 ;;; convention. The lvars are annotated in reverse order, since the
314 ;;; last argument is on top, thus must be popped first. We disallow
315 ;;; delayed evaluation of the function lvar to simplify IR2 conversion
316 ;;; of MV call.
317 ;;;
318 ;;; We could be cleverer when we know the number of values returned by
319 ;;; the lvars, but optimizations of MV call are probably unworthwhile.
320 ;;;
321 ;;; We are also responsible for handling THROW, which is represented
322 ;;; in IR1 as an MV call to the %THROW funny function. We annotate the
323 ;;; tag lvar for a single value and the values lvar for unknown
324 ;;; values.
325 (defun ltn-analyze-mv-call (call)
326   (declare (type mv-combination call))
327   (let ((fun (basic-combination-fun call))
328         (args (basic-combination-args call)))
329     (cond ((eq (lvar-fun-name fun) '%throw)
330            (setf (basic-combination-info call) :funny)
331            (annotate-ordinary-lvar (first args))
332            (annotate-unknown-values-lvar (second args))
333            (setf (node-tail-p call) nil))
334           (t
335            (setf (basic-combination-info call) :full)
336            (annotate-fun-lvar (basic-combination-fun call) nil)
337            (dolist (arg (reverse args))
338              (annotate-unknown-values-lvar arg))
339            (flush-full-call-tail-transfer call))))
340
341   (values))
342
343 ;;; Annotate the arguments as ordinary single-value lvars. And check
344 ;;; the successor.
345 (defun ltn-analyze-local-call (call)
346   (declare (type combination call))
347   (setf (basic-combination-info call) :local)
348   (dolist (arg (basic-combination-args call))
349     (when arg
350       (annotate-ordinary-lvar arg)))
351   (when (node-tail-p call)
352     (set-tail-local-call-successor call))
353   (values))
354
355 ;;; Make sure that a tail local call is linked directly to the bind
356 ;;; node. Usually it will be, but calls from XEPs and calls that might have
357 ;;; needed a cleanup after them won't have been swung over yet, since we
358 ;;; weren't sure they would really be TR until now.
359 (defun set-tail-local-call-successor (call)
360   (let ((caller (node-home-lambda call))
361         (callee (combination-lambda call)))
362     (aver (eq (lambda-tail-set caller)
363               (lambda-tail-set (lambda-home callee))))
364     (node-ends-block call)
365     (let ((block (node-block call)))
366       (unlink-blocks block (first (block-succ block)))
367       (link-blocks block (lambda-block callee))))
368   (values))
369
370 ;;; Annotate the value lvar.
371 (defun ltn-analyze-set (node)
372   (declare (type cset node))
373   (setf (node-tail-p node) nil)
374   (annotate-ordinary-lvar (set-value node))
375   (values))
376
377 ;;; If the only use of the TEST lvar is a combination annotated with a
378 ;;; conditional template, then don't annotate the lvar so that IR2
379 ;;; conversion knows not to emit any code, otherwise annotate as an
380 ;;; ordinary lvar. Since we only use a conditional template if the
381 ;;; call immediately precedes the IF node in the same block, we know
382 ;;; that any predicate will already be annotated.
383 (defun ltn-analyze-if (node)
384   (declare (type cif node))
385   (setf (node-tail-p node) nil)
386   (let* ((test (if-test node))
387          (use (lvar-uses test)))
388     (unless (and (combination-p use)
389                  (let ((info (basic-combination-info use)))
390                    (and (template-p info)
391                         (eq (template-result-types info) :conditional))))
392       (annotate-ordinary-lvar test)))
393   (values))
394
395 ;;; If there is a value lvar, then annotate it for unknown values. In
396 ;;; this case, the exit is non-local, since all other exits are
397 ;;; deleted or degenerate by this point.
398 (defun ltn-analyze-exit (node)
399   (setf (node-tail-p node) nil)
400   (let ((value (exit-value node)))
401     (when value
402       (annotate-unknown-values-lvar value)))
403   (values))
404
405 ;;; We need a special method for %UNWIND-PROTECT that ignores the
406 ;;; cleanup function. We don't annotate either arg, since we don't
407 ;;; need them at run-time.
408 ;;;
409 ;;; (The default is o.k. for %CATCH, since environment analysis
410 ;;; converted the reference to the escape function into a constant
411 ;;; reference to the NLX-INFO.)
412 (defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup)
413                                               node
414                                               ltn-policy)
415   ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
416   (setf (basic-combination-info node) :funny)
417   (setf (node-tail-p node) nil))
418
419 ;;; Make sure that arguments of magic functions are not annotated.
420 ;;; (Otherwise the compiler may dump its internal structures as
421 ;;; constants :-()
422 (defoptimizer (%pop-values ltn-annotate) ((%lvar) node ltn-policy)
423   %lvar node ltn-policy)
424 (defoptimizer (%nip-values ltn-annotate) ((last-nipped last-preserved
425                                                        &rest moved)
426                                           node ltn-policy)
427   last-nipped last-preserved moved node ltn-policy)
428
429 \f
430 ;;;; known call annotation
431
432 ;;; Return true if RESTR is satisfied by TYPE. If T-OK is true, then a
433 ;;; T restriction allows any operand type. This is also called by IR2
434 ;;; translation when it determines whether a result temporary needs to
435 ;;; be made, and by representation selection when it is deciding which
436 ;;; move VOP to use. LVAR and TN are used to test for constant
437 ;;; arguments.
438 (defun operand-restriction-ok (restr type &key lvar tn (t-ok t))
439   (declare (type (or (member *) cons) restr)
440            (type primitive-type type)
441            (type (or lvar null) lvar)
442            (type (or tn null) tn))
443   (if (eq restr '*)
444       t
445       (ecase (first restr)
446         (:or
447          (dolist (mem (rest restr) nil)
448            (when (or (and t-ok (eq mem *backend-t-primitive-type*))
449                      (eq mem type))
450              (return t))))
451         (:constant
452          (cond (lvar
453                 (and (constant-lvar-p lvar)
454                      (funcall (second restr) (lvar-value lvar))))
455                (tn
456                 (and (eq (tn-kind tn) :constant)
457                      (funcall (second restr) (tn-value tn))))
458                (t
459                 (error "Neither LVAR nor TN supplied.")))))))
460
461 ;;; Check that the argument type restriction for TEMPLATE are
462 ;;; satisfied in call. If an argument's TYPE-CHECK is :NO-CHECK and
463 ;;; our policy is safe, then only :SAFE templates are OK.
464 (defun template-args-ok (template call safe-p)
465   (declare (type template template)
466            (type combination call))
467   (declare (ignore safe-p))
468   (let ((mtype (template-more-args-type template)))
469     (do ((args (basic-combination-args call) (cdr args))
470          (types (template-arg-types template) (cdr types)))
471         ((null types)
472          (cond ((null args) t)
473                ((not mtype) nil)
474                (t
475                 (dolist (arg args t)
476                   (unless (operand-restriction-ok mtype
477                                                   (lvar-ptype arg))
478                     (return nil))))))
479       (when (null args) (return nil))
480       (let ((arg (car args))
481             (type (car types)))
482         (unless (operand-restriction-ok type (lvar-ptype arg)
483                                         :lvar arg)
484           (return nil))))))
485
486 ;;; Check that TEMPLATE can be used with the specifed RESULT-TYPE.
487 ;;; Result type checking is pretty different from argument type
488 ;;; checking due to the relaxed rules for values count. We succeed if
489 ;;; for each required result, there is a positional restriction on the
490 ;;; value that is at least as good. If we run out of result types
491 ;;; before we run out of restrictions, then we only succeed if the
492 ;;; leftover restrictions are *. If we run out of restrictions before
493 ;;; we run out of result types, then we always win.
494 (defun template-results-ok (template result-type)
495   (declare (type template template)
496            (type ctype result-type))
497   (when (template-more-results-type template)
498     (error "~S has :MORE results with :TRANSLATE." (template-name template)))
499   (let ((types (template-result-types template)))
500     (cond
501      ((values-type-p result-type)
502       (do ((ltypes (append (args-type-required result-type)
503                            (args-type-optional result-type))
504                    (rest ltypes))
505            (types types (rest types)))
506           ((null ltypes)
507            (dolist (type types t)
508              (unless (eq type '*)
509                (return nil))))
510         (when (null types) (return t))
511         (let ((type (first types)))
512           (unless (operand-restriction-ok type
513                                           (primitive-type (first ltypes)))
514             (return nil)))))
515      (types
516       (operand-restriction-ok (first types) (primitive-type result-type)))
517      (t t))))
518
519 ;;; Return true if CALL is an ok use of TEMPLATE according to SAFE-P.
520 ;;; -- If the template has a GUARD that isn't true, then we ignore the
521 ;;;    template, not even considering it to be rejected.
522 ;;; -- If the argument type restrictions aren't satisfied, then we
523 ;;;    reject the template.
524 ;;; -- If the template is :CONDITIONAL, then we accept it only when the
525 ;;;    destination of the value is an immediately following IF node.
526 ;;; -- If either the template is safe or the policy is unsafe (i.e. we
527 ;;;    can believe output assertions), then we test against the
528 ;;;    intersection of the node derived type and the lvar
529 ;;;    asserted type. Otherwise, we just use the node type. If
530 ;;;    TYPE-CHECK is null, there is no point in doing the intersection,
531 ;;;    since the node type must be a subtype of the  assertion.
532 ;;;
533 ;;; If the template is *not* ok, then the second value is a keyword
534 ;;; indicating which aspect failed.
535 (defun is-ok-template-use (template call safe-p)
536   (declare (type template template) (type combination call))
537   (let* ((guard (template-guard template))
538          (lvar (node-lvar call))
539          (dtype (node-derived-type call)))
540     (cond ((and guard (not (funcall guard)))
541            (values nil :guard))
542           ((not (template-args-ok template call safe-p))
543            (values nil
544                    (if (and safe-p (template-args-ok template call nil))
545                        :arg-check
546                        :arg-types)))
547           ((eq (template-result-types template) :conditional)
548            (let ((dest (lvar-dest lvar)))
549              (if (and (if-p dest)
550                       (immediately-used-p (if-test dest) call))
551                  (values t nil)
552                  (values nil :conditional))))
553           ((template-results-ok template dtype)
554            (values t nil))
555           (t
556            (values nil :result-types)))))
557
558 ;;; Use operand type information to choose a template from the list
559 ;;; TEMPLATES for a known CALL. We return three values:
560 ;;; 1. The template we found.
561 ;;; 2. Some template that we rejected due to unsatisfied type restrictions, or
562 ;;;    NIL if none.
563 ;;; 3. The tail of Templates for templates we haven't examined yet.
564 ;;;
565 ;;; We just call IS-OK-TEMPLATE-USE until it returns true.
566 (defun find-template (templates call safe-p)
567   (declare (list templates) (type combination call))
568   (do ((templates templates (rest templates))
569        (rejected nil))
570       ((null templates)
571        (values nil rejected nil))
572     (let ((template (first templates)))
573       (when (is-ok-template-use template call safe-p)
574         (return (values template rejected (rest templates))))
575       (setq rejected template))))
576
577 ;;; Given a partially annotated known call and a translation policy,
578 ;;; return the appropriate template, or NIL if none can be found. We
579 ;;; scan the templates (ordered by increasing cost) looking for a
580 ;;; template whose restrictions are satisfied and that has our policy.
581 ;;;
582 ;;; If we find a template that doesn't have our policy, but has a
583 ;;; legal alternate policy, then we also record that to return as a
584 ;;; last resort. If our policy is safe, then only safe policies are
585 ;;; O.K., otherwise anything goes.
586 ;;;
587 ;;; If we find a template with :SAFE policy, then we return it, or any
588 ;;; cheaper fallback template. The theory behind this is that if it is
589 ;;; cheapest, small and safe, we can't lose. If it is not cheapest,
590 ;;; then we use the fallback, which won't have the desired policy, but
591 ;;; :SAFE isn't desired either, so we might as well go with the
592 ;;; cheaper one. The main reason for doing this is to make sure that
593 ;;; cheap safe templates are used when they apply and the current
594 ;;; policy is something else. This is useful because :SAFE has the
595 ;;; additional semantics of implicit argument type checking, so we may
596 ;;; be forced to define a template with :SAFE policy when it is really
597 ;;; small and fast as well.
598 (defun find-template-for-ltn-policy (call ltn-policy)
599   (declare (type combination call)
600            (type ltn-policy ltn-policy))
601   (let ((safe-p (ltn-policy-safe-p ltn-policy))
602         (current (fun-info-templates (basic-combination-fun-info call)))
603         (fallback nil)
604         (rejected nil))
605     (loop
606      (multiple-value-bind (template this-reject more)
607          (find-template current call safe-p)
608        (unless rejected
609          (setq rejected this-reject))
610        (setq current more)
611        (unless template
612          (return (values fallback rejected)))
613        (let ((tcpolicy (template-ltn-policy template)))
614          (cond ((eq tcpolicy ltn-policy)
615                 (return (values template rejected)))
616                ((eq tcpolicy :safe)
617                 (return (values (or fallback template) rejected)))
618                ((or (not safe-p) (eq tcpolicy :fast-safe))
619                 (unless fallback
620                   (setq fallback template)))))))))
621
622 (defvar *efficiency-note-limit* 2
623   #!+sb-doc
624   "This is the maximum number of possible optimization alternatives will be
625   mentioned in a particular efficiency note. NIL means no limit.")
626 (declaim (type (or index null) *efficiency-note-limit*))
627
628 (defvar *efficiency-note-cost-threshold* 5
629   #!+sb-doc
630   "This is the minumum cost difference between the chosen implementation and
631   the next alternative that justifies an efficiency note.")
632 (declaim (type index *efficiency-note-cost-threshold*))
633
634 ;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't
635 ;;; figure out any reason why TEMPLATE was rejected. Users should
636 ;;; never see these messages, but they can happen in situations where
637 ;;; the VM definition is messed up somehow.
638 (defun strange-template-failure (template call ltn-policy frob)
639   (declare (type template template) (type combination call)
640            (type ltn-policy ltn-policy) (type function frob))
641   (funcall frob "This shouldn't happen!  Bug?")
642   (multiple-value-bind (win why)
643       (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
644     (aver (not win))
645     (ecase why
646       (:guard
647        (funcall frob "template guard failed"))
648       (:arg-check
649        (funcall frob "The template isn't safe, yet we were counting on it."))
650       (:arg-types
651        (funcall frob "argument types invalid")
652        (funcall frob "argument primitive types:~%  ~S"
653                 (mapcar (lambda (x)
654                           (primitive-type-name
655                            (lvar-ptype x)))
656                         (combination-args call)))
657        (funcall frob "argument type assertions:~%  ~S"
658                 (mapcar (lambda (x)
659                           (if (atom x)
660                               x
661                               (ecase (car x)
662                                 (:or `(:or .,(mapcar #'primitive-type-name
663                                                      (cdr x))))
664                                 (:constant `(:constant ,(third x))))))
665                         (template-arg-types template))))
666       (:conditional
667        (funcall frob "conditional in a non-conditional context"))
668       (:result-types
669        (funcall frob "result types invalid")))))
670
671 ;;; This function emits efficiency notes describing all of the
672 ;;; templates better (faster) than TEMPLATE that we might have been
673 ;;; able to use if there were better type declarations. Template is
674 ;;; null when we didn't find any template, and thus must do a full
675 ;;; call.
676 ;;;
677 ;;; In order to be worth complaining about, a template must:
678 ;;; -- be allowed by its guard,
679 ;;; -- be safe if the current policy is safe,
680 ;;; -- have argument/result type restrictions consistent with the
681 ;;;    known type information, e.g. we don't consider float templates
682 ;;;    when an operand is known to be an integer,
683 ;;; -- be disallowed by the stricter operand subtype test (which
684 ;;;    resembles, but is not identical to the test done by
685 ;;;    FIND-TEMPLATE.)
686 ;;;
687 ;;; Note that there may not be any possibly applicable templates,
688 ;;; since we are called whenever any template is rejected. That
689 ;;; template might have the wrong policy or be inconsistent with the
690 ;;; known type.
691 ;;;
692 ;;; We go to some trouble to make the whole multi-line output into a
693 ;;; single call to COMPILER-NOTIFY so that repeat messages are
694 ;;; suppressed, etc.
695 (defun note-rejected-templates (call ltn-policy template)
696   (declare (type combination call) (type ltn-policy ltn-policy)
697            (type (or template null) template))
698
699   (collect ((losers))
700     (let ((safe-p (ltn-policy-safe-p ltn-policy))
701           (verbose-p (policy call (= inhibit-warnings 0)))
702           (max-cost (- (template-cost
703                         (or template
704                             (template-or-lose 'call-named)))
705                        *efficiency-note-cost-threshold*)))
706       (dolist (try (fun-info-templates (basic-combination-fun-info call)))
707         (when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner.
708         (let ((guard (template-guard try)))
709           (when (and (or (not guard) (funcall guard))
710                      (or (not safe-p)
711                          (ltn-policy-safe-p (template-ltn-policy try)))
712                      ;; :SAFE is also considered to be :SMALL-SAFE,
713                      ;; while the template cost describes time cost;
714                      ;; so the fact that (< (t-cost try) (t-cost
715                      ;; template)) does not mean that TRY is better
716                      (not (and (eq ltn-policy :safe)
717                                (eq (template-ltn-policy try) :fast-safe)))
718                      (or verbose-p
719                          (and (template-note try)
720                               (valid-fun-use
721                                call (template-type try)
722                                :argument-test #'types-equal-or-intersect
723                                :result-test
724                                #'values-types-equal-or-intersect))))
725             (losers try)))))
726
727     (when (losers)
728       (collect ((messages)
729                 (notes 0 +))
730         (flet ((lose1 (string &rest stuff)
731                  (messages string)
732                  (messages stuff)))
733           (dolist (loser (losers))
734             (when (and *efficiency-note-limit*
735                        (>= (notes) *efficiency-note-limit*))
736               (lose1 "etc.")
737               (return))
738             (let* ((type (template-type loser))
739                    (valid (valid-fun-use call type))
740                    (strict-valid (valid-fun-use call type)))
741               (lose1 "unable to do ~A (cost ~W) because:"
742                      (or (template-note loser) (template-name loser))
743                      (template-cost loser))
744               (cond
745                ((and valid strict-valid)
746                 (strange-template-failure loser call ltn-policy #'lose1))
747                ((not valid)
748                 (aver (not (valid-fun-use call type
749                                           :lossage-fun #'lose1
750                                           :unwinnage-fun #'lose1))))
751                (t
752                 (aver (ltn-policy-safe-p ltn-policy))
753                 (lose1 "can't trust output type assertion under safe policy")))
754               (notes 1))))
755
756         (let ((*compiler-error-context* call))
757           (compiler-notify "~{~?~^~&~6T~}"
758                            (if template
759                                `("forced to do ~A (cost ~W)"
760                                  (,(or (template-note template)
761                                        (template-name template))
762                                   ,(template-cost template))
763                                  . ,(messages))
764                                `("forced to do full call"
765                                  nil
766                                  . ,(messages))))))))
767   (values))
768
769 ;;; If a function has a special-case annotation method use that,
770 ;;; otherwise annotate the argument lvars and try to find a template
771 ;;; corresponding to the type signature. If there is none, convert a
772 ;;; full call.
773 (defun ltn-analyze-known-call (call)
774   (declare (type combination call))
775   (let ((ltn-policy (node-ltn-policy call))
776         (method (fun-info-ltn-annotate (basic-combination-fun-info call)))
777         (args (basic-combination-args call)))
778     (when method
779       (funcall method call ltn-policy)
780       (return-from ltn-analyze-known-call (values)))
781
782     (dolist (arg args)
783       (setf (lvar-info arg)
784             (make-ir2-lvar (primitive-type (lvar-type arg)))))
785
786     (multiple-value-bind (template rejected)
787         (find-template-for-ltn-policy call ltn-policy)
788       ;; If we are unable to use some templates due to unsatisfied
789       ;; operand type restrictions and our policy enables efficiency
790       ;; notes, then we call NOTE-REJECTED-TEMPLATES.
791       (when (and rejected
792                  (policy call (> speed inhibit-warnings)))
793         (note-rejected-templates call ltn-policy template))
794       ;; If we are forced to do a full call, we check to see whether
795       ;; the function called is the same as the current function. If
796       ;; so, we give a warning, as this is probably a botched attempt
797       ;; to implement an out-of-line version in terms of inline
798       ;; transforms or VOPs or whatever.
799       (unless template
800         (when (let ((funleaf (physenv-lambda (node-physenv call))))
801                 (and (leaf-has-source-name-p funleaf)
802                      (eq (lvar-fun-name (combination-fun call))
803                          (leaf-source-name funleaf))
804                      (let ((info (basic-combination-fun-info call)))
805                        (not (or (fun-info-ir2-convert info)
806                                 (ir1-attributep (fun-info-attributes info)
807                                                 recursive))))))
808           (let ((*compiler-error-context* call))
809             (compiler-warn "~@<recursion in known function definition~2I ~
810                             ~_policy=~S ~_arg types=~S~:>"
811                            (lexenv-policy (node-lexenv call))
812                            (mapcar (lambda (arg)
813                                      (type-specifier (lvar-type arg)))
814                                    args))))
815         (ltn-default-call call)
816         (return-from ltn-analyze-known-call (values)))
817       (setf (basic-combination-info call) template)
818       (setf (node-tail-p call) nil)
819
820       (dolist (arg args)
821         (annotate-1-value-lvar arg))))
822
823   (values))
824
825 ;;; CASTs are merely lvar annotations than nodes. So we wait until
826 ;;; value consumer deside how values should be passed, and after that
827 ;;; we propagate this decision backwards through CAST chain. The
828 ;;; exception is a dangling CAST with a type check, which we process
829 ;;; immediately.
830 (defun ltn-analyze-cast (cast)
831   (declare (type cast cast))
832   (setf (node-tail-p cast) nil)
833   (when (and (cast-type-check cast)
834              (not (node-lvar cast)))
835     ;; FIXME
836     (bug "IR2 type checking of unused values is not implemented.")
837     )
838   (values))
839
840 (defun ltn-annotate-casts (lvar)
841   (declare (type lvar lvar))
842   (do-uses (node lvar)
843     (when (cast-p node)
844       (ltn-annotate-cast node))))
845
846 (defun ltn-annotate-cast (cast)
847   (declare (type cast))
848   (let ((2lvar (lvar-info (node-lvar cast)))
849         (value (cast-value cast)))
850     (aver 2lvar)
851     ;; XXX
852     (ecase (ir2-lvar-kind 2lvar)
853       (:unknown
854        (annotate-unknown-values-lvar value))
855       (:fixed
856        (let* ((count (length (ir2-lvar-locs 2lvar)))
857               (ctype (lvar-derived-type value)))
858          (multiple-value-bind (types rest)
859              (values-type-types ctype (specifier-type 'null))
860            (annotate-fixed-values-lvar
861             value
862             (mapcar #'primitive-type
863                     (adjust-list types count rest))))))))
864   (values))
865
866 \f
867 ;;;; interfaces
868
869 ;;; most of the guts of the two interface functions: Compute the
870 ;;; policy and dispatch to the appropriate node-specific function.
871 ;;;
872 ;;; Note: we deliberately don't use the DO-NODES macro, since the
873 ;;; block can be split out from underneath us, and DO-NODES would scan
874 ;;; past the block end in that case.
875 (defun ltn-analyze-block (block)
876   (do* ((node (block-start-node block)
877               (ctran-next ctran))
878         (ctran (node-next node) (node-next node)))
879       (nil)
880     (etypecase node
881       (ref)
882       (combination
883        (ecase (basic-combination-kind node)
884          (:local (ltn-analyze-local-call node))
885          ((:full :error) (ltn-default-call node))
886          (:known
887           (ltn-analyze-known-call node))))
888       (cif (ltn-analyze-if node))
889       (creturn (ltn-analyze-return node))
890       ((or bind entry))
891       (exit (ltn-analyze-exit node))
892       (cset (ltn-analyze-set node))
893       (cast (ltn-analyze-cast node))
894       (mv-combination
895        (ecase (basic-combination-kind node)
896          (:local
897           (ltn-analyze-mv-bind node))
898          ((:full :error)
899           (ltn-analyze-mv-call node)))))
900     (when (eq node (block-last block))
901       (return))))
902
903 ;;; Loop over the blocks in COMPONENT, doing stuff to nodes that
904 ;;; receive values. In addition to the stuff done by FROB, we also see
905 ;;; whether there are any unknown values receivers, making notations
906 ;;; in the components' GENERATORS and RECEIVERS as appropriate.
907 ;;;
908 ;;; If any unknown-values lvars are received by this block (as
909 ;;; indicated by IR2-BLOCK-POPPED), then we add the block to the
910 ;;; IR2-COMPONENT-VALUES-RECEIVERS.
911 ;;;
912 ;;; This is where we allocate IR2 blocks because it is the first place
913 ;;; we need them.
914 (defun ltn-analyze (component)
915   (declare (type component component))
916   (let ((2comp (component-info component)))
917     (do-blocks (block component)
918       (aver (not (block-info block)))
919       (let ((2block (make-ir2-block block)))
920         (setf (block-info block) 2block)
921         (ltn-analyze-block block)))
922     (do-blocks (block component)
923       (let ((2block (block-info block)))
924         (let ((popped (ir2-block-popped 2block)))
925           (when popped
926             (push block (ir2-component-values-receivers 2comp)))))))
927   (values))
928
929 ;;; This function is used to analyze blocks that must be added to the
930 ;;; flow graph after the normal LTN phase runs. Such code is
931 ;;; constrained not to use weird unknown values (and probably in lots
932 ;;; of other ways).
933 (defun ltn-analyze-belated-block (block)
934   (declare (type cblock block))
935   (ltn-analyze-block block)
936   (aver (not (ir2-block-popped (block-info block))))
937   (values))
938