-;;; This allows us to take what has been proven about CONT's 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 continuation-check-types (cont)
- (declare (type continuation cont))
- (let ((type (continuation-asserted-type cont))
- (dest (continuation-dest cont)))
- (aver (not (eq type *wild-type*)))
- (multiple-value-bind (types count) (no-fun-values-types type)
- (cond ((not (eq count :unknown))
- (if (or (exit-p dest)
- (and (return-p dest)
- (multiple-value-bind (ignore count)
- (values-types (return-result-type dest))
- (declare (ignore ignore))
- (eq count :unknown))))
- (maybe-negate-check cont types t)
- (maybe-negate-check cont types nil)))
- ((and (mv-combination-p dest)
- (eq (basic-combination-kind dest) :local))
- (aver (values-type-p type))
- (maybe-negate-check cont (args-type-optional type) nil))
- (t
- (values :too-hairy nil))))))
+;;; 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)))))
+
+;;; 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 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))))))