master: Optimize SSET-INTERSECTION

The branch "master" has been updated in SBCL:
       via  da7d90ca9a80a8e73c79ddc39dc8fb9ae10e1b87 (commit)
      from  0843efc927405e31a970cfd145fe845f29d0923b (commit)

- Log -----------------------------------------------------------------
commit da7d90ca9a80a8e73c79ddc39dc8fb9ae10e1b87
Author: Douglas Katzman <[email protected]>
Date:   Sun Jul 19 11:33:20 2026 -0400

    Optimize SSET-INTERSECTION
    
    Impose a stricter upper bound on consing as explained in the comments.
    Test cases by Gemini
---
 src/compiler/sset.lisp | 41 +++++++++++++++++++++++++-----------
 tests/sset.pure.lisp   | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 85 insertions(+), 12 deletions(-)

diff --git a/src/compiler/sset.lisp b/src/compiler/sset.lisp
index c9b31f9e2..228aa5fbc 100644
--- a/src/compiler/sset.lisp
+++ b/src/compiler/sset.lisp
@@ -156,6 +156,7 @@
 
 ;;; Return true if SET contains no elements, false otherwise.
 (declaim (ftype (sfunction (sset) boolean) sset-empty))
+(declaim (inline sset-empty))
 (defun sset-empty (set)
   (zerop (sset-count set)))
 
@@ -178,18 +179,34 @@
         finally (return modified)))
 
 (defun sset-intersection (set1 set2)
-  ;; If SET2 is _significantly_ smaller than SET1 it would make sense to
-  ;; iterate over SET2 looking for the elements that are in SET1.
-  ;; However, to do that means consing a new temporary SSET, performing
-  ;; the operation, then moving the temporary on top of SET1.
-  ;; I don't feel like doing all that.
-  (let ((to-delete nil))
-    (do-sset-elements (element set1)
-      (unless (sset-member element set2)
-        (push element to-delete)))
-    (when to-delete
-      (dolist (element to-delete t)
-        (sset-delete element set1)))))
+  (cond
+    ((or (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.
+    ((<= (sset-count set2) (ash (sset-count set1) -1))
+     (let ((to-keep nil))
+       (do-sset-elements (element set2)
+         (when (sset-member element set1)
+           (push element to-keep)))
+       (fill (sset-vector set1) 0)
+       (setf (sset-count set1) 0)
+       ;; Since |SET2| < |SET1|, SET1 is guaranteed to shrink, so we always return T.
+       (dolist (element to-keep t)
+         (sset-adjoin element set1))))
+    (t
+     (let ((to-delete nil))
+       (do-sset-elements (element set1)
+         (unless (sset-member element set2)
+           (push element to-delete)))
+       (when to-delete
+         (dolist (element to-delete t)
+           (sset-delete element set1)))))))
 
 (defun sset-difference (set1 set2)
   ;; If sets are EQ, the algorithms below are either terribly broken (if you pick
diff --git a/tests/sset.pure.lisp b/tests/sset.pure.lisp
index 16d9c4f94..77afdf51f 100644
--- a/tests/sset.pure.lisp
+++ b/tests/sset.pure.lisp
@@ -178,3 +178,59 @@
       ;; Subtract non-empty from empty
       (assert (not (sset-difference s2 s1))) ; modified = nil
       (assert (sset-empty s2)))))
+
+(with-test (:name :sset-intersection-comprehensive)
+  (let ((elems (loop for i from 1 to 20 collect (make-dummy-test-element i))))
+    ;; 1. Small set2, large set1 (Branch 1: set2 <= set1/2)
+    (let ((s1 (make-sset))
+          (s2 (make-sset)))
+      (dolist (e (subseq elems 0 10)) (sset-adjoin e s1)) ; s1 has 10 elements (0..9)
+      (dolist (e (subseq elems 3 6))  (sset-adjoin e s2)) ; s2 has 3 elements (3..5)
+      (assert (sset-intersection s1 s2)) ; modified = t
+      (assert (= (sset-count s1) 3))
+      (assert (sset-member (elt elems 3) s1))
+      (assert (sset-member (elt elems 4) s1))
+      (assert (sset-member (elt elems 5) s1))
+      (assert (not (sset-member (elt elems 0) s1)))
+      (assert (not (sset-member (elt elems 9) s1)))
+
+      ;; Intersecting with small disjoint set empties s1
+      (let ((s3 (make-sset)))
+        (dolist (e (subseq elems 15 17)) (sset-adjoin e s3)) ; s3 has 2 elements (15, 16)
+        (assert (sset-intersection s1 s3)) ; modified = t
+        (assert (sset-empty s1))))
+
+    ;; 2. Large set2, small set1 (Branch 2: set2 > set1/2)
+    (let ((s1 (make-sset))
+          (s2 (make-sset)))
+      (dolist (e (subseq elems 0 4))  (sset-adjoin e s1)) ; s1 has 4 elements (0..3)
+      (dolist (e (subseq elems 2 12)) (sset-adjoin e s2)) ; s2 has 10 elements (2..11)
+      (assert (sset-intersection s1 s2)) ; modified = t
+      (assert (= (sset-count s1) 2)) ; elements 2 and 3 kept
+      (assert (sset-member (elt elems 2) s1))
+      (assert (sset-member (elt elems 3) s1))
+      (assert (not (sset-member (elt elems 0) s1)))
+
+      ;; Intersecting when set2 contains all elements of set1 (unmodified = nil)
+      (let ((s4 (make-sset)))
+        (dolist (e (subseq elems 0 10)) (sset-adjoin e s4)) ; contains all of s1
+        (assert (not (sset-intersection s1 s4))) ; modified = nil
+        (assert (= (sset-count s1) 2))))
+
+    ;; 3. (eq set1 set2) returns nil (unmodified)
+    (let ((s1 (make-sset)))
+      (dolist (e (subseq elems 0 5)) (sset-adjoin e s1))
+      (assert (not (sset-intersection s1 s1)))
+      (assert (= (sset-count s1) 5)))
+
+    ;; 4. Empty set operations
+    (let ((s1 (make-sset))
+          (s2 (make-sset)))
+      (sset-adjoin (elt elems 0) s1)
+      ;; Intersect non-empty with empty (s2 <= s1/2 => returns t, s1 becomes empty)
+      (assert (sset-intersection s1 s2))
+      (assert (sset-empty s1))
+      ;; Intersect empty with non-empty (returns nil)
+      (sset-adjoin (elt elems 0) s2)
+      (assert (not (sset-intersection s1 s2)))
+      (assert (sset-empty s1)))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL