master: Do not cons for (when (intersection a b))

The branch "master" has been updated in SBCL:
       via  8007e82231cc8d1f8dfd8baa8591abbf750354ac (commit)
      from  1f8a40c435fc3df7a41500db298c84000e3adce8 (commit)

- Log -----------------------------------------------------------------
commit 8007e82231cc8d1f8dfd8baa8591abbf750354ac
Author: Stas Boukarev <[email protected]>
Date:   Sat May 16 01:20:50 2026 +0300

    Do not cons for (when (intersection a b))
    
    (Except for a possible hash-table).
---
 src/code/list.lisp        | 32 +++++++++++++++++++++++++++++++-
 src/compiler/fndb.lisp    | 10 ++++++++++
 src/compiler/seqtran.lisp | 11 +++++++++++
 3 files changed, 52 insertions(+), 1 deletion(-)

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 4b32f3a8c..442b9b1a7 100644
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -1129,7 +1129,37 @@
                      (dolist (elt short)
                        (when (funcall member-test elt long key test)
                          (push elt res)))))))
-          res))))))
+          res)))))
+
+;;; A boolean variant
+(defun intersection-p (list1 list2
+                       &key key (test nil testp) (test-not nil notp))
+  (declare (dynamic-extent key test test-not)
+           (explicit-check key test test-not))
+  (when (and testp notp)
+    (error ":TEST and :TEST-NOT were both supplied."))
+  (with-member-test (member-test)
+    (when (and list1 list2)
+      (multiple-value-bind (short long short-length long-nthcdr)
+          (shorter-list-length list1 list2)
+        (let ((hash-table (hashing-p notp testp test short-length long-nthcdr)))
+          (cond (hash-table
+                 (dolist (elt short)
+                   (setf (gethash (apply-key key elt) hash-table) t))
+                 (dolist (elt long)
+                   (when (gethash (apply-key key elt) hash-table)
+                     (return-from intersection-p t))))
+                (t
+                 (flet ((swapped-test (x y)
+                          (funcall (truly-the function test) y x)))
+                   (declare (dynamic-extent #'swapped-test))
+                   (let ((test (if (eq list1 short)
+                                   test
+                                   (and test #'swapped-test))))
+                     (dolist (elt short)
+                       (when (funcall member-test elt long key test)
+                         (return-from intersection-p t)))))))
+          nil))))))
 
 (defun nintersection (list1 list2
                       &key key (test nil testp) (test-not nil notp))
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index d3748a566..69a7f4be3 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1233,6 +1233,16 @@
   list
   (foldable flushable call))
 
+(defknown sb-impl::intersection-p
+  (proper-list proper-list &key (:key (function-designator ((or (nth-arg 0 :sequence t)
+                                                  (nth-arg 1 :sequence t)))))
+                  (:test (function-designator ((nth-arg 0 :sequence t :key :key)
+                                               (nth-arg 1 :sequence t :key :key))))
+                  (:test-not (function-designator ((nth-arg 0 :sequence t :key :key)
+                                                   (nth-arg 1 :sequence t :key :key)))))
+  boolean
+  (foldable flushable call))
+
 (defknown (nunion nset-exclusive-or)
   ((modifying list) (modifying list)
    &key (:key (function-designator ((or (nth-arg 0 :sequence t)
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 7b9e984c3..71faafa76 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -3969,6 +3969,17 @@
           (t
            (give-up-ir1-transform)))))
 
+(defoptimizer (intersection rewrite-full-call)
+    ((function sequence &rest args) node)
+  (when (block nil
+          (map-all-dests (lambda (dest lvar nth-value)
+                           (declare (ignore lvar nth-value))
+                           (unless (if-p dest)
+                             (return)))
+                         node)
+          t)
+    'sb-impl::intersection-p))
+
 (deftransform nunion ((list1 list2 &key key test test-not))
   (let ((null-type (specifier-type 'null)))
     (cond ((csubtypep (lvar-type list1) null-type)

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


hooks/post-receive
-- 
SBCL