X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=b30ecd212a1226a39e6ba028253c97a7394d72d2;hb=b83353d9f998e5c0e34604b5593df70c66d2c510;hp=79f19c1888d514d7f4932a83245ff4f4891fba1b;hpb=fb24d88c8f97f1b344addab398fc54f62d8aa4ce;p=sbcl.git

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 79f19c1..b30ecd2 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -427,6 +427,7 @@
          (when ,constraints
            (let ((,min (conset-min ,conset))
                  (,max (conset-max ,conset)))
+             (declare (optimize speed))
              (map nil (lambda (constraint)
                         (declare (type constraint constraint))
                         (let ((number (constraint-number constraint)))
@@ -584,7 +585,7 @@
     (precise-add-test-constraint fun x y not-p constraints
                                 consequent-constraints)
     (precise-add-test-constraint fun x y (not not-p) constraints
-                         alternative-constraints))
+                                 alternative-constraints))
   (values))
 
 (defun quick-add-complement-constraints (fun x y not-p
@@ -653,7 +654,7 @@
                          (var2 (ok-lvar-lambda-var arg2 constraints)))
                     ;; The code below assumes that the constant is the
                     ;; second argument in case of variable to constant
-                    ;; comparision which is sometimes true (see source
+                    ;; comparison which is sometimes true (see source
                     ;; transformations for EQ, EQL and CHAR=). Fixing
                     ;; that would result in more constant substitutions
                     ;; which is not a universally good thing, thus the
@@ -668,10 +669,7 @@
                            (add 'eql var1 var2 nil))
                           ((constant-lvar-p arg2)
                            (add 'eql var1
-                                (let ((use (principal-lvar-use arg2)))
-                                  (if (ref-p use)
-                                      (ref-leaf use)
-                                      (find-constant (lvar-value arg2))))
+                                (find-constant (lvar-value arg2))
                                 nil))
                           (t
                            (add-test-constraint quick-p
@@ -738,6 +736,11 @@
        (eq (numeric-type-complexp x) :real)))
 
 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
+;;;
+;;; In contrast to the integer version, here the input types can have
+;;; open bounds in addition to closed ones and we don't increment or
+;;; decrement a bound to honor OR-EQUAL being NIL but put an open bound
+;;; into the result instead, if appropriate.
 (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
@@ -759,10 +762,9 @@
            (tighter-p (x ref)
              (cond ((null x) nil)
                    ((null ref) t)
-                   ((and or-equal
-                         (= (type-bound-number x) (type-bound-number ref)))
-                    ;; X is tighter if REF is not an open bound and X is
-                    (and (not (consp ref)) (consp x)))
+                   ((= (type-bound-number x) (type-bound-number ref))
+                    ;; X is tighter if X is an open bound and REF is not
+                    (and (consp x) (not (consp ref))))
                    (greater
                     (< (type-bound-number ref) (type-bound-number x)))
                    (t
@@ -941,6 +943,12 @@
        (binding* ((var (set-var node))
                   (nil (lambda-var-p var) :exit-if-null)
                   (nil (lambda-var-constraints var) :exit-if-null))
+         (when (policy node (and (= speed 3) (> speed compilation-speed)))
+           (let ((type (lambda-var-type var)))
+             (unless (eql *universal-type* type)
+               (do-eql-vars (other (var gen))
+                 (unless (eql other var)
+                   (conset-add-constraint gen 'typep other type nil))))))
          (conset-clear-lambda-var gen var)
          (let ((type (single-value-type (node-derived-type node))))
            (unless (eq type *universal-type*)
@@ -957,7 +965,7 @@
           (add-test-constraints use node gen))))))
 
 ;;; Starting from IN compute OUT and (consequent/alternative
-;;; constraints if the block ends with and IF). Return the list of
+;;; constraints if the block ends with an IF). Return the list of
 ;;; successors that may need to be recomputed.
 (defun find-block-type-constraints (block final-pass-p)
   (declare (type cblock block))