X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=812976e69d88a358a48da61241d7f3f2ec42d443;hb=4d0b87793a047baecf2403455ddca1a82f44a41b;hp=ba008cd267a4e3e5b195a1e10dad1c3fdc7e46c3;hpb=0223a229f6fd1b4cfc809e30e35361df99fb2340;p=sbcl.git

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index ba008cd..812976e 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -155,9 +155,10 @@
 
   (defmacro do-conset-elements ((constraint conset &optional result) &body body)
     (with-unique-names (vector index start end
-                               ignore constraint-universe-end)
+                               #-sb-xc-host ignore
+                               #-sb-xc-host constraint-universe-end)
       (let* ((constraint-universe #+sb-xc-host '*constraint-universe*
-                                  #-sb-xc-host (gensym))
+                                  #-sb-xc-host (sb!xc:gensym "UNIVERSE"))
              (with-array-data
                 #+sb-xc-host '(progn)
                 #-sb-xc-host `(with-array-data
@@ -202,7 +203,7 @@
       ret))
 
   (defun %conset-grow (conset new-size)
-    (declare (index new-size))
+    (declare (type index new-size))
     (setf (conset-vector conset)
           (replace (the simple-bit-vector
                      (make-array
@@ -214,7 +215,7 @@
 
   (declaim (inline conset-grow))
   (defun conset-grow (conset new-size)
-    (declare (index new-size))
+    (declare (type index new-size))
     (when (< (length (conset-vector conset)) new-size)
       (%conset-grow conset new-size))
     (values))
@@ -356,7 +357,7 @@
       (let ((new (make-constraint (length *constraint-universe*)
                                   kind x y not-p)))
         (vector-push-extend new *constraint-universe*
-                            (* 2 (length *constraint-universe*)))
+                            (1+ (length *constraint-universe*)))
         (conset-adjoin new (lambda-var-constraints x))
         (when (lambda-var-p y)
           (conset-adjoin new (lambda-var-constraints y)))
@@ -467,7 +468,8 @@
                              (ok-lvar-lambda-var (first args) constraints)
                              (if (ctype-p val)
                                  val
-                                 (specifier-type val))
+                                 (let ((*compiler-error-context* use))
+                                   (specifier-type val)))
                              nil)))))
                  ((eq eql)
                   (let* ((arg1 (first args))
@@ -489,7 +491,11 @@
                           (var2
                            (add 'eql var1 var2 nil))
                           ((constant-lvar-p arg2)
-                           (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
+                           (add 'eql var1
+                                (let ((use (principal-lvar-use arg2)))
+                                  (if (ref-p use)
+                                      (ref-leaf use)
+                                      (find-constant (lvar-value arg2))))
                                 nil))
                           (t
                            (add-test-constraint 'typep var1 (lvar-type arg2)
@@ -598,6 +604,24 @@
           (modified-numeric-type x :low new-bound)
           (modified-numeric-type x :high new-bound)))))
 
+;;; Return true if LEAF is "visible" from NODE.
+(defun leaf-visible-from-node-p (leaf node)
+  (cond
+   ((lambda-var-p leaf)
+    ;; A LAMBDA-VAR is visible iif it is homed in a CLAMBDA that is an
+    ;; ancestor for NODE.
+    (let ((leaf-lambda (lambda-var-home leaf)))
+      (loop for lambda = (node-home-lambda node)
+            then (lambda-parent lambda)
+            while lambda
+            when (eq lambda leaf-lambda)
+            return t)))
+   ;; FIXME: Check on FUNCTIONALs (CLAMBDAs and OPTIONAL-DISPATCHes),
+   ;; not just LAMBDA-VARs.
+   (t
+    ;; Assume everything else is globally visible.
+    t)))
+
 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 ;;; restrictions from flow analysis IN, set the type for REF
 ;;; accordingly.
@@ -653,7 +677,9 @@
                               (and (leaf-refs other) ; protect from
                                         ; deleted vars
                                    (csubtypep other-type leaf-type)
-                                   (not (type= other-type leaf-type))))
+                                   (not (type= other-type leaf-type))
+                                   ;; Don't change to a LEAF not visible here.
+                                   (leaf-visible-from-node-p other ref)))
                           (change-ref-leaf ref other)
                           (when (constant-p other) (return)))
                          (t
@@ -755,11 +781,11 @@
                  for var in (lambda-vars fun)
                  and val in (combination-args call)
                  when (and val (lambda-var-constraints var))
-                 do (let* ((type (lvar-type val))
-                           (con (find-or-create-constraint 'typep var type
-                                                           nil)))
-                      (conset-adjoin con gen))
-                 (maybe-add-eql-var-var-constraint var val gen)))))
+                 do (let ((type (lvar-type val)))
+                      (unless (eq type *universal-type*)
+                        (let ((con (find-or-create-constraint 'typep var type nil)))
+                          (conset-adjoin con gen))))
+                    (maybe-add-eql-var-var-constraint var val gen)))))
       (ref
        (when (ok-ref-lambda-var node)
          (maybe-add-eql-var-lvar-constraint node gen)
@@ -772,17 +798,19 @@
          (let ((var (ok-lvar-lambda-var lvar gen)))
            (when var
              (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
-               (do-eql-vars (var (var gen))
-                 (let ((con (find-or-create-constraint 'typep var atype nil)))
-                   (conset-adjoin con gen))))))))
+               (unless (eq atype *universal-type*)
+                 (do-eql-vars (var (var gen))
+                   (let ((con (find-or-create-constraint 'typep var atype nil)))
+                     (conset-adjoin con gen)))))))))
       (cset
        (binding* ((var (set-var node))
                   (nil (lambda-var-p var) :exit-if-null)
                   (cons (lambda-var-constraints var) :exit-if-null))
          (conset-difference gen cons)
-         (let* ((type (single-value-type (node-derived-type node)))
-                (con (find-or-create-constraint 'typep var type nil)))
-           (conset-adjoin con gen))
+         (let ((type (single-value-type (node-derived-type node))))
+           (unless (eq type *universal-type*)
+             (let ((con (find-or-create-constraint 'typep var type nil)))
+               (conset-adjoin con gen))))
          (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
   gen)