/[cmucl]/src/compiler/ltn.lisp
ViewVC logotype

Contents of /src/compiler/ltn.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.46 - (show annotations)
Tue Apr 20 17:57:46 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.45: +17 -17 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/ltn.lisp,v 1.46 2010/04/20 17:57:46 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the LTN pass in the compiler. LTN allocates
13 ;;; expression evaluation TNs, makes nearly all the implementation policy
14 ;;; decisions, and also does a few other random things.
15 ;;;
16 ;;; Written by Rob MacLachlan
17 ;;;
18 (in-package "C")
19 (in-package "EXTENSIONS")
20 (intl:textdomain "cmucl")
21
22 (export '(*efficiency-note-limit* *efficiency-note-cost-threshold*))
23 (in-package "C")
24
25
26 ;;;; Utilities:
27
28 ;;; Translation-Policy -- Internal
29 ;;;
30 ;;; Return the policies keyword indicated by the node policy.
31 ;;;
32 (defun translation-policy (node)
33 (declare (type node node))
34 (let* ((cookie (lexenv-cookie (node-lexenv node)))
35 (safety (cookie-safety cookie))
36 (space (max (cookie-space cookie)
37 (cookie-cspeed cookie)))
38 (speed (cookie-speed cookie)))
39 (if (zerop safety)
40 (if (>= speed space) :fast :small)
41 (if (>= speed space) :fast-safe :safe))))
42
43
44 ;;; Policy-Safe-P -- Interface
45 ;;;
46 ;;; Return true if Policy is a safe policy.
47 ;;;
48 (declaim (inline policy-safe-p))
49 (defun policy-safe-p (policy)
50 (declare (type policies policy))
51 (or (eq policy :safe) (eq policy :fast-safe)))
52
53
54 ;;; FLUSH-TYPE-CHECK -- Internal
55 ;;;
56 ;;; Called when an unsafe policy indicates that no type check should be done
57 ;;; on CONT. We delete the type check unless it is :ERROR (indicating a
58 ;;; compile-time type error.)
59 ;;;
60 (declaim (inline flush-type-check))
61 (defun flush-type-check (cont)
62 (declare (type continuation cont))
63 (when (member (continuation-type-check cont) '(t :no-check))
64 (setf (continuation-%type-check cont) :deleted))
65 (undefined-value))
66
67
68 ;;; Continuation-PType -- Internal
69 ;;;
70 ;;; A annotated continuation's primitive-type.
71 ;;;
72 (declaim (inline continuation-ptype))
73 (defun continuation-ptype (cont)
74 (declare (type continuation cont))
75 (ir2-continuation-primitive-type (continuation-info cont)))
76
77
78 ;;; LEGAL-IMMEDIATE-CONSTANT-P -- Interface
79 ;;;
80 ;;; Return true if a constant Leaf is of a type which we can legally
81 ;;; directly reference in code. Named constants with arbitrary pointer values
82 ;;; cannot, since we must preserve EQLness.
83 ;;;
84 (defun legal-immediate-constant-p (leaf)
85 (declare (type constant leaf))
86 (or (null (leaf-name leaf))
87 (typecase (constant-value leaf)
88 ((or number character) t)
89 (symbol (symbol-package (constant-value leaf)))
90 (t nil))))
91
92
93 ;;; Continuation-Delayed-Leaf -- Internal
94 ;;;
95 ;;; If Cont is used only by a Ref to a leaf that can be delayed, then return
96 ;;; the leaf, otherwise return NIL.
97 ;;;
98 (defun continuation-delayed-leaf (cont)
99 (declare (type continuation cont))
100 (let ((use (continuation-use cont)))
101 (and (ref-p use)
102 (let ((leaf (ref-leaf use)))
103 (etypecase leaf
104 (lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
105 (constant (if (legal-immediate-constant-p leaf) leaf nil))
106 ((or functional global-var) nil))))))
107
108
109 ;;; Annotate-1-Value-Continuation -- Internal
110 ;;;
111 ;;; Annotate a normal single-value continuation. If its only use is a ref
112 ;;; that we are allowed to delay the evaluation of, then we mark the
113 ;;; continuation for delayed evaluation, otherwise we assign a TN to hold the
114 ;;; continuation's value. If the continuation has a type check, we make the TN
115 ;;; according to the proven type to ensure that the possibly erroneous value
116 ;;; can be represented.
117 ;;;
118 (defun annotate-1-value-continuation (cont)
119 (declare (type continuation cont))
120 (let ((info (continuation-info cont)))
121 (assert (eq (ir2-continuation-kind info) :fixed))
122 (cond
123 ((continuation-delayed-leaf cont)
124 (setf (ir2-continuation-kind info) :delayed))
125 ((member (continuation-type-check cont) '(:deleted nil))
126 (setf (ir2-continuation-locs info)
127 (list (make-normal-tn (ir2-continuation-primitive-type info)))))
128 (t
129 (setf (ir2-continuation-locs info)
130 (list (make-normal-tn
131 (primitive-type
132 (single-value-type (continuation-proven-type cont)))))))))
133 (undefined-value))
134
135
136 ;;; Annotate-Ordinary-Continuation -- Internal
137 ;;;
138 ;;; Make an IR2-Continuation corresponding to the continuation type and then
139 ;;; do Annotate-1-Value-Continuation. If Policy isn't a safe policy, then we
140 ;;; clear the type-check flag.
141 ;;;
142 (defun annotate-ordinary-continuation (cont policy)
143 (declare (type continuation cont)
144 (type policies policy))
145 (let ((info (make-ir2-continuation
146 (primitive-type (continuation-type cont)))))
147 (setf (continuation-info cont) info)
148 (unless (policy-safe-p policy) (flush-type-check cont))
149 (annotate-1-value-continuation cont))
150 (undefined-value))
151
152
153 ;;; Annotate-Function-Continuation -- Internal
154 ;;;
155 ;;; Annotate the function continuation for a full call. If the only
156 ;;; reference is to a global function and Delay is true, then we delay
157 ;;; the reference, otherwise we annotate for a single value.
158 ;;;
159 ;;; Unlike for an argument, we only clear the type check flag when the policy
160 ;;; is unsafe, since the check for a valid function object must be done before
161 ;;; the call.
162 ;;;
163 (defun annotate-function-continuation (cont policy &optional (delay t))
164 (declare (type continuation cont) (type policies policy))
165 (unless (policy-safe-p policy) (flush-type-check cont))
166 (let* ((ptype (primitive-type (continuation-type cont)))
167 (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil))
168 ptype
169 (primitive-type
170 (single-value-type
171 (continuation-proven-type cont)))))
172 (info (make-ir2-continuation ptype)))
173 (setf (continuation-info cont) info)
174 (let ((name (continuation-function-name cont t)))
175 (if (and delay name)
176 (setf (ir2-continuation-kind info) :delayed)
177 (setf (ir2-continuation-locs info)
178 (list (make-normal-tn tn-ptype))))))
179 (undefined-value))
180
181
182 ;;; FLUSH-FULL-CALL-TAIL-TRANSFER -- Internal
183 ;;;
184 ;;; If TAIL-P is true, then we check to see if the call can really be a tail
185 ;;; call by seeing if this function's return convention is :UNKNOWN. If so, we
186 ;;; move the call block succssor link from the return block to the component
187 ;;; tail (after ensuring that they are in separate blocks.) This allows the
188 ;;; return to be deleted when there are no non-tail uses.
189 ;;;
190 (defun flush-full-call-tail-transfer (call)
191 (declare (type basic-combination call))
192 (let ((tails (and (node-tail-p call)
193 (lambda-tail-set (node-home-lambda call)))))
194 (when tails
195 (cond ((eq (return-info-kind (tail-set-info tails)) :unknown)
196 (node-ends-block call)
197 (let ((block (node-block call)))
198 (unlink-blocks block (first (block-succ block)))
199 (link-blocks block (component-tail (block-component block)))))
200 (t
201 (setf (node-tail-p call) nil)))))
202 (undefined-value))
203
204
205 ;;; LTN-Default-Call -- Internal
206 ;;;
207 ;;; We set the kind to :FULL or :FUNNY, depending on whether there is an
208 ;;; IR2-CONVERT method. If a funny function, then we inhibit tail recursion
209 ;;; and type check normally, since the IR2 convert method is going to want to
210 ;;; deliver values normally. We still annotate the function continuation,
211 ;;; since IR2tran might decide to call after all.
212 ;;;
213 ;;; If not funny, we always flush arg type checks, but do it after
214 ;;; annotation when the policy is safe, since we don't want to choose the TNs
215 ;;; according to a type assertions that may not hold.
216 ;;;
217 ;;; Note that args may already be annotated because template selection can
218 ;;; bail out to here.
219 ;;;
220 (defun ltn-default-call (call policy)
221 (declare (type combination call) (type policies policy))
222 (let ((kind (basic-combination-kind call)))
223 (annotate-function-continuation (basic-combination-fun call) policy)
224
225 (cond
226 ((and (function-info-p kind)
227 (function-info-ir2-convert kind))
228 (setf (basic-combination-info call) :funny)
229 (setf (node-tail-p call) nil)
230 (dolist (arg (basic-combination-args call))
231 (unless (continuation-info arg)
232 (setf (continuation-info arg)
233 (make-ir2-continuation
234 (primitive-type
235 (continuation-type arg)))))
236 (annotate-1-value-continuation arg)))
237 (t
238 (let ((safe-p (policy-safe-p policy)))
239 (dolist (arg (basic-combination-args call))
240 (unless safe-p (flush-type-check arg))
241 (unless (continuation-info arg)
242 (setf (continuation-info arg)
243 (make-ir2-continuation
244 (primitive-type
245 (continuation-type arg)))))
246 (annotate-1-value-continuation arg)
247 (when safe-p (flush-type-check arg))))
248 (when (eq kind :error)
249 (setf (basic-combination-kind call) :full))
250 (setf (basic-combination-info call) :full)
251 (flush-full-call-tail-transfer call))))
252
253 (undefined-value))
254
255
256 ;;; Annotate-Unknown-Values-Continuation -- Internal
257 ;;;
258 ;;; Annotate a continuation for unknown multiple values:
259 ;;; -- Delete any type check, regardless of policy, since we IR2 conversion
260 ;;; isn't prepared to check unknown-values continuations. If we delete a
261 ;;; type check when the policy is safe, then we emit a warning.
262 ;;; -- Add the continuation to the IR2-Block-Popped if it is used across a
263 ;;; block boundry.
264 ;;; -- Assign a :Unknown IR2-Continuation.
265 ;;;
266 ;;; Note: it is critical that this be called only during LTN analysis of Cont's
267 ;;; DEST, and called in the order that the continuations are received.
268 ;;; Otherwise the IR2-Block-Popped and IR2-Component-Values-XXX will get all
269 ;;; messed up.
270 ;;;
271 (defun annotate-unknown-values-continuation (cont policy)
272 (declare (type continuation cont) (type policies policy))
273 (when (eq (continuation-type-check cont) t)
274 (let* ((dest (continuation-dest cont))
275 (*compiler-error-context* dest))
276 (when (and (policy-safe-p policy)
277 (policy dest (>= safety brevity)))
278 (compiler-note _N"Unable to check type assertion in unknown-values ~
279 context:~% ~S"
280 (continuation-asserted-type cont))))
281 (setf (continuation-%type-check cont) :deleted))
282
283 (let* ((block (node-block (continuation-dest cont)))
284 (use (continuation-use cont))
285 (2block (block-info block)))
286 (unless (and use (eq (node-block use) block))
287 (setf (ir2-block-popped 2block)
288 (nconc (ir2-block-popped 2block) (list cont)))))
289
290 (let ((2cont (make-ir2-continuation nil)))
291 (setf (ir2-continuation-kind 2cont) :unknown)
292 (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
293 (setf (continuation-info cont) 2cont))
294
295 (undefined-value))
296
297
298 ;;; Annotate-Fixed-Values-Continuation -- Internal
299 ;;;
300 ;;; Annotate Cont for a fixed, but arbitrary number of values, of the
301 ;;; specified primitive Types. If the continuation has a type check, we
302 ;;; annotate for the number of values indicated by Types, but only use proven
303 ;;; type information.
304 ;;;
305 (defun annotate-fixed-values-continuation (cont policy types)
306 (declare (type continuation cont) (type policies policy) (list types))
307 (unless (policy-safe-p policy) (flush-type-check cont))
308
309 (let ((res (make-ir2-continuation nil)))
310 (if (member (continuation-type-check cont) '(:deleted nil))
311 (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
312 (let* ((proven (mapcar #'(lambda (x)
313 (make-normal-tn (primitive-type x)))
314 (values-types
315 (continuation-proven-type cont))))
316 (num-proven (length proven))
317 (num-types (length types)))
318 (setf (ir2-continuation-locs res)
319 (cond
320 ((< num-proven num-types)
321 (append proven
322 (make-n-tns (- num-types num-proven)
323 (backend-any-primitive-type *backend*))))
324 ((> num-proven num-types)
325 (subseq proven 0 num-types))
326 (t
327 proven)))))
328 (setf (continuation-info cont) res))
329
330 (undefined-value))
331
332
333 ;;;; Node-specific analysis functions:
334
335 ;;; LTN-Analyze-Return -- Internal
336 ;;;
337 ;;; Annotate the result continuation for a function. We use the Return-Info
338 ;;; computed by GTN to determine how to represent the return values within the
339 ;;; function:
340 ;;; -- If the tail-set has a fixed values count, then use that many values.
341 ;;; -- If the actual uses of the result continuation in this function have a
342 ;;; fixed number of values (after intersection with the assertion), then use
343 ;;; that number. We throw out TAIL-P :FULL and :LOCAL calls, since we know
344 ;;; they will truly end up as TR calls. We can use the
345 ;;; BASIC-COMBINATION-INFO even though it is assigned by this phase, since
346 ;;; the initial value NIL doesn't look like a TR call.
347 ;;;
348 ;;; If there are *no* non-tail-call uses, then it falls out that we annotate
349 ;;; for one value (type is NIL), but the return will end up being deleted.
350 ;;;
351 ;;; In non-perverse code, the DFO walk will reach all uses of the result
352 ;;; continuation before it reaches the RETURN. In perverse code, we may
353 ;;; annotate for unknown values when we didn't have to.
354 ;;; -- Otherwise, we must annotate the continuation for unknown values.
355 ;;;
356 (defun ltn-analyze-return (node policy)
357 (declare (type creturn node) (type policies policy))
358 (let* ((cont (return-result node))
359 (fun (return-lambda node))
360 (returns (tail-set-info (lambda-tail-set fun)))
361 (types (return-info-types returns)))
362 (if (eq (return-info-count returns) :unknown)
363 (collect ((res *empty-type* values-type-union))
364 (do-uses (use (return-result node))
365 (unless (and (node-tail-p use)
366 (basic-combination-p use)
367 (member (basic-combination-info use) '(:local :full)))
368 (res (node-derived-type use))))
369
370 (let ((int (values-type-intersection
371 (res)
372 (continuation-asserted-type cont))))
373 (multiple-value-bind
374 (types kind)
375 (values-types (if (eq int *empty-type*) (res) int))
376 (if (eq kind :unknown)
377 (annotate-unknown-values-continuation cont policy)
378 (annotate-fixed-values-continuation
379 cont policy
380 (mapcar #'primitive-type types))))))
381 (annotate-fixed-values-continuation cont policy types)))
382
383 (undefined-value))
384
385
386 ;;; LTN-Analyze-MV-Bind -- Internal
387 ;;;
388 ;;; Annotate the single argument continuation as a fixed-values
389 ;;; continuation. We look at the called lambda to determine number and type of
390 ;;; return values desired. It is assumed that only a function that
391 ;;; Looks-Like-An-MV-Bind will be converted to a local call.
392 ;;;
393 (defun ltn-analyze-mv-bind (call policy)
394 (declare (type mv-combination call)
395 (type policies policy))
396 (setf (basic-combination-kind call) :local)
397 (setf (node-tail-p call) nil)
398 (annotate-fixed-values-continuation
399 (first (basic-combination-args call)) policy
400 (mapcar #'(lambda (var)
401 (primitive-type (basic-var-type var)))
402 (lambda-vars
403 (ref-leaf
404 (continuation-use
405 (basic-combination-fun call))))))
406 (undefined-value))
407
408
409 ;;; LTN-Analyze-MV-Call -- Internal
410 ;;;
411 ;;; We force all the argument continuations to use the unknown values
412 ;;; convention. The continuations are annotated in reverse order, since the
413 ;;; last argument is on top, thus must be popped first. We disallow delayed
414 ;;; evaluation of the function continuation to simplify IR2 conversion of MV
415 ;;; call.
416 ;;;
417 ;;; We could be cleverer when we know the number of values returned by the
418 ;;; continuations, but optimizations of MV-Call are probably unworthwhile.
419 ;;;
420 ;;; We are also responsible for handling THROW, which is represented in IR1
421 ;;; as an mv-call to the %THROW funny function. We annotate the tag
422 ;;; continuation for a single value and the values continuation for unknown
423 ;;; values.
424 ;;;
425 (defun ltn-analyze-mv-call (call policy)
426 (declare (type mv-combination call))
427 (let ((fun (basic-combination-fun call))
428 (args (basic-combination-args call)))
429 (cond ((eq (continuation-function-name fun) '%throw)
430 (setf (basic-combination-info call) :funny)
431 (annotate-ordinary-continuation (first args) policy)
432 (annotate-unknown-values-continuation (second args) policy)
433 (setf (node-tail-p call) nil))
434 (t
435 (setf (basic-combination-info call) :full)
436 (annotate-function-continuation (basic-combination-fun call)
437 policy nil)
438 (dolist (arg (reverse args))
439 (annotate-unknown-values-continuation arg policy))
440 (flush-full-call-tail-transfer call))))
441
442 (undefined-value))
443
444
445 ;;; LTN-Analyze-Local-Call -- Internal
446 ;;;
447 ;;; Annotate the arguments as ordinary single-value continuations. And check
448 ;;; the successor.
449 ;;;
450 (defun ltn-analyze-local-call (call policy)
451 (declare (type combination call)
452 (type policies policy))
453 (setf (basic-combination-info call) :local)
454
455 (dolist (arg (basic-combination-args call))
456 (when arg
457 (annotate-ordinary-continuation arg policy)))
458
459 (when (node-tail-p call)
460 (set-tail-local-call-successor call))
461 (undefined-value))
462
463
464 ;;; SET-TAIL-LOCAL-CALL-SUCCESSOR -- Interface
465 ;;;
466 ;;; Make sure that a tail local call is linked directly to the bind
467 ;;; node. Usually it will be, but calls from XEPs and calls that might have
468 ;;; needed a cleanup after them won't have been swung over yet, since we
469 ;;; weren't sure they would really be TR until now. Also called by byte
470 ;;; compiler.
471 ;;;
472 (defun set-tail-local-call-successor (call)
473 (let ((caller (node-home-lambda call))
474 (callee (combination-lambda call)))
475 (assert (eq (lambda-tail-set caller)
476 (lambda-tail-set (lambda-home callee))))
477 (node-ends-block call)
478 (let ((block (node-block call)))
479 (unlink-blocks block (first (block-succ block)))
480 (link-blocks block (node-block (lambda-bind callee)))))
481 (undefined-value))
482
483
484 ;;; LTN-Analyze-Set -- Internal
485 ;;;
486 ;;; Annotate the value continuation.
487 ;;;
488 (defun ltn-analyze-set (node policy)
489 (declare (type cset node) (type policies policy))
490 (setf (node-tail-p node) nil)
491 (annotate-ordinary-continuation (set-value node) policy)
492 (undefined-value))
493
494
495 ;;; LTN-Analyze-If -- Internal
496 ;;;
497 ;;; If the only use of the Test continuation is a combination annotated with
498 ;;; a conditional template, then don't annotate the continuation so that IR2
499 ;;; conversion knows not to emit any code, otherwise annotate as an ordinary
500 ;;; continuation. Since we only use a conditional template if the call
501 ;;; immediately precedes the IF node in the same block, we know that any
502 ;;; predicate will already be annotated.
503 ;;;
504 (defun ltn-analyze-if (node policy)
505 (declare (type cif node) (type policies policy))
506 (setf (node-tail-p node) nil)
507 (let* ((test (if-test node))
508 (use (continuation-use test)))
509 (unless (and (combination-p use)
510 (let ((info (basic-combination-info use)))
511 (and (template-p info)
512 (eq (template-result-types info) :conditional))))
513 (annotate-ordinary-continuation test policy)))
514 (undefined-value))
515
516
517 ;;; LTN-Analyze-Exit -- Internal
518 ;;;
519 ;;; If there is a value continuation, then annotate it for unknown values.
520 ;;; In this case, the exit is non-local, since all other exits are deleted or
521 ;;; degenerate by this point.
522 ;;;
523 (defun ltn-analyze-exit (node policy)
524 (setf (node-tail-p node) nil)
525 (let ((value (exit-value node)))
526 (when value
527 (annotate-unknown-values-continuation value policy)))
528 (undefined-value))
529
530
531 ;;; LTN annotate %Unwind-Protect -- Internal
532 ;;;
533 ;;; We need a special method for %Unwind-Protect that ignores the cleanup
534 ;;; function. We don't annotate either arg, since we don't need them at
535 ;;; run-time.
536 ;;;
537 ;;; [The default is o.k. for %Catch, since environment analysis converted the
538 ;;; reference to the escape function into a constant reference to the
539 ;;; NLX-Info.]
540 ;;;
541 (defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node policy)
542 policy ; Ignore...
543 (setf (basic-combination-info node) :funny)
544 (setf (node-tail-p node) nil)
545 )
546
547
548 ;;; LTN annotate %Slot-Setter, %Slot-Accessor -- Internal
549 ;;;
550 ;;; Both of these functions need special LTN-annotate methods, since we only
551 ;;; want to clear the Type-Check in unsafe policies. If we allowed the call to
552 ;;; be annotated as a full call, then no type checking would be done.
553 ;;;
554 ;;; We also need a special LTN annotate method for %Slot-Setter so that the
555 ;;; function is ignored. This is because the reference to a SETF function
556 ;;; can't be delayed, so IR2 conversion would have already emitted a call to
557 ;;; FDEFINITION by the time the IR2 convert method got control.
558 ;;;
559 (defoptimizer (%slot-accessor ltn-annotate) ((struct) node policy)
560 (setf (basic-combination-info node) :funny)
561 (setf (node-tail-p node) nil)
562 (annotate-ordinary-continuation struct policy))
563 ;;;
564 (defoptimizer (%slot-setter ltn-annotate) ((struct value) node policy)
565 (setf (basic-combination-info node) :funny)
566 (setf (node-tail-p node) nil)
567 (annotate-ordinary-continuation struct policy)
568 (annotate-ordinary-continuation value policy))
569
570
571 ;;;; Known call annotation:
572
573 ;;; OPERAND-RESTRICTION-OK -- Interface
574 ;;;
575 ;;; Return true if Restr is satisfied by Type. If T-OK is true, then a T
576 ;;; restriction allows any operand type. This is also called by IR2tran when
577 ;;; it determines whether a result temporary needs to be made, and by
578 ;;; representation selection when it is deciding which move VOP to use.
579 ;;; Cont and TN are used to test for constant arguments.
580 ;;;
581 (declaim (inline operand-restriction-ok))
582 (defun operand-restriction-ok (restr type &key cont tn (t-ok t))
583 (declare (type (or (member *) cons) restr)
584 (type primitive-type type)
585 (type (or continuation null) cont)
586 (type (or tn null) tn))
587 (if (eq restr '*)
588 t
589 (ecase (first restr)
590 (:or
591 (dolist (mem (rest restr) nil)
592 (when (or (and t-ok (eq mem (backend-any-primitive-type *backend*)))
593 (eq mem type))
594 (return t))))
595 (:constant
596 (cond (cont
597 (and (constant-continuation-p cont)
598 (funcall (second restr) (continuation-value cont))))
599 (tn
600 (and (eq (tn-kind tn) :constant)
601 (funcall (second restr) (tn-value tn))))
602 (t
603 (error (intl:gettext "Neither CONT nor TN supplied."))))))))
604
605
606 ;;; Template-Args-OK -- Internal
607 ;;;
608 ;;; Check that the argument type restriction for Template are satisfied in
609 ;;; call. If an argument's TYPE-CHECK is :NO-CHECK and our policy is safe,
610 ;;; then only :SAFE templates are o.k.
611 ;;;
612 (defun template-args-ok (template call safe-p)
613 (declare (type template template)
614 (type combination call))
615 (let ((mtype (template-more-args-type template)))
616 (do ((args (basic-combination-args call) (cdr args))
617 (types (template-arg-types template) (cdr types)))
618 ((null types)
619 (cond ((null args) t)
620 ((not mtype) nil)
621 (t
622 (dolist (arg args t)
623 (unless (operand-restriction-ok mtype
624 (continuation-ptype arg))
625 (return nil))))))
626 (when (null args) (return nil))
627 (let ((arg (car args))
628 (type (car types)))
629 (when (and (eq (continuation-type-check arg) :no-check)
630 safe-p
631 (not (eq (template-policy template) :safe)))
632 (return nil))
633 (unless (operand-restriction-ok type (continuation-ptype arg)
634 :cont arg)
635 (return nil))))))
636
637
638 ;;; Template-Results-OK -- Internal
639 ;;;
640 ;;; Check that Template can be used with the specifed Result-Type. Result
641 ;;; type checking is pretty different from argument type checking due to the
642 ;;; relaxed rules for values count. We succeed if for each required result,
643 ;;; there is a positional restriction on the value that is at least as good.
644 ;;; If we run out of result types before we run out of restrictions, then we
645 ;;; only suceed if the leftover restrictions are *. If we run out of
646 ;;; restrictions before we run out of result types, then we always win.
647 ;;;
648 (defun template-results-ok (template result-type)
649 (declare (type template template)
650 (type ctype result-type))
651 (when (template-more-results-type template)
652 (error (intl:gettext "~S has :MORE results with :TRANSLATE.") (template-name template)))
653 (let ((types (template-result-types template)))
654 (cond
655 ((values-type-p result-type)
656 (do ((ltypes (append (args-type-required result-type)
657 (args-type-optional result-type))
658 (rest ltypes))
659 (types types (rest types)))
660 ((null ltypes)
661 (dolist (type types t)
662 (unless (eq type '*)
663 (return nil))))
664 (when (null types) (return t))
665 (let ((type (first types)))
666 (unless (operand-restriction-ok type
667 (primitive-type (first ltypes)))
668 (return nil)))))
669 (types
670 (operand-restriction-ok (first types) (primitive-type result-type)))
671 (t t))))
672
673
674 ;;; IS-OK-TEMPLATE-USE -- Internal
675 ;;;
676 ;;; Return true if Call is an ok use of Template according to Safe-P.
677 ;;; -- If the template has a Guard that isn't true, then we ignore the
678 ;;; template, not even considering it to be rejected.
679 ;;; -- If the argument type restrictions aren't satisfied, then we reject the
680 ;;; template.
681 ;;; -- If the template is :Conditional, then we accept it only when the
682 ;;; destination of the value is an immediately following IF node.
683 ;;; -- If either the template is safe or the policy is unsafe (i.e. we can
684 ;;; believe output assertions), then we test against the intersection of the
685 ;;; node derived type and the continuation asserted type. Otherwise, we
686 ;;; just use the node type. If TYPE-CHECK is null, there is no point in
687 ;;; doing the intersection, since the node type must be a subtype of the
688 ;;; assertion.
689 ;;;
690 ;;; If the template is *not* ok, then the second value is a keyword indicating
691 ;;; which aspect failed.
692 ;;;
693 (defun is-ok-template-use (template call safe-p)
694 (declare (type template template) (type combination call))
695 (let* ((guard (template-guard template))
696 (cont (node-cont call))
697 (atype (continuation-asserted-type cont))
698 (dtype (node-derived-type call)))
699 (cond ((and guard (not (funcall guard)))
700 (values nil :guard))
701 ((not (template-args-ok template call safe-p))
702 (values nil
703 (if (and safe-p (template-args-ok template call nil))
704 :arg-check
705 :arg-types)))
706 ((eq (template-result-types template) :conditional)
707 (let ((dest (continuation-dest cont)))
708 (if (and (if-p dest)
709 (immediately-used-p (if-test dest) call))
710 (values t nil)
711 (values nil :conditional))))
712 ((template-results-ok
713 template
714 (if (and (or (eq (template-policy template) :safe)
715 (not safe-p))
716 (continuation-type-check cont))
717 (values-type-intersection dtype atype)
718 dtype))
719 (values t nil))
720 (t
721 (values nil :result-types)))))
722
723
724 ;;; Find-Template -- Internal
725 ;;;
726 ;;; Use operand type information to choose a template from the list
727 ;;; Templates for a known Call. We return three values:
728 ;;; 1] The template we found.
729 ;;; 2] Some template that we rejected due to unsatisfied type restrictions, or
730 ;;; NIL if none.
731 ;;; 3] The tail of Templates for templates we haven't examined yet.
732 ;;;
733 ;;; We just call IS-OK-TEMPLATE-USE until it returns true.
734 ;;;
735 (defun find-template (templates call safe-p)
736 (declare (list templates) (type combination call))
737 (do ((templates templates (rest templates))
738 (rejected nil))
739 ((null templates)
740 (values nil rejected nil))
741 (let ((template (first templates)))
742 (when (is-ok-template-use template call safe-p)
743 (return (values template rejected (rest templates))))
744 (setq rejected template))))
745
746
747 ;;; Find-Template-For-Policy -- Internal
748 ;;;
749 ;;; Given a partially annotated known call and a translation policy, return
750 ;;; the appropriate template, or NIL if none can be found. We scan the
751 ;;; templates (ordered by increasing cost) looking for a template whose
752 ;;; restrictions are satisfied and that has our policy.
753 ;;;
754 ;;; If we find a template that doesn't have our policy, but has a legal
755 ;;; alternate policy, then we also record that to return as a last resort. If
756 ;;; our policy is safe, then only safe policies are O.K., otherwise anything
757 ;;; goes.
758 ;;;
759 ;;; If we find a template with :SAFE policy, then we return it, or any cheaper
760 ;;; fallback template. The theory behind this is that if it is cheapest, small
761 ;;; and safe, we can't lose. If it is not cheapest, then we use the fallback,
762 ;;; which won't have the desired policy, but :SAFE isn't desired either, so we
763 ;;; might as well go with the cheaper one. The main reason for doing this is
764 ;;; to make sure that cheap safe templates are used when they apply and the
765 ;;; current policy is something else. This is useful because :SAFE has the
766 ;;; additional semantics of implicit argument type checking, so we may be
767 ;;; forced to define a template with :SAFE policy when it is really small and
768 ;;; fast as well.
769 ;;;
770 (defun find-template-for-policy (call policy)
771 (declare (type combination call)
772 (type policies policy))
773 (let ((safe-p (policy-safe-p policy)))
774 (let ((current (function-info-templates (basic-combination-kind call)))
775 (fallback nil)
776 (rejected nil))
777 (loop
778 (multiple-value-bind (template this-reject more)
779 (find-template current call safe-p)
780 (unless rejected
781 (setq rejected this-reject))
782 (setq current more)
783 (unless template
784 (return (values fallback rejected)))
785
786 (let ((tpolicy (template-policy template)))
787 (cond ((eq tpolicy policy)
788 (return (values template rejected)))
789 ((eq tpolicy :safe)
790 (return (values (or fallback template) rejected)))
791 ((or (not safe-p) (eq tpolicy :fast-safe))
792 (unless fallback
793 (setq fallback template))))))))))
794
795
796 (defvar *efficiency-note-limit* 2
797 "This is the maximum number of possible optimization alternatives will be
798 mentioned in a particular efficiency note. NIL means no limit.")
799 (declaim (type (or index null) *efficiency-note-limit*))
800
801 (defvar *efficiency-note-cost-threshold* 5
802 "This is the minumum cost difference between the chosen implementation and
803 the next alternative that justifies an efficiency note.")
804 (declaim (type index *efficiency-note-cost-threshold*))
805
806
807 ;;; STRANGE-TEMPLATE-FAILURE -- Internal
808 ;;;
809 ;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't figure
810 ;;; out any reason why Template was rejected. Users should never see these
811 ;;; messages, but they can happen in situations where the VM definition is
812 ;;; messed up somehow.
813 ;;;
814 (defun strange-template-failure (template call policy frob)
815 (declare (type template template) (type combination call)
816 (type policies policy) (type function frob))
817 (funcall frob (intl:gettext "This shouldn't happen! Bug?"))
818 (multiple-value-bind (win why)
819 (is-ok-template-use template call
820 (policy-safe-p policy))
821 (assert (not win))
822 (ecase why
823 (:guard
824 (funcall frob (intl:gettext "Template guard failed.")))
825 (:arg-check
826 (funcall frob (intl:gettext "Template is not safe, yet we were counting on it.")))
827 (:arg-types
828 (funcall frob (intl:gettext "Argument types invalid."))
829 (funcall frob (intl:gettext "Argument primitive types:~% ~S")
830 (mapcar #'(lambda (x)
831 (primitive-type-name
832 (continuation-ptype x)))
833 (combination-args call)))
834 (funcall frob (intl:gettext "Argument type assertions:~% ~S")
835 (mapcar #'(lambda (x)
836 (if (atom x)
837 x
838 (ecase (car x)
839 (:or `(:or .,(mapcar #'primitive-type-name
840 (cdr x))))
841 (:constant `(:constant ,(third x))))))
842 (template-arg-types template))))
843 (:conditional
844 (funcall frob (intl:gettext "Conditional in a non-conditional context.")))
845 (:result-types
846 (funcall frob (intl:gettext "Result types invalid."))))))
847
848
849 ;;; Note-Rejected-Templates -- Internal
850 ;;;
851 ;;; This function emits efficiency notes describing all of the templates
852 ;;; better (faster) than Template that we might have been able to use if there
853 ;;; were better type declarations. Template is null when we didn't find any
854 ;;; template, and thus must do a full call.
855 ;;;
856 ;;; In order to be worth complaining about, a template must:
857 ;;; -- be allowed by its guard,
858 ;;; -- be safe if the current policy is safe,
859 ;;; -- have argument/result type restrictions consistent with the known type
860 ;;; information, e.g. we don't consider float templates when an operand is
861 ;;; known to be an integer,
862 ;;; -- be disallowed by the stricter operand subtype test (which resembles, but
863 ;;; is not identical to the test done by Find-Template.)
864 ;;;
865 ;;; Note that there may not be any possibly applicable templates, since we are
866 ;;; called whenever any template is rejected. That template might have the
867 ;;; wrong policy or be inconsistent with the known type.
868 ;;;
869 ;;; We go to some trouble to make the whole multi-line output into a single
870 ;;; call to Compiler-Note so that repeat messages are suppressed, etc.
871 ;;;
872 (defun note-rejected-templates (call policy template)
873 (declare (type combination call) (type policies policy)
874 (type (or template null) template))
875
876 (collect ((losers))
877 (let ((safe-p (eq policy :safe))
878 (verbose-p (policy call (= brevity 0)))
879 (max-cost (- (template-cost
880 (or template
881 (template-or-lose 'call-named *backend*)))
882 *efficiency-note-cost-threshold*)))
883 (dolist (try (function-info-templates (basic-combination-kind call)))
884 (when (> (template-cost try) max-cost) (return))
885 (let ((guard (template-guard try)))
886 (when (and (or (not guard) (funcall guard))
887 (or (not safe-p)
888 (eq :safe (template-policy try)))
889 (or verbose-p
890 (and (template-note try)
891 (valid-function-use
892 call (template-type try)
893 :argument-test #'types-intersect
894 :result-test #'values-types-intersect))))
895 (losers try)))))
896
897 (when (losers)
898 (collect ((messages)
899 (count 0 +))
900 (flet ((frob (string &rest stuff)
901 (messages string)
902 (messages stuff)))
903 (dolist (loser (losers))
904 (when (and *efficiency-note-limit*
905 (>= (count) *efficiency-note-limit*))
906 (frob (intl:gettext "etc."))
907 (return))
908 (let* ((type (template-type loser))
909 (valid (valid-function-use call type))
910 (strict-valid (valid-function-use call type
911 :strict-result t)))
912 (frob (intl:gettext "Unable to do ~A (cost ~D) because:")
913 (intl:dgettext (template-note-domain loser)
914 (or (template-note loser) (template-name loser)))
915 (template-cost loser))
916 (cond
917 ((and valid strict-valid)
918 (strange-template-failure loser call policy #'frob))
919 ((not valid)
920 (assert (not (valid-function-use call type
921 :error-function #'frob
922 :warning-function #'frob))))
923 (t
924 (assert (policy-safe-p policy))
925 (frob (intl:gettext "Can't trust output type assertion under safe ~
926 policy."))))
927 (count 1))))
928
929 (let ((*compiler-error-context* call))
930 (efficiency-note "~{~?~^~&~6T~}"
931 (if template
932 (list* (intl:gettext "Forced to do ~A (cost ~D).")
933 `(,(or (template-note template)
934 (template-name template))
935 ,(template-cost template))
936 (messages))
937 (list* (intl:gettext "Forced to do full call.")
938 nil
939 (messages))))))))
940 (undefined-value))
941
942
943
944 ;;; Flush-Type-Checks-According-To-Policy -- Internal
945 ;;;
946 ;;; Flush type checks according to policy. If the policy is
947 ;;; unsafe, then we never do any checks. If our policy is safe, and
948 ;;; we are using a safe template, then we can also flush arg and
949 ;;; result type checks. Result type checks are only flushed when the
950 ;;; continuation as a single use. Result type checks are not flush if
951 ;;; the policy is safe because the selection of template for results
952 ;;; readers assumes the type check is done (uses the derived type
953 ;;; which is the intersection of the proven and asserted types).
954 ;;;
955 (defun flush-type-checks-according-to-policy (call policy template)
956 (declare (type combination call) (type policies policy)
957 (type template template))
958 (let ((safe-op (eq (template-policy template) :safe)))
959 (when (or (not (policy-safe-p policy)) safe-op)
960 (dolist (arg (basic-combination-args call))
961 (flush-type-check arg)))
962 (when safe-op
963 (let ((cont (node-cont call)))
964 (when (and (eq (continuation-use cont) call)
965 (not (policy-safe-p policy)))
966 (flush-type-check cont)))))
967
968 (undefined-value))
969
970
971 ;;; LTN-Analyze-Known-Call -- Internal
972 ;;;
973 ;;; If a function has a special-case annotation method use that, otherwise
974 ;;; annotate the argument continuations and try to find a template
975 ;;; corresponding to the type signature. If there is none, convert a full
976 ;;; call.
977 ;;;
978 ;;; If we are unable to use some templates due to unstatisfied operand type
979 ;;; restrictions and our policy enables efficiency notes, then we call
980 ;;; Note-Rejected-Templates.
981 ;;;
982 ;;; If we are forced to do a full call, we check to see if the function
983 ;;; called is the same as the current function. If so, we give a warning, as
984 ;;; this is probably a botched interpreter stub.
985 ;;;
986 (defun ltn-analyze-known-call (call policy)
987 (declare (type combination call)
988 (type policies policy))
989 (let ((method (function-info-ltn-annotate (basic-combination-kind call)))
990 (args (basic-combination-args call)))
991 (when method
992 (funcall method call policy)
993 (return-from ltn-analyze-known-call (undefined-value)))
994
995 (dolist (arg args)
996 (setf (continuation-info arg)
997 (make-ir2-continuation (primitive-type (continuation-type arg)))))
998
999 (multiple-value-bind (template rejected)
1000 (find-template-for-policy call policy)
1001 (when (and rejected
1002 (policy call (> speed brevity)))
1003 (note-rejected-templates call policy template))
1004 (unless template
1005 (when (and (eq (continuation-function-name (combination-fun call))
1006 (leaf-name
1007 (environment-function
1008 (node-environment call))))
1009 (let ((info (basic-combination-kind call)))
1010 (not (or (function-info-ir2-convert info)
1011 (ir1-attributep (function-info-attributes info)
1012 recursive)))))
1013 (let ((*compiler-error-context* call))
1014 (compiler-warning _N"Recursive known function definition.")))
1015 (ltn-default-call call policy)
1016 (return-from ltn-analyze-known-call (undefined-value)))
1017 (setf (basic-combination-info call) template)
1018 (setf (node-tail-p call) nil)
1019
1020 (flush-type-checks-according-to-policy call policy template)
1021
1022 (dolist (arg args)
1023 (annotate-1-value-continuation arg))))
1024
1025 (undefined-value))
1026
1027
1028 ;;;; Interfaces:
1029
1030 (eval-when (compile eval)
1031
1032 ;;; LTN-Analyze-Block-Macro -- Internal
1033 ;;;
1034 ;;; We make the main per-block code in for LTN into a macro so that it can
1035 ;;; be shared between LTN-Analyze and LTN-Analyze-Block, yet can cache policy
1036 ;;; across blocks in the normal (full component) case.
1037 ;;;
1038 ;;; This code computes the policy and then dispatches to the appropriate
1039 ;;; node-specific function.
1040 ;;;
1041 ;;; Note: we deliberately don't use the DO-NODES macro, since the block can be
1042 ;;; split out from underneath us, and DO-NODES scans past the block end in this
1043 ;;; case.
1044 ;;;
1045 (defmacro ltn-analyze-block-macro ()
1046 '(do* ((node (continuation-next (block-start block))
1047 (continuation-next cont))
1048 (cont (node-cont node) (node-cont node)))
1049 (())
1050 (unless (eq (node-lexenv node) lexenv)
1051 (setq policy (translation-policy node))
1052 (setq lexenv (node-lexenv node)))
1053
1054 (etypecase node
1055 (ref)
1056 (combination
1057 (case (basic-combination-kind node)
1058 (:local (ltn-analyze-local-call node policy))
1059 ((:full :error) (ltn-default-call node policy))
1060 (t
1061 (ltn-analyze-known-call node policy))))
1062 (cif
1063 (ltn-analyze-if node policy))
1064 (creturn
1065 (ltn-analyze-return node policy))
1066 ((or bind entry))
1067 (exit
1068 (ltn-analyze-exit node policy))
1069 (cset (ltn-analyze-set node policy))
1070 (mv-combination
1071 (ecase (basic-combination-kind node)
1072 (:local (ltn-analyze-mv-bind node policy))
1073 ((:full :error) (ltn-analyze-mv-call node policy)))))
1074
1075 (when (eq node (block-last block)) (return))))
1076
1077 ); Eval-When (Compile Eval)
1078
1079
1080 ;;; LTN-Analyze -- Interface
1081 ;;;
1082 ;;; Loop over the blocks in Component, doing stuff to nodes that receive
1083 ;;; values. In addition to the stuff done by LTN-Analyze-Block-Macro, we also
1084 ;;; see if there are any unknown values receivers, making notations in the
1085 ;;; components Generators and Receivers as appropriate.
1086 ;;;
1087 ;;; If any unknown-values continations are received by this block (as
1088 ;;; indicated by IR2-Block-Popped, then we add the block to the
1089 ;;; IR2-Component-Values-Receivers.
1090 ;;;
1091 ;;; This is where we allocate IR2 blocks because it is the first place we
1092 ;;; need them.
1093 ;;;
1094 (defun ltn-analyze (component)
1095 (declare (type component component))
1096 (let ((2comp (component-info component))
1097 (lexenv nil)
1098 policy)
1099 (do-blocks (block component)
1100 (assert (not (block-info block)))
1101 (let ((2block (make-ir2-block block)))
1102 (setf (block-info block) 2block)
1103 (ltn-analyze-block-macro)
1104 (let ((popped (ir2-block-popped 2block)))
1105 (when popped
1106 (push block (ir2-component-values-receivers 2comp)))))))
1107 (undefined-value))
1108
1109
1110 ;;; LTN-Analyze-Block -- Interface
1111 ;;;
1112 ;;; This function is used to analyze blocks that must be added to the flow
1113 ;;; graph after the normal LTN phase runs. Such code is constrained not to
1114 ;;; use weird unknown values (and probably in lots of other ways).
1115 ;;;
1116 (defun ltn-analyze-block (block)
1117 (declare (type cblock block))
1118 (let ((lexenv nil)
1119 policy)
1120 (ltn-analyze-block-macro))
1121
1122 (assert (not (ir2-block-popped (block-info block))))
1123 (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5