mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
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.)
This commit is contained in:
Douglas Katzman
parent
52b2af5b94
commit
83ec17c0a0
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
266
src/compiler/int-sset.lisp
Normal file
266
src/compiler/int-sset.lisp
Normal file
|
|
@ -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)))))))
|
||||
314
tests/int-sset.pure.lisp
Normal file
314
tests/int-sset.pure.lisp
Normal file
|
|
@ -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)))))
|
||||
Loading…
Reference in a new issue