X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=3bc736213f9d4d02cc59591caba287fe0301a508;hb=07d6dd986728e8ea781954f5a3c2799ff0418ecb;hp=85c2bb85b65bd0efbee66422d853b0994a9f1ca3;hpb=b34a3535ed7950a17e5dfe940285dcc10a814cb6;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 85c2bb8..3bc7362 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)))))