master: count transforms: accept :key and :test
stassats via Sbcl-commits <[email protected]> Wed, 01 Jul 2026 19:14:11 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 8b5a25e7cd1c62449fa751a5068652459aadae6a (commit)
from 23aa0d832b2c38e1dca8c1f09c66c1d7f8494522 (commit)
- Log -----------------------------------------------------------------
commit 8b5a25e7cd1c62449fa751a5068652459aadae6a
Author: Stas Boukarev <[email protected]>
Date: Wed Jul 1 22:02:41 2026 +0300
count transforms: accept :key and :test
---
src/compiler/generic/vm-tran.lisp | 72 ----------------------------------
src/compiler/seqtran.lisp | 81 +++++++++++++++++++++++++++++++++++++++
xperfecthash63.lisp-expr | 11 ++++++
3 files changed, 92 insertions(+), 72 deletions(-)
diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 54816912b..a0c1e4f89 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -592,78 +592,6 @@
(zerop (shift-towards-end (logxor (%vector-raw-bits x words)
(%vector-raw-bits y words))
(- remainder))))))))))
-
-;;; This transform has to deal with unused bits in the
-;;; last data word of a simple-bit-vector can be random.
-(deftransform count ((item sequence &key (start 0) end)
- (bit bit-vector &key (:start index) (:end (or index null)))
- * :policy (>= speed space) :important nil)
- (if (and (or (not start) (lvar-value-is start 0))
- (eq end nil)
- (lvar-csubtypep sequence simple-bit-vector))
- `(let* ((length (vector-length sequence))
- (count 0)
- (words (floor length sb-vm:n-word-bits)))
- (declare (index count))
- (declare (optimize (speed 3) (safety 0)))
- (dotimes (i words)
- (incf count (logcount (%vector-raw-bits sequence i))))
- (let ((remainder (mod length sb-vm:n-word-bits)))
- (unless (zerop remainder)
- (incf count (logcount (shift-towards-end (%vector-raw-bits sequence words)
- (- sb-vm:n-word-bits remainder))))))
- ,(if (constant-lvar-p item)
- (if (zerop (lvar-value item)) '(- length count) 'count)
- '(if (zerop item) (- length count) count)))
- `(let ((count 0))
- (declare (index count))
- (with-array-data ((raw-bv sequence) (real-start start) (real-end end) :check-fill-pointer t)
- (multiple-value-bind (start-words start-remainder)
- (floor real-start sb-vm:n-word-bits)
- (multiple-value-bind (end-words end-remainder)
- (floor real-end sb-vm:n-word-bits)
- (cond
- ((= start-words end-words)
- ;; Less than a word. Careful that SHL/SHR are masked to 5 bits, so
- ;; (count 1 #*111 :start 0 :end 0) would generate a shift of 64 here,
- ;; which is a NOP, so catch that first and avoid it!
- (unless (= start-remainder end-remainder)
- (incf count
- (logcount
- (shift-towards-end
- (shift-towards-start (%vector-raw-bits raw-bv start-words)
- start-remainder)
- (+ start-remainder (- sb-vm:n-word-bits end-remainder)))))))
- (t
- (unless (zerop start-remainder)
- (incf count (logcount (shift-towards-start
- (%vector-raw-bits raw-bv start-words)
- start-remainder)))
- (incf start-words))
- (loop for word-offset of-type index from start-words below end-words
- do (incf count (logcount (%vector-raw-bits raw-bv word-offset))))
- (unless (zerop end-remainder)
- (let ((num-1s (logcount (shift-towards-end
- (%vector-raw-bits raw-bv end-words)
- (- sb-vm:n-word-bits end-remainder)))))
- (incf count num-1s)))))
- ,(if (constant-lvar-p item)
- (if (zerop (lvar-value item)) '(- real-end real-start count) 'count)
- '(if (zerop item) (- real-end real-start count) count))))))))
-
-(deftransform count ((item sequence &key (start 0) end key test) (t (not bit-vector)) *
- :important nil)
- (when (not (types-equal-or-intersect (lvar-type item) (sequence-element-type sequence key)))
- ;; When array cannot store the thing we are searching for, punt, user gets an
- ;; Item of type X can't be found in a sequence of type Y message in later count transforms
- (give-up-ir1-transform))
- `(let ((count 0))
- (declare (index count))
- (flet ((counter (x) (when (eql x item) (incf count))))
- (declare (dynamic-extent #'counter))
- (map nil #'counter sequence))
- count))
-
;;;; %BYTE-BLT
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index a10d3391e..c3ff3f0d7 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -2609,6 +2609,87 @@
(index-into-sequence-derive-type sequence start end)
(make-numeric-type 'integer 0 (- max min))))
+;;; This transform has to deal with unused bits in the
+;;; last data word of a simple-bit-vector can be random.
+(deftransform count ((item sequence &key (start 0) end test)
+ (bit bit-vector &rest t)
+ * :policy (>= speed space) :important nil)
+ (when (and test
+ (not (lvar-fun-is test '(eq eql))))
+ (give-up-ir1-transform))
+ (if (and (or (not start) (lvar-value-is start 0))
+ (eq end nil)
+ (lvar-csubtypep sequence simple-bit-vector))
+ `(let* ((length (vector-length sequence))
+ (count 0)
+ (words (floor length sb-vm:n-word-bits)))
+ (declare (index count))
+ (declare (optimize (speed 3) (safety 0)))
+ (dotimes (i words)
+ (incf count (logcount (%vector-raw-bits sequence i))))
+ (let ((remainder (mod length sb-vm:n-word-bits)))
+ (unless (zerop remainder)
+ (incf count (logcount (shift-towards-end (%vector-raw-bits sequence words)
+ (- sb-vm:n-word-bits remainder))))))
+ ,(if (constant-lvar-p item)
+ (if (zerop (lvar-value item)) '(- length count) 'count)
+ '(if (zerop item) (- length count) count)))
+ `(let ((count 0))
+ (declare (index count))
+ (with-array-data ((raw-bv sequence) (real-start start) (real-end end) :check-fill-pointer t)
+ (multiple-value-bind (start-words start-remainder)
+ (floor real-start sb-vm:n-word-bits)
+ (multiple-value-bind (end-words end-remainder)
+ (floor real-end sb-vm:n-word-bits)
+ (cond
+ ((= start-words end-words)
+ ;; Less than a word. Careful that SHL/SHR are masked to 5 bits, so
+ ;; (count 1 #*111 :start 0 :end 0) would generate a shift of 64 here,
+ ;; which is a NOP, so catch that first and avoid it!
+ (unless (= start-remainder end-remainder)
+ (incf count
+ (logcount
+ (shift-towards-end
+ (shift-towards-start (%vector-raw-bits raw-bv start-words)
+ start-remainder)
+ (+ start-remainder (- sb-vm:n-word-bits end-remainder)))))))
+ (t
+ (unless (zerop start-remainder)
+ (incf count (logcount (shift-towards-start
+ (%vector-raw-bits raw-bv start-words)
+ start-remainder)))
+ (incf start-words))
+ (loop for word-offset of-type index from start-words below end-words
+ do (incf count (logcount (%vector-raw-bits raw-bv word-offset))))
+ (unless (zerop end-remainder)
+ (let ((num-1s (logcount (shift-towards-end
+ (%vector-raw-bits raw-bv end-words)
+ (- sb-vm:n-word-bits end-remainder)))))
+ (incf count num-1s)))))
+ ,(if (constant-lvar-p item)
+ (if (zerop (lvar-value item)) '(- real-end real-start count) 'count)
+ '(if (zerop item) (- real-end real-start count) count))))))))
+
+(deftransform count ((item sequence &key test key) (t (not bit-vector) &rest t) *
+ :important nil)
+ (when (not (types-equal-or-intersect (lvar-type item) (sequence-element-type sequence key)))
+ ;; When array cannot store the thing we are searching for, punt, user gets an
+ ;; Item of type X can't be found in a sequence of type Y message in later count transforms
+ (give-up-ir1-transform))
+ `(let ((count 0)
+ ,@(and key
+ `((key (%coerce-callable-to-fun key)))))
+ (declare (index count))
+ (flet ((counter (x) (when (funcall ,(if test 'test ''eql)
+ item
+ ,(if key
+ `(funcall key x)
+ `x))
+ (incf count))))
+ (declare (dynamic-extent #'counter))
+ (map nil #'counter sequence))
+ count))
+
(defoptimizer (sb-impl::length-remove-duplicates derive-type) ((sequence &key &allow-other-keys))
(multiple-value-bind (max min) (sequence-lvar-dimensions sequence)
(make-numeric-type 'integer
diff --git a/xperfecthash63.lisp-expr b/xperfecthash63.lisp-expr
index 2b29fc6ec..35cf10be2 100644
--- a/xperfecthash63.lisp-expr
+++ b/xperfecthash63.lisp-expr
@@ -1820,5 +1820,16 @@
(let ((b (& val #xf)))
(let ((a (>> (u32+ val (<< val 23)) 28)))
(^ a (aref tab b))))))")
+(#(208FE110 3B4ABA52 6C7BFBCB AB4685DD AEC88182 D110413A E0C5F126 E9E0577D)
+ "(ARRAY-TYPE NEGATION-TYPE ALIEN-TYPE-TYPE SIMD-PACK-512-TYPE SIMD-PACK-256-TYPE SIMD-PACK-TYPE UNKNOWN-TYPE HAIRY-TYPE)"
+ "((& (+ val (>> val 29)) 7))")
+(#(0 2 4 6 8 A E 10 12 14 16 18 1A 1C 1E 20 22 24 26 28 2A 2E 30 32 34 36 38 3A 3C 7A)
+ "(61 4 3 10 7 8 9 5 14 13 12 11 26 25 24 23 16 17 15 29 30 28 27 21 20 2 19 18 0 1)"
+ "((let ((tab #a((16) (unsigned-byte 8) 21 0 16 13 18 3 24 15 1 9 11 28 26 4 20 29)))
+ (+= val #x2c45f2cb)
+ (^= val (>> val 4))
+ (let ((b (& val #xf)))
+ (let ((a (>> (u32+ val (<< val 23)) 28)))
+ (^ a (aref tab b))))))")
)
;; EOF
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL