-;;; 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)
+;;; 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)
+ (let ((creq (car (args-type-required ctype))))
+ (multiple-value-setq (ctype atype)
+ (if creq
+ (values creq (car (args-type-required atype)))
+ (values (car (args-type-optional ctype))
+ (car (args-type-optional 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)))))
+
+;;; 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
+;;; no IR2-CONVERT method or :FAST-SAFE templates that are
+;;; compatible with the call's type.
+(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)