(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.)
(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*))
+ (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 (or (type-difference res not-res)
- res)))))))
+ (derive-node-type ref
+ (make-single-value-type
+ (or (type-difference res not-res)
+ res))))))))
(values))
(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 (continuation-dest cont)))
+ (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)
(let ((cons (lambda-var-constraints var)))
(when cons
(sset-difference gen cons)
- (let* ((type (node-derived-type node))
+ (let* ((type (single-value-type (node-derived-type node)))
(con (find-constraint 'typep var type nil)))
(sset-adjoin con gen)))))))))
(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))))))
-
;;; 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
;;; looks identical to one that is new, so we optimistically keep