;;;
;;; -- 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")
(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))))
(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))
+ (lvar-uses 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
+ (let ((use (lvar-uses (if-test last))))
+ (when (node-p use)
(add-test-constraints use last)))))
(setf (block-test-modified block) nil)
(defun constrain-float-type (x y greater or-equal)
(declare (type numeric-type x y))
(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.)
(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)
- (eq (continuation-asserted-type cont) *wild-type*))
- (setf (node-derived-type ref) *wild-type*)
- (change-ref-leaf ref (find-constant t)))
- (t
- (derive-node-type ref (or (type-difference res not-res)
- res)))))))
+ (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)))))))
(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))
- (when (continuation-type-check cont)
- (let* ((atype (continuation-derived-type cont))
- (con (find-constraint 'typep var atype nil)))
- (sset-adjoin con gen))))))
+ (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 (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)
(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))))))))
-
-;;; Return true if VAR would have to be closed over if environment
-;;; analysis ran now (i.e. if there are any uses that have a different
-;;; home lambda than VAR's home.)
-(defun closure-var-p (var)
- (declare (type lambda-var var))
- (let ((home (lambda-home (lambda-var-home var))))
- (flet ((frob (l)
- (dolist (node l nil)
- (unless (eq (node-home-lambda node) home)
- (return t)))))
- (or (frob (leaf-refs var))
- (frob (basic-var-sets var))))))
+ (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
projects / sbcl.git / blobdiff