1.0.35.8: Fix FILE-POSITION on simple-streams after READ-VECTOR
[sbcl/smoofra.git] / src / compiler / checkgen.lisp
blob46b32e11cc9140e1729c6309e1f3fe792f99283d
1 ;;;; This file implements type check generation. This is a phase that
2 ;;;; runs at the very end of IR1. If a type check is too complex for
3 ;;;; the back end to directly emit in-line, then we transform the check
4 ;;;; into an explicit conditional using TYPEP.
6 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; more information.
8 ;;;;
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
15 (in-package "SB!C")
17 ;;;; cost estimation
19 ;;; Return some sort of guess about the cost of a call to a function.
20 ;;; If the function has some templates, we return the cost of the
21 ;;; cheapest one, otherwise we return the cost of CALL-NAMED. Calling
22 ;;; this with functions that have transforms can result in relatively
23 ;;; meaningless results (exaggerated costs.)
24 ;;;
25 ;;; We special-case NULL, since it does have a source tranform and is
26 ;;; interesting to us.
27 (defun fun-guessed-cost (name)
28 (declare (symbol name))
29 (let ((info (info :function :info name))
30 (call-cost (template-cost (template-or-lose 'call-named))))
31 (if info
32 (let ((templates (fun-info-templates info)))
33 (if templates
34 (template-cost (first templates))
35 (case name
36 (null (template-cost (template-or-lose 'if-eq)))
37 (t call-cost))))
38 call-cost)))
40 ;;; Return some sort of guess for the cost of doing a test against
41 ;;; TYPE. The result need not be precise as long as it isn't way out
42 ;;; in space. The units are based on the costs specified for various
43 ;;; templates in the VM definition.
44 (defun type-test-cost (type)
45 (declare (type ctype type))
46 (or (when (eq type *universal-type*)
48 (when (eq type *empty-type*)
50 (let ((check (type-check-template type)))
51 (if check
52 (template-cost check)
53 (let ((found (cdr (assoc type *backend-type-predicates*
54 :test #'type=))))
55 (if found
56 (+ (fun-guessed-cost found) (fun-guessed-cost 'eq))
57 nil))))
58 (typecase type
59 (compound-type
60 (reduce #'+ (compound-type-types type) :key 'type-test-cost))
61 (member-type
62 (* (member-type-size type)
63 (fun-guessed-cost 'eq)))
64 (numeric-type
65 (* (if (numeric-type-complexp type) 2 1)
66 (fun-guessed-cost
67 (if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp))
68 (+ 1
69 (if (numeric-type-low type) 1 0)
70 (if (numeric-type-high type) 1 0))))
71 (cons-type
72 (+ (type-test-cost (specifier-type 'cons))
73 (fun-guessed-cost 'car)
74 (type-test-cost (cons-type-car-type type))
75 (fun-guessed-cost 'cdr)
76 (type-test-cost (cons-type-cdr-type type))))
78 (fun-guessed-cost 'typep)))))
80 (defun weaken-integer-type (type)
81 (cond ((union-type-p type)
82 (let* ((types (union-type-types type))
83 (one (pop types))
84 (low (numeric-type-low one))
85 (high (numeric-type-high one)))
86 (flet ((maximize (bound)
87 (if (and bound high)
88 (setf high (max high bound))
89 (setf high nil)))
90 (minimize (bound)
91 (if (and bound low)
92 (setf low (min low bound))
93 (setf low nil))))
94 (dolist (a types)
95 (minimize (numeric-type-low a))
96 (maximize (numeric-type-high a))))
97 (specifier-type `(integer ,(or low '*) ,(or high '*)))))
99 (aver (integer-type-p type))
100 type)))
102 (defun-cached
103 (weaken-type :hash-bits 8
104 :hash-function (lambda (x)
105 (logand (type-hash-value x) #xFF)))
106 ((type eq))
107 (declare (type ctype type))
108 (cond ((named-type-p type)
109 type)
110 ((csubtypep type (specifier-type 'integer))
111 ;; KLUDGE: Simple range checks are not that expensive, and we *don't*
112 ;; want to accidentally lose eg. array bounds checks due to weakening,
113 ;; so for integer types we simply collapse all ranges into one.
114 (weaken-integer-type type))
116 (let ((min-cost (type-test-cost type))
117 (min-type type)
118 (found-super nil))
119 (dolist (x *backend-type-predicates*)
120 (let* ((stype (car x))
121 (samep (type= stype type)))
122 (when (or samep
123 (and (csubtypep type stype)
124 (not (union-type-p stype))))
125 (let ((stype-cost (type-test-cost stype)))
126 (when (or (< stype-cost min-cost)
127 samep)
128 ;; If the supertype is equal in cost to the type, we
129 ;; prefer the supertype. This produces a closer
130 ;; approximation of the right thing in the presence of
131 ;; poor cost info.
132 (setq found-super t
133 min-type stype
134 min-cost stype-cost))))))
135 ;; This used to return the *UNIVERSAL-TYPE* if no supertype was found,
136 ;; but that's too liberal: it's far too easy for the user to create
137 ;; a union type (which are excluded above), and then trick the compiler
138 ;; into trusting the union type... and finally ending up corrupting the
139 ;; heap once a bad object sneaks past the missing type check.
140 (if found-super
141 min-type
142 type)))))
144 (defun weaken-values-type (type)
145 (declare (type ctype type))
146 (cond ((eq type *wild-type*) type)
147 ((not (values-type-p type))
148 (weaken-type type))
150 (make-values-type :required (mapcar #'weaken-type
151 (values-type-required type))
152 :optional (mapcar #'weaken-type
153 (values-type-optional type))
154 :rest (acond ((values-type-rest type)
155 (weaken-type it)))))))
157 ;;;; checking strategy determination
159 ;;; Return the type we should test for when we really want to check
160 ;;; for TYPE. If type checking policy is "fast", then we return a
161 ;;; weaker type if it is easier to check. First we try the defined
162 ;;; type weakenings, then look for any predicate that is cheaper.
163 (defun maybe-weaken-check (type policy)
164 (declare (type ctype type))
165 (ecase (policy policy type-check)
166 (0 *wild-type*)
167 (2 (weaken-values-type type))
168 (3 type)))
170 ;;; This is like VALUES-TYPES, only we mash any complex function types
171 ;;; to FUNCTION.
172 (defun no-fun-values-types (type)
173 (declare (type ctype type))
174 (multiple-value-bind (res count) (values-types type)
175 (values (mapcar (lambda (type)
176 (if (fun-type-p type)
177 (specifier-type 'function)
178 type))
179 res)
180 count)))
182 ;;; Switch to disable check complementing, for evaluation.
183 (defvar *complement-type-checks* t)
185 ;;; LVAR is an lvar we are doing a type check on and TYPES is a list
186 ;;; of types that we are checking its values against. If we have
187 ;;; proven that LVAR generates a fixed number of values, then for each
188 ;;; value, we check whether it is cheaper to then difference between
189 ;;; the proven type and the corresponding type in TYPES. If so, we opt
190 ;;; for a :HAIRY check with that test negated. Otherwise, we try to do
191 ;;; a simple test, and if that is impossible, we do a hairy test with
192 ;;; non-negated types. If true, FORCE-HAIRY forces a hairy type check.
193 (defun maybe-negate-check (lvar types original-types force-hairy n-required)
194 (declare (type lvar lvar) (list types original-types))
195 (let ((ptypes (values-type-out (lvar-derived-type lvar) (length types))))
196 (multiple-value-bind (hairy-res simple-res)
197 (loop for p in ptypes
198 and c in types
199 and a in original-types
200 and i from 0
201 for cc = (if (>= i n-required)
202 (type-union c (specifier-type 'null))
204 for diff = (type-difference p cc)
205 collect (if (and diff
206 (< (type-test-cost diff)
207 (type-test-cost cc))
208 *complement-type-checks*)
209 (list t diff a)
210 (list nil cc a))
211 into hairy-res
212 collect cc into simple-res
213 finally (return (values hairy-res simple-res)))
214 (cond ((or force-hairy (find-if #'first hairy-res))
215 (values :hairy hairy-res))
216 ((every #'type-check-template simple-res)
217 (values :simple simple-res))
219 (values :hairy hairy-res))))))
221 ;;; Determines whether CAST's assertion is:
222 ;;; -- checkable by the back end (:SIMPLE), or
223 ;;; -- not checkable by the back end, but checkable via an explicit
224 ;;; test in type check conversion (:HAIRY), or
225 ;;; -- not reasonably checkable at all (:TOO-HAIRY).
227 ;;; We may check only fixed number of values; in any case the number
228 ;;; of generated values is trusted. If we know the number of produced
229 ;;; values, all of them are checked; otherwise if we know the number
230 ;;; of consumed -- only they are checked; otherwise the check is not
231 ;;; performed.
233 ;;; A type is simply checkable if all the type assertions have a
234 ;;; TYPE-CHECK-TEMPLATE. In this :SIMPLE case, the second value is a
235 ;;; list of the type restrictions specified for the leading positional
236 ;;; values.
238 ;;; Old comment:
240 ;;; We force a check to be hairy even when there are fixed values
241 ;;; if we are in a context where we may be forced to use the
242 ;;; unknown values convention anyway. This is because IR2tran can't
243 ;;; generate type checks for unknown values lvars but people could
244 ;;; still be depending on the check being done. We only care about
245 ;;; EXIT and RETURN (not MV-COMBINATION) since these are the only
246 ;;; contexts where the ultimate values receiver
248 ;;; In the :HAIRY case, the second value is a list of triples of
249 ;;; the form:
250 ;;; (NOT-P TYPE ORIGINAL-TYPE)
252 ;;; If true, the NOT-P flag indicates a test that the corresponding
253 ;;; value is *not* of the specified TYPE. ORIGINAL-TYPE is the type
254 ;;; asserted on this value in the lvar, for use in error
255 ;;; messages. When NOT-P is true, this will be different from TYPE.
257 ;;; This allows us to take what has been proven about CAST's argument
258 ;;; type into consideration. If it is cheaper to test for the
259 ;;; difference between the derived type and the asserted type, then we
260 ;;; check for the negation of this type instead.
261 (defun cast-check-types (cast force-hairy)
262 (declare (type cast cast))
263 (let* ((ctype (coerce-to-values (cast-type-to-check cast)))
264 (atype (coerce-to-values (cast-asserted-type cast)))
265 (dtype (node-derived-type cast))
266 (value (cast-value cast))
267 (lvar (node-lvar cast))
268 (dest (and lvar (lvar-dest lvar)))
269 (n-consumed (cond ((not lvar)
270 nil)
271 ((lvar-single-value-p lvar)
273 ((and (mv-combination-p dest)
274 (eq (mv-combination-kind dest) :local))
275 (let ((fun-ref (lvar-use (mv-combination-fun dest))))
276 (length (lambda-vars (ref-leaf fun-ref)))))))
277 (n-required (length (values-type-required dtype))))
278 (aver (not (eq ctype *wild-type*)))
279 (cond ((and (null (values-type-optional dtype))
280 (not (values-type-rest dtype)))
281 ;; we [almost] know how many values are produced
282 (maybe-negate-check value
283 (values-type-out ctype n-required)
284 (values-type-out atype n-required)
285 ;; backend checks only consumed values
286 (not (eql n-required n-consumed))
287 n-required))
288 ((lvar-single-value-p lvar)
289 ;; exactly one value is consumed
290 (principal-lvar-single-valuify lvar)
291 (flet ((get-type (type)
292 (acond ((args-type-required type)
293 (car it))
294 ((args-type-optional type)
295 (car it))
296 (t (bug "type ~S is too hairy" type)))))
297 (multiple-value-bind (ctype atype)
298 (values (get-type ctype) (get-type atype))
299 (maybe-negate-check value
300 (list ctype) (list atype)
301 force-hairy
302 n-required))))
303 ((and (mv-combination-p dest)
304 (eq (mv-combination-kind dest) :local))
305 ;; we know the number of consumed values
306 (maybe-negate-check value
307 (adjust-list (values-type-types ctype)
308 n-consumed
309 *universal-type*)
310 (adjust-list (values-type-types atype)
311 n-consumed
312 *universal-type*)
313 force-hairy
314 n-required))
316 (values :too-hairy nil)))))
318 ;;; Return T is the cast appears to be from the declaration of the callee,
319 ;;; and should be checked externally -- that is, by the callee and not the caller.
320 (defun cast-externally-checkable-p (cast)
321 (declare (type cast cast))
322 (let* ((lvar (node-lvar cast))
323 (dest (and lvar (lvar-dest lvar))))
324 (and (combination-p dest)
325 ;; The theory is that the type assertion is from a declaration on the
326 ;; callee, so the callee should be able to do the check. We want to
327 ;; let the callee do the check, because it is possible that by the
328 ;; time of call that declaration will be changed and we do not want
329 ;; to make people recompile all calls to a function when they were
330 ;; originally compiled with a bad declaration.
332 ;; ALMOST-IMMEDIATELY-USED-P ensures that we don't delegate casts
333 ;; that occur before nodes that can cause observable side effects --
334 ;; most commonly other non-external casts: so the order in which
335 ;; possible type errors are signalled matches with the evaluation
336 ;; order.
338 ;; FIXME: We should let more cases be handled by the callee then we
339 ;; currently do, see: https://bugs.launchpad.net/sbcl/+bug/309104
340 ;; This is not fixable quite here, though, because flow-analysis has
341 ;; deleted the LVAR of the cast by the time we get here, so there is
342 ;; no destination. Perhaps we should mark cases inserted by
343 ;; ASSERT-CALL-TYPE explicitly, and delete those whose destination is
344 ;; deemed unreachable?
345 (almost-immediately-used-p lvar cast)
346 (values (values-subtypep (lvar-externally-checkable-type lvar)
347 (cast-type-to-check cast))))))
349 ;;; Return true if CAST's value is an lvar whose type the back end is
350 ;;; likely to be able to check (see GENERATE-TYPE-CHECKS). Since we
351 ;;; don't know what template the back end is going to choose to
352 ;;; implement the continuation's DEST, we use a heuristic.
354 ;;; We always return T unless nobody uses the value (the backend
355 ;;; cannot check unused LVAR chains).
357 ;;; The logic used to be more complex, but most of the cases that used
358 ;;; to be checked here are now dealt with differently . FIXME: but
359 ;;; here's one we used to do, don't anymore, but could still benefit
360 ;;; from, if we reimplemented it (elsewhere):
362 ;;; -- If the lvar is an argument to a known function that has
363 ;;; no IR2-CONVERT method or :FAST-SAFE templates that are
364 ;;; compatible with the call's type: return NIL.
366 ;;; The code used to look like something like this:
367 ;;; ...
368 ;;; (:known
369 ;;; (let ((info (basic-combination-fun-info dest)))
370 ;;; (if (fun-info-ir2-convert info)
371 ;;; t
372 ;;; (dolist (template (fun-info-templates info) nil)
373 ;;; (when (eq (template-ltn-policy template)
374 ;;; :fast-safe)
375 ;;; (multiple-value-bind (val win)
376 ;;; (valid-fun-use dest (template-type template))
377 ;;; (when (or val (not win)) (return t)))))))))))))
379 ;;; ADP says: It is still interesting. When we have a :SAFE template
380 ;;; and the type assertion is derived from the destination function
381 ;;; type, the check is unneccessary. We cannot return NIL here (the
382 ;;; whole function has changed its meaning, and here NIL *forces*
383 ;;; hairy check), but the functionality is interesting.
384 (defun probable-type-check-p (cast)
385 (declare (type cast cast))
386 (let* ((lvar (node-lvar cast))
387 (dest (and lvar (lvar-dest lvar))))
388 (cond ((not dest) nil)
389 (t t))))
391 ;;; Return a lambda form that we can convert to do a hairy type check
392 ;;; of the specified TYPES. TYPES is a list of the format returned by
393 ;;; LVAR-CHECK-TYPES in the :HAIRY case.
395 ;;; Note that we don't attempt to check for required values being
396 ;;; unsupplied. Such checking is impossible to efficiently do at the
397 ;;; source level because our fixed-values conventions are optimized
398 ;;; for the common MV-BIND case.
399 (defun make-type-check-form (types)
400 (let ((temps (make-gensym-list (length types))))
401 `(multiple-value-bind ,temps
402 'dummy
403 ,@(mapcar (lambda (temp type)
404 (let* ((spec
405 (let ((*unparse-fun-type-simplify* t))
406 (type-specifier (second type))))
407 (test (if (first type) `(not ,spec) spec)))
408 `(unless (typep ,temp ',test)
409 (%type-check-error
410 ,temp
411 ',(type-specifier (third type))))))
412 temps
413 types)
414 (values ,@temps))))
416 ;;; Splice in explicit type check code immediately before CAST. This
417 ;;; code receives the value(s) that were being passed to CAST-VALUE,
418 ;;; checks the type(s) of the value(s), then passes them further.
419 (defun convert-type-check (cast types)
420 (declare (type cast cast) (type list types))
421 (let ((value (cast-value cast))
422 (length (length types)))
423 (filter-lvar value (make-type-check-form types))
424 (reoptimize-lvar (cast-value cast))
425 (setf (cast-type-to-check cast) *wild-type*)
426 (setf (cast-%type-check cast) nil)
427 (let* ((atype (cast-asserted-type cast))
428 (atype (cond ((not (values-type-p atype))
429 atype)
430 ((= length 1)
431 (single-value-type atype))
433 (make-values-type
434 :required (values-type-out atype length)))))
435 (dtype (node-derived-type cast))
436 (dtype (make-values-type
437 :required (values-type-out dtype length))))
438 (setf (cast-asserted-type cast) atype)
439 (setf (node-derived-type cast) dtype)))
441 (values))
443 ;;; Check all possible arguments of CAST and emit type warnings for
444 ;;; those with type errors. If the value of USE is being used for a
445 ;;; variable binding, we figure out which one for source context. If
446 ;;; the value is a constant, we print it specially.
447 (defun cast-check-uses (cast)
448 (declare (type cast cast))
449 (let* ((lvar (node-lvar cast))
450 (dest (and lvar (lvar-dest lvar)))
451 (value (cast-value cast))
452 (atype (cast-asserted-type cast)))
453 (do-uses (use value)
454 (let ((dtype (node-derived-type use)))
455 (unless (values-types-equal-or-intersect dtype atype)
456 (let* ((*compiler-error-context* use)
457 (atype-spec (type-specifier atype))
458 (what (when (and (combination-p dest)
459 (eq (combination-kind dest) :local))
460 (let ((lambda (combination-lambda dest))
461 (pos (position-or-lose
462 lvar (combination-args dest))))
463 (format nil "~:[A possible~;The~] binding of ~S"
464 (and (lvar-has-single-use-p lvar)
465 (eq (functional-kind lambda) :let))
466 (leaf-source-name (elt (lambda-vars lambda)
467 pos)))))))
468 (cond ((and (ref-p use) (constant-p (ref-leaf use)))
469 (warn 'type-warning
470 :format-control
471 "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
472 :format-arguments
473 (list what atype-spec
474 (constant-value (ref-leaf use)))))
476 (warn 'type-warning
477 :format-control
478 "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
479 :format-arguments
480 (list what (type-specifier dtype) atype-spec)))))))))
481 (values))
483 ;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set,
484 ;;; looking for CASTs with TYPE-CHECK T. We do two mostly unrelated
485 ;;; things: detect compile-time type errors and determine if and how
486 ;;; to do run-time type checks.
488 ;;; If there is a compile-time type error, then we mark the CAST and
489 ;;; emit a warning if appropriate. This part loops over all the uses
490 ;;; of the continuation, since after we convert the check, the
491 ;;; :DELETED kind will inhibit warnings about the types of other uses.
493 ;;; If the cast is too complex to be checked by the back end, or is
494 ;;; better checked with explicit code, then convert to an explicit
495 ;;; test. Assertions that can checked by the back end are passed
496 ;;; through. Assertions that can't be tested are flamed about and
497 ;;; marked as not needing to be checked.
499 ;;; If we determine that a type check won't be done, then we set
500 ;;; TYPE-CHECK to :NO-CHECK. In the non-hairy cases, this is just to
501 ;;; prevent us from wasting time coming to the same conclusion again
502 ;;; on a later iteration. In the hairy case, we must indicate to LTN
503 ;;; that it must choose a safe implementation, since IR2 conversion
504 ;;; will choke on the check.
506 ;;; The generation of the type checks is delayed until all the type
507 ;;; check decisions have been made because the generation of the type
508 ;;; checks creates new nodes whose derived types aren't always updated
509 ;;; which may lead to inappropriate template choices due to the
510 ;;; modification of argument types.
511 (defun generate-type-checks (component)
512 (collect ((casts))
513 (do-blocks (block component)
514 (when (block-type-check block)
515 ;; CAST-EXTERNALLY-CHECKABLE-P wants the backward pass
516 (do-nodes-backwards (node nil block)
517 (when (and (cast-p node)
518 (cast-type-check node))
519 (cast-check-uses node)
520 (cond ((cast-externally-checkable-p node)
521 (setf (cast-%type-check node) :external))
523 ;; it is possible that NODE was marked :EXTERNAL by
524 ;; the previous pass
525 (setf (cast-%type-check node) t)
526 (casts (cons node (not (probable-type-check-p node))))))))
527 (setf (block-type-check block) nil)))
528 (dolist (cast (casts))
529 (destructuring-bind (cast . force-hairy) cast
530 (multiple-value-bind (check types)
531 (cast-check-types cast force-hairy)
532 (ecase check
533 (:simple)
534 (:hairy
535 (convert-type-check cast types))
536 (:too-hairy
537 (let ((*compiler-error-context* cast))
538 (when (policy cast (>= safety inhibit-warnings))
539 (compiler-notify
540 "type assertion too complex to check:~% ~S."
541 (type-specifier (coerce-to-values (cast-asserted-type cast))))))
542 (setf (cast-type-to-check cast) *wild-type*)
543 (setf (cast-%type-check cast) nil)))))))
544 (values))