- (count 0 +))
- (flet ((frob (string &rest stuff)
- (messages string)
- (messages stuff)))
- (dolist (loser (losers))
- (when (and *efficiency-note-limit*
- (>= (count) *efficiency-note-limit*))
- (frob "etc.")
- (return))
- (let* ((type (template-type loser))
- (valid (valid-function-use call type))
- (strict-valid (valid-function-use call type
- :strict-result t)))
- (frob "unable to do ~A (cost ~D) because:"
- (or (template-note loser) (template-name loser))
- (template-cost loser))
- (cond
- ((and valid strict-valid)
- (strange-template-failure loser call ltn-policy #'frob))
- ((not valid)
- (aver (not (valid-function-use call type
- :error-function #'frob
- :warning-function #'frob))))
- (t
- (aver (ltn-policy-safe-p ltn-policy))
- (frob "can't trust output type assertion under safe policy")))
- (count 1))))
-
- (let ((*compiler-error-context* call))
- (compiler-note "~{~?~^~&~6T~}"
- (if template
- `("forced to do ~A (cost ~D)"
- (,(or (template-note template)
- (template-name template))
- ,(template-cost template))
- . ,(messages))
- `("forced to do full call"
- nil
- . ,(messages))))))))
- (values))
-
-;;; Flush type checks according to policy. If the policy is
-;;; unsafe, then we never do any checks. If our policy is safe, and
-;;; we are using a safe template, then we can also flush arg and
-;;; result type checks. Result type checks are only flushed when the
-;;; continuation as a single use. Result type checks are not flush if
-;;; the policy is safe because the selection of template for results
-;;; readers assumes the type check is done (uses the derived type
-;;; which is the intersection of the proven and asserted types).
-(defun flush-type-checks-according-to-ltn-policy (call ltn-policy template)
- (declare (type combination call) (type ltn-policy ltn-policy)
- (type template template))
- (let ((safe-op (eq (template-ltn-policy template) :safe)))
- (when (or (not (ltn-policy-safe-p ltn-policy)) safe-op)
- (dolist (arg (basic-combination-args call))
- (flush-type-check arg)))
- (when safe-op
- (let ((cont (node-cont call)))
- (when (and (eq (continuation-use cont) call)
- (not (ltn-policy-safe-p ltn-policy)))
- (flush-type-check cont)))))
-
+ (notes 0 +))
+ (flet ((lose1 (string &rest stuff)
+ (messages string)
+ (messages stuff)))
+ (dolist (loser (losers))
+ (when (and *efficiency-note-limit*
+ (>= (notes) *efficiency-note-limit*))
+ (lose1 "etc.")
+ (return))
+ (let* ((type (template-type loser))
+ (valid (valid-fun-use call type))
+ (strict-valid (valid-fun-use call type)))
+ (lose1 "unable to do ~A (cost ~W) because:"
+ (or (template-note loser) (template-name loser))
+ (template-cost loser))
+ (cond
+ ((and valid strict-valid)
+ (strange-template-failure loser call ltn-policy #'lose1))
+ ((not valid)
+ (aver (not (valid-fun-use call type
+ :lossage-fun #'lose1
+ :unwinnage-fun #'lose1))))
+ (t
+ (aver (ltn-policy-safe-p ltn-policy))
+ (lose1 "can't trust output type assertion under safe policy")))
+ (notes 1))))
+
+ (let ((*compiler-error-context* call))
+ (compiler-notify "~{~?~^~&~6T~}"
+ (if template
+ `("forced to do ~A (cost ~W)"
+ (,(or (template-note template)
+ (template-name template))
+ ,(template-cost template))
+ . ,(messages))
+ `("forced to do full call"
+ nil
+ . ,(messages))))))))