X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fctype.lisp;h=8e1940b821c74f31cd11f4b886aac3e433c3f276;hb=997959cc458b00ff7faae526511533d24bdc0fde;hp=22ca449cd136dd4305a70abc1dedcbf37e769770;hpb=736f5ba61a8a87df309df7c51b05f0a27f42df4c;p=sbcl.git

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 22ca449..8e1940b 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -607,7 +607,6 @@
       (frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
     (flet ((frob (x y what)
              (unless (eq x y)
-               (break "~S" type)
                (note-lossage
                 "The definition ~:[doesn't have~;has~] ~A, but ~
                  ~A ~:[doesn't~;does~]."
@@ -838,13 +837,27 @@
 ;;; Assert that CALL is to a function of the specified TYPE. It is
 ;;; assumed that the call is legal and has only constants in the
 ;;; keyword positions.
-(defun assert-call-type (call type)
+(defun assert-call-type (call type &optional (trusted t))
   (declare (type combination call) (type fun-type type))
-  (derive-node-type call (fun-type-returns type))
-  (let ((policy (lexenv-policy (node-lexenv call))))
+  (let ((policy (lexenv-policy (node-lexenv call)))
+        (returns (fun-type-returns type)))
+    (if trusted
+        (derive-node-type call returns)
+        (let ((lvar (node-lvar call)))
+          ;; If the value is used in a non-tail position, and
+          ;; the lvar is a single-use, assert the type. Multiple use
+          ;; sites need to be elided because the assertion has to apply
+          ;; to all uses. Tail positions are elided because the assertion
+          ;; would lose cause us not the be in a tail-position anymore.
+          (when (and lvar
+                     (not (return-p (lvar-dest lvar)))
+                     (lvar-has-single-use-p lvar))
+            (when (assert-lvar-type lvar returns policy)
+              (reoptimize-lvar lvar)))))
     (map-combination-args-and-types
      (lambda (arg type)
-       (assert-lvar-type arg type policy))
+       (when (assert-lvar-type arg type policy)
+         (unless trusted (reoptimize-lvar arg))))
      call))
   (values))