0.8.0.78.vector-nil-string.14:

[sbcl.git] / src / compiler / ir1opt.lisp

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index f65cc3a..0cac21d 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -411,7 +411,8 @@
                 (join-blocks block next))
               t)
               ((and (null (block-start-uses next))
-                    (not (exit-p (continuation-dest last-cont)))
+                    (not (typep (continuation-dest last-cont)
+                                '(or exit creturn)))
                     (null (continuation-lexenv-uses last-cont)))
                (assert (null (find-uses next-cont)))
                (when (continuation-dest last-cont)
@@ -934,7 +935,7 @@
                        ;; issue a full WARNING if the call
                        ;; violates a DECLAIM FTYPE.
                        :lossage-fun #'compiler-style-warn
-                       :unwinnage-fun #'compiler-note)
+                       :unwinnage-fun #'compiler-notify)
         (assert-call-type call type)
         (maybe-terminate-block call ir1-converting-not-optimizing-p)
         (recognize-known-call call ir1-converting-not-optimizing-p))
@@ -1734,6 +1735,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)
@@ -1763,24 +1766,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)))