From 83ec17c0a0afc1dd3f72d6cfd97d798c8e427195 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Tue, 21 Jul 2026 03:12:46 +0000 Subject: [PATCH] Implement sparse sets having greater storage density than SSET Not compiled in yet but potentially part of the adaptive CONSET which dynamically chooses between simple-bit-vector or sparse set of integers. (Since constraints are indexed by small integers, CONSETs don't need SSETs that store the constraints themselves - integers will do just fine.) --- src/cold/build-order.lisp-expr | 1 + src/cold/exports.lisp | 10 ++ src/compiler/int-sset.lisp | 266 ++++++++++++++++++++++++++++ tests/int-sset.pure.lisp | 314 +++++++++++++++++++++++++++++++++ 4 files changed, 591 insertions(+) create mode 100644 src/compiler/int-sset.lisp create mode 100644 tests/int-sset.pure.lisp diff --git a/src/cold/build-order.lisp-expr b/src/cold/build-order.lisp-expr index f7143005b..9a32d3ad8 100644 --- a/src/cold/build-order.lisp-expr +++ b/src/cold/build-order.lisp-expr @@ -199,6 +199,7 @@ ("src/code/specializable-array" :not-target) ("src/compiler/sset" :c-headers) + #+adaptive-conset ("src/compiler/int-sset" :not-host) ;; for e.g. BLOCK-ANNOTATION, needed by "compiler/vop" ("src/compiler/node" :c-headers :block-compile) ;; This has ASSEMBLY-UNIT-related stuff needed by core.lisp. diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp index 95ce5bb77..7230aef2f 100644 --- a/src/cold/exports.lisp +++ b/src/cold/exports.lisp @@ -2867,6 +2867,16 @@ be submitted as a \\CDR") "MAP-PACKED-XREF-DATA" "MAP-SIMPLE-FUNS")) +#+adaptive-conset +(defpackage "SB-INTEGER-SPARSE-SET" + (:use "CL" "SB-INT" "SB-EXT") + (:import-from "SB-C" "INSERT-ARRAY-BOUNDS-CHECKS") + (:export "MAKE-INT-SSET" "COPY-INT-SSET" + "DO-INT-SSET-ELEMENTS" "INT-SSET=" + "INT-SSET-ADJOIN" "INT-SSET-DELETE" "INT-SSET-MEMBER" + "INT-SSET-UNION" "INT-SSET-INTERSECTION" "INT-SSET-DIFFERENCE" + "INT-SSET-EMPTY" "INT-SSET-COUNT")) + (defpackage "SB-REGALLOC" (:documentation "private: implementation of the compiler's register allocator") (:use "CL" "SB-EXT" "SB-INT" "SB-KERNEL" "SB-SYS" "SB-C") diff --git a/src/compiler/int-sset.lisp b/src/compiler/int-sset.lisp new file mode 100644 index 000000000..98d2130b0 --- /dev/null +++ b/src/compiler/int-sset.lisp @@ -0,0 +1,266 @@ +;;;; This file implements a sparse set abstraction capable of storing only +;;;; small non-negative integers using heuristics to choose from several +;;;; representations with the goal of minimizing computational complexity. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-INTEGER-SPARSE-SET") + +;;; These won't be needed after combining this package into SB-C +(defconstant +sset-rehash-threshold+ 4) +(declaim (inline sset-hash)) +(defun sset-hash (element-number) (mix element-number 0)) + +;;; INTEGER-SSETs can logically store 0, but 0 is the physical sentinel value. +;;; The trick is that we increment the user's value by 1 when storing, +;;; and decrement when reading out of the array during iteration. +(deftype int-sset-element () '(integer 0 #xFFFFFFFE)) +(deftype int-sset-stored-value () '(integer 1 #xFFFFFFFF)) +(defmacro int-sset-elt-encode (e) `(1+ ,e)) +(defmacro int-sset-elt-decode (e) `(1- ,e)) + +(defstruct (integer-sset (:conc-name int-sset-) + (:copier nil) + (:constructor %make-int-sset (vector %bounds inline-bits))) + ;; Vector containing the set values. + ;; Using 0 as the empty value is convenient both from a perspective of being the + ;; default memory fill value, but also not having to pick different sentinels + ;; (such as #xFFFF and #xFFFFFFFF) for the two array specializations allows logic + ;; in the algebraic operations to be shared for either specialization. + (vector #* :type (or (simple-array (unsigned-byte 16) 1) + (simple-array (unsigned-byte 32) 1) + simple-bit-vector)) ; not used yet + (%bounds 0 :type sb-vm:word) + (inline-bits 0 :type sb-vm:word)) + +(declaim (freeze-type integer-sset)) + +(defmacro int-sset-limit (x) `(ldb (byte 32 0) (int-sset-%bounds ,x))) +(defmacro int-sset-count (x) `(ldb (byte 32 32) (int-sset-%bounds ,x))) + +(defun make-int-sset () + (declare (inline %make-int-sset)) + (%make-int-sset #.(sb-xc:make-array 0 :element-type '(unsigned-byte 16)) 0 0)) + +(declaim (inline int-sset-vector-smallp)) +(defun int-sset-vector-smallp (v) + (typep v '(simple-array (unsigned-byte 16)))) + +;;; Iterate over the elements in SSET, binding VAR to each element in +;;; turn. +(defmacro do-int-sset-elements ((var sset &optional result) &body body) + (let ((v '#:v) (small'#:small) (i '#:i) (elt '#:e)) + `(let* ((,v (int-sset-vector ,sset)) + (,small (int-sset-vector-smallp ,v))) + (do ((,i (1- (length ,v)) (1- ,i))) + ((minusp ,i) ,result) + (declare (sb-kernel:index-or-minus-1 ,i) + (optimize (sb-c::insert-array-bounds-checks 0))) + (let ((,elt (if ,small + (aref (truly-the (simple-array (unsigned-byte 16) 1) ,v) ,i) + (aref (truly-the (simple-array (unsigned-byte 32) 1) ,v) ,i)))) + (unless (eql ,elt 0) + (let ((,var (int-sset-elt-decode ,elt))) ,@body))))))) + +;; This variant purposely inserts the body twice, which is generally frowned upon +;; if arbitrary user code is allowed in the body, but is reasonable within +;; the context of implementating the operations on int-ssets. +(defmacro unswitched-do-int-sset-elt ((var sset) &body body) + (let ((vector '#:vector)) + `(int-sset-loop-unswitch (,vector (int-sset-vector ,sset)) + (dovector (,var ,vector) (unless (eql ,var 0) ,@body))))) +(defmacro int-sset-loop-unswitch ((var expr) &body body) + `(let ((,var ,expr)) + (if (int-sset-vector-smallp ,var) + (let ((,var (truly-the (simple-array (unsigned-byte 16) 1) ,var))) ,@body) + (let ((,var (truly-the (simple-array (unsigned-byte 32) 1) ,var))) ,@body)))) + +;;; Double the size of the hash vector of SET. +(defun int-sset-grow (set) + (let* ((vector (int-sset-vector set)) + (length (* (length vector) 2)) + (new-vector + (if (int-sset-vector-smallp vector) + (make-array length :element-type '(unsigned-byte 16) :initial-element 0) + (make-array length :element-type '(unsigned-byte 32) :initial-element 0))) + (new-limit (- length (truncate length +sset-rehash-threshold+)))) + (setf (int-sset-vector set) new-vector + (int-sset-limit set) new-limit + (int-sset-count set) 0) + ;; Can't use UNSWITCHED-DO-INT-SSET-ELT here because we're scanning the _old_ vector! + (int-sset-loop-unswitch (old-vector vector) + (dovector (e old-vector) + (unless (eql e 0) (%iss-adjoin e set)))))) + +;;; Destructively add ELEMENT to SET. If ELEMENT was not in the set, +;;; then we return true, otherwise we return false. +(defun %iss-adjoin (element set) + (declare (int-sset-stored-value element)) + #-sb-xc-host (declare (optimize (insert-array-bounds-checks 0))) + (let ((vector (int-sset-vector set))) + (if (<= element #xFFFF) ; almost always true + (when (zerop (length vector)) + (setf vector (make-array 2 :element-type '(unsigned-byte 16) :initial-element 0) + (int-sset-vector set) vector + (int-sset-limit set) 1)) + ;; Ensure the vector can hold (UNSIGNED-BYTE 32). No extra test is needed for 0-length + ;; vectors because they are always of element-type (UNSIGNED-BYTE 16). + (when (int-sset-vector-smallp vector) + (let ((new-vector (make-array (max 2 (length vector)) :element-type '(unsigned-byte 32) + :initial-element 0))) + (setf vector (cond ((plusp (length vector)) (replace new-vector vector)) + (t (setf (int-sset-limit set) 1) new-vector)) + (int-sset-vector set) new-vector)))) + (int-sset-loop-unswitch (vector vector) + (loop with mask = (truly-the index (1- (length vector))) + for hash of-type index = (logand mask (sset-hash element)) then (logand mask (1+ hash)) + for current = (aref vector hash) + do (cond ((eql current 0) + (setf (aref vector hash) element) + (when (> (incf (int-sset-count set)) (int-sset-limit set)) + (int-sset-grow set)) + (return t)) + ((eql current element) + (return nil))))))) +(defun int-sset-adjoin (element set) + (declare (type int-sset-element element)) + (%iss-adjoin (int-sset-elt-encode element) set)) + +;;; Destructively remove ELEMENT from SET. If element was in the set, +;;; then return true, otherwise return false. +(defun %iss-delete (element set) + (declare (int-sset-stored-value element)) + #-sb-xc-host (declare (optimize (insert-array-bounds-checks 0))) + (when (zerop (int-sset-count set)) + (return-from %iss-delete nil)) + (int-sset-loop-unswitch (vector (int-sset-vector set)) + (loop with mask = (truly-the index (1- (length vector))) + for hash = (logand mask (sset-hash element)) then (logand mask (1+ hash)) + for current = (aref vector hash) + do (cond ((eql current 0) + (return nil)) + ((eql current element) + ;; COUNT was nonzero, so it can't become negative. + ;; Compiler isn't inferring that, so inform it. + (setf (int-sset-count set) (truly-the index (1- (int-sset-count set)))) + (do ((i hash)) (nil) + (do ((j (logand mask (1+ i)) (logand mask (1+ j)))) (nil) + (declare (index j)) + (let ((candidate (aref vector j))) + (when (eql candidate 0) + (setf (aref vector i) 0) + (return-from %iss-delete t)) + (let ((n candidate)) + (when (>= (logand mask (- j (logand mask (sset-hash n)))) + (logand mask (- j i))) + (setf (aref vector i) candidate i j) + (return))))))))))) + +(defun int-sset-delete (element set) + (declare (type int-sset-element element)) + (%iss-delete (int-sset-elt-encode element) set)) + +;;; Return true if ELEMENT is in SET, false otherwise. +(defun %iss-member (element set) + (declare (int-sset-stored-value element)) + #-sb-xc-host (declare (optimize (insert-array-bounds-checks 0))) + (int-sset-loop-unswitch (vector (int-sset-vector set)) + (loop with mask = (truly-the index (1- (length vector))) + for hash of-type index = (logand mask (sset-hash element)) then + (logand mask (1+ hash)) + for current = (aref vector hash) + do (cond ((eql current element) (return t)) + ((eql current 0) (return nil)))))) + +(defun int-sset-member (element set) + (declare (type int-sset-element element)) + (and (/= 0 (int-sset-count set)) + (%iss-member (int-sset-elt-encode element) set))) + +(defun int-sset= (set1 set2) + (unless (eql (int-sset-count set1) (int-sset-count set2)) + (return-from int-sset= nil)) + (unswitched-do-int-sset-elt (e set1) + (unless (%iss-member e set2) + (return-from int-sset= nil))) + t) + +;;; Return true if SET contains no elements, false otherwise. +(declaim (inline int-sset-empty)) +(defun int-sset-empty (set) (= 0 (int-sset-count set))) + +;;; Return a new copy of SET. +(defun copy-int-sset (set) + (%make-int-sset (copy-seq (int-sset-vector set)) + (int-sset-%bounds set) (int-sset-inline-bits set))) + +;;; Perform the appropriate set operation on SET1 and SET2 by +;;; destructively modifying SET1. We return true if SET1 was modified, +;;; false otherwise. +(defun int-sset-union (set1 set2 &aux modified) + (unswitched-do-int-sset-elt (element set2) + (when (%iss-adjoin element set1) + (setf modified t))) + modified) + +(defun int-sset-intersection (set1 set2) + (cond + ((or (int-sset-empty set1) (eq set1 set2)) nil) + ;; Consing can always be bounded by the cardinality of the smaller set, + ;; we just have to decide whether to collect items to ADJOIN vs DELETE. + ;; In the situation where SET2 is empty (and SET1 is not, because empty was + ;; ruled out above), this correctly pick the first of the following two COND + ;; clauses, doing zero consing. + ;; When SET2 is no more than half the size of SET1, collecting kept elements + ;; by scanning SET2 conses at most |SET2| items, whereas scanning SET1 + ;; conses at least |SET1| - |SET2| items. + ((<= (int-sset-count set2) (ash (int-sset-count set1) -1)) + (let ((to-keep nil)) + (unswitched-do-int-sset-elt (element set2) + (when (%iss-member element set1) + (push element to-keep))) + (fill (int-sset-vector set1) 0) + (setf (int-sset-count set1) 0) + ;; Since |SET2| < |SET1|, SET1 is guaranteed to shrink, so we always return T. + (dolist (element to-keep t) + (%iss-adjoin element set1)))) + (t + (let ((to-delete nil)) + (unswitched-do-int-sset-elt (element set1) + (unless (%iss-member element set2) + (push element to-delete))) + (when to-delete + (dolist (element to-delete t) + (%iss-delete element set1))))))) + +(defun int-sset-difference (set1 set2) + ;; If sets are EQ, the algorithms below are either terribly broken (if you pick + ;; the first cond clause) or terribly stupid (if you pick the second). + ;; The result should technically be an empty set, but we don't need it. + (aver (neq set1 set2)) + ;; If SET2 is smaller than SET1, or possibly even larger by an allowance, + ;; we should prefer to scan all of it, calling SSET-DELETE on each item. + ;; This technique never conses a list of items to delete. + ;; When SET1 drives iteration, we can not both delete from and iterate over it, + ;; so we necessarily cons an intermediate list. + (cond ((<= (ash (int-sset-count set2) -1) (int-sset-count set1)) ; allow 2x larger SET2 + (let (modified) + (unswitched-do-int-sset-elt (element set2) + (when (%iss-delete element set1) + (setq modified t))) + modified)) + (t + (let ((to-delete nil)) + (unswitched-do-int-sset-elt (element set1) + (when (%iss-member element set2) + (push element to-delete))) + (when to-delete + (dolist (element to-delete t) + (%iss-delete element set1))))))) diff --git a/tests/int-sset.pure.lisp b/tests/int-sset.pure.lisp new file mode 100644 index 000000000..d25150854 --- /dev/null +++ b/tests/int-sset.pure.lisp @@ -0,0 +1,314 @@ +#-adaptive-conset (invoke-restart 'run-tests::skip-file) + +(import sb-integer-sparse-set::'(make-int-sset int-sset-adjoin int-sset-delete copy-int-sset + int-sset-union int-sset-intersection int-sset-difference + int-sset-member int-sset-empty + int-sset-vector int-sset-count int-sset-limit + do-int-sset-elements int-sset-vector-smallp)) + +(with-test (:name :new-int-sset-basic-operations) + (let ((set (make-int-sset)) + (e1 10) + (e2 20) + (e3 30) + (e4 40)) + (assert (int-sset-empty set)) + (assert (not (int-sset-member e1 set))) + + ;; Adjoin + (assert (int-sset-adjoin e1 set)) + (assert (not (int-sset-adjoin e1 set))) ; already present + (assert (int-sset-adjoin e2 set)) + (assert (int-sset-adjoin e3 set)) + (assert (= (int-sset-count set) 3)) + (assert (int-sset-member e1 set)) + (assert (int-sset-member e2 set)) + (assert (int-sset-member e3 set)) + (assert (not (int-sset-member e4 set))) + + ;; Delete + (assert (int-sset-delete e2 set)) + (assert (not (int-sset-delete e2 set))) ; already deleted + (assert (= (int-sset-count set) 2)) + (assert (int-sset-member e1 set)) + (assert (not (int-sset-member e2 set))) + (assert (int-sset-member e3 set)) + + (assert (int-sset-delete e1 set)) + (assert (int-sset-delete e3 set)) + (assert (int-sset-empty set)))) + +(with-test (:name :new-int-sset-shift-deletion-stress) + (let ((set (make-int-sset)) + (elems (loop for i from 1 to 100 collect i))) + (dolist (e elems) + (int-sset-adjoin e set)) + (assert (= (int-sset-count set) 100)) + ;; Delete every second element + (loop for e in elems by #'cddr + do (assert (int-sset-delete e set))) + (assert (= (int-sset-count set) 50)) + (loop for e in elems + for i from 0 + do (if (evenp i) + (assert (not (int-sset-member e set))) + (assert (int-sset-member e set)))) + (loop for e in (cdr elems) by #'cddr + do (assert (int-sset-delete e set))) + (assert (int-sset-empty set)))) + +(with-test (:name :new-int-sset-set-operations) + (let ((s1 (make-int-sset)) + (s2 (make-int-sset)) + (e1 1) + (e2 2) + (e3 3) + (e4 4)) + (int-sset-adjoin e1 s1) + (int-sset-adjoin e2 s1) + (int-sset-adjoin e3 s1) + + (int-sset-adjoin e2 s2) + (int-sset-adjoin e3 s2) + (int-sset-adjoin e4 s2) + + ;; Union + (let ((u (copy-int-sset s1))) + (int-sset-union u s2) + (assert (= (int-sset-count u) 4)) + (assert (int-sset-member e4 u))) + + ;; Intersection + (let ((i (copy-int-sset s1))) + (int-sset-intersection i s2) + (assert (= (int-sset-count i) 2)) + (assert (not (int-sset-member e1 i))) + (assert (int-sset-member e2 i)) + (assert (int-sset-member e3 i))) + + ;; Difference + (let ((d (copy-int-sset s1))) + (int-sset-difference d s2) + (assert (= (int-sset-count d) 1)) + (assert (int-sset-member e1 d)) + (assert (not (int-sset-member e2 d))) + (assert (not (int-sset-member e3 d)))))) + +(with-test (:name :int-sset-growth-optimization) + (let ((set (make-int-sset)) + (e1 1) + (e2 2)) + ;; Initially empty, limit is 0 + (assert (zerop (int-sset-limit set))) + (assert (= (length (int-sset-vector set)) 0)) + + ;; Adjoin e1. Should grow to size 2, and count reaches limit. + (assert (int-sset-adjoin e1 set)) + (assert (= (int-sset-count set) (int-sset-limit set))) + (assert (= (length (int-sset-vector set)) 2)) + + ;; Adjoin e1 again. Should NOT grow. + (assert (not (int-sset-adjoin e1 set))) + (assert (= (int-sset-count set) (int-sset-limit set))) + (assert (= (length (int-sset-vector set)) 2)) + + ;; Adjoin e2. Should grow to size 4. + (assert (int-sset-adjoin e2 set)) + (assert (= (length (int-sset-vector set)) 4)))) + +(with-test (:name :int-sset-difference-comprehensive) + (let ((elems (loop for i from 1 to 20 collect i))) + ;; 1. Small set2, large set1 (Branch 1: set2 <= 2*set1) + (let ((s1 (make-int-sset)) + (s2 (make-int-sset))) + (dolist (e (subseq elems 0 10)) (int-sset-adjoin e s1)) + (dolist (e (subseq elems 3 6)) (int-sset-adjoin e s2)) ; s2 has 3 elements + (assert (int-sset-difference s1 s2)) ; modified = t + (assert (= (int-sset-count s1) 7)) + (assert (not (int-sset-member (elt elems 3) s1))) + (assert (not (int-sset-member (elt elems 4) s1))) + (assert (not (int-sset-member (elt elems 5) s1))) + (assert (int-sset-member (elt elems 0) s1)) + ;; No modification when subtracting disjoint set + (let ((s3 (make-int-sset))) + (int-sset-adjoin (elt elems 3) s3) + (assert (not (int-sset-difference s1 s3))) ; modified = nil + (assert (= (int-sset-count s1) 7)))) + + ;; 2. Large set2, small set1 (Branch 2: set2 > 2*set1) + (let ((s1 (make-int-sset)) + (s2 (make-int-sset))) + (dolist (e (subseq elems 0 3)) (int-sset-adjoin e s1)) ; s1 has 3 elements + (dolist (e (subseq elems 2 15)) (int-sset-adjoin e s2)) ; s2 has 13 elements + (assert (int-sset-difference s1 s2)) ; modified = t + (assert (= (int-sset-count s1) 2)) ; element 2 removed + (assert (not (int-sset-member (elt elems 2) s1))) + (assert (int-sset-member (elt elems 0) s1)) + (assert (int-sset-member (elt elems 1) s1))) + + ;; 3. (int-sset-difference s s) - self difference triggers aver error + (let ((s (make-int-sset))) + (dolist (e (subseq elems 0 5)) (int-sset-adjoin e s)) + (assert-error (int-sset-difference s s))) + + ;; 4. Empty set operations + (let ((s1 (make-int-sset)) + (s2 (make-int-sset))) + (int-sset-adjoin (elt elems 0) s1) + ;; Subtract empty from non-empty + (assert (not (int-sset-difference s1 s2))) ; modified = nil + (assert (= (int-sset-count s1) 1)) + ;; Subtract non-empty from empty + (assert (not (int-sset-difference s2 s1))) ; modified = nil + (assert (int-sset-empty s2))))) + +(with-test (:name :int-sset-intersection-comprehensive) + (let ((elems (loop for i from 1 to 20 collect i))) + ;; 1. Small set2, large set1 (Branch 1: set2 <= set1/2) + (let ((s1 (make-int-sset)) + (s2 (make-int-sset))) + (dolist (e (subseq elems 0 10)) (int-sset-adjoin e s1)) ; s1 has 10 elements + (dolist (e (subseq elems 3 6)) (int-sset-adjoin e s2)) ; s2 has 3 elements + (assert (int-sset-intersection s1 s2)) ; modified = t + (assert (= (int-sset-count s1) 3)) + (assert (int-sset-member (elt elems 3) s1)) + (assert (int-sset-member (elt elems 4) s1)) + (assert (int-sset-member (elt elems 5) s1)) + (assert (not (int-sset-member (elt elems 0) s1))) + (assert (not (int-sset-member (elt elems 9) s1))) + + ;; Intersecting with small disjoint set empties s1 + (let ((s3 (make-int-sset))) + (dolist (e (subseq elems 15 17)) (int-sset-adjoin e s3)) + (assert (int-sset-intersection s1 s3)) ; modified = t + (assert (int-sset-empty s1)))) + + ;; 2. Large set2, small set1 (Branch 2: set2 > set1/2) + (let ((s1 (make-int-sset)) + (s2 (make-int-sset))) + (dolist (e (subseq elems 0 4)) (int-sset-adjoin e s1)) ; s1 has 4 elements + (dolist (e (subseq elems 2 12)) (int-sset-adjoin e s2)) ; s2 has 10 elements + (assert (int-sset-intersection s1 s2)) ; modified = t + (assert (= (int-sset-count s1) 2)) + (assert (int-sset-member (elt elems 2) s1)) + (assert (int-sset-member (elt elems 3) s1)) + (assert (not (int-sset-member (elt elems 0) s1))) + + ;; Intersecting when set2 contains all elements of set1 (unmodified = nil) + (let ((s4 (make-int-sset))) + (dolist (e (subseq elems 0 10)) (int-sset-adjoin e s4)) ; contains all of s1 + (assert (not (int-sset-intersection s1 s4))) ; modified = nil + (assert (= (int-sset-count s1) 2)))) + + ;; 3. (eq set1 set2) returns nil (unmodified) + (let ((s1 (make-int-sset))) + (dolist (e (subseq elems 0 5)) (int-sset-adjoin e s1)) + (assert (not (int-sset-intersection s1 s1))) + (assert (= (int-sset-count s1) 5))) + + ;; 4. Empty set operations + (let ((s1 (make-int-sset)) + (s2 (make-int-sset))) + (int-sset-adjoin (elt elems 0) s1) + ;; Intersect non-empty with empty (s2 <= s1/2 => returns t, s1 becomes empty) + (assert (int-sset-intersection s1 s2)) + (assert (int-sset-empty s1)) + ;; Intersect empty with non-empty (returns nil) + (int-sset-adjoin (elt elems 0) s2) + (assert (not (int-sset-intersection s1 s2))) + (assert (int-sset-empty s1))))) + +(with-test (:name :int-sset-zero-element) + (let ((set (make-int-sset))) + (assert (int-sset-empty set)) + (assert (not (int-sset-member 0 set))) + ;; Adjoin 0 + (assert (int-sset-adjoin 0 set)) + (assert (find 1 (int-sset-vector set))) + (assert (not (int-sset-adjoin 0 set))) ; already present + (assert (= (int-sset-count set) 1)) + (assert (int-sset-member 0 set)) + (assert (not (int-sset-empty set))) + + ;; do-int-sset-elements yields 0 (biased down by 1) + (let (collected) + (do-int-sset-elements (e set) + (push e collected)) + (assert (equal collected '(0)))) + + ;; Adjoin other elements alongside 0 + (assert (int-sset-adjoin 10 set)) + (assert (int-sset-adjoin 20 set)) + (assert (= (int-sset-count set) 3)) + (assert (int-sset-member 0 set)) + (assert (int-sset-member 10 set)) + (assert (int-sset-member 20 set)) + + ;; Set operations with 0 + (let ((s2 (make-int-sset))) + (int-sset-adjoin 0 s2) + (int-sset-adjoin 30 s2) + (let ((u (copy-int-sset set))) + (int-sset-union u s2) + (assert (int-sset-member 0 u)) + (assert (= (int-sset-count u) 4))) + (let ((i (copy-int-sset set))) + (int-sset-intersection i s2) + (assert (int-sset-member 0 i)) + (assert (= (int-sset-count i) 1))) + (let ((d (copy-int-sset set))) + (int-sset-difference d s2) + (assert (not (int-sset-member 0 d))) + (assert (= (int-sset-count d) 2)))) + + ;; Delete 0 + (assert (int-sset-delete 0 set)) + (assert (not (int-sset-member 0 set))) + (assert (= (int-sset-count set) 2)))) + +(with-test (:name :int-sset-array-type-upgrade) + (let ((set (make-int-sset))) + ;; 1. Small elements and #xFFFE (whose stored bit pattern is #xFFFF) fit in (unsigned-byte 16) + (int-sset-adjoin 0 set) + (int-sset-adjoin 42 set) + (int-sset-adjoin #xFFFE set) + (assert (int-sset-vector-smallp (int-sset-vector set))) + (assert (typep (int-sset-vector set) '(simple-array (unsigned-byte 16) (*)))) + (assert (int-sset-member 0 set)) + (assert (int-sset-member 42 set)) + (assert (int-sset-member #xFFFE set)) + + ;; 2. Inserting #xFFFF (logically 65535, stored as #x10000) exceeds (unsigned-byte 16) storage + ;; and transparently upgrades the backing array to (unsigned-byte 32). + (assert (int-sset-adjoin #xFFFF set)) + (assert (not (int-sset-vector-smallp (int-sset-vector set)))) + (assert (typep (int-sset-vector set) '(simple-array (unsigned-byte 32) (*)))) + (assert (int-sset-member 0 set)) + (assert (int-sset-member 42 set)) + (assert (int-sset-member #xFFFE set)) + (assert (int-sset-member #xFFFF set)) + + ;; 3. Further insertions of large numbers into upgraded set + (assert (int-sset-adjoin #x12345678 set)) + (assert (int-sset-adjoin #xFFFFFFFE set)) + (assert (int-sset-member #x12345678 set)) + (assert (int-sset-member #xFFFFFFFE set)) + (assert (= (int-sset-count set) 6)) + + ;; 4. Directly inserting large numbers into a fresh empty set + (let ((set2 (make-int-sset))) + (assert (int-sset-adjoin #xFFFF set2)) + (assert (not (int-sset-vector-smallp (int-sset-vector set2)))) + (assert (typep (int-sset-vector set2) '(simple-array (unsigned-byte 32) (*)))) + (assert (int-sset-member #xFFFF set2))) + + ;; 5. Union of (unsigned-byte 16) set with (unsigned-byte 32) set upgrades the target set + (let ((small-set (make-int-sset)) + (large-set (make-int-sset))) + (int-sset-adjoin 1 small-set) + (assert (int-sset-vector-smallp (int-sset-vector small-set))) + (int-sset-adjoin #xFFFF large-set) + (int-sset-union small-set large-set) + (assert (not (int-sset-vector-smallp (int-sset-vector small-set)))) + (assert (int-sset-member 1 small-set)) + (assert (int-sset-member #xFFFF small-set)))))