X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=7c4d6235a73bfb1a35068be243b992059ddeeed2;hb=dcf8b8ccc1e15a5c1c6aba00204b7d3a81827acc;hp=85c2bb85b65bd0efbee66422d853b0994a9f1ca3;hpb=b34a3535ed7950a17e5dfe940285dcc10a814cb6;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 85c2bb8..7c4d623 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -171,16 +171,10 @@ ;;; Add complementary constraints to the consequent and alternative ;;; blocks of IF. We do nothing if X is NIL. -(defun add-complement-constraints (if fun x y not-p constraints - consequent-constraints - alternative-constraints) - (when (and x - ;; Note: Even if we do (IF test exp exp) => (PROGN test exp) - ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means - ;; that we can't guarantee that the optimization will be - ;; done, so we still need to avoid barfing on this case. - (not (eq (if-consequent if) - (if-alternative if)))) +(defun add-complement-constraints (fun x y not-p constraints + 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 @@ -191,58 +185,80 @@ ;;; the test represented by USE. (defun add-test-constraints (use if constraints) (declare (type node use) (type cif if)) - (let ((consequent-constraints (make-sset)) - (alternative-constraints (make-sset))) - (macrolet ((add (fun x y not-p) - `(add-complement-constraints if ,fun ,x ,y ,not-p - constraints - consequent-constraints - alternative-constraints))) - (typecase use - (ref - (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints) - (specifier-type 'null) t)) - (combination - (unless (eq (combination-kind use) - :error) - (let ((name (lvar-fun-name - (basic-combination-fun use))) - (args (basic-combination-args use))) - (case name - ((%typep %instance-typep) - (let ((type (second args))) - (when (constant-lvar-p type) - (let ((val (lvar-value type))) + ;; Note: Even if we do (IF test exp exp) => (PROGN test exp) + ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we + ;; can't guarantee that the optimization will be done, so we still + ;; need to avoid barfing on this case. + (unless (eq (if-consequent if) (if-alternative if)) + (let ((consequent-constraints (make-sset)) + (alternative-constraints (make-sset))) + (macrolet ((add (fun x y not-p) + `(add-complement-constraints ,fun ,x ,y ,not-p + constraints + consequent-constraints + alternative-constraints))) + (typecase use + (ref + (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints) + (specifier-type 'null) t)) + (combination + (unless (eq (combination-kind use) + :error) + (let ((name (lvar-fun-name + (basic-combination-fun use))) + (args (basic-combination-args use))) + (case name + ((%typep %instance-typep) + (let ((type (second args))) + (when (constant-lvar-p type) + (let ((val (lvar-value type))) + (add 'typep + (ok-lvar-lambda-var (first args) constraints) + (if (ctype-p val) + val + (specifier-type val)) + nil))))) + ((eq eql) + (let* ((arg1 (first args)) + (var1 (ok-lvar-lambda-var arg1 constraints)) + (arg2 (second args)) + (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 + ;; 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) + nil constraints + consequent-constraints))) + (var2 + (add 'eql var1 var2 nil)) + ((constant-lvar-p arg2) + (add 'eql var1 (ref-leaf (principal-lvar-use arg2)) + nil)) + (t + (add-test-constraint 'typep var1 (lvar-type arg2) + nil constraints + consequent-constraints))))) + ((< >) + (let* ((arg1 (first args)) + (var1 (ok-lvar-lambda-var arg1 constraints)) + (arg2 (second args)) + (var2 (ok-lvar-lambda-var arg2 constraints))) + (when var1 + (add name var1 (lvar-type arg2) nil)) + (when var2 + (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil)))) + (t + (let ((ptype (gethash name *backend-predicate-types*))) + (when ptype (add 'typep (ok-lvar-lambda-var (first args) constraints) - (if (ctype-p val) - val - (specifier-type val)) - nil))))) - ((eq eql) - (let* ((var1 (ok-lvar-lambda-var (first args) constraints)) - (arg2 (second args)) - (var2 (ok-lvar-lambda-var arg2 constraints))) - (cond ((not var1)) - (var2 - (add 'eql var1 var2 nil)) - ((constant-lvar-p arg2) - (add 'eql var1 (ref-leaf (principal-lvar-use arg2)) - nil))))) - ((< >) - (let* ((arg1 (first args)) - (var1 (ok-lvar-lambda-var arg1 constraints)) - (arg2 (second args)) - (var2 (ok-lvar-lambda-var arg2 constraints))) - (when var1 - (add name var1 (lvar-type arg2) nil)) - (when var2 - (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil)))) - (t - (let ((ptype (gethash name *backend-predicate-types*))) - (when ptype - (add 'typep (ok-lvar-lambda-var (first args) constraints) - ptype nil)))))))))) - (values consequent-constraints alternative-constraints))) + ptype nil)))))))))) + (values consequent-constraints alternative-constraints)))) ;;;; Applying constraints @@ -294,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))))) @@ -346,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)) @@ -392,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 @@ -415,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. @@ -438,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 @@ -463,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 @@ -504,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)