(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 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
(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.
+ ;; 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))
(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
(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