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 ;;; Do we want to do a type check?
 319 (defun cast-externally-checkable-p (cast)
 320   (declare (type cast cast))
 321   (let* ((lvar (node-lvar cast))
 322          (dest (and lvar (lvar-dest lvar))))
 323     (and (combination-p dest)
 324          ;; The theory is that the type assertion is from a
 325          ;; declaration in (or on) the callee, so the callee should be
 326          ;; able to do the check. We want to let the callee do the
 327          ;; check, because it is possible that by the time of call
 328          ;; that declaration will be changed and we do not want to
 329          ;; make people recompile all calls to a function when they
 330          ;; were originally compiled with a bad declaration. (See also
 331          ;; bug 35.)
 332          (or (immediately-used-p lvar cast)
 333              (binding* ((ctran (node-next cast) :exit-if-null)
 334                         (next (ctran-next ctran)))
 335                (and (cast-p next)
 336                     (eq (node-dest next) dest)
 337                     (eq (cast-type-check next) :external))))
 338          (values-subtypep (lvar-externally-checkable-type lvar)
 339                           (cast-type-to-check cast)))))
 340
 341 ;;; Return true if CAST's value is an lvar whose type the back end is
 342 ;;; likely to be able to check (see GENERATE-TYPE-CHECKS). Since we
 343 ;;; don't know what template the back end is going to choose to
 344 ;;; implement the continuation's DEST, we use a heuristic.
 345 ;;;
 346 ;;; We always return T unless nobody uses the value (the backend
 347 ;;; cannot check unused LVAR chains).
 348 ;;;
 349 ;;; The logic used to be more complex, but most of the cases that used
 350 ;;; to be checked here are now dealt with differently . FIXME: but
 351 ;;; here's one we used to do, don't anymore, but could still benefit
 352 ;;; from, if we reimplemented it (elsewhere):
 353 ;;;
 354 ;;;  -- If the lvar is an argument to a known function that has
 355 ;;;     no IR2-CONVERT method or :FAST-SAFE templates that are
 356 ;;;     compatible with the call's type: return NIL.
 357 ;;;
 358 ;;; The code used to look like something like this:
 359 ;;;   ...
 360 ;;;   (:known
 361 ;;;    (let ((info (basic-combination-fun-info dest)))
 362 ;;;      (if (fun-info-ir2-convert info)
 363 ;;;          t
 364 ;;;          (dolist (template (fun-info-templates info) nil)
 365 ;;;            (when (eq (template-ltn-policy template)
 366 ;;;                      :fast-safe)
 367 ;;;              (multiple-value-bind (val win)
 368 ;;;                  (valid-fun-use dest (template-type template))
 369 ;;;                (when (or val (not win)) (return t)))))))))))))
 370 ;;;
 371 ;;; ADP says: It is still interesting. When we have a :SAFE template
 372 ;;; and the type assertion is derived from the destination function
 373 ;;; type, the check is unneccessary. We cannot return NIL here (the
 374 ;;; whole function has changed its meaning, and here NIL *forces*
 375 ;;; hairy check), but the functionality is interesting.
 376 (defun probable-type-check-p (cast)
 377   (declare (type cast cast))
 378   (let* ((lvar (node-lvar cast))
 379          (dest (and lvar (lvar-dest lvar))))
 380     (cond ((not dest) nil)
 381           (t t))))
 382
 383 ;;; Return a lambda form that we can convert to do a hairy type check
 384 ;;; of the specified TYPES. TYPES is a list of the format returned by
 385 ;;; LVAR-CHECK-TYPES in the :HAIRY case.
 386 ;;;
 387 ;;; Note that we don't attempt to check for required values being
 388 ;;; unsupplied. Such checking is impossible to efficiently do at the
 389 ;;; source level because our fixed-values conventions are optimized
 390 ;;; for the common MV-BIND case.
 391 (defun make-type-check-form (types)
 392   (let ((temps (make-gensym-list (length types))))
 393     `(multiple-value-bind ,temps
 394          'dummy
 395        ,@(mapcar (lambda (temp type)
 396                    (let* ((spec
 397                            (let ((*unparse-fun-type-simplify* t))
 398                              (type-specifier (second type))))
 399                           (test (if (first type) `(not ,spec) spec)))
 400                      `(unless (typep ,temp ',test)
 401                         (%type-check-error
 402                          ,temp
 403                          ',(type-specifier (third type))))))
 404                  temps
 405                  types)
 406        (values ,@temps))))
 407
 408 ;;; Splice in explicit type check code immediately before CAST. This
 409 ;;; code receives the value(s) that were being passed to CAST-VALUE,
 410 ;;; checks the type(s) of the value(s), then passes them further.
 411 (defun convert-type-check (cast types)
 412   (declare (type cast cast) (type list types))
 413   (let ((value (cast-value cast))
 414         (length (length types)))
 415     (filter-lvar value (make-type-check-form types))
 416     (reoptimize-lvar (cast-value cast))
 417     (setf (cast-type-to-check cast) *wild-type*)
 418     (setf (cast-%type-check cast) nil)
 419     (let* ((atype (cast-asserted-type cast))
 420            (atype (cond ((not (values-type-p atype))
 421                          atype)
 422                         ((= length 1)
 423                          (single-value-type atype))
 424                         (t
 425                          (make-values-type
 426                           :required (values-type-out atype length)))))
 427            (dtype (node-derived-type cast))
 428            (dtype (make-values-type
 429                    :required (values-type-out dtype length))))
 430       (setf (cast-asserted-type cast) atype)
 431       (setf (node-derived-type cast) dtype)))
 432
 433   (values))
 434
 435 ;;; Check all possible arguments of CAST and emit type warnings for
 436 ;;; those with type errors. If the value of USE is being used for a
 437 ;;; variable binding, we figure out which one for source context. If
 438 ;;; the value is a constant, we print it specially.
 439 (defun cast-check-uses (cast)
 440   (declare (type cast cast))
 441   (let* ((lvar (node-lvar cast))
 442          (dest (and lvar (lvar-dest lvar)))
 443          (value (cast-value cast))
 444          (atype (cast-asserted-type cast)))
 445     (do-uses (use value)
 446       (let ((dtype (node-derived-type use)))
 447         (unless (values-types-equal-or-intersect dtype atype)
 448           (let* ((*compiler-error-context* use)
 449                  (atype-spec (type-specifier atype))
 450                  (what (when (and (combination-p dest)
 451                                   (eq (combination-kind dest) :local))
 452                          (let ((lambda (combination-lambda dest))
 453                                (pos (position-or-lose
 454                                      lvar (combination-args dest))))
 455                            (format nil "~:[A possible~;The~] binding of ~S"
 456                                    (and (lvar-has-single-use-p lvar)
 457                                         (eq (functional-kind lambda) :let))
 458                                    (leaf-source-name (elt (lambda-vars lambda)
 459                                                           pos)))))))
 460             (cond ((and (ref-p use) (constant-p (ref-leaf use)))
 461                    (warn 'type-warning
 462                          :format-control
 463                          "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~%  ~S"
 464                          :format-arguments
 465                          (list what atype-spec
 466                                (constant-value (ref-leaf use)))))
 467                   (t
 468                    (warn 'type-warning
 469                          :format-control
 470                          "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
 471                          :format-arguments
 472                          (list what (type-specifier dtype) atype-spec)))))))))
 473   (values))
 474
 475 ;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set,
 476 ;;; looking for CASTs with TYPE-CHECK T. We do two mostly unrelated
 477 ;;; things: detect compile-time type errors and determine if and how
 478 ;;; to do run-time type checks.
 479 ;;;
 480 ;;; If there is a compile-time type error, then we mark the CAST and
 481 ;;; emit a warning if appropriate. This part loops over all the uses
 482 ;;; of the continuation, since after we convert the check, the
 483 ;;; :DELETED kind will inhibit warnings about the types of other uses.
 484 ;;;
 485 ;;; If the cast is too complex to be checked by the back end, or is
 486 ;;; better checked with explicit code, then convert to an explicit
 487 ;;; test. Assertions that can checked by the back end are passed
 488 ;;; through. Assertions that can't be tested are flamed about and
 489 ;;; marked as not needing to be checked.
 490 ;;;
 491 ;;; If we determine that a type check won't be done, then we set
 492 ;;; TYPE-CHECK to :NO-CHECK. In the non-hairy cases, this is just to
 493 ;;; prevent us from wasting time coming to the same conclusion again
 494 ;;; on a later iteration. In the hairy case, we must indicate to LTN
 495 ;;; that it must choose a safe implementation, since IR2 conversion
 496 ;;; will choke on the check.
 497 ;;;
 498 ;;; The generation of the type checks is delayed until all the type
 499 ;;; check decisions have been made because the generation of the type
 500 ;;; checks creates new nodes whose derived types aren't always updated
 501 ;;; which may lead to inappropriate template choices due to the
 502 ;;; modification of argument types.
 503 (defun generate-type-checks (component)
 504   (collect ((casts))
 505     (do-blocks (block component)
 506       (when (block-type-check block)
 507         ;; CAST-EXTERNALLY-CHECKABLE-P wants the backward pass
 508         (do-nodes-backwards (node nil block)
 509           (when (and (cast-p node)
 510                      (cast-type-check node))
 511             (cast-check-uses node)
 512             (cond ((cast-externally-checkable-p node)
 513                    (setf (cast-%type-check node) :external))
 514                   (t
 515                    ;; it is possible that NODE was marked :EXTERNAL by
 516                    ;; the previous pass
 517                    (setf (cast-%type-check node) t)
 518                    (casts (cons node (not (probable-type-check-p node))))))))
 519         (setf (block-type-check block) nil)))
 520     (dolist (cast (casts))
 521       (destructuring-bind (cast . force-hairy) cast
 522         (multiple-value-bind (check types)
 523             (cast-check-types cast force-hairy)
 524           (ecase check
 525             (:simple)
 526             (:hairy
 527              (convert-type-check cast types))
 528             (:too-hairy
 529              (let ((*compiler-error-context* cast))
 530                (when (policy cast (>= safety inhibit-warnings))
 531                  (compiler-notify
 532                   "type assertion too complex to check:~% ~S."
 533                   (type-specifier (coerce-to-values (cast-asserted-type cast))))))
 534              (setf (cast-type-to-check cast) *wild-type*)
 535              (setf (cast-%type-check cast) nil)))))))
 536   (values))