;;;
;;; -- this code does not check whether SET appears between REF and a
;;; test (bug 233b)
-;;;
-;;; -- type check is assumed to be inserted immediately after a node
-;;; producing the value; it disagrees with the rest of Python (bug
-;;; 233a)
(in-package "SB!C")
(defstruct (constraint
- (:include sset-element)
- (:constructor make-constraint (number kind x y not-p))
- (:copier nil))
+ (:include sset-element)
+ (:constructor make-constraint (number kind x y not-p))
+ (:copier nil))
;; the kind of constraint we have:
;;
;; TYPEP
;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
(defun find-constraint (kind x y not-p)
(declare (type lambda-var x) (type (or constant lambda-var ctype) y)
- (type boolean not-p))
+ (type boolean not-p))
(or (etypecase y
- (ctype
- (do-sset-elements (con (lambda-var-constraints x) nil)
- (when (and (eq (constraint-kind con) kind)
- (eq (constraint-not-p con) not-p)
- (type= (constraint-y con) y))
- (return con))))
- (constant
- (do-sset-elements (con (lambda-var-constraints x) nil)
- (when (and (eq (constraint-kind con) kind)
- (eq (constraint-not-p con) not-p)
- (eq (constraint-y con) y))
- (return con))))
- (lambda-var
- (do-sset-elements (con (lambda-var-constraints x) nil)
- (when (and (eq (constraint-kind con) kind)
- (eq (constraint-not-p con) not-p)
- (let ((cx (constraint-x con)))
- (eq (if (eq cx x)
- (constraint-y con)
- cx)
- y)))
- (return con)))))
+ (ctype
+ (do-sset-elements (con (lambda-var-constraints x) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (type= (constraint-y con) y))
+ (return con))))
+ (constant
+ (do-sset-elements (con (lambda-var-constraints x) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (eq (constraint-y con) y))
+ (return con))))
+ (lambda-var
+ (do-sset-elements (con (lambda-var-constraints x) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (let ((cx (constraint-x con)))
+ (eq (if (eq cx x)
+ (constraint-y con)
+ cx)
+ y)))
+ (return con)))))
(let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
- (sset-adjoin new (lambda-var-constraints x))
- (when (lambda-var-p y)
- (sset-adjoin new (lambda-var-constraints y)))
- new)))
+ (sset-adjoin new (lambda-var-constraints x))
+ (when (lambda-var-p y)
+ (sset-adjoin new (lambda-var-constraints y)))
+ new)))
;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
(declare (type ref ref))
(let ((leaf (ref-leaf ref)))
(when (and (lambda-var-p leaf)
- (lambda-var-constraints leaf))
+ (lambda-var-constraints leaf))
leaf)))
-;;; If CONT's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE,
+;;; If LVAR's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE,
;;; otherwise NIL.
-#!-sb-fluid (declaim (inline ok-cont-lambda-var))
-(defun ok-cont-lambda-var (cont)
- (declare (type continuation cont))
- (let ((use (continuation-use cont)))
+#!-sb-fluid (declaim (inline ok-lvar-lambda-var))
+(defun ok-lvar-lambda-var (lvar)
+ (declare (type lvar lvar))
+ (let ((use (lvar-uses lvar)))
(when (ref-p use)
(ok-ref-lambda-var use))))
(defun add-test-constraint (block fun x y not-p)
(unless (rest (block-pred block))
(let ((con (find-constraint fun x y not-p))
- (old (or (block-test-constraint block)
- (setf (block-test-constraint block) (make-sset)))))
+ (old (or (block-test-constraint block)
+ (setf (block-test-constraint block) (make-sset)))))
(when (sset-adjoin con old)
- (setf (block-type-asserted block) t))))
+ (setf (block-type-asserted block) t))))
(values))
;;; 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)
(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.
+ ;; 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))))
(add-test-constraint (if-consequent if) fun x y not-p)
(typecase use
(ref
(add-complement-constraints if 'typep (ok-ref-lambda-var use)
- (specifier-type 'null) t))
+ (specifier-type 'null) t))
(combination
(unless (eq (combination-kind use)
:error)
- (let ((name (continuation-fun-name
+ (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-continuation-p type)
- (let ((val (continuation-value type)))
+ (when (constant-lvar-p type)
+ (let ((val (lvar-value type)))
(add-complement-constraints if 'typep
- (ok-cont-lambda-var (first args))
+ (ok-lvar-lambda-var (first args))
(if (ctype-p val)
val
(specifier-type val))
nil)))))
((eq eql)
- (let* ((var1 (ok-cont-lambda-var (first args)))
+ (let* ((var1 (ok-lvar-lambda-var (first args)))
(arg2 (second args))
- (var2 (ok-cont-lambda-var arg2)))
+ (var2 (ok-lvar-lambda-var arg2)))
(cond ((not var1))
(var2
(add-complement-constraints if 'eql var1 var2 nil))
- ((constant-continuation-p arg2)
+ ((constant-lvar-p arg2)
(add-complement-constraints if 'eql var1
(ref-leaf
- (continuation-use arg2))
+ (principal-lvar-use arg2))
nil)))))
((< >)
(let* ((arg1 (first args))
- (var1 (ok-cont-lambda-var arg1))
+ (var1 (ok-lvar-lambda-var arg1))
(arg2 (second args))
- (var2 (ok-cont-lambda-var arg2)))
+ (var2 (ok-lvar-lambda-var arg2)))
(when var1
- (add-complement-constraints if name var1 (continuation-type arg2)
+ (add-complement-constraints if name var1 (lvar-type arg2)
nil))
(when var2
(add-complement-constraints if (if (eq name '<) '> '<)
- var2 (continuation-type arg1)
+ var2 (lvar-type arg1)
nil))))
(t
(let ((ptype (gethash name *backend-predicate-types*)))
(when ptype
(add-complement-constraints if 'typep
- (ok-cont-lambda-var (first args))
+ (ok-lvar-lambda-var (first args))
ptype nil)))))))))
(values))
(declare (type cblock block))
(let ((last (block-last block)))
(when (if-p last)
- (let ((use (continuation-use (if-test last))))
- (when use
- (add-test-constraints use last)))))
+ (let ((use (lvar-uses (if-test last))))
+ (when (node-p use)
+ (add-test-constraints use last)))))
(setf (block-test-modified block) nil)
(values))
(defun constrain-integer-type (x y greater or-equal)
(declare (type numeric-type x y))
(flet ((exclude (x)
- (cond ((not x) nil)
- (or-equal x)
- (greater (1+ x))
- (t (1- x))))
- (bound (x)
- (if greater (numeric-type-low x) (numeric-type-high x))))
+ (cond ((not x) nil)
+ (or-equal x)
+ (greater (1+ x))
+ (t (1- x))))
+ (bound (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)))))
+ (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)))))
(if greater
- (modified-numeric-type x :low new-bound)
- (modified-numeric-type x :high new-bound)))))
+ (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)
x
#-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))))))
+ (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))))))
(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))
- (t
- (min-upper-bound x-bound y-bound)))))
+ (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))
+ (t
+ (min-upper-bound x-bound y-bound)))))
(if greater
- (modified-numeric-type x :low new-bound)
- (modified-numeric-type x :high new-bound)))))
+ (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
(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)))
+ (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
- (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)))
- (when (or (constant-p other)
- (and (csubtypep other-type leaf-type)
- (not (type= other-type leaf-type))))
- (change-ref-leaf ref other)
- (when (constant-p other) (return)))))))
- ((< >)
- (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)))))
- )))))
-
- (let* ((cont (node-cont ref))
- (dest (continuation-dest cont)))
- (cond ((and (if-p dest)
- (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))))))))
+ (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
+ (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)))
+ (when (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)))))))
+ ((< >)
+ (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)))))
(values))
(when test
(sset-union gen test)))
- (do-nodes (node cont block)
+ (do-nodes (node lvar block)
(typecase node
(bind
(let ((fun (bind-lambda node)))
(when (eq (functional-kind fun) :let)
- (loop with call = (continuation-dest
- (node-cont (first (lambda-refs fun))))
- for var in (lambda-vars fun)
- and val in (combination-args call)
- when (and val
- (lambda-var-constraints var)
- ;; if VAR has no SETs, type inference is
- ;; fully performed by IR1 optimizer
- (lambda-var-sets var))
- do (let* ((type (continuation-type val))
- (con (find-constraint 'typep var type nil)))
- (sset-adjoin con gen))))))
+ (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
+ for var in (lambda-vars fun)
+ and val in (combination-args call)
+ when (and val
+ (lambda-var-constraints var)
+ ;; if VAR has no SETs, type inference is
+ ;; fully performed by IR1 optimizer
+ (lambda-var-sets var))
+ do (let* ((type (lvar-type val))
+ (con (find-constraint 'typep var type nil)))
+ (sset-adjoin con gen))))))
(ref
(let ((var (ok-ref-lambda-var node)))
(when var
(when ref-preprocessor
(funcall ref-preprocessor node gen))
- (let ((dest (continuation-dest cont)))
+ (let ((dest (and lvar (lvar-dest lvar))))
(when (cast-p dest)
(let* ((atype (single-value-type (cast-derived-type dest))) ; FIXME
(con (find-constraint 'typep var atype nil)))
(sset-adjoin con gen)))))))
(cset
- (let ((var (set-var node)))
- (when (lambda-var-p var)
- (when set-preprocessor
- (funcall set-preprocessor var))
- (let ((cons (lambda-var-constraints var)))
- (when cons
- (sset-difference gen cons)
- (let* ((type (single-value-type (node-derived-type node)))
- (con (find-constraint 'typep var type nil)))
- (sset-adjoin con 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-constraint 'typep var type nil)))
+ (sset-adjoin con gen))))))
gen)
(kill (block-kill block))
(out (copy-sset (block-gen block))))
(cond ((null kill)
- (sset-union out in))
- ((null (rest kill))
- (let ((con (lambda-var-constraints (first kill))))
- (if con
- (sset-union-of-difference out in con)
- (sset-union out in))))
- (t
- (let ((kill-set (make-sset)))
- (dolist (var kill)
- (let ((con (lambda-var-constraints var)))
- (when con
- (sset-union kill-set con))))
- (sset-union-of-difference out in kill-set))))
+ (sset-union out in))
+ ((null (rest kill))
+ (let ((con (lambda-var-constraints (first kill))))
+ (if con
+ (sset-union-of-difference out in con)
+ (sset-union out in))))
+ (t
+ (let ((kill-set (make-sset)))
+ (dolist (var kill)
+ (let ((con (lambda-var-constraints var)))
+ (when con
+ (sset-union kill-set con))))
+ (sset-union-of-difference out in kill-set))))
out))
;;; Compute the initial flow analysis sets for BLOCK:
;;; Return True if we have done something.
(defun flow-propagate-constraints (block)
(let* ((pred (block-pred block))
- (in (progn (aver pred)
+ (in (progn (aver pred)
(let ((res (copy-sset (block-out (first pred)))))
(dolist (b (rest pred))
(sset-intersection res (block-out b)))
(constraint-propagate-in-block
block (block-in block)
:ref-preprocessor (lambda (node cons)
- (let ((var (ref-leaf node)))
- (when (lambda-var-p var)
- (let ((con (lambda-var-constraints var)))
- (when con
- (constrain-ref-type node con cons))))))))
+ (let* ((var (ref-leaf node))
+ (con (lambda-var-constraints var)))
+ (constrain-ref-type node con cons)))))
;;; 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
(declare (type component component))
(dolist (fun (component-lambdas component))
(flet ((frob (x)
- (dolist (var (lambda-vars x))
- (unless (lambda-var-constraints var)
- (when (or (null (lambda-var-sets var))
- (not (closure-var-p var)))
- (setf (lambda-var-constraints var) (make-sset)))))))
+ (dolist (var (lambda-vars x))
+ (unless (lambda-var-constraints var)
+ (when (or (null (lambda-var-sets var))
+ (not (closure-var-p var)))
+ (setf (lambda-var-constraints var) (make-sset)))))))
(frob fun)
(dolist (let (lambda-lets fun))
- (frob let)))))
+ (frob let)))))
;;; How many blocks does COMPONENT have?
(defun component-n-blocks (component)
(return))))))
(do-blocks (block component)
- (use-result-constraints block))
+ (unless (block-delete-p block)
+ (use-result-constraints block)))
(values))
projects / sbcl.git / blobdiff