-;;; If there is a compile-time type error, then we always return true unless
-;;; the DEST is a full call. With a full call, the theory is that the type
-;;; error is probably 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 the error is really in the callee, not the
-;;; caller. We don't want to make people recompile all calls to a function
-;;; when they were originally compiled with a bad declaration (or an old type
-;;; assertion derived from a definition appearing after the call.)
-(defun probable-type-check-p (cont)
- (declare (type continuation cont))
- (let ((dest (continuation-dest cont)))
- (cond ((eq (continuation-type-check cont) :error)
- (if (and (combination-p dest) (eq (combination-kind dest) :error))
- nil
- t))
- ((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)
- ((eq kind :local) t)
- ((member kind '(:full :error)) nil)
- ((function-info-ir2-convert kind) t)
- (t
- (dolist (template (function-info-templates kind) nil)
- (when (eq (template-policy template) :fast-safe)
- (multiple-value-bind (val win)
- (valid-function-use dest (template-type template))
- (when (or val (not win)) (return t)))))))))
- (t t))))
+;;; This allows us to take what has been proven about CAST's argument
+;;; type into consideration. If it is cheaper to test for the
+;;; difference between the derived type and the asserted type, then we
+;;; check for the negation of this type instead.
+(defun cast-check-types (cast force-hairy)
+ (declare (type cast cast))
+ (let* ((ctype (coerce-to-values (cast-type-to-check cast)))
+ (atype (coerce-to-values (cast-asserted-type cast)))
+ (dtype (node-derived-type cast))
+ (value (cast-value cast))
+ (lvar (node-lvar cast))
+ (dest (and lvar (lvar-dest lvar)))
+ (n-consumed (cond ((not lvar)
+ nil)
+ ((lvar-single-value-p lvar)
+ 1)
+ ((and (mv-combination-p dest)
+ (eq (mv-combination-kind dest) :local))
+ (let ((fun-ref (lvar-use (mv-combination-fun dest))))
+ (length (lambda-vars (ref-leaf fun-ref)))))))
+ (n-required (length (values-type-required dtype))))
+ (aver (not (eq ctype *wild-type*)))
+ (cond ((and (null (values-type-optional dtype))
+ (not (values-type-rest dtype)))
+ ;; we [almost] know how many values are produced
+ (maybe-negate-check value
+ (values-type-out ctype n-required)
+ (values-type-out atype n-required)
+ ;; backend checks only consumed values
+ (not (eql n-required n-consumed))
+ n-required))
+ ((lvar-single-value-p lvar)
+ ;; exactly one value is consumed
+ (principal-lvar-single-valuify lvar)
+ (flet ((get-type (type)
+ (acond ((args-type-required type)
+ (car it))
+ ((args-type-optional type)
+ (car it))
+ (t (bug "type ~S is too hairy" type)))))
+ (multiple-value-bind (ctype atype)
+ (values (get-type ctype) (get-type atype))
+ (maybe-negate-check value
+ (list ctype) (list atype)
+ force-hairy
+ n-required))))
+ ((and (mv-combination-p dest)
+ (eq (mv-combination-kind dest) :local))
+ ;; we know the number of consumed values
+ (maybe-negate-check value
+ (adjust-list (values-type-types ctype)
+ n-consumed
+ *universal-type*)
+ (adjust-list (values-type-types atype)
+ n-consumed
+ *universal-type*)
+ force-hairy
+ n-required))
+ (t
+ (values :too-hairy nil)))))
+
+;;; Do we want to do a type check?
+(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)))))