;;; -- documentation
;;;
;;; -- MV-BIND, :ASSIGNMENT
+;;;
+;;; Note: The functions in this file that accept constraint sets are
+;;; actually receiving the constraint sets associated with nodes,
+;;; blocks, and lambda-vars. It might be make CP easier to understand
+;;; and work on if these functions traded in nodes, blocks, and
+;;; lambda-vars directly.
;;; Problems:
;;;
;;; 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
;;; 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
(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)))))
;;; 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
(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.
&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
;;; constraint.]
;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
;;; a type constraint based on the new value type.
-(declaim (ftype (function (cblock sset
- &key (:ref-preprocessor (or null function))
- (:set-preprocessor (or null function)))
+(declaim (ftype (function (cblock sset boolean)
sset)
constraint-propagate-in-block))
-(defun constraint-propagate-in-block
- (block gen &key ref-preprocessor set-preprocessor)
-
+(defun constraint-propagate-in-block (block gen preprocess-refs-p)
(do-nodes (node lvar block)
(typecase node
(bind
(ref
(when (ok-ref-lambda-var node)
(maybe-add-eql-var-lvar-constraint node gen)
- (when ref-preprocessor
- (funcall ref-preprocessor node gen))))
+ (when preprocess-refs-p
+ (let* ((var (ref-leaf node))
+ (con (lambda-var-constraints var)))
+ (constrain-ref-type node con gen)))))
(cast
(let ((lvar (cast-value node)))
(let ((var (ok-lvar-lambda-var lvar gen)))
(binding* ((var (set-var node))
(nil (lambda-var-p var) :exit-if-null)
(cons (lambda-var-constraints var) :exit-if-null))
- (when set-preprocessor
- (funcall set-preprocessor var))
(sset-difference gen cons)
(let* ((type (single-value-type (node-derived-type node)))
(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)
(when (node-p use)
(add-test-constraints use node gen))))))
-(defun constrain-node (node cons)
- (let* ((var (ref-leaf node))
- (con (lambda-var-constraints var)))
- (constrain-ref-type node con cons)))
-
;;; Starting from IN compute OUT and (consequent/alternative
;;; constraints if the block ends with and IF). Return the list of
;;; successors that may need to be recomputed.
-(defun find-block-type-constraints (block &key final-pass-p)
+(defun find-block-type-constraints (block final-pass-p)
(declare (type cblock block))
(let ((gen (constraint-propagate-in-block
block
(if final-pass-p
(block-in block)
(copy-sset (block-in block)))
- :ref-preprocessor (if final-pass-p #'constrain-node nil))))
+ final-pass-p)))
(setf (block-gen block) gen)
(multiple-value-bind (consequent-constraints alternative-constraints)
(constraint-propagate-if block gen)
;;; block.
(defun use-result-constraints (block)
(declare (type cblock block))
- (constraint-propagate-in-block block (block-in block)
- :ref-preprocessor #'constrain-node))
+ (constraint-propagate-in-block block (block-in block) t))
;;; Give an empty constraints set to any var that doesn't have one and
;;; isn't a set closure var. Since a var that we previously rejected
;; USE-RESULT-CONSTRAINTS later.
(dolist (block leading-blocks)
(setf (block-in block) (compute-block-in block))
- (find-block-type-constraints block :final-pass-p t))
+ (find-block-type-constraints block t))
(setq blocks-to-process (copy-list rest-of-blocks))
;; The rest of the blocks.
(dolist (block rest-of-blocks)
(aver (eq block (pop blocks-to-process)))
(setf (block-in block) (compute-block-in block))
- (enqueue (find-block-type-constraints block)))
+ (enqueue (find-block-type-constraints block nil)))
;; Propagate constraints
(loop for block = (pop blocks-to-process)
while block do
(unless (eq block (component-tail component))
(when (update-block-in block)
- (enqueue (find-block-type-constraints block)))))
+ (enqueue (find-block-type-constraints block nil)))))
rest-of-blocks))))
(defun constraint-propagate (component)
projects / sbcl.git / blobdiff