X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=7c4d6235a73bfb1a35068be243b992059ddeeed2;hb=dcf8b8ccc1e15a5c1c6aba00204b7d3a81827acc;hp=cec677001e7b415c4f6087c0d3c6aa0bbb8deee5;hpb=a3d84edc295f60e459ec917e8bc1e3d19829381e;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index cec6770..7c4d623 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -310,49 +310,39 @@ (aver (eql (numeric-type-class x) 'float)) (aver (eql (numeric-type-class y) 'float)) - #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) x - #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (labels ((exclude (x) (cond ((not x) nil) (or-equal x) - (greater - (if (consp x) - (car x) - x)) (t (if (consp x) x (list x))))) (bound (x) (if greater (numeric-type-low x) (numeric-type-high x))) - (max-lower-bound (x y) - ;; Both X and Y are not null. Find the max. - (let ((res (max (type-bound-number x) (type-bound-number y)))) - ;; An open lower bound is greater than a close - ;; lower bound because the open bound doesn't - ;; contain the bound, so choose an open lower - ;; bound. - (set-bound res (or (consp x) (consp y))))) - (min-upper-bound (x y) - ;; Same as above, but for the min of upper bounds - ;; Both X and Y are not null. Find the min. - (let ((res (min (type-bound-number x) (type-bound-number y)))) - ;; An open upper bound is less than a closed - ;; upper bound because the open bound doesn't - ;; contain the bound, so choose an open lower - ;; bound. - (set-bound res (or (consp x) (consp y)))))) + (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))) + (greater + (< (type-bound-number ref) (type-bound-number x))) + (t + (> (type-bound-number ref) (type-bound-number x)))))) (let* ((x-bound (bound x)) (y-bound (exclude (bound y))) (new-bound (cond ((not x-bound) y-bound) ((not y-bound) x-bound) - (greater - (max-lower-bound x-bound y-bound)) + ((tighter-p y-bound x-bound) + y-bound) (t - (min-upper-bound x-bound y-bound))))) + x-bound)))) (if greater (modified-numeric-type x :low new-bound) (modified-numeric-type x :high new-bound))))) @@ -362,12 +352,11 @@ ;;; accordingly. (defun constrain-ref-type (ref constraints in) (declare (type ref ref) (type sset constraints in)) - (let ((var-cons (copy-sset constraints))) - (sset-intersection var-cons in) - (let ((res (single-value-type (node-derived-type ref))) - (not-res *empty-type*) - (leaf (ref-leaf ref))) - (do-sset-elements (con var-cons) + (let ((res (single-value-type (node-derived-type ref))) + (not-res *empty-type*) + (leaf (ref-leaf ref))) + (do-sset-elements (con constraints) + (when (sset-member con in) (let* ((x (constraint-x con)) (y (constraint-y con)) (not-p (constraint-not-p con)) @@ -408,18 +397,17 @@ (let ((greater (eq kind '>))) (let ((greater (if not-p (not greater) greater))) (setq res - (constrain-float-type res y greater not-p)))))))))) - (cond ((and (if-p (node-dest ref)) - (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 - (make-single-value-type - (or (type-difference res not-res) - res))) - (maybe-terminate-block ref nil))))) - + (constrain-float-type res y greater not-p))))))))))) + (cond ((and (if-p (node-dest ref)) + (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 + (make-single-value-type + (or (type-difference res not-res) + res))) + (maybe-terminate-block ref nil)))) (values)) ;;;; Flow analysis @@ -431,22 +419,23 @@ (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil) gen)))) -;;; Copy all CONSTRAINTS involving FROM-VAR to VAR except the (EQL VAR -;;; LVAR) ones. -(defun inherit-constraints (var from-var constraints target) +;;; 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-sset-elements (con constraints) - (let ((eq-x (eq from-var (constraint-x con))) - (eq-y (eq from-var (constraint-y con)))) - ;; Constant substitution is controversial. - (unless (constant-p (constraint-y con)) - (when (or (and eq-x (not (lvar-p (constraint-y con)))) - eq-y) - (sset-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)))))) + ;; Constant substitution is controversial. + (unless (constant-p (constraint-y con)) + (dolist (var vars) + (let ((eq-x (eq from-var (constraint-x con))) + (eq-y (eq from-var (constraint-y con)))) + (when (or (and eq-x (not (lvar-p (constraint-y con)))) + eq-y) + (sset-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. @@ -454,10 +443,13 @@ &optional (target constraints)) (let ((con (find-or-create-constraint 'eql var1 var2 nil))) (when (sset-adjoin con target) - (do-eql-vars (var2 (var2 constraints)) - (inherit-constraints var1 var2 constraints target)) - (do-eql-vars (var1 (var1 constraints)) - (inherit-constraints var1 var2 constraints 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))) ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's @@ -479,9 +471,8 @@ (:set-preprocessor (or null function))) sset) constraint-propagate-in-block)) -(defun constraint-propagate-in-block - (block gen &key ref-preprocessor set-preprocessor) - +(defun constraint-propagate-in-block (block gen &key + ref-preprocessor set-preprocessor) (do-nodes (node lvar block) (typecase node (bind @@ -520,7 +511,6 @@ (con (find-or-create-constraint 'typep var type nil))) (sset-adjoin con gen)) (maybe-add-eql-var-var-constraint var (set-value node) gen))))) - gen) (defun constraint-propagate-if (block gen)