X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=0b9b694b71b8e6b1a80edcca1d32955005202c60;hb=389b5755b2eab960c1f4c14045a26de5dbd510c1;hp=9f1e1f030690bf91300ddfba95388275b56679ac;hpb=3c9981c71f4d0d2c5b5830486c4b9a35ab50a240;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 9f1e1f0..0b9b694 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -352,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 @@ -421,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. @@ -444,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 var2 var1 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 @@ -469,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 @@ -510,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)