(t
(fun-guessed-cost 'typep)))))
+(defun weaken-integer-type (type)
+ (cond ((union-type-p type)
+ (let* ((types (union-type-types type))
+ (one (pop types))
+ (low (numeric-type-low one))
+ (high (numeric-type-high one)))
+ (flet ((maximize (bound)
+ (if (and bound high)
+ (setf high (max high bound))
+ (setf high nil)))
+ (minimize (bound)
+ (if (and bound low)
+ (setf low (min low bound))
+ (setf low nil))))
+ (dolist (a types)
+ (minimize (numeric-type-low a))
+ (maximize (numeric-type-high a))))
+ (specifier-type `(integer ,(or low '*) ,(or high '*)))))
+ (t
+ (aver (integer-type-p type))
+ type)))
+
(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))
- (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)))
+ (cond ((named-type-p type)
+ type)
+ ((csubtypep type (specifier-type 'integer))
+ ;; KLUDGE: 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))
(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 be able to check (see GENERATE-TYPE-CHECKS). Since we
projects / sbcl.git / blobdiff