1.0.32.14: fix build under clisp
[sbcl.git] / src / compiler / checkgen.lisp
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.
5
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.
14
15 (in-package "SB!C")
16 \f
17 ;;;; cost estimation
18
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)))
39
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*)
47         0)
48       (when (eq type *empty-type*)
49         0)
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))))
77         (t
78          (fun-guessed-cost 'typep)))))
79
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 '*)))))
98         (t
99          (aver (integer-type-p type))
100          type)))
101
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))
115         (t
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)))))
143
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))
149         (t
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)))))))
156 \f
157 ;;;; checking strategy determination
158
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)))
169
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)))
181
182 ;;; Switch to disable check complementing, for evaluation.
183 (defvar *complement-type-checks* t)
184
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))
203                            c)
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))
218             (t
219              (values :hairy hairy-res))))))
220
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).
226 ;;;
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.
232 ;;;
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.
237 ;;;
238 ;;; Old comment:
239 ;;;
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
247 ;;;
248 ;;; In the :HAIRY case, the second value is a list of triples of
249 ;;; the form:
250 ;;;    (NOT-P TYPE ORIGINAL-TYPE)
251 ;;;
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.
256 ;;;
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)
272                             1)
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))
315           (t
316            (values :too-hairy nil)))))
317
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.
331          ;;
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.
337          ;;
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))))))
348
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.
353 ;;;
354 ;;; We always return T unless nobody uses the value (the backend
355 ;;; cannot check unused LVAR chains).
356 ;;;
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):
361 ;;;
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.
365 ;;;
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)))))))))))))
378 ;;;
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))))
390
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.
394 ;;;
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))))
415
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))
432                         (t
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)))
440
441   (values))
442
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)))))
475                   (t
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))
482
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.
487 ;;;
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.
492 ;;;
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.
498 ;;;
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.
505 ;;;
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))
522                   (t
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))