0.8.0.3:

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

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 5e61624..17b51ee 100644 (file)
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -279,7 +279,7 @@
 (defun constrain-float-type (x y greater or-equal)
   (declare (type numeric-type x y))
   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
-  
+
   (aver (eql (numeric-type-class x) 'float))
   (aver (eql (numeric-type-class y) 'float))
   #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
@@ -378,13 +378,14 @@
       (let* ((cont (node-cont ref))
             (dest (continuation-dest cont)))
        (cond ((and (if-p dest)
-                   (csubtypep (specifier-type 'null) not-res)
-                   (eq (continuation-asserted-type cont) *wild-type*))
+                   (csubtypep (specifier-type 'null) not-res))
               (setf (node-derived-type ref) *wild-type*)
               (change-ref-leaf ref (find-constant t)))
              (t
-              (derive-node-type ref (or (type-difference res not-res)
-                                        res)))))))
+              (derive-node-type ref
+                                 (make-single-value-type
+                                  (or (type-difference res not-res)
+                                      res))))))))
 
   (values))
 
@@ -429,10 +430,11 @@
          (when var
            (when ref-preprocessor
              (funcall ref-preprocessor node gen))
-           (when (continuation-type-check cont)
-             (let* ((atype (continuation-derived-type cont))
-                    (con (find-constraint 'typep var atype nil)))
-               (sset-adjoin con gen))))))
+           (let ((dest (continuation-dest cont)))
+             (when (cast-p dest)
+               (let* ((atype (single-value-type (cast-derived-type dest))) ; FIXME
+                      (con (find-constraint 'typep var atype nil)))
+                 (sset-adjoin con gen)))))))
       (cset
        (let ((var (set-var node)))
          (when (lambda-var-p var)
@@ -441,7 +443,7 @@
            (let ((cons (lambda-var-constraints var)))
              (when cons
                (sset-difference gen cons)
-               (let* ((type (node-derived-type node))
+               (let* ((type (single-value-type (node-derived-type node)))
                       (con (find-constraint 'typep var type nil)))
                  (sset-adjoin con gen)))))))))