- (multiple-value-bind (ctypes count) (no-fun-values-types ctype)
- (multiple-value-bind (atypes acount) (no-fun-values-types ctype)
- (aver (eq count acount))
- (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 ctypes atypes t)
- (maybe-negate-check cont ctypes atypes force-hairy)))
- ((and (mv-combination-p dest)
- (eq (basic-combination-kind dest) :local))
- (aver (values-type-p ctype))
- (maybe-negate-check cont
- (args-type-optional ctype)
- (args-type-optional atype)
- force-hairy))
- (t
- (values :too-hairy nil)))))))
-
-;;; Do we want to do a type check?
-(defun worth-type-check-p (cont)
- (let ((dest (continuation-dest cont)))
- (not (or (values-subtypep (continuation-proven-type cont)
- (continuation-type-to-check cont))
- (and (combination-p dest)
- (eq (combination-kind dest) :full)
- ;; 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.)
- (values-subtypep (continuation-externally-checkable-type cont)
- (continuation-type-to-check cont)))
- (and (mv-combination-p dest) ; bug 220
- (eq (mv-combination-kind dest) :full))))))
-
-;;; Return true if CONT is a continuation 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 continuation is an argument to an unknown function, or
-;;; -- the continuation is an argument to a known function that has
+ (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))))))
+
+;;; 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
+;;; 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 (the backend
+;;; cannot check unused LVAR chains).
+;;;
+;;; The logic used to be more complex, but most of the cases that used
+;;; to be checked here are now dealt with differently . FIXME: but
+;;; here's one we used to do, don't anymore, but could still benefit
+;;; from, if we reimplemented it (elsewhere):
+;;;
+;;; -- If the lvar is an argument to a known function that has