;;; -- documentation
;;;
;;; -- MV-BIND, :ASSIGNMENT
+;;;
+;;; Note: The functions in this file that accept constraint sets are
+;;; actually receiving the constraint sets associated with nodes,
+;;; blocks, and lambda-vars. It might be make CP easier to understand
+;;; and work on if these functions traded in nodes, blocks, and
+;;; lambda-vars directly.
;;; Problems:
;;;
(in-package "SB!C")
+;;; *CONSTRAINT-UNIVERSE* gets bound in IR1-PHASES to a fresh,
+;;; zero-length, non-zero-total-size vector-with-fill-pointer.
+(declaim (type (and vector (not simple-vector)) *constraint-universe*))
+(defvar *constraint-universe*)
+
(deftype constraint-y () '(or ctype lvar lambda-var constant))
(defstruct (constraint
;; If true, negates the sense of the constraint, so the relation
;; does *not* hold.
(not-p nil :type boolean))
-
-(defvar *constraint-number*)
-(declaim (type (integer 0) *constraint-number*))
-
+\f
+;;; Historically, CMUCL and SBCL have used a sparse set implementation
+;;; for which most operations are O(n) (see sset.lisp), but at the
+;;; cost of at least a full word of pointer for each constraint set
+;;; element. Using bit-vectors instead of pointer structures saves a
+;;; lot of space and thus GC time (particularly on 64-bit machines),
+;;; and saves time on copy, union, intersection, and difference
+;;; operations; but makes iteration slower. Circa September 2008,
+;;; switching to bit-vectors gave a modest (5-10%) improvement in real
+;;; compile time for most Lisp systems, and as much as 20-30% for some
+;;; particularly CP-dependent systems.
+
+;;; It's bad to leave commented code in files, but if some clever
+;;; person comes along and makes SSETs better than bit-vectors as sets
+;;; for constraint propagation, or if bit-vectors on some XC host
+;;; really lose compared to SSETs, here's the conset API as a wrapper
+;;; around SSETs:
+#+nil
+(progn
+ (deftype conset () 'sset)
+ (declaim (ftype (sfunction (conset) boolean) conset-empty))
+ (declaim (ftype (sfunction (conset) conset) copy-conset))
+ (declaim (ftype (sfunction (constraint conset) boolean) conset-member))
+ (declaim (ftype (sfunction (constraint conset) boolean) conset-adjoin))
+ (declaim (ftype (sfunction (conset conset) boolean) conset=))
+ (declaim (ftype (sfunction (conset conset) (values)) conset-union))
+ (declaim (ftype (sfunction (conset conset) (values)) conset-intersection))
+ (declaim (ftype (sfunction (conset conset) (values)) conset-difference))
+ (defun make-conset () (make-sset))
+ (defmacro do-conset-elements ((constraint conset &optional result) &body body)
+ `(do-sset-elements (,constraint ,conset ,result) ,@body))
+ (defmacro do-conset-intersection
+ ((constraint conset1 conset2 &optional result) &body body)
+ `(do-conset-elements (,constraint ,conset1 ,result)
+ (when (conset-member ,constraint ,conset2)
+ ,@body)))
+ (defun conset-empty (conset) (sset-empty conset))
+ (defun copy-conset (conset) (copy-sset conset))
+ (defun conset-member (constraint conset) (sset-member constraint conset))
+ (defun conset-adjoin (constraint conset) (sset-adjoin constraint conset))
+ (defun conset= (conset1 conset2) (sset= conset1 conset2))
+ ;; Note: CP doesn't ever care whether union, intersection, and
+ ;; difference change the first set. (This is an important degree of
+ ;; freedom, since some ways of implementing sets lose a great deal
+ ;; when these operations are required to track changes.)
+ (defun conset-union (conset1 conset2)
+ (sset-union conset1 conset2) (values))
+ (defun conset-intersection (conset1 conset2)
+ (sset-intersection conset1 conset2) (values))
+ (defun conset-difference (conset1 conset2)
+ (sset-difference conset1 conset2) (values)))
+
+(locally
+ ;; This is performance critical for the compiler, and benefits
+ ;; 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)
+ (sset-element-number constraint))
+ (defstruct (conset
+ (:constructor make-conset ())
+ (:copier %copy-conset))
+ (vector (make-array
+ ;; FIXME: make POWER-OF-TWO-CEILING available earlier?
+ (ash 1 (integer-length (1- (length *constraint-universe*))))
+ :element-type 'bit :initial-element 0)
+ :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.
+ (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
+ #-sb-xc-host ignore
+ #-sb-xc-host constraint-universe-end)
+ (let* ((constraint-universe #+sb-xc-host '*constraint-universe*
+ #-sb-xc-host (gensym))
+ (with-array-data
+ #+sb-xc-host '(progn)
+ #-sb-xc-host `(with-array-data
+ ((,constraint-universe *constraint-universe*)
+ (,ignore 0) (,constraint-universe-end nil)
+ :check-fill-pointer t)
+ (declare (ignore ,ignore))
+ (aver (<= ,end ,constraint-universe-end)))))
+ `(let* ((,vector (conset-vector ,conset))
+ (,start (conset-min ,conset))
+ (,end (min (conset-max ,conset) (length ,vector))))
+ (,@with-array-data
+ (do ((,index ,start (1+ ,index))) ((>= ,index ,end) ,result)
+ (when (plusp (sbit ,vector ,index))
+ (let ((,constraint (elt ,constraint-universe ,index)))
+ ,@body))))))))
+
+ ;; Oddly, iterating just between the maximum of the two sets' minima
+ ;; and the minimum of the sets' maxima slowed down CP.
+ (defmacro do-conset-intersection
+ ((constraint conset1 conset2 &optional result) &body body)
+ `(do-conset-elements (,constraint ,conset1 ,result)
+ (when (conset-member ,constraint ,conset2)
+ ,@body)))
+
+ (defun conset-empty (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)
+ :start (conset-min conset)
+ ;; By inspection, supplying :END here breaks the
+ ;; build with a "full call to
+ ;; DATA-VECTOR-REF-WITH-OFFSET" in the
+ ;; cross-compiler. If that should change, add
+ ;; :end (conset-max conset)
+ ))))
+
+ (defun copy-conset (conset)
+ (let ((ret (%copy-conset conset)))
+ (setf (conset-vector ret) (copy-seq (conset-vector conset)))
+ ret))
+
+ (defun %conset-grow (conset new-size)
+ (declare (index new-size))
+ (setf (conset-vector conset)
+ (replace (the simple-bit-vector
+ (make-array
+ (ash 1 (integer-length (1- new-size)))
+ :element-type 'bit
+ :initial-element 0))
+ (the simple-bit-vector
+ (conset-vector conset)))))
+
+ (declaim (inline conset-grow))
+ (defun conset-grow (conset new-size)
+ (declare (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))
+ (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)))
+ (conset-grow conset (1+ number))
+ (setf (sbit (conset-vector conset) number) 1)
+ (setf (conset-min conset) (min number (conset-min conset)))
+ (when (>= number (conset-max conset))
+ (setf (conset-max conset) (1+ number))))))
+
+ (defun conset= (conset1 conset2)
+ (let* ((vector1 (conset-vector conset1))
+ (vector2 (conset-vector conset2))
+ (length1 (length vector1))
+ (length2 (length vector2)))
+ (if (= length1 length2)
+ ;; When the lengths are the same, we can rely on EQUAL being
+ ;; nicely optimized on bit-vectors.
+ (equal vector1 vector2)
+ (multiple-value-bind (shorter longer)
+ (if (< length1 length2)
+ (values vector1 vector2)
+ (values vector2 vector1))
+ ;; FIXME: make MISMATCH fast on bit-vectors.
+ (dotimes (index (length shorter))
+ (when (/= (sbit vector1 index) (sbit vector2 index))
+ (return-from conset= nil)))
+ (if (find 1 longer :start (length shorter))
+ nil
+ t)))))
+
+ (macrolet
+ ((defconsetop (name bit-op)
+ `(defun ,name (conset-1 conset-2)
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((size-1 (length (conset-vector conset-1)))
+ (size-2 (length (conset-vector conset-2)))
+ (new-size (max size-1 size-2)))
+ (conset-grow conset-1 new-size)
+ (conset-grow conset-2 new-size))
+ (let ((vector1 (conset-vector conset-1))
+ (vector2 (conset-vector conset-2)))
+ (declare (simple-bit-vector vector1 vector2))
+ (setf (conset-vector conset-1) (,bit-op vector1 vector2 t))
+ ;; Update the extrema.
+ ,(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)
+ 0
+ (or (position 1 (conset-vector conset-1)
+ :start start :end end)
+ 0))
+ (conset-max conset-1)
+ (if (> start end)
+ 0
+ (let ((position
+ (position
+ 1 (conset-vector conset-1)
+ :start start :end end :from-end t)))
+ (if position
+ (1+ 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 (conset-min conset-1)
+ :end (conset-max conset-1)
+ :from-end t)))
+ (if position
+ (1+ position)
+ 0))))))
+ (values))))
+ (defconsetop conset-union bit-ior)
+ (defconsetop conset-intersection bit-and)
+ (defconsetop conset-difference bit-andc2)))
+\f
(defun find-constraint (kind x y not-p)
(declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
(etypecase y
(ctype
- (do-sset-elements (con (lambda-var-constraints x) nil)
+ (do-conset-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))))
((or lvar constant)
- (do-sset-elements (con (lambda-var-constraints x) nil)
+ (do-conset-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)
+ (do-conset-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)))
(defun find-or-create-constraint (kind x y not-p)
(declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
(or (find-constraint kind x y not-p)
- (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
- (sset-adjoin new (lambda-var-constraints x))
+ (let ((new (make-constraint (length *constraint-universe*)
+ kind x y not-p)))
+ (vector-push-extend new *constraint-universe*
+ (* 2 (length *constraint-universe*)))
+ (conset-adjoin new (lambda-var-constraints x))
(when (lambda-var-p y)
- (sset-adjoin new (lambda-var-constraints y)))
+ (conset-adjoin new (lambda-var-constraints y)))
new)))
;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
(let ((lambda-var (ok-ref-lambda-var use)))
(when lambda-var
(let ((constraint (find-constraint 'eql lambda-var lvar nil)))
- (when (and constraint (sset-member constraint constraints))
+ (when (and constraint (conset-member constraint constraints))
lambda-var)))))
((cast-p use)
(ok-lvar-lambda-var (cast-value use) constraints)))))
(flet ((body-fun ()
,@body))
(body-fun)
- (do-sset-elements (con ,constraints ,result)
+ (do-conset-elements (con ,constraints ,result)
(let ((other (and (eq (constraint-kind con) 'eql)
(eq (constraint-not-p con) nil)
(cond ((eq ,var (constraint-x con))
(t
(do-eql-vars (x (x constraints))
(let ((con (find-or-create-constraint fun x y not-p)))
- (sset-adjoin con target)))))
+ (conset-adjoin con target)))))
(values))
;;; Add complementary constraints to the consequent and alternative
;; can't guarantee that the optimization will be done, so we still
;; need to avoid barfing on this case.
(unless (eq (if-consequent if) (if-alternative if))
- (let ((consequent-constraints (make-sset))
- (alternative-constraints (make-sset)))
+ (let ((consequent-constraints (make-conset))
+ (alternative-constraints (make-conset)))
(macrolet ((add (fun x y not-p)
`(add-complement-constraints ,fun ,x ,y ,not-p
- constraints
- consequent-constraints
- alternative-constraints)))
+ constraints
+ consequent-constraints
+ alternative-constraints)))
(typecase use
(ref
(add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
(aver (eql (numeric-type-class x) 'float))
(aver (eql (numeric-type-class y) 'float))
- #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+ #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
x
- #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+ #-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))))))
+ (tighter-p (x ref)
+ (cond ((null x) nil)
+ ((null ref) t)
+ ((and or-equal
+ (= (type-bound-number x) (type-bound-number ref)))
+ ;; X is tighter if REF is not an open bound and X is
+ (and (not (consp ref)) (consp x)))
+ (greater
+ (< (type-bound-number ref) (type-bound-number x)))
+ (t
+ (> (type-bound-number ref) (type-bound-number 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-lower-bound x-bound y-bound))
+ ((tighter-p y-bound x-bound)
+ y-bound)
(t
- (min-upper-bound x-bound y-bound)))))
+ x-bound))))
(if greater
(modified-numeric-type x :low new-bound)
(modified-numeric-type x :high new-bound)))))
;;; restrictions from flow analysis IN, set the type for REF
;;; accordingly.
(defun constrain-ref-type (ref constraints in)
- (declare (type ref ref) (type sset constraints in))
- (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)))
- (do-sset-elements (con var-cons)
+ (declare (type ref ref) (type conset constraints in))
+ ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
+ ;; cons up endless union types when propagating large number of EQL
+ ;; constraints -- eg. from large CASE forms -- instead we just
+ ;; directly accumulate one XSET, and a set of fp zeroes, which we at
+ ;; the end turn into a MEMBER-TYPE.
+ ;;
+ ;; Since massive symbol cases are an especially atrocious pattern
+ ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
+ ;; a more useful type, don't propagate their negation except for NIL
+ ;; unless SPEED > COMPILATION-SPEED.
+ (let ((res (single-value-type (node-derived-type ref)))
+ (constrain-symbols (policy ref (> speed compilation-speed)))
+ (not-set (alloc-xset))
+ (not-fpz nil)
+ (not-res *empty-type*)
+ (leaf (ref-leaf ref)))
+ (flet ((note-not (x)
+ (if (fp-zero-p x)
+ (push x not-fpz)
+ (when (or constrain-symbols (null x) (not (symbolp x)))
+ (add-to-xset x not-set)))))
+ ;; KLUDGE: the implementations of DO-CONSET-INTERSECTION will
+ ;; probably run faster when the smaller set comes first, so
+ ;; don't change the order here.
+ (do-conset-intersection (con constraints in)
(let* ((x (constraint-x con))
(y (constraint-y con))
(not-p (constraint-not-p con))
(case kind
(typep
(if not-p
- (setq not-res (type-union not-res other))
+ (if (member-type-p other)
+ (mapc-member-type-members #'note-not other)
+ (setq not-res (type-union not-res other)))
(setq res (type-approx-intersection2 res other))))
(eql
(unless (lvar-p other)
(if not-p
(when (and (constant-p other)
(member-type-p other-type))
- (setq not-res (type-union not-res other-type)))
+ (note-not (constant-value other)))
(let ((leaf-type (leaf-type leaf)))
(cond
((or (constant-p other)
(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)))))
-
+ (constrain-float-type res y greater not-p)))))))))))
+ (cond ((and (if-p (node-dest ref))
+ (or (xset-member-p nil not-set)
+ (csubtypep (specifier-type 'null) not-res)))
+ (setf (node-derived-type ref) *wild-type*)
+ (change-ref-leaf ref (find-constant t)))
+ (t
+ (setf not-res
+ (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz)))
+ (derive-node-type ref
+ (make-single-value-type
+ (or (type-difference res not-res)
+ res)))
+ (maybe-terminate-block ref nil))))
(values))
;;;; Flow analysis
(let ((lvar (ref-lvar ref))
(leaf (ref-leaf ref)))
(when (and (lambda-var-p leaf) lvar)
- (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
- gen))))
-
-;;; Copy all CONSTRAINTS involving FROM-VAR to VAR except the (EQL VAR
-;;; LVAR) ones.
-(defun inherit-constraints (var from-var constraints target)
- (do-sset-elements (con constraints)
- (let ((eq-x (eq from-var (constraint-x con)))
- (eq-y (eq from-var (constraint-y con))))
- ;; Constant substitution is controversial.
- (unless (constant-p (constraint-y con))
- (when (or (and eq-x (not (lvar-p (constraint-y con))))
- eq-y)
- (sset-adjoin (find-or-create-constraint
- (constraint-kind con)
- (if eq-x var (constraint-x con))
- (if eq-y var (constraint-y con))
- (constraint-not-p con))
- target))))))
+ (conset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
+ gen))))
+
+;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
+;;; LVAR) ones - to all of the variables in the VARS list.
+(defun inherit-constraints (vars from-var constraints target)
+ (do-conset-elements (con constraints)
+ ;; Constant substitution is controversial.
+ (unless (constant-p (constraint-y con))
+ (dolist (var vars)
+ (let ((eq-x (eq from-var (constraint-x con)))
+ (eq-y (eq from-var (constraint-y con))))
+ (when (or (and eq-x (not (lvar-p (constraint-y con))))
+ eq-y)
+ (conset-adjoin (find-or-create-constraint
+ (constraint-kind con)
+ (if eq-x var (constraint-x con))
+ (if eq-y var (constraint-y con))
+ (constraint-not-p con))
+ target)))))))
;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
;; inherit each other's constraints.
(defun add-eql-var-var-constraint (var1 var2 constraints
&optional (target constraints))
(let ((con (find-or-create-constraint 'eql var1 var2 nil)))
- (when (sset-adjoin con target)
- (do-eql-vars (var2 (var2 constraints))
- (inherit-constraints var1 var2 constraints target))
- (do-eql-vars (var1 (var1 constraints))
- (inherit-constraints var1 var2 constraints target))
+ (when (conset-adjoin con target)
+ (collect ((eql1) (eql2))
+ (do-eql-vars (var1 (var1 constraints))
+ (eql1 var1))
+ (do-eql-vars (var2 (var2 constraints))
+ (eql2 var2))
+ (inherit-constraints (eql1) var2 constraints target)
+ (inherit-constraints (eql2) var1 constraints target))
t)))
;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
;;; constraint.]
;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
;;; a type constraint based on the new value type.
-(declaim (ftype (function (cblock sset
- &key (:ref-preprocessor (or null function))
- (:set-preprocessor (or null function)))
- sset)
+(declaim (ftype (function (cblock conset boolean)
+ conset)
constraint-propagate-in-block))
-(defun constraint-propagate-in-block
- (block gen &key ref-preprocessor set-preprocessor)
-
+(defun constraint-propagate-in-block (block gen preprocess-refs-p)
(do-nodes (node lvar block)
(typecase node
(bind
do (let* ((type (lvar-type val))
(con (find-or-create-constraint 'typep var type
nil)))
- (sset-adjoin con gen))
+ (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)
- (when ref-preprocessor
- (funcall ref-preprocessor node gen))))
+ (when preprocess-refs-p
+ (let* ((var (ref-leaf node))
+ (con (lambda-var-constraints var)))
+ (constrain-ref-type node con gen)))))
(cast
(let ((lvar (cast-value node)))
(let ((var (ok-lvar-lambda-var lvar gen)))
(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)))
- (sset-adjoin con gen))))))))
+ (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))
- (when set-preprocessor
- (funcall set-preprocessor var))
- (sset-difference gen cons)
+ (conset-difference gen cons)
(let* ((type (single-value-type (node-derived-type node)))
(con (find-or-create-constraint 'typep var type nil)))
- (sset-adjoin con gen))
+ (conset-adjoin con gen))
(maybe-add-eql-var-var-constraint var (set-value node) gen)))))
-
gen)
(defun constraint-propagate-if (block gen)
(when (node-p use)
(add-test-constraints use node gen))))))
-(defun constrain-node (node cons)
- (let* ((var (ref-leaf node))
- (con (lambda-var-constraints var)))
- (constrain-ref-type node con cons)))
-
;;; Starting from IN compute OUT and (consequent/alternative
;;; constraints if the block ends with and IF). Return the list of
;;; successors that may need to be recomputed.
-(defun find-block-type-constraints (block &key final-pass-p)
+(defun find-block-type-constraints (block final-pass-p)
(declare (type cblock block))
(let ((gen (constraint-propagate-in-block
block
(if final-pass-p
(block-in block)
- (copy-sset (block-in block)))
- :ref-preprocessor (if final-pass-p #'constrain-node nil))))
+ (copy-conset (block-in block)))
+ final-pass-p)))
(setf (block-gen block) gen)
(multiple-value-bind (consequent-constraints alternative-constraints)
(constraint-propagate-if block gen)
(old-alternative-constraints (if-alternative-constraints node))
(succ ()))
;; Add the consequent and alternative constraints to GEN.
- (cond ((sset-empty consequent-constraints)
+ (cond ((conset-empty consequent-constraints)
(setf (if-consequent-constraints node) gen)
(setf (if-alternative-constraints node) gen))
(t
- (setf (if-consequent-constraints node) (copy-sset gen))
- (sset-union (if-consequent-constraints node)
- consequent-constraints)
+ (setf (if-consequent-constraints node) (copy-conset gen))
+ (conset-union (if-consequent-constraints node)
+ consequent-constraints)
(setf (if-alternative-constraints node) gen)
- (sset-union (if-alternative-constraints node)
- alternative-constraints)))
+ (conset-union (if-alternative-constraints node)
+ alternative-constraints)))
;; Has the consequent been changed?
(unless (and old-consequent-constraints
- (sset= (if-consequent-constraints node)
- old-consequent-constraints))
+ (conset= (if-consequent-constraints node)
+ old-consequent-constraints))
(push (if-consequent node) succ))
;; Has the alternative been changed?
(unless (and old-alternative-constraints
- (sset= (if-alternative-constraints node)
- old-alternative-constraints))
+ (conset= (if-alternative-constraints node)
+ old-alternative-constraints))
(push (if-alternative node) succ))
succ)
;; There is no IF.
(unless (and (block-out block)
- (sset= gen (block-out block)))
+ (conset= gen (block-out block)))
(setf (block-out block) gen)
(block-succ block))))))
;;; block.
(defun use-result-constraints (block)
(declare (type cblock block))
- (constraint-propagate-in-block block (block-in block)
- :ref-preprocessor #'constrain-node))
+ (constraint-propagate-in-block block (block-in block) t))
;;; 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
(unless (lambda-var-constraints var)
(when (or (null (lambda-var-sets var))
(not (closure-var-p var)))
- (setf (lambda-var-constraints var) (make-sset)))))))
+ (setf (lambda-var-constraints var) (make-conset)))))))
(frob fun)
(dolist (let (lambda-lets fun))
(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))
(let ((out (block-out-for-successor pred block)))
(when out
(if in
- (sset-intersection in out)
- (setq in (copy-sset out))))))
- (or in (make-sset))))
+ (conset-intersection in out)
+ (setq in (copy-conset out))))))
+ (or in (make-conset))))
(defun update-block-in (block)
(let ((in (compute-block-in block)))
- (cond ((and (block-in block) (sset= in (block-in block)))
+ (cond ((and (block-in block) (conset= in (block-in block)))
nil)
(t
(setf (block-in block) in)))))
;; USE-RESULT-CONSTRAINTS later.
(dolist (block leading-blocks)
(setf (block-in block) (compute-block-in block))
- (find-block-type-constraints block :final-pass-p t))
+ (find-block-type-constraints block t))
(setq blocks-to-process (copy-list rest-of-blocks))
;; The rest of the blocks.
(dolist (block rest-of-blocks)
(aver (eq block (pop blocks-to-process)))
(setf (block-in block) (compute-block-in block))
- (enqueue (find-block-type-constraints block)))
+ (enqueue (find-block-type-constraints block nil)))
;; Propagate constraints
(loop for block = (pop blocks-to-process)
while block do
(unless (eq block (component-tail component))
(when (update-block-in block)
- (enqueue (find-block-type-constraints block)))))
+ (enqueue (find-block-type-constraints block nil)))))
rest-of-blocks))))
(defun constraint-propagate (component)
(init-var-constraints component)
(unless (block-out (component-head component))
- (setf (block-out (component-head component)) (make-sset)))
+ (setf (block-out (component-head component)) (make-conset)))
(dolist (block (find-and-propagate-constraints component))
(unless (block-delete-p block)