X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1util.lisp;h=eaf3377d36135e732750580f67131143c13df781;hb=7f13323739a0d2b474bfd5c740942db5a78349d6;hp=39ea55e1e149ec7c502f69779b02670e7ee37cd1;hpb=dbfe7e6c8b06e1b0b1ba35d9894fae13e6305602;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 39ea55e..eaf3377 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -515,11 +515,6 @@
       (mv-combination
        (eq (basic-combination-fun dest) cont))
       (cast
-       nil
-       ;; The following property means that the cast chain allows
-       ;; changing number of values, produced by the USE of CONT, but
-       ;; derived types of the casts must be updated (TODO: how?).
-       #+nil
        (locally
            (declare (notinline continuation-single-value-p))
          (and (not (values-type-p (cast-asserted-type dest)))
@@ -532,6 +527,15 @@
         for dest = (continuation-dest prev)
         while (cast-p dest)
         finally (return (values dest prev))))
+
+(defun principal-continuation-single-valuify (cont)
+  (loop for prev = cont then (node-cont dest)
+     for dest = (continuation-dest prev)
+     while (cast-p dest)
+     do (setf (node-derived-type dest)
+              (make-short-values-type (list (single-value-type
+                                             (node-derived-type dest)))))
+     (reoptimize-continuation prev)))
 
 ;;; Return a new LEXENV just like DEFAULT except for the specified
 ;;; slot values. Values for the alist slots are NCONCed to the