(compound-type
(reduce #'+ (compound-type-types type) :key 'type-test-cost))
(member-type
- (* (length (member-type-members type))
+ (* (member-type-size type)
(fun-guessed-cost 'eq)))
(numeric-type
(* (if (numeric-type-complexp type) 2 1)
(t
(fun-guessed-cost 'typep)))))
+(defun weaken-integer-type (type &key range-only)
+ ;; FIXME: Our canonicalization isn't quite ideal for this. We get
+ ;; types such as:
+ ;;
+ ;; (OR (AND (SATISFIES FOO) (INTEGER -100 -50))
+ ;; (AND (SATISFIES FOO) (INTEGER 100 200)))
+ ;;
+ ;; here, and weakening that into
+ ;;
+ ;; (AND (SATISFIES FOO) (INTEGER -100 200))
+ ;;
+ ;; is too much work to do here ... but if we canonicalized things
+ ;; differently, we could get it for free with trivial changes here.
+ (labels ((weaken-integer-type-part (type base)
+ (cond ((intersection-type-p type)
+ (let ((new (specifier-type base)))
+ (dolist (part (intersection-type-types type))
+ (when (if range-only
+ (numeric-type-p part)
+ (not (unknown-type-p part)))
+ (setf new (type-intersection
+ new (weaken-integer-type-part part t)))))
+ new))
+ ((union-type-p type)
+ (let ((low t) (high t) (rest *empty-type*))
+ (flet ((maximize (bound)
+ (if (and bound high)
+ (setf high (if (eq t high)
+ bound
+ (max high bound)))
+ (setf high nil)))
+ (minimize (bound)
+ (if (and bound low)
+ (setf low (if (eq t low)
+ bound
+ (min low bound)))
+ (setf low nil))))
+ (dolist (part (union-type-types type))
+ (let ((weak (weaken-integer-type-part part t)))
+ (cond ((numeric-type-p weak)
+ (minimize (numeric-type-low weak))
+ (maximize (numeric-type-high weak)))
+ ((not range-only)
+ (setf rest (type-union rest weak)))))))
+ (if (eq t low)
+ rest
+ (type-union rest
+ (specifier-type
+ `(integer ,(or low '*) ,(or high '*)))))))
+ (t
+ type))))
+ (weaken-integer-type-part type 'integer)))
+
(defun-cached
(weaken-type :hash-bits 8
:hash-function (lambda (x)
(logand (type-hash-value x) #xFF)))
((type eq))
(declare (type ctype type))
- (let ((min-cost (type-test-cost type))
- (min-type type)
- (found-super nil))
- (dolist (x *backend-type-predicates*)
- (let ((stype (car x)))
- (when (and (csubtypep type stype)
- (not (union-type-p stype)))
- (let ((stype-cost (type-test-cost stype)))
- (when (or (< stype-cost min-cost)
- (type= stype type))
- ;; If the supertype is equal in cost to the type, we
- ;; prefer the supertype. This produces a closer
- ;; approximation of the right thing in the presence of
- ;; poor cost info.
- (setq found-super t
- min-type stype
- min-cost stype-cost))))))
- (if found-super
- min-type
- *universal-type*)))
+ (cond ((named-type-p type)
+ type)
+ ((csubtypep type (specifier-type 'integer))
+ ;; Simple range checks are not that expensive, and we *don't*
+ ;; want to accidentally lose eg. array bounds checks due to
+ ;; weakening, so for integer types we simply collapse all
+ ;; ranges into one.
+ (weaken-integer-type type))
+ (t
+ (let ((min-cost (type-test-cost type))
+ (min-type type)
+ (found-super nil))
+ (dolist (x *backend-type-predicates*)
+ (let* ((stype (car x))
+ (samep (type= stype type)))
+ (when (or samep
+ (and (csubtypep type stype)
+ (not (union-type-p stype))))
+ (let ((stype-cost (type-test-cost stype)))
+ (when (or (< stype-cost min-cost)
+ samep)
+ ;; If the supertype is equal in cost to the type, we
+ ;; prefer the supertype. This produces a closer
+ ;; approximation of the right thing in the presence of
+ ;; poor cost info.
+ (setq found-super t
+ min-type stype
+ min-cost stype-cost))))))
+ ;; This used to return the *UNIVERSAL-TYPE* if no supertype was found,
+ ;; but that's too liberal: it's far too easy for the user to create
+ ;; a union type (which are excluded above), and then trick the compiler
+ ;; into trusting the union type... and finally ending up corrupting the
+ ;; heap once a bad object sneaks past the missing type check.
+ (if found-super
+ min-type
+ type)))))
(defun weaken-values-type (type)
(declare (type ctype type))
;;; for a :HAIRY check with that test negated. Otherwise, we try to do
;;; a simple test, and if that is impossible, we do a hairy test with
;;; non-negated types. If true, FORCE-HAIRY forces a hairy type check.
-;;;
-;;; When doing a non-negated check, we call MAYBE-WEAKEN-CHECK to
-;;; weaken the test to a convenient supertype (conditional on policy.)
-;;; If SPEED is 3, or DEBUG-INFO is not particularly important (DEBUG
-;;; <= 1), then we allow weakened checks to be simple, resulting in
-;;; less informative error messages, but saving space and possibly
-;;; time.
-;;;
-;;; FIXME: I don't quite understand this, but it looks as though
-;;; that means type checks are weakened when SPEED=3 regardless of
-;;; the SAFETY level, which is not the right thing to do.
(defun maybe-negate-check (lvar types original-types force-hairy n-required)
(declare (type lvar lvar) (list types original-types))
(let ((ptypes (values-type-out (lvar-derived-type lvar) (length types))))
(t
(values :too-hairy nil)))))
-;;; Do we want to do a type check?
+;;; Return T is the cast appears to be from the declaration of the callee,
+;;; and should be checked externally -- that is, by the callee and not the caller.
(defun cast-externally-checkable-p (cast)
(declare (type cast cast))
(let* ((lvar (node-lvar cast))
(dest (and lvar (lvar-dest lvar))))
(and (combination-p dest)
- ;; The theory is that the type assertion is from a
- ;; declaration in (or on) the callee, so the callee should be
- ;; able to do the check. We want to let the callee do the
- ;; check, because it is possible that by the time of call
- ;; that declaration will be changed and we do not want to
- ;; make people recompile all calls to a function when they
- ;; were originally compiled with a bad declaration. (See also
- ;; bug 35.)
- (or (immediately-used-p lvar cast)
- (binding* ((ctran (node-next cast) :exit-if-null)
- (next (ctran-next ctran)))
- (and (cast-p next)
- (eq (node-dest next) dest)
- (eq (cast-type-check next) :external))))
- (values-subtypep (lvar-externally-checkable-type lvar)
- (cast-type-to-check cast)))))
+ ;; The theory is that the type assertion is from a declaration on the
+ ;; callee, so the callee should be able to do the check. We want to
+ ;; let the callee do the check, because it is possible that by the
+ ;; time of call that declaration will be changed and we do not want
+ ;; to make people recompile all calls to a function when they were
+ ;; originally compiled with a bad declaration.
+ ;;
+ ;; ALMOST-IMMEDIATELY-USED-P ensures that we don't delegate casts
+ ;; that occur before nodes that can cause observable side effects --
+ ;; most commonly other non-external casts: so the order in which
+ ;; possible type errors are signalled matches with the evaluation
+ ;; order.
+ ;;
+ ;; FIXME: We should let more cases be handled by the callee then we
+ ;; currently do, see: https://bugs.launchpad.net/sbcl/+bug/309104
+ ;; This is not fixable quite here, though, because flow-analysis has
+ ;; deleted the LVAR of the cast by the time we get here, so there is
+ ;; no destination. Perhaps we should mark cases inserted by
+ ;; ASSERT-CALL-TYPE explicitly, and delete those whose destination is
+ ;; deemed unreachable?
+ (almost-immediately-used-p lvar cast)
+ (values (values-subtypep (lvar-externally-checkable-type lvar)
+ (cast-type-to-check cast))))))
;;; Return true if CAST's value is an lvar whose type the back end is
-;;; likely to want to check. Since we don't know what template the
-;;; back end is going to choose to implement the continuation's DEST,
-;;; we use a heuristic. We always return T unless:
-;;; -- nobody uses the value, or
-;;; -- safety is totally unimportant, or
-;;; -- the lvar is an argument to an unknown function, or
-;;; -- the lvar is an argument to a known function that has
+;;; likely to be able to check (see GENERATE-TYPE-CHECKS). Since we
+;;; don't know what template the back end is going to choose to
+;;; implement the continuation's DEST, we use a heuristic.
+;;;
+;;; We always return T unless nobody uses the value (the backend
+;;; cannot check unused LVAR chains).
+;;;
+;;; The logic used to be more complex, but most of the cases that used
+;;; to be checked here are now dealt with differently . FIXME: but
+;;; here's one we used to do, don't anymore, but could still benefit
+;;; from, if we reimplemented it (elsewhere):
+;;;
+;;; -- If the lvar is an argument to a known function that has
;;; no IR2-CONVERT method or :FAST-SAFE templates that are
-;;; compatible with the call's type.
+;;; compatible with the call's type: return NIL.
+;;;
+;;; The code used to look like something like this:
+;;; ...
+;;; (:known
+;;; (let ((info (basic-combination-fun-info dest)))
+;;; (if (fun-info-ir2-convert info)
+;;; t
+;;; (dolist (template (fun-info-templates info) nil)
+;;; (when (eq (template-ltn-policy template)
+;;; :fast-safe)
+;;; (multiple-value-bind (val win)
+;;; (valid-fun-use dest (template-type template))
+;;; (when (or val (not win)) (return t)))))))))))))
+;;;
+;;; ADP says: It is still interesting. When we have a :SAFE template
+;;; and the type assertion is derived from the destination function
+;;; type, the check is unneccessary. We cannot return NIL here (the
+;;; whole function has changed its meaning, and here NIL *forces*
+;;; hairy check), but the functionality is interesting.
(defun probable-type-check-p (cast)
(declare (type cast cast))
(let* ((lvar (node-lvar cast))
(dest (and lvar (lvar-dest lvar))))
(cond ((not dest) nil)
- (t t))
- #+nil
- (cond ((or (not dest)
- (policy dest (zerop safety)))
- nil)
- ((basic-combination-p dest)
- (let ((kind (basic-combination-kind dest)))
- (cond
- ((eq cont (basic-combination-fun dest)) t)
- (t
- (ecase kind
- (:local t)
- (:full
- (and (combination-p dest)
- (not (values-subtypep ; explicit THE
- (continuation-externally-checkable-type cont)
- (continuation-type-to-check cont)))))
- ;; :ERROR means that we have an invalid syntax of
- ;; the call and the callee will detect it before
- ;; thinking about types.
- (:error nil)
- (:known
- (let ((info (basic-combination-fun-info dest)))
- (if (fun-info-ir2-convert info)
- t
- (dolist (template (fun-info-templates info) nil)
- (when (eq (template-ltn-policy template)
- :fast-safe)
- (multiple-value-bind (val win)
- (valid-fun-use dest (template-type template))
- (when (or val (not win)) (return t)))))))))))))
(t t))))
;;; Return a lambda form that we can convert to do a hairy type check
(let* ((lvar (node-lvar cast))
(dest (and lvar (lvar-dest lvar)))
(value (cast-value cast))
- (atype (cast-asserted-type cast)))
+ (atype (cast-asserted-type cast))
+ (condition 'type-warning)
+ (not-ok-uses '()))
(do-uses (use value)
(let ((dtype (node-derived-type use)))
- (unless (values-types-equal-or-intersect dtype atype)
- (let* ((*compiler-error-context* use)
- (atype-spec (type-specifier atype))
- (what (when (and (combination-p dest)
- (eq (combination-kind dest) :local))
- (let ((lambda (combination-lambda dest))
- (pos (position-or-lose
- lvar (combination-args dest))))
- (format nil "~:[A possible~;The~] binding of ~S"
- (and (lvar-has-single-use-p lvar)
- (eq (functional-kind lambda) :let))
- (leaf-source-name (elt (lambda-vars lambda)
- pos)))))))
- (cond ((and (ref-p use) (constant-p (ref-leaf use)))
- (warn 'type-warning
- :format-control
- "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
- :format-arguments
- (list what atype-spec
- (constant-value (ref-leaf use)))))
- (t
- (warn 'type-warning
- :format-control
- "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
- :format-arguments
- (list what (type-specifier dtype) atype-spec)))))))))
+ (if (values-types-equal-or-intersect dtype atype)
+ (setf condition 'type-style-warning)
+ (push use not-ok-uses))))
+ (dolist (use (nreverse not-ok-uses))
+ (let* ((*compiler-error-context* use)
+ (dtype (node-derived-type use))
+ (atype-spec (type-specifier atype))
+ (what (when (and (combination-p dest)
+ (eq (combination-kind dest) :local))
+ (let ((lambda (combination-lambda dest))
+ (pos (position-or-lose
+ lvar (combination-args dest))))
+ (format nil "~:[A possible~;The~] binding of ~S"
+ (and (lvar-has-single-use-p lvar)
+ (eq (functional-kind lambda) :let))
+ (leaf-source-name (elt (lambda-vars lambda)
+ pos)))))))
+ (cond ((and (ref-p use) (constant-p (ref-leaf use)))
+ (warn condition
+ :format-control
+ "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
+ :format-arguments
+ (list what atype-spec
+ (constant-value (ref-leaf use)))))
+ (t
+ (warn condition
+ :format-control
+ "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
+ :format-arguments
+ (list what (type-specifier dtype) atype-spec)))))))
(values))
;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set,
projects / sbcl.git / blobdiff