X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fconstraint.lisp;h=17b51eed25a6fc43aef71e220437a375c6d6f16f;hb=77c80b85dc9ae9bde0692d4193187bfca507b936;hp=507eaf824b12d65f2864dd1e79ea78768c60db17;hpb=a7c2a16d0c2be6709becc962be1cb5e0aeda68c6;p=sbcl.git

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 507eaf8..17b51ee 100644
--- 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)))))))))
 
@@ -540,19 +542,6 @@
                              (when con
                                (constrain-ref-type node con cons))))))))
 
-;;; Return true if VAR would have to be closed over if environment
-;;; analysis ran now (i.e. if there are any uses that have a different
-;;; home lambda than VAR's home.)
-(defun closure-var-p (var)
-  (declare (type lambda-var var))
-  (let ((home (lambda-home (lambda-var-home var))))
-    (flet ((frob (l)
-	     (dolist (node l nil)
-	       (unless (eq (node-home-lambda node) home)
-		 (return t)))))
-      (or (frob (leaf-refs var))
-	  (frob (basic-var-sets var))))))
-
 ;;; Give an empty constraints set to any var that doesn't have one and
 ;;; isn't a set closure var. Since a var that we previously rejected
 ;;; looks identical to one that is new, so we optimistically keep