;; from the following declarations. Probably you'll want to
;; disable these declarations when debugging consets.
(declare #-sb-xc-host (optimize (speed 3) (safety 0) (space 0)))
- (declaim (inline constraint-number))
- (defun constraint-number (constraint)
+ (declaim (inline %constraint-number))
+ (defun %constraint-number (constraint)
(sset-element-number constraint))
(defstruct (conset
(:constructor make-conset ())
:type simple-bit-vector)
;; Bit-vectors win over lightweight hashes for copy, union,
;; intersection, difference, but lose for iteration if you iterate
- ;; over the whole vector. Tracking extrema helps a bit. Note
- ;; that the CONSET-MIN is NIL when the set is known to be empty.
- ;; CONSET-MAX is a normal end bounding index.
- (min nil :type (or fixnum null))
+ ;; over the whole vector. Tracking extrema helps a bit.
+ (min 0 :type fixnum)
(max 0 :type fixnum))
(defmacro do-conset-elements ((constraint conset &optional result) &body body)
(with-unique-names (vector index start end
- ignore constraint-universe-end)
+ #-sb-xc-host ignore
+ #-sb-xc-host constraint-universe-end)
(let* ((constraint-universe #+sb-xc-host '*constraint-universe*
- #-sb-xc-host (gensym))
+ #-sb-xc-host (sb!xc:gensym "UNIVERSE"))
(with-array-data
#+sb-xc-host '(progn)
#-sb-xc-host `(with-array-data
(declare (ignore ,ignore))
(aver (<= ,end ,constraint-universe-end)))))
`(let* ((,vector (conset-vector ,conset))
- (,start (or (conset-min ,conset) 0))
+ (,start (conset-min ,conset))
(,end (min (conset-max ,conset) (length ,vector))))
(,@with-array-data
(do ((,index ,start (1+ ,index))) ((>= ,index ,end) ,result)
,@body)))
(defun conset-empty (conset)
- (or (null (conset-min conset))
+ (or (= (conset-min conset) (conset-max conset))
;; TODO: I bet FIND on bit-vectors can be optimized, if it
;; isn't.
(not (find 1 (conset-vector conset)
ret))
(defun %conset-grow (conset new-size)
- (declare (index new-size))
+ (declare (type index new-size))
(setf (conset-vector conset)
(replace (the simple-bit-vector
(make-array
(declaim (inline conset-grow))
(defun conset-grow (conset new-size)
- (declare (index new-size))
+ (declare (type index new-size))
(when (< (length (conset-vector conset)) new-size)
(%conset-grow conset new-size))
(values))
(defun conset-member (constraint conset)
- (let ((number (constraint-number constraint))
+ (let ((number (%constraint-number constraint))
(vector (conset-vector conset)))
(when (< number (length vector))
(plusp (sbit vector number)))))
(defun conset-adjoin (constraint conset)
(prog1
(not (conset-member constraint conset))
- (let ((number (constraint-number constraint)))
+ (let ((number (%constraint-number constraint)))
(conset-grow conset (1+ number))
(setf (sbit (conset-vector conset) number) 1)
- (setf (conset-min conset) (min number (or (conset-min conset)
- most-positive-fixnum)))
+ (setf (conset-min conset) (min number (conset-min conset)))
(when (>= number (conset-max conset))
(setf (conset-max conset) (1+ number))))))
(declare (simple-bit-vector vector1 vector2))
(setf (conset-vector conset-1) (,bit-op vector1 vector2 t))
;; Update the extrema.
- (setf (conset-min conset-1)
- ,(ecase name
- ((conset-union)
- `(min (or (conset-min conset-1)
- most-positive-fixnum)
- (or (conset-min conset-2)
- most-positive-fixnum)))
- ((conset-intersection)
- `(let ((start (max (or (conset-min conset-1) 0)
- (or (conset-min conset-2) 0)))
- (end (min (conset-max conset-1)
- (conset-max conset-1))))
+ ,(ecase name
+ ((conset-union)
+ `(setf (conset-min conset-1)
+ (min (conset-min conset-1)
+ (conset-min conset-2))
+ (conset-max conset-1)
+ (max (conset-max conset-1)
+ (conset-max conset-2))))
+ ((conset-intersection)
+ `(let ((start (max (conset-min conset-1)
+ (conset-min conset-2)))
+ (end (min (conset-max conset-1)
+ (conset-max conset-2))))
+ (setf (conset-min conset-1)
(if (> start end)
- nil
- (position 1 (conset-vector conset-1)
- :start start :end end))))
- ((conset-difference)
- `(position 1 (conset-vector conset-1)
- :start (or (conset-min conset-1) 0)
- :end (conset-max conset-1)
- )))
- (conset-max conset-1)
- ,(ecase name
- ((conset-union)
- `(max (conset-max conset-1)
- (conset-max conset-2)))
- ((conset-intersection)
- `(let ((start (max (or (conset-min conset-1) 0)
- (or (conset-min conset-2) 0)))
- (end (let ((minimum-maximum
- (min (conset-max conset-1)
- (conset-max conset-2))))
- (if (plusp minimum-maximum)
- (1- minimum-maximum)
- 0))))
+ 0
+ (or (position 1 (conset-vector conset-1)
+ :start start :end end)
+ 0))
+ (conset-max conset-1)
(if (> start end)
0
(let ((position
:start start :end end :from-end t)))
(if position
(1+ position)
- 0)))))
- ((conset-difference)
- `(let ((position
+ 0))))))
+ ((conset-difference)
+ `(setf (conset-min conset-1)
+ (or (position 1 (conset-vector conset-1)
+ :start (conset-min conset-1)
+ :end (conset-max conset-1))
+ 0)
+ (conset-max conset-1)
+ (let ((position
(position
1 (conset-vector conset-1)
- :start (or (conset-min conset-1) 0)
+ :start (conset-min conset-1)
:end (conset-max conset-1)
:from-end t)))
(if position
(let ((new (make-constraint (length *constraint-universe*)
kind x y not-p)))
(vector-push-extend new *constraint-universe*
- (* 2 (length *constraint-universe*)))
+ (1+ (length *constraint-universe*)))
(conset-adjoin new (lambda-var-constraints x))
(when (lambda-var-p y)
(conset-adjoin new (lambda-var-constraints y)))
(ok-lvar-lambda-var (first args) constraints)
(if (ctype-p val)
val
- (specifier-type val))
+ (let ((*compiler-error-context* use))
+ (specifier-type val)))
nil)))))
((eq eql)
(let* ((arg1 (first args))
(var2
(add 'eql var1 var2 nil))
((constant-lvar-p arg2)
- (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
+ (add 'eql var1
+ (let ((use (principal-lvar-use arg2)))
+ (if (ref-p use)
+ (ref-leaf use)
+ (find-constant (lvar-value arg2))))
nil))
(t
(add-test-constraint 'typep var1 (lvar-type arg2)
(modified-numeric-type x :low new-bound)
(modified-numeric-type x :high new-bound)))))
+;;; Return true if LEAF is "visible" from NODE.
+(defun leaf-visible-from-node-p (leaf node)
+ (cond
+ ((lambda-var-p leaf)
+ ;; A LAMBDA-VAR is visible iif it is homed in a CLAMBDA that is an
+ ;; ancestor for NODE.
+ (let ((leaf-lambda (lambda-var-home leaf)))
+ (loop for lambda = (node-home-lambda node)
+ then (lambda-parent lambda)
+ while lambda
+ when (eq lambda leaf-lambda)
+ return t)))
+ ;; FIXME: Check on FUNCTIONALs (CLAMBDAs and OPTIONAL-DISPATCHes),
+ ;; not just LAMBDA-VARs.
+ (t
+ ;; Assume everything else is globally visible.
+ t)))
+
;;; Given the set of CONSTRAINTS for a variable and the current set of
;;; restrictions from flow analysis IN, set the type for REF
;;; accordingly.
(and (leaf-refs other) ; protect from
; deleted vars
(csubtypep other-type leaf-type)
- (not (type= other-type leaf-type))))
+ (not (type= other-type leaf-type))
+ ;; Don't change to a LEAF not visible here.
+ (leaf-visible-from-node-p other ref)))
(change-ref-leaf ref other)
(when (constant-p other) (return)))
(t
for var in (lambda-vars fun)
and val in (combination-args call)
when (and val (lambda-var-constraints var))
- do (let* ((type (lvar-type val))
- (con (find-or-create-constraint 'typep var type
- nil)))
- (conset-adjoin con gen))
- (maybe-add-eql-var-var-constraint var val gen)))))
+ do (let ((type (lvar-type val)))
+ (unless (eq type *universal-type*)
+ (let ((con (find-or-create-constraint 'typep var type nil)))
+ (conset-adjoin con gen))))
+ (maybe-add-eql-var-var-constraint var val gen)))))
(ref
(when (ok-ref-lambda-var node)
(maybe-add-eql-var-lvar-constraint node gen)
(let ((var (ok-lvar-lambda-var lvar gen)))
(when var
(let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
- (do-eql-vars (var (var gen))
- (let ((con (find-or-create-constraint 'typep var atype nil)))
- (conset-adjoin con gen))))))))
+ (unless (eq atype *universal-type*)
+ (do-eql-vars (var (var gen))
+ (let ((con (find-or-create-constraint 'typep var atype nil)))
+ (conset-adjoin con gen)))))))))
(cset
(binding* ((var (set-var node))
(nil (lambda-var-p var) :exit-if-null)
(cons (lambda-var-constraints var) :exit-if-null))
(conset-difference gen cons)
- (let* ((type (single-value-type (node-derived-type node)))
- (con (find-or-create-constraint 'typep var type nil)))
- (conset-adjoin con gen))
+ (let ((type (single-value-type (node-derived-type node))))
+ (unless (eq type *universal-type*)
+ (let ((con (find-or-create-constraint 'typep var type nil)))
+ (conset-adjoin con gen))))
(maybe-add-eql-var-var-constraint var (set-value node) gen)))))
gen)
(frob let)))))
;;; Return the constraints that flow from PRED to SUCC. This is
-;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
+;;; BLOCK-OUT unless PRED ends with an IF and test constraints were
;;; added.
(defun block-out-for-successor (pred succ)
(declare (type cblock pred succ))
projects / sbcl.git / blobdiff