X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=0b9b694b71b8e6b1a80edcca1d32955005202c60;hb=389b5755b2eab960c1f4c14045a26de5dbd510c1;hp=85c2bb85b65bd0efbee66422d853b0994a9f1ca3;hpb=b34a3535ed7950a17e5dfe940285dcc10a814cb6;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 85c2bb8..0b9b694 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,64 +352,85 @@ ;;; 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* ((x (constraint-x con)) - (y (constraint-y con)) - (not-p (constraint-not-p con)) - (other (if (eq x leaf) y x)) - (kind (constraint-kind con))) - (case kind - (typep - (if not-p - (setq not-res (type-union not-res other)) - (setq res (type-approx-intersection2 res other)))) - (eql - (unless (lvar-p other) - (let ((other-type (leaf-type other))) - (if not-p - (when (and (constant-p other) - (member-type-p other-type)) - (setq not-res (type-union not-res other-type))) - (let ((leaf-type (leaf-type leaf))) - (cond - ((or (constant-p other) - (and (leaf-refs other) ; protect from + ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to + ;; cons up endless union types when propagating large number of EQL + ;; constraints -- eg. from large CASE forms -- instead we just + ;; directly accumulate one XSET, and a set of fp zeroes, which we at + ;; the end turn into a MEMBER-TYPE. + ;; + ;; Since massive symbol cases are an especially atrocious pattern + ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into + ;; a more useful type, don't propagate their negation except for NIL + ;; unless SPEED > COMPILATION-SPEED. + (let ((res (single-value-type (node-derived-type ref))) + (constrain-symbols (policy ref (> speed compilation-speed))) + (not-set (alloc-xset)) + (not-fpz nil) + (not-res *empty-type*) + (leaf (ref-leaf ref))) + (flet ((note-not (x) + (if (fp-zero-p x) + (push x not-fpz) + (when (or constrain-symbols (null x) (not (symbolp x))) + (add-to-xset x not-set))))) + (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)) + (other (if (eq x leaf) y x)) + (kind (constraint-kind con))) + (case kind + (typep + (if not-p + (if (member-type-p other) + (mapc-member-type-members #'note-not other) + (setq not-res (type-union not-res other))) + (setq res (type-approx-intersection2 res other)))) + (eql + (unless (lvar-p other) + (let ((other-type (leaf-type other))) + (if not-p + (when (and (constant-p other) + (member-type-p other-type)) + (note-not (constant-value other))) + (let ((leaf-type (leaf-type leaf))) + (cond + ((or (constant-p other) + (and (leaf-refs other) ; protect from ; deleted vars - (csubtypep other-type leaf-type) - (not (type= other-type leaf-type)))) - (change-ref-leaf ref other) - (when (constant-p other) (return))) - (t - (setq res (type-approx-intersection2 - res other-type))))))))) - ((< >) - (cond - ((and (integer-type-p res) (integer-type-p y)) - (let ((greater (eq kind '>))) - (let ((greater (if not-p (not greater) greater))) - (setq res - (constrain-integer-type res y greater not-p))))) - ((and (float-type-p res) (float-type-p y)) - (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))))) - + (csubtypep other-type leaf-type) + (not (type= other-type leaf-type)))) + (change-ref-leaf ref other) + (when (constant-p other) (return))) + (t + (setq res (type-approx-intersection2 + res other-type))))))))) + ((< >) + (cond + ((and (integer-type-p res) (integer-type-p y)) + (let ((greater (eq kind '>))) + (let ((greater (if not-p (not greater) greater))) + (setq res + (constrain-integer-type res y greater not-p))))) + ((and (float-type-p res) (float-type-p y)) + (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)) + (or (xset-member-p nil not-set) + (csubtypep (specifier-type 'null) not-res))) + (setf (node-derived-type ref) *wild-type*) + (change-ref-leaf ref (find-constant t))) + (t + (setf not-res + (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz))) + (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 +442,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 +466,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 +494,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 +534,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)