+\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))
+
+ (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 (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)))))