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))