X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=d7afaee450d8c03259795a83d7044b9f80d29560;hb=65f551e30f6f52855fdb7ff28e0cfff2f17c3e48;hp=2e8c17ff40c28c363675ca4f36f2158131d26f7e;hpb=05525d3a5906d7a89fcb689c26177732493c40ce;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 2e8c17f..d7afaee 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -197,26 +197,28 @@
 
 ;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an
 ;;; error for CONT's value not to be TYPEP to TYPE. We implement it
-;;; moving uses behind a new CAST node. If we improve the assertion,
+;;; splitting off DEST a new CAST node. If we improve the assertion,
 ;;; we set TYPE-CHECK and TYPE-ASSERTED to guarantee that the new
-;;; assertion will be checked.
+;;; assertion will be checked. We return the new "argument"
+;;; continuation of DEST.
 (defun assert-continuation-type (cont type policy)
   (declare (type continuation cont) (type ctype type))
-  (when (values-subtypep (continuation-derived-type cont) type)
-    (return-from assert-continuation-type))
-  (let* ((dest (continuation-dest cont))
-         (prev-cont (node-prev dest)))
-    (aver dest)
-    (with-ir1-environment-from-node dest
-      (let* ((cast (make-cast cont type policy))
-             (checked-value (make-continuation)))
-        (setf (continuation-next prev-cont) cast
-              (node-prev cast) prev-cont)
-        (use-continuation cast checked-value)
-        (link-node-to-previous-continuation dest checked-value)
-        (substitute-continuation checked-value cont)
-        (setf (continuation-dest cont) cast)
-        (reoptimize-continuation cont)))))
+  (if (values-subtypep (continuation-derived-type cont) type)
+      cont
+      (let* ((dest (continuation-dest cont))
+             (prev-cont (node-prev dest)))
+        (aver dest)
+        (with-ir1-environment-from-node dest
+          (let* ((cast (make-cast cont type policy))
+                 (checked-value (make-continuation)))
+            (setf (continuation-next prev-cont) cast
+                  (node-prev cast) prev-cont)
+            (use-continuation cast checked-value)
+            (link-node-to-previous-continuation dest checked-value)
+            (substitute-continuation checked-value cont)
+            (setf (continuation-dest cont) cast)
+            (reoptimize-continuation cont)
+            checked-value)))))
 
 ;;; 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
@@ -1745,7 +1747,7 @@
          value
          ;; FIXME: Derived type.
          `(%compile-time-type-error 'dummy
-                                    ',(type-specifier (coerce-to-values atype))
+                                    ',(type-specifier atype)
                                     ',(type-specifier value-type)))
         ;; KLUDGE: FILTER-CONTINUATION does not work for
         ;; non-returning functions, so we declare the return type of