X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=b30ecd212a1226a39e6ba028253c97a7394d72d2;hb=11dc847696f9c5441c409ce5b7fdf77cf27746c5;hp=27f2feb087eb35f9d0f0c597eccea793d797f4d2;hpb=8f31e3b32926c61b13240c447637d4bb9af10cdc;p=sbcl.git

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 27f2feb..b30ecd2 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -153,37 +153,6 @@
     (min 0 :type fixnum)
     (max 0 :type fixnum))
 
-  (defmacro do-conset-elements ((constraint conset &optional result) &body body)
-    (with-unique-names (vector index start end
-                               #-sb-xc-host ignore
-                               #-sb-xc-host constraint-universe-end)
-      (let* ((constraint-universe #+sb-xc-host '*constraint-universe*
-                                  #-sb-xc-host (sb!xc:gensym "UNIVERSE"))
-             (with-array-data
-                #+sb-xc-host '(progn)
-                #-sb-xc-host `(with-array-data
-                                  ((,constraint-universe *constraint-universe*)
-                                   (,ignore 0) (,constraint-universe-end nil)
-                                   :check-fill-pointer t)
-                                (declare (ignore ,ignore))
-                                (aver (<= ,end ,constraint-universe-end)))))
-        `(let* ((,vector (conset-vector ,conset))
-               (,start (conset-min ,conset))
-               (,end (min (conset-max ,conset) (length ,vector))))
-          (,@with-array-data
-            (do ((,index ,start (1+ ,index))) ((>= ,index ,end) ,result)
-              (when (plusp (sbit ,vector ,index))
-                (let ((,constraint (elt ,constraint-universe ,index)))
-                  ,@body))))))))
-
-  ;; Oddly, iterating just between the maximum of the two sets' minima
-  ;; and the minimum of the sets' maxima slowed down CP.
-  (defmacro do-conset-intersection
-      ((constraint conset1 conset2 &optional result) &body body)
-    `(do-conset-elements (,constraint ,conset1 ,result)
-       (when (conset-member ,constraint ,conset2)
-         ,@body)))
-
   (defun conset-empty (conset)
     (or (= (conset-min conset) (conset-max conset))
         ;; TODO: I bet FIND on bit-vectors can be optimized, if it
@@ -227,14 +196,13 @@
         (plusp (sbit vector number)))))
 
   (defun conset-adjoin (constraint conset)
-    (prog1
-      (not (conset-member constraint conset))
-      (let ((number (%constraint-number constraint)))
-        (conset-grow conset (1+ number))
-        (setf (sbit (conset-vector conset) number) 1)
-        (setf (conset-min conset) (min number (conset-min conset)))
-        (when (>= number (conset-max conset))
-          (setf (conset-max conset) (1+ number))))))
+    (let ((number (%constraint-number constraint)))
+      (conset-grow conset (1+ number))
+      (setf (sbit (conset-vector conset) number) 1)
+      (setf (conset-min conset) (min number (conset-min conset)))
+      (when (>= number (conset-max conset))
+        (setf (conset-max conset) (1+ number))))
+    conset)
 
   (defun conset= (conset1 conset2)
     (let* ((vector1 (conset-vector conset1))
@@ -325,7 +293,6 @@
 ;;; to over-approximate and then linear search through the potential hits.
 ;;; LVARs can only be found in EQL (not-p = NIL) constraints, while constant
 ;;; and lambda-vars can only be found in EQL constraints.
-
 (defun find-constraint (kind x y not-p)
   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
   (etypecase y
@@ -359,7 +326,10 @@
 ;;; Lambda-var -- lvar EQL constraints only serve one purpose: remember whether
 ;;; an lvar is (only) written to by a ref to that lambda-var, and aren't ever
 ;;; propagated.
-
+;;;
+;;; Finally, the lambda-var conset is only used to track the whole set of
+;;; constraints associated with a given lambda-var, and thus easily delete
+;;; such constraints from a conset.
 (defun register-constraint (x con y)
   (declare (type lambda-var x) (type constraint con) (type constraint-y y))
   (conset-adjoin con (lambda-var-constraints x))
@@ -410,33 +380,43 @@
         (when (lambda-var-p y)
           (register-constraint y new x))
         new)))
-
-;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
-;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
-#!-sb-fluid (declaim (inline ok-ref-lambda-var))
-(defun ok-ref-lambda-var (ref)
-  (declare (type ref ref))
-  (let ((leaf (ref-leaf ref)))
-    (when (and (lambda-var-p leaf)
-               (lambda-var-constraints leaf))
-      leaf)))
-
-;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
-;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
-(defun ok-lvar-lambda-var (lvar constraints)
-  (declare (type lvar lvar))
-  (let ((use (lvar-uses lvar)))
-    (cond ((ref-p use)
-           (let ((lambda-var (ok-ref-lambda-var use)))
-             (when lambda-var
-               (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
-                 (when (and constraint (conset-member constraint constraints))
-                   lambda-var)))))
-          ((cast-p use)
-           (ok-lvar-lambda-var (cast-value use) constraints)))))
-
+
+;;; Actual conset interface
+;;;
+;;; Constraint propagation needs to iterate over the set of lambda-vars known to
+;;; be EQL to a given variable (including itself), via DO-EQL-VARS.
+;;;
+;;; It also has to iterate through constraints that are inherited by EQL variables
+;;; (DO-INHERITABLE-CONSTRAINTS), and through constraints used by
+;;; CONSTRAIN-REF-TYPE (to derive the type of a REF to a lambda-var).
+;;;
+;;; Consets must keep track of which lvars are EQL to a given lambda-var (result
+;;; from a REF to the lambda-var): CONSET-LVAR-LAMBDA-VAR-EQL-P and
+;;; CONSET-ADD-LVAR-LAMBDA-VAR-EQL.  This, as all other constraints, must of
+;;; course be cleared when a lambda-var's constraints are dropped because of
+;;; assignment.
+;;;
+;;; Consets must be able to add constraints to a given lambda-var
+;;; (CONSET-ADD-CONSTRAINT), and to the set of variables EQL to a given
+;;; lambda-var (CONSET-ADD-CONSTRAINT-TO-EQL).
+;;;
+;;; When a lambda-var is assigned to, all the constraints involving that variable
+;;; must be dropped: constraint propagation is flow-sensitive, so the constraints
+;;; relate to the variable at a given range of program point.  In such cases,
+;;; constraint propagation calls CONSET-CLEAR-LAMBDA-VAR.
+;;;
+;;; Finally, one of the main strengths of constraint propagation in SBCL is the
+;;; tracking of EQL variables to help constraint propagation.  When two variables
+;;; are known to be EQL (e.g. after a branch), ADD-EQL-VAR-VAR-CONSTRAINT is
+;;; called to add the EQL constraint, but also have each equality class inherit
+;;; the other's (inheritable) constraints.
+;;;
+;;; On top of that, we have the usual bulk set operations: intersection, copy,
+;;; equality or emptiness testing.  There's also union, but that's only an
+;;; optimisation to avoid useless copies in ADD-TEST-CONSTRAINTS and
+;;; FIND-BLOCK-TYPE-CONSTRAINTS.
 (defmacro do-conset-constraints-intersection ((symbol (conset constraints) &optional result)
-                                             &body body)
+                                              &body body)
   (let ((min (gensym "MIN"))
         (max (gensym "MAX")))
     (once-only ((conset conset)
@@ -447,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)))
@@ -499,32 +480,133 @@
          (do-conset-constraints-intersection
              (con (,conset (lambda-var-inheritable-constraints ,variable)) ,result)
            (body-fun con))))))
+
+(declaim (inline conset-lvar-lambda-var-eql-p conset-add-lvar-lambda-var-eql))
+(defun conset-lvar-lambda-var-eql-p (conset lvar lambda-var)
+  (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
+    (and constraint
+         (conset-member constraint conset))))
+
+(defun conset-add-lvar-lambda-var-eql (conset lvar lambda-var)
+  (let ((constraint (find-or-create-constraint 'eql lambda-var lvar nil)))
+    (conset-adjoin constraint conset)))
+
+(declaim (inline conset-add-constraint conset-add-constraint-to-eql))
+(defun conset-add-constraint (conset kind x y not-p)
+  (declare (type conset conset)
+           (type lambda-var x))
+  (conset-adjoin (find-or-create-constraint kind x y not-p)
+                 conset))
+
+(defun conset-add-constraint-to-eql (conset kind x y not-p &optional (target conset))
+  (declare (type conset target conset)
+           (type lambda-var x))
+  (do-eql-vars (x (x conset))
+    (conset-add-constraint target kind x y not-p)))
+
+(declaim (inline conset-clear-lambda-var))
+(defun conset-clear-lambda-var (conset var)
+  (conset-difference conset (lambda-var-constraints var)))
+
+;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
+;;; LVAR) ones - to all of the variables in the VARS list.
+(defun inherit-constraints (vars from-var constraints target)
+  (do-inheritable-constraints (con (constraints from-var))
+    (let ((eq-x (eq from-var (constraint-x con)))
+          (eq-y (eq from-var (constraint-y con))))
+      (dolist (var vars)
+        (conset-add-constraint target
+                               (constraint-kind con)
+                               (if eq-x var (constraint-x con))
+                               (if eq-y var (constraint-y con))
+                               (constraint-not-p con))))))
+
+;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
+;; inherit each other's constraints.
+(defun add-eql-var-var-constraint (var1 var2 constraints
+                                   &optional (target constraints))
+  (let ((constraint (find-or-create-constraint 'eql var1 var2 nil)))
+    (unless (conset-member constraint target)
+      (conset-adjoin constraint target)
+      (collect ((eql1) (eql2))
+        (do-eql-vars (var1 (var1 constraints))
+          (eql1 var1))
+        (do-eql-vars (var2 (var2 constraints))
+          (eql2 var2))
+        (inherit-constraints (eql1) var2 constraints target)
+        (inherit-constraints (eql2) var1 constraints target))
+      t)))
+
+;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
+;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
+#!-sb-fluid (declaim (inline ok-ref-lambda-var))
+(defun ok-ref-lambda-var (ref)
+  (declare (type ref ref))
+  (let ((leaf (ref-leaf ref)))
+    (when (and (lambda-var-p leaf)
+               (lambda-var-constraints leaf))
+      leaf)))
+
+;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
+;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
+(defun ok-lvar-lambda-var (lvar constraints)
+  (declare (type lvar lvar))
+  (let ((use (lvar-uses lvar)))
+    (cond ((ref-p use)
+           (let ((lambda-var (ok-ref-lambda-var use)))
+             (and lambda-var
+                  (conset-lvar-lambda-var-eql-p constraints lvar lambda-var)
+                  lambda-var)))
+          ((cast-p use)
+           (ok-lvar-lambda-var (cast-value use) constraints)))))
 ;;;; Searching constraints
 
 ;;; Add the indicated test constraint to BLOCK. We don't add the
 ;;; constraint if the block has multiple predecessors, since it only
 ;;; holds on this particular path.
-(defun add-test-constraint (fun x y not-p constraints target)
-  (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
-         (add-eql-var-var-constraint x y constraints target))
-        (t
-         (do-eql-vars (x (x constraints))
-           (let ((con (find-or-create-constraint fun x y not-p)))
-             (conset-adjoin con target)))))
+(defun precise-add-test-constraint (fun x y not-p constraints target)
+  (if (and (eq 'eql fun) (lambda-var-p y) (not not-p))
+      (add-eql-var-var-constraint x y constraints target)
+      (conset-add-constraint-to-eql constraints fun x y not-p target))
   (values))
 
+(defun add-test-constraint (quick-p fun x y not-p constraints target)
+  (cond (quick-p
+         (conset-add-constraint target fun x y not-p))
+        (t
+         (precise-add-test-constraint fun x y not-p constraints target))))
 ;;; Add complementary constraints to the consequent and alternative
 ;;; blocks of IF. We do nothing if X is NIL.
-(defun add-complement-constraints (fun x y not-p constraints
-                                   consequent-constraints
-                                   alternative-constraints)
+(declaim (inline precise-add-test-constraint quick-add-complement-constraints))
+(defun precise-add-complement-constraints (fun x y not-p constraints
+                                           consequent-constraints
+                                           alternative-constraints)
+  (when x
+    (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))
+  (values))
+
+(defun quick-add-complement-constraints (fun x y not-p
+                                         consequent-constraints
+                                         alternative-constraints)
   (when x
-    (add-test-constraint fun x y not-p constraints
-                         consequent-constraints)
-    (add-test-constraint fun x y (not not-p) constraints
-                         alternative-constraints))
+    (conset-add-constraint consequent-constraints fun x y not-p)
+    (conset-add-constraint alternative-constraints fun x y (not not-p)))
   (values))
 
+(defun add-complement-constraints (quick-p fun x y not-p constraints
+                                   consequent-constraints
+                                   alternative-constraints)
+  (if quick-p
+      (quick-add-complement-constraints fun x y not-p
+                                        consequent-constraints
+                                        alternative-constraints)
+      (precise-add-complement-constraints fun x y not-p constraints
+                                          consequent-constraints
+                                          alternative-constraints)))
+
 ;;; Add test constraints to the consequent and alternative blocks of
 ;;; the test represented by USE.
 (defun add-test-constraints (use if constraints)
@@ -535,9 +617,11 @@
   ;; need to avoid barfing on this case.
   (unless (eq (if-consequent if) (if-alternative if))
     (let ((consequent-constraints (make-conset))
-          (alternative-constraints (make-conset)))
+          (alternative-constraints (make-conset))
+          (quick-p (policy if (> compilation-speed speed))))
       (macrolet ((add (fun x y not-p)
-                   `(add-complement-constraints ,fun ,x ,y ,not-p
+                   `(add-complement-constraints quick-p
+                                                ,fun ,x ,y ,not-p
                                                 constraints
                                                 consequent-constraints
                                                 alternative-constraints)))
@@ -570,27 +654,26 @@
                          (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
                     ;; unnatural asymmetry of the tests.
                     (cond ((not var1)
                            (when var2
-                             (add-test-constraint 'typep var2 (lvar-type arg1)
+                             (add-test-constraint quick-p
+                                                  'typep var2 (lvar-type arg1)
                                                   nil constraints
                                                   consequent-constraints)))
                           (var2
                            (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 'typep var1 (lvar-type arg2)
+                           (add-test-constraint quick-p
+                                                'typep var1 (lvar-type arg2)
                                                 nil constraints
                                                 consequent-constraints)))))
                  ((< >)
@@ -653,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
@@ -674,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
@@ -807,37 +894,7 @@
   (let ((lvar (ref-lvar ref))
         (leaf (ref-leaf ref)))
     (when (and (lambda-var-p leaf) lvar)
-      (conset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
-                     gen))))
-
-;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
-;;; LVAR) ones - to all of the variables in the VARS list.
-(defun inherit-constraints (vars from-var constraints target)
-  (do-inheritable-constraints (con (constraints from-var))
-    (let ((eq-x (eq from-var (constraint-x con)))
-          (eq-y (eq from-var (constraint-y con))))
-      (dolist (var vars)
-        (conset-adjoin (find-or-create-constraint
-                        (constraint-kind con)
-                        (if eq-x var (constraint-x con))
-                        (if eq-y var (constraint-y con))
-                        (constraint-not-p con))
-                       target)))))
-
-;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
-;; inherit each other's constraints.
-(defun add-eql-var-var-constraint (var1 var2 constraints
-                                   &optional (target constraints))
-  (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
-    (when (conset-adjoin con target)
-      (collect ((eql1) (eql2))
-        (do-eql-vars (var1 (var1 constraints))
-          (eql1 var1))
-        (do-eql-vars (var2 (var2 constraints))
-          (eql2 var2))
-        (inherit-constraints (eql1) var2 constraints target)
-        (inherit-constraints (eql2) var1 constraints target))
-      t)))
+      (conset-add-lvar-lambda-var-eql gen lvar leaf))))
 
 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
 ;; LAMBDA-VAR if possible.
@@ -868,8 +925,7 @@
                  when (and val (lambda-var-constraints var))
                  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))))
+                        (conset-add-constraint gen 'typep var type nil)))
                     (maybe-add-eql-var-var-constraint var val gen)))))
       (ref
        (when (ok-ref-lambda-var node)
@@ -882,19 +938,23 @@
            (when var
              (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
                (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)))))))))
+                 (conset-add-constraint-to-eql gen 'typep var atype nil)))))))
       (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)
+                  (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*)
-             (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)))))
+             (conset-add-constraint gen 'typep var type nil)))
+         (unless (policy node (> compilation-speed speed))
+           (maybe-add-eql-var-var-constraint var (set-value node) gen))))))
   gen)
 
 (defun constraint-propagate-if (block gen)
@@ -905,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))