master: Don't cons a new list for (length (intersection a b))

The branch "master" has been updated in SBCL:
       via  0298a35f891649f62217f5506d91268e00f48a9b (commit)
      from  3991dc73d6871cd88558dee9aab0a37adb5cb18c (commit)

- Log -----------------------------------------------------------------
commit 0298a35f891649f62217f5506d91268e00f48a9b
Author: Stas Boukarev <[email protected]>
Date:   Wed Jun 10 18:10:10 2026 +0300

    Don't cons a new list for (length (intersection a b))
---
 src/code/list.lisp           | 32 ++++++++++++++++++++++++++++++++
 src/compiler/array-tran.lisp |  5 ++---
 src/compiler/fndb.lisp       | 10 ++++++++++
 src/compiler/ir1opt.lisp     | 37 ++++++++++++++++---------------------
 src/compiler/ir1util.lisp    |  7 ++++---
 src/compiler/node.lisp       |  2 +-
 src/compiler/srctran.lisp    | 11 +++++------
 7 files changed, 70 insertions(+), 34 deletions(-)

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 442b9b1a7..4067bb3f2 100644
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -1131,6 +1131,38 @@
                          (push elt res)))))))
           res)))))
 
+(defun length-intersection (list1 list2
+                            &key key (test nil testp) (test-not nil notp))
+  (declare (dynamic-extent key test test-not)
+           (explicit-check key test test-not)
+           (optimize speed))
+  (when (and testp notp)
+    (error ":TEST and :TEST-NOT were both supplied."))
+  (let ((length 0))
+    (declare (fixnum length))
+    (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)
+                       (incf (truly-the index length)))))
+                  (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)
+                           (incf (truly-the index length))))))))))))
+    length))
+
 ;;; A boolean variant
 (defun intersection-p (list1 list2
                        &key key (test nil testp) (test-not nil notp))
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 7e1adaba5..b3a2ca36f 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -2804,9 +2804,8 @@
        (delay-ir1-transform node :ir1-phases)
        ;; Handle (make-array n :element-type `(signed-byte ,x))
        ;; without consing
-       (let ((args (splice-fun-args type 'list nil nil)))
-         (when args
-           (make-transform-lambda 'sb-vm::%vector-widetag-and-n-bits-shift-list args)))))
+       (make-transform-lambda 'sb-vm::%vector-widetag-and-n-bits-shift-list
+                              (splice-fun-args type 'list nil nil))))
     (t
      (give-up-ir1-transform "ELEMENT-TYPE is not constant."))))
 
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 622d27a08..618e5dabe 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1233,6 +1233,16 @@
   list
   (foldable flushable call))
 
+(defknown sb-impl::length-intersection
+    (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)))))
+    index
+    (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)))))
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 2b5c0d684..3a87f5a9a 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1732,34 +1732,29 @@
 
 ;;; Wait for the next component-reoptimize-counter
 (defun delay-ir1-optimizer (node reason)
-  (let* ((delayed (basic-combination-delay-to node))
-         (delayed-n (ash delayed -1))
+  (let* ((delay (basic-combination-delay-to node))
          (component *component-being-compiled*)
          (reoptimize-counter (component-reoptimize-counter component))
          (phase-counter (component-phase-counter component)))
     (aver (eq component (node-component node)))
     (ecase reason
       (:constraint
-       (cond ((> phase-counter 0)
-              ;; There will be no more constraint-propagate
-              nil)
-             ((or (= delayed-n -1)
-                  (logbitp 0 delayed)) ;; delayed to :ir1-phases but :constraint takes priority
-              (push node *ir1-transforms-after-constraints*)
-              (setf (basic-combination-delay-to node)
-                    ;; Disambiguate by having different low bits
-                    (logand most-positive-fixnum (ash reoptimize-counter 1)))
-              t)
-             ((= delayed-n reoptimize-counter))))
+       (unless (> phase-counter 0) ;; There will be no more constraint-propagate
+         (let ((constraint-delay (ldb (byte 8 0) delay)))
+           (cond ((= constraint-delay 255)
+                  (push node *ir1-transforms-after-constraints*)
+                  (setf (basic-combination-delay-to node)
+                        (dpb reoptimize-counter (byte 8 0) delay))
+                  t)
+                 ((= constraint-delay reoptimize-counter))))))
       (:ir1-phases
-       (cond ((and (not (logbitp 0 delayed))
-                   (= delayed-n reoptimize-counter))) ;; already delayed to :constraint
-             ((= delayed -1)
-              (push node *ir1-transforms-after-ir1-phases*)
-              (setf (basic-combination-delay-to node)
-                    (logand most-positive-fixnum (1+ (ash phase-counter 1))))
-              t)
-             ((= delayed-n phase-counter)))))))
+       (let ((ir1-phases-delay (ldb (byte 8 8) delay)))
+         (cond ((= ir1-phases-delay 255)
+                (push node *ir1-transforms-after-ir1-phases*)
+                (setf (basic-combination-delay-to node)
+                      (dpb phase-counter (byte 8 8) delay))
+                t)
+               ((= ir1-phases-delay phase-counter))))))))
 
 (defun delay-ir1-transform (node reason)
   (when (delay-ir1-optimizer node reason)
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index d1e03dd84..10a8bfba4 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -4231,6 +4231,7 @@ is :ANY, the function name is not checked."
                 (specifier-type 'simple-array))))))))
 
 (defun make-transform-lambda (fun args)
-  (let ((vars (make-gensym-list (length args))))
-    `(lambda ,vars
-       (,fun ,@vars))))
+  (when args
+    (let ((vars (make-gensym-list (length args))))
+      `(lambda ,vars
+         (,fun ,@vars)))))
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index dfee35b3d..989993e8a 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -1587,7 +1587,7 @@
   (step-info nil)
   ;; A plist of inline expansions
   (inline-expansions *inline-expansions* :type list :read-only t)
-  ;; Current COMPONENT-REOPTIMIZE-COUNTER set when calling delay-ir1-transform.
+  ;; Current COMPONENT-REOPTIMIZE-COUNTER + -PHASE-COUNTER set in delay-ir1-transform
   (delay-to -1 :type fixnum)
   (constraints-in)
   #+() (constraints-out))
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 487fe4f2a..3e921ece4 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -8452,12 +8452,11 @@
              (delay-ir1-optimizer node :constraint))))))
 
 (deftransform length ((sequence) * * :node node)
-  (let ((args (splice-fun-args sequence 'remove-duplicates nil nil)))
-    (cond (args
-           (make-transform-lambda 'sb-impl::length-remove-duplicates args))
-          (t
-           (make-transform-lambda 'sb-impl::length-delete-duplicates
-                                  (splice-fun-args sequence 'delete-duplicates nil))))))
+  (delay-ir1-transform node :ir1-phases)
+  (or (make-transform-lambda 'sb-impl::length-remove-duplicates (splice-fun-args sequence 'remove-duplicates nil nil))
+      (make-transform-lambda 'sb-impl::length-delete-duplicates (splice-fun-args sequence 'delete-duplicates nil nil))
+      (make-transform-lambda 'sb-impl::length-intersection (splice-fun-args sequence 'intersection nil nil))
+      (give-up-ir1-transform)))
 
 ;;; ENDP, NULL and NOT -> %REST-NULL
 ;;;

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


hooks/post-receive
-- 
SBCL