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

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 2e8c17f..3f83536 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
@@ -1718,6 +1720,7 @@
   (unless (continuation-single-value-p (node-cont node))
     (give-up-ir1-transform))
   (setf (node-derived-type node) *wild-type*)
+  (principal-continuation-single-valuify (node-cont node))
   (if vals
       (let ((dummies (make-gensym-list (length (cdr vals)))))
 	`(lambda (val ,@dummies)
@@ -1731,6 +1734,8 @@
   (declare (type cast cast))
   (let* ((value (cast-value cast))
          (value-type (continuation-derived-type value))
+         (cont (node-cont cast))
+         (dest (continuation-dest cont))
          (atype (cast-asserted-type cast))
          (int (values-type-intersection value-type atype)))
     (derive-node-type cast int)
@@ -1745,7 +1750,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
@@ -1760,24 +1765,40 @@
     (when (eq (node-derived-type cast) *empty-type*)
       (maybe-terminate-block cast nil))
 
-    (flet ((delete-cast ()
-             (let ((cont (node-cont cast)))
-               (delete-filter cast cont value)
-               (reoptimize-continuation cont)
-               (when (continuation-single-value-p cont)
-                 (note-single-valuified-continuation cont))
-               (when (not (continuation-dest cont))
-                 (reoptimize-continuation-uses cont)))))
-      (cond
-        ((and (not do-not-optimize)
-              (values-subtypep value-type
-                               (cast-asserted-type cast)))
-         (delete-cast)
-         (return-from ir1-optimize-cast t))
-        ((and (cast-%type-check cast)
-              (values-subtypep value-type
-                               (cast-type-to-check cast)))
-         (setf (cast-%type-check cast) nil)))))
+    (when (and (not do-not-optimize)
+               (values-subtypep value-type
+                                (cast-asserted-type cast)))
+      (delete-filter cast cont value)
+      (reoptimize-continuation cont)
+      (when (continuation-single-value-p cont)
+        (note-single-valuified-continuation cont))
+      (when (not dest)
+        (reoptimize-continuation-uses cont))
+      (return-from ir1-optimize-cast t))
+
+    (when (and (not do-not-optimize)
+               (not (continuation-use value))
+               dest)
+      (collect ((merges))
+        (do-uses (use value)
+          (when (and (values-subtypep (node-derived-type use) atype)
+                     (immediately-used-p value use))
+            (ensure-block-start cont)
+            (delete-continuation-use use)
+            (add-continuation-use use cont)
+            (unlink-blocks (node-block use) (node-block cast))
+            (link-blocks (node-block use) (continuation-block cont))
+            (when (and (return-p dest)
+                       (basic-combination-p use)
+                       (eq (basic-combination-kind use) :local))
+              (merges use))))
+        (dolist (use (merges))
+          (merge-tail-sets use))))
+
+    (when (and (cast-%type-check cast)
+               (values-subtypep value-type
+                                (cast-type-to-check cast)))
+      (setf (cast-%type-check cast) nil)))
 
   (unless do-not-optimize
     (setf (node-reoptimize cast) nil)))