X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcompiler%2Fir1opt.lisp;h=0cac21d6416ac6efd19a1930b90ce375018752b6;hb=d0552bdb80b50eb2c600de19b89b2d7139c4841c;hp=8b25671440e21cf831673b14988e4215163c663d;hpb=efb7317381c54e1a28f6c1c179a4fb8d58fdc7eb;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 8b25671..0cac21d 100644
--- 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))
@@ -1720,6 +1721,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)
@@ -1733,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)
@@ -1747,7 +1751,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
@@ -1762,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)))