(add-complement-constraints if 'typep (ok-ref-lambda-var use)
(specifier-type 'null) t))
(combination
- (let ((name (continuation-function-name
- (basic-combination-fun use)))
- (args (basic-combination-args use)))
- (case name
- ((%typep %instance-typep)
- (let ((type (second args)))
- (when (constant-continuation-p type)
- (let ((val (continuation-value type)))
- (add-complement-constraints if 'typep
- (ok-cont-lambda-var (first args))
- (if (ctype-p val)
- val
- (specifier-type val))
- nil)))))
- ((eq eql)
- (let* ((var1 (ok-cont-lambda-var (first args)))
- (arg2 (second args))
- (var2 (ok-cont-lambda-var arg2)))
- (cond ((not var1))
- (var2
- (add-complement-constraints if 'eql var1 var2 nil))
- ((constant-continuation-p arg2)
- (add-complement-constraints if 'eql var1
- (ref-leaf
- (continuation-use arg2))
- nil)))))
- ((< >)
- (let* ((arg1 (first args))
- (var1 (ok-cont-lambda-var arg1))
- (arg2 (second args))
- (var2 (ok-cont-lambda-var arg2)))
- (when var1
- (add-complement-constraints if name var1 (continuation-type arg2)
- nil))
- (when var2
- (add-complement-constraints if (if (eq name '<) '> '<)
- var2 (continuation-type arg1)
- nil))))
- (t
- (let ((ptype (gethash name *backend-predicate-types*)))
- (when ptype
- (add-complement-constraints if 'typep
- (ok-cont-lambda-var (first args))
- ptype nil))))))))
+ (unless (eq (combination-kind use)
+ :error)
+ (let ((name (continuation-fun-name
+ (basic-combination-fun use)))
+ (args (basic-combination-args use)))
+ (case name
+ ((%typep %instance-typep)
+ (let ((type (second args)))
+ (when (constant-continuation-p type)
+ (let ((val (continuation-value type)))
+ (add-complement-constraints if 'typep
+ (ok-cont-lambda-var (first args))
+ (if (ctype-p val)
+ val
+ (specifier-type val))
+ nil)))))
+ ((eq eql)
+ (let* ((var1 (ok-cont-lambda-var (first args)))
+ (arg2 (second args))
+ (var2 (ok-cont-lambda-var arg2)))
+ (cond ((not var1))
+ (var2
+ (add-complement-constraints if 'eql var1 var2 nil))
+ ((constant-continuation-p arg2)
+ (add-complement-constraints if 'eql var1
+ (ref-leaf
+ (continuation-use arg2))
+ nil)))))
+ ((< >)
+ (let* ((arg1 (first args))
+ (var1 (ok-cont-lambda-var arg1))
+ (arg2 (second args))
+ (var2 (ok-cont-lambda-var arg2)))
+ (when var1
+ (add-complement-constraints if name var1 (continuation-type arg2)
+ nil))
+ (when var2
+ (add-complement-constraints if (if (eq name '<) '> '<)
+ var2 (continuation-type arg1)
+ nil))))
+ (t
+ (let ((ptype (gethash name *backend-predicate-types*)))
+ (when ptype
+ (add-complement-constraints if 'typep
+ (ok-cont-lambda-var (first args))
+ ptype nil)))))))))
(values))
;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to
;;; Compute the initial flow analysis sets for BLOCK:
;;; -- For any lambda-var ref with a type check, add that constraint.
-;;; -- For any lambda-var set, delete all constraints on that var, and add
+;;; -- For any LAMBDA-VAR set, delete all constraints on that var, and add
;;; those constraints to the set nuked by this block.
(defun find-block-type-constraints (block)
(declare (type cblock block))
(setf (block-in block) nil)
(setf (block-gen block) gen)
- (setf (block-kill block) (kill))
+ (setf (block-kill-list block) (kill))
(setf (block-out block) (copy-sset gen))
(setf (block-type-asserted block) nil)
(values))))
(greater (1+ x))
(t (1- x))))
(bound (x)
- (if greater (numeric-type-low x) (numeric-type-high x)))
- (validate (x)
- (if (and (numeric-type-low x) (numeric-type-high x)
- (> (numeric-type-low x) (numeric-type-high x)))
- *empty-type*
- x)))
+ (if greater (numeric-type-low x) (numeric-type-high 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 x-bound y-bound))
- (t (min x-bound y-bound))))
- (res (copy-numeric-type x)))
+ (t (min x-bound y-bound)))))
(if greater
- (setf (numeric-type-low res) new-bound)
- (setf (numeric-type-high res) new-bound))
- (validate res))))
+ (modified-numeric-type x :low new-bound)
+ (modified-numeric-type x :high new-bound)))))
;;; Return true if X is a float NUMERIC-TYPE.
(defun float-type-p (x)
;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
(defun constrain-float-type (x y greater or-equal)
(declare (type numeric-type x y))
- ;; Unless :PROPAGATE-FLOAT-TYPE is in target features, then
- ;; SB!C::BOUND-VALUE (used in the code below) is not defined, so we
- ;; just return X without trying to calculate additional constraints.
- #!-propagate-float-type (declare (ignore y greater or-equal))
- #!-propagate-float-type x
- #!+propagate-float-type
+ (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
+
+ (aver (eql (numeric-type-class x) 'float))
+ (aver (eql (numeric-type-class y) 'float))
+ #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+ x
+ #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(labels ((exclude (x)
(cond ((not x) nil)
(or-equal 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 (bound-value x) (bound-value 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
(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 (bound-value x) (bound-value y))))
+ ;; 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)))))
- (validate (x)
- (let ((x-lo (numeric-type-low x))
- (x-hi (numeric-type-high x)))
- (if (and x-lo x-hi (> (bound-value x-lo) (bound-value x-hi)))
- *empty-type*
- x))))
+ (set-bound res (or (consp x) (consp y))))))
(let* ((x-bound (bound x))
(y-bound (exclude (bound y)))
(new-bound (cond ((not x-bound)
(greater
(max-lower-bound x-bound y-bound))
(t
- (min-upper-bound x-bound y-bound))))
- (res (copy-numeric-type x)))
+ (min-upper-bound x-bound y-bound)))))
(if greater
- (setf (numeric-type-low res) new-bound)
- (setf (numeric-type-high res) new-bound))
- (validate res))))
+ (modified-numeric-type x :low new-bound)
+ (modified-numeric-type x :high new-bound)))))
;;; Given the set of CONSTRAINTS for a variable and the current set of
;;; restrictions from flow analysis IN, set the type for REF
(typep
(if not-p
(setq not-res (type-union not-res other))
- (setq res (type-intersection res other))))
+ (setq res (type-approx-intersection2 res other))))
(eql
(let ((other-type (leaf-type other)))
(if not-p
(let ((greater (if not-p (not greater) greater)))
(setq res
(constrain-integer-type res y greater not-p)))))
- #!+constrain-float-type
((and (float-type-p res) (float-type-p y))
(let ((greater (eq kind '>)))
(let ((greater (if not-p (not greater) greater)))
(csubtypep (specifier-type 'null) not-res)
(eq (continuation-asserted-type cont) *wild-type*))
(setf (node-derived-type ref) *wild-type*)
- (change-ref-leaf ref (find-constant 't)))
+ (change-ref-leaf ref (find-constant t)))
(t
(derive-node-type ref (or (type-difference res not-res)
res)))))))
(dolist (let (lambda-lets fun))
(frob let)))))
-;;; BLOCK-IN becomes the intersection of the OUT of the prececessors.
+;;; BLOCK-IN becomes the intersection of the OUT of the predecessors.
;;; Our OUT is:
;;; out U (in - kill)
;;;
-;;; BLOCK-KILL is just a list of the lambda-vars killed, so we must
+;;; BLOCK-KILL-LIST is just a list of the LAMBDA-VARs killed, so we must
;;; compute the kill set when there are any vars killed. We bum this a
;;; bit by special-casing when only one var is killed, and just using
;;; that var's constraints as the kill set. This set could possibly be
(sset-intersection res (block-out b)))
res))
(t
- (when *check-consistency*
- (let ((*compiler-error-context* (block-last block)))
- (compiler-warning
- "*** Unreachable code in constraint ~
- propagation... Bug?")))
+ (let ((*compiler-error-context* (block-last block)))
+ (compiler-warn
+ "unreachable code in constraint ~
+ propagation -- apparent compiler bug"))
(make-sset))))
- (kill (block-kill block))
+ (kill-list (block-kill-list block))
(out (block-out block)))
(setf (block-in block) in)
- (cond ((null kill)
+ (cond ((null kill-list)
(sset-union (block-out block) in))
- ((null (rest kill))
- (let ((con (lambda-var-constraints (first kill))))
+ ((null (rest kill-list))
+ (let ((con (lambda-var-constraints (first kill-list))))
(if con
(sset-union-of-difference out in con)
(sset-union out in))))
(t
(let ((kill-set (make-sset)))
- (dolist (var kill)
+ (dolist (var kill-list)
(let ((con (lambda-var-constraints var)))
(when con
(sset-union kill-set con))))
(sset-union-of-difference (block-out block) in kill-set))))))
+;;; How many blocks does COMPONENT have?
+(defun component-n-blocks (component)
+ (let ((result 0))
+ (declare (type index result))
+ (do-blocks (block component :both)
+ (incf result))
+ result))
+
(defun constraint-propagate (component)
(declare (type component component))
(init-var-constraints component)
(setf (block-out (component-head component)) (make-sset))
- (let ((did-something nil))
- (loop
- (do-blocks (block component)
- (when (flow-propagate-constraints block)
- (setq did-something t)))
-
- (unless did-something (return))
- (setq did-something nil)))
+ (let (;; If we have to propagate changes more than this many times,
+ ;; something is wrong.
+ (max-n-changes-remaining (component-n-blocks component)))
+ (declare (type fixnum max-n-changes-remaining))
+ (loop (aver (plusp max-n-changes-remaining))
+ (decf max-n-changes-remaining)
+ (let ((did-something nil))
+ (do-blocks (block component)
+ (when (flow-propagate-constraints block)
+ (setq did-something t)))
+ (unless did-something
+ (return)))))
(do-blocks (block component)
(use-result-constraints block))
(values))
-
projects / sbcl.git / blobdiff