+ (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 (type 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 (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))
+ (vector (conset-vector conset)))
+ (when (< number (length vector))
+ (plusp (sbit vector number)))))
+
+ (defun conset-adjoin (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))))
+ conset)
+
+ (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
+;;; Constraints are hash-consed. Unfortunately, types aren't, so we have
+;;; to over-approximate and then linear search through the potential hits.
+;;; LVARs can only be found in EQL (not-p = NIL) constraints, while constant
+;;; and lambda-vars can only be found in EQL constraints.
+(defun find-constraint (kind x y not-p)
+ (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
+ (etypecase y
+ (ctype
+ (awhen (lambda-var-ctype-constraints x)
+ (dolist (con (gethash (sb!kernel::type-class-info y) it) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (type= (constraint-y con) y))
+ (return-from find-constraint con)))
+ nil))
+ (lvar
+ (awhen (lambda-var-eq-constraints x)
+ (gethash y it)))
+ ((or constant lambda-var)
+ (awhen (lambda-var-eq-constraints x)
+ (let ((cache (gethash y it)))
+ (declare (type list cache))
+ (if not-p (cdr cache) (car cache)))))))
+
+;;; The most common operations on consets are iterating through the constraints
+;;; that are related to a certain variable in a given conset. Storing the
+;;; constraints related to each variable in vectors allows us to easily iterate
+;;; through the intersection of such constraints and the constraints in a conset.
+;;;
+;;; EQL-var constraints assert that two lambda-vars are EQL.
+;;; Private constraints assert that a lambda-var is EQL or not EQL to a constant.
+;;; Inheritable constraints are constraints that may be propagated to EQL
+;;; lambda-vars (along with EQL-var constraints).
+;;;
+;;; Lambda-var -- lvar EQL constraints only serve one purpose: remember whether
+;;; an lvar is (only) written to by a ref to that lambda-var, and aren't ever
+;;; propagated.
+;;;
+;;; Finally, the lambda-var conset is only used to track the whole set of
+;;; constraints associated with a given lambda-var, and thus easily delete
+;;; such constraints from a conset.
+(defun register-constraint (x con y)
+ (declare (type lambda-var x) (type constraint con) (type constraint-y y))
+ (conset-adjoin con (lambda-var-constraints x))
+ (macrolet ((ensuref (place default)
+ `(or ,place (setf ,place ,default)))
+ (ensure-hash (place)
+ `(ensuref ,place (make-hash-table)))
+ (ensure-vec (place)
+ `(ensuref ,place (make-array 8 :adjustable t :fill-pointer 0))))
+ (etypecase y
+ (ctype
+ (let ((index (ensure-hash (lambda-var-ctype-constraints x)))
+ (vec (ensure-vec (lambda-var-inheritable-constraints x))))
+ (push con (gethash (sb!kernel::type-class-info y) index))
+ (vector-push-extend con vec)))
+ (lvar
+ (let ((index (ensure-hash (lambda-var-eq-constraints x))))
+ (setf (gethash y index) con)))
+ ((or constant lambda-var)
+ (let* ((index (ensure-hash (lambda-var-eq-constraints x)))
+ (cons (ensuref (gethash y index) (list nil))))
+ (if (constraint-not-p con)
+ (setf (cdr cons) con)
+ (setf (car cons) con)))
+ (typecase y
+ (constant
+ (let ((vec (ensure-vec (lambda-var-private-constraints x))))
+ (vector-push-extend con vec)))
+ (lambda-var
+ (let ((vec (if (constraint-not-p con)
+ (ensure-vec (lambda-var-inheritable-constraints x))
+ (ensure-vec (lambda-var-eql-var-constraints x)))))
+ (vector-push-extend con vec)))))))
+ nil)