(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 ((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))
(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
(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
(: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
(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)