master: Fix failure to choose a jump table for a key type of (MOD 4)
snuglas via Sbcl-commits <[email protected]> Wed, 29 Jul 2026 20:57:40 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 629a0df18206ff73e400289f86ac2d328d2f91b0 (commit)
from 52d8f80c929a6d847e75eba4c5c5270b4e32e819 (commit)
- Log -----------------------------------------------------------------
commit 629a0df18206ff73e400289f86ac2d328d2f91b0
Author: Douglas Katzman <[email protected]>
Date: Wed Jul 29 20:56:46 2026 +0000
Fix failure to choose a jump table for a key type of (MOD 4)
Ironically it was working when the key's derived type was _not_ known
to be exactly (MOD 4) with a CASE over 4 keys.
---
src/compiler/srctran.lisp | 33 +++++++++++++++++----------------
tests/jump-table.pure.lisp | 22 ++++++++++++++++++++++
xperfecthash30.lisp-expr | 6 ++++++
xperfecthash61.lisp-expr | 6 ++++++
xperfecthash63.lisp-expr | 15 ++++++++++++---
5 files changed, 63 insertions(+), 19 deletions(-)
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index ef7ff88bd..ec27e8300 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -10286,6 +10286,23 @@
(lvar (first (combination-args node)))
(otherwise (and last-if
(if-alternative last-if))))
+ (let ((diff (type-difference (lvar-type lvar)
+ (specifier-type `(member ,@keys)))))
+ ;; If it's an exhaustive case add the missing case back,
+ ;; that way the hash doesn't need to be checked for collisions.
+ ;; Also the missing case may be needed to meet the threshold
+ ;; minimum number of items to create a jump table.
+ (multiple-value-bind (p value) (type-singleton-p diff)
+ (when (and p
+ (typecase (car keys)
+ (sb-xc:fixnum (fixnump value))
+ (symbol (symbolp value))
+ (character (characterp value))))
+ (push value keys)
+ (setf targets (append targets (list otherwise))
+ key-lists (append key-lists
+ (list (list value)))
+ otherwise nil))))
(cond ((not (and keys
(sb-impl::should-attempt-hash-based-case-dispatch keys)
(not (key-lists-for-or-eq-transform-p key-lists))))
@@ -10314,22 +10331,6 @@
(otherwise . ,otherwise)))
t))
t)
- ((let ((diff (type-difference (lvar-type lvar)
- (specifier-type `(member ,@keys)))))
- ;; If it's an exhaustive case add the missing case back,
- ;; that way the hash doesn't need to be checked for collisions.
- (multiple-value-bind (p value) (type-singleton-p diff)
- (when (and p
- (typecase (car keys)
- (sb-xc:fixnum (fixnump value))
- (symbol (symbolp value))
- (character (characterp value))))
- (push value keys)
- (setf targets (append targets (list otherwise))
- key-lists (append key-lists
- (list (list value)))
- otherwise nil)))
- nil))
((or-eq-to-aref keys key-lists targets last-if chains otherwise))
(t
(multiple-value-bind (code new-targets)
diff --git a/tests/jump-table.pure.lisp b/tests/jump-table.pure.lisp
index 299db9bc9..c56632499 100644
--- a/tests/jump-table.pure.lisp
+++ b/tests/jump-table.pure.lisp
@@ -196,3 +196,25 @@
,(make-symbol (map 'string #'code-char '(18689 30023 3247 59527 37241 35427))))
standard-char)
p1))))
+
+(defun good-example (x y)
+ (declare (fixnum x))
+ (let ((bits (logand x 7)))
+ (case bits
+ (0 (print 'foo))
+ (1 (cons 'a y))
+ (2 (cons y 'zook))
+ (3 "hi"))))
+
+(defun failing-example (x y)
+ (declare (fixnum x))
+ (let ((bits (logand x 3)))
+ (case bits
+ (0 (print 'foo))
+ (1 (cons 'a y))
+ (2 (cons y 'zook))
+ (3 "hi"))))
+
+(with-test (:name :should-use-jump-table)
+ (assert (= (sb-kernel:code-jump-table-words (sb-kernel:fun-code-header #'good-example)) 5))
+ (assert (= (sb-kernel:code-jump-table-words (sb-kernel:fun-code-header #'failing-example)) 5)))
diff --git a/xperfecthash30.lisp-expr b/xperfecthash30.lisp-expr
index f9f3a7c0b..6a503acf0 100644
--- a/xperfecthash30.lisp-expr
+++ b/xperfecthash30.lisp-expr
@@ -382,6 +382,9 @@
(#(D0C591 11D1FAD 35ED22C BCE7F62 C841474 10F360C2 12F86037 15E7305A)
"(FLOAT RATIONAL REAL LONG-FLOAT DOUBLE-FLOAT SINGLE-FLOAT SHORT-FLOAT *)"
"((& (- (>> val 11) (>> val 15)) 7))")
+(#(D0C591 11D1FAD 35ED22C C841474 12F86037)
+ "(RATIONAL LONG-FLOAT DOUBLE-FLOAT SINGLE-FLOAT SHORT-FLOAT)"
+ "((& (>> val 24) 7))")
(#(D0C591 331CAB8 48D4754 6B4780F 8892768 A8C210D B445B28 C841474 EF3F4BC 102153B3 10BE7277 12E2CBDA 1A7E09AF 1BAC0C5C)
"(NIL COMPLEX INTEGER MOD SINGLE-FLOAT DOUBLE-FLOAT SIGNED-BYTE UNSIGNED-BYTE FIXNUM BIT CHARACTER STANDARD-CHAR BASE-CHAR T)"
"((let ((tab #a((8) (unsigned-byte 8) 0 12 15 0 9 2 8 5)))
@@ -1119,6 +1122,9 @@
(#(3AF52DD 487643D 12D6C85E 15B1443E)
"(SB-IMPL::|List| LIST SB-IMPL::|Vector| VECTOR)"
"((& (>> val 20) 3))")
+(#(3AF52DD F5EC8DB 10D899FE 12D6C85E 1D1D902E)
+ "(SB-IMPL::|Vector| SB-IMPL::|List*| SB-IMPL::|List| SB-IMPL::|Append| NCONC)"
+ "((& (- (>> val 11) (>> val 25)) 7))")
(#(3BC72D2 102153B3 11B13DF2 16124E24)
"(NIL :FAIL :DEFER :LISP)"
"((& (>> val 24) 3))")
diff --git a/xperfecthash61.lisp-expr b/xperfecthash61.lisp-expr
index 82b909687..6eb72486b 100644
--- a/xperfecthash61.lisp-expr
+++ b/xperfecthash61.lisp-expr
@@ -806,6 +806,9 @@
(#(235ED22C 42D83FFB 75E7305A A8892768 E06FC299)
"(:ALLOW-OTHER-KEYS :UNSIGNED :COMPLEX :FLOAT :RATIONAL)"
"((& val 7))")
+(#(235ED22C 611D1FAD 80D0C591 AC841474 D2F86037)
+ "(RATIONAL LONG-FLOAT DOUBLE-FLOAT SINGLE-FLOAT SHORT-FLOAT)"
+ "((& (>> val 24) 7))")
(#(235ED22C 72E2CBDA 75E7305A 80D0C591 AC841474)
"(DOUBLE-FLOAT SINGLE-FLOAT FLOAT RATIONAL INTEGER)"
"((& (+ (>> val 1) (>> val 23)) 7))")
@@ -1049,6 +1052,9 @@
(#(3C5EFFF8 7AAF3CC2 C1E847AD EA771EC5)
"(SB-C::PROPER-OR-DOTTED-LIST SB-C::PROPER-OR-CIRCULAR-LIST SB-C::PROPER-SEQUENCE SB-C::PROPER-LIST)"
"((& (>> val 2) 3))")
+(#(3D1D902E 43AF52DD 72D6C85E B0D899FE CF5EC8DB)
+ "(SB-IMPL::|Vector| SB-IMPL::|List*| SB-IMPL::|List| SB-IMPL::|Append| NCONC)"
+ "((& (- (>> val 11) (>> val 25)) 7))")
(#(3E02DA52 42D83FFB 4D28C61A 50BC6DF5 53351B33 5C084D2B A2DD0906 F26B59C0)
"(:ALLOW-OTHER-KEYS :KEY :COUNT :END :START :TEST-NOT :TEST :FROM-END)"
"((& (+ (>> val 12) (>> val 24)) 7))")
diff --git a/xperfecthash63.lisp-expr b/xperfecthash63.lisp-expr
index e3f3bb137..98a6ed4bc 100644
--- a/xperfecthash63.lisp-expr
+++ b/xperfecthash63.lisp-expr
@@ -125,6 +125,9 @@
(#(0 2C62CDF1 2FBB375F 57DA1CEC 7E1E0B08 EA6D3871)
"(:RESULT-TYPES NIL :CONDITIONAL :ARG-TYPES :ARG-CHECK :GUARD)"
"((& (+ (>> val 6) (>> val 14)) 7))")
+(#(0 2C62CDF1 2FBB375F 7E1E0B08 EA6D3871)
+ "(:RESULT-TYPES NIL :ARG-TYPES :ARG-CHECK :GUARD)"
+ "((& (- (>> val 2) (>> val 26)) 7))")
(#(0 2DF0AB1F 860D0EEC 8B8666B5 CB5B4BC6 EBFEA11D)
"(:MORE :CLEANUP :TOPLEVEL :EXTERNAL :OPTIONAL NIL)"
"((& (+ val (>> val 28)) 7))")
@@ -1097,6 +1100,9 @@
(#(235ED22C 42D83FFB 75E7305A A8892768 E06FC299)
"(:ALLOW-OTHER-KEYS :UNSIGNED :COMPLEX :FLOAT :RATIONAL)"
"((& val 7))")
+(#(235ED22C 611D1FAD 80D0C591 AC841474 D2F86037)
+ "(RATIONAL LONG-FLOAT DOUBLE-FLOAT SINGLE-FLOAT SHORT-FLOAT)"
+ "((& (>> val 24) 7))")
(#(235ED22C 72E2CBDA 75E7305A 80D0C591 AC841474)
"(DOUBLE-FLOAT SINGLE-FLOAT FLOAT RATIONAL INTEGER)"
"((& (+ (>> val 1) (>> val 23)) 7))")
@@ -1349,6 +1355,9 @@
(#(35455F60 4E3391D6 5256235A 6AC11619 A37EFB8E A7D5BCEA)
"(SB-VM::NOISE SB-VM::IMMEDIATE-CONSTANT CONSTANT SB-VM::STACK SB-VM::FLOAT-REGISTERS SB-VM::REGISTERS)"
"((& (>> val 26) 7))")
+(#(359CB801 4D28C61A 53351B33 A2DD0906 B9B79FF6)
+ "(FUNCTION SB-IMPL::PREDICATE SB-IMPL::KEY SB-IMPL::TEST SB-IMPL::TEST-NOT)"
+ "((& (^ (>> val 3) (>> val 6)) 7))")
(#(359CB801 5DAB18D0 625827B9 7D5DAB1C BF38ADF8 C2B3EDA3 C7436840 D2821F1C E391E233 EBD01872 F1F25102)
"(:PURE :INITIAL-OFFSET :NAMED :TYPE :PRINT-OBJECT :PRINT-FUNCTION :INCLUDE :PREDICATE :COPIER :CONSTRUCTOR :CONC-NAME)"
"((let ((tab #a((8) (unsigned-byte 8) 0 5 8 11 4 1 0 5)))
@@ -1412,6 +1421,9 @@
(#(3C5EFFF8 7AAF3CC2 C1E847AD EA771EC5)
"(SB-C::PROPER-OR-DOTTED-LIST SB-C::PROPER-OR-CIRCULAR-LIST SB-C::PROPER-SEQUENCE SB-C::PROPER-LIST)"
"((& (>> val 2) 3))")
+(#(3D1D902E 43AF52DD 72D6C85E B0D899FE CF5EC8DB)
+ "(SB-IMPL::|Vector| SB-IMPL::|List*| SB-IMPL::|List| SB-IMPL::|Append| NCONC)"
+ "((& (- (>> val 11) (>> val 25)) 7))")
(#(3E02DA52 42D83FFB 4D28C61A 50BC6DF5 53351B33 5C084D2B A2DD0906 F26B59C0)
"(:ALLOW-OTHER-KEYS :KEY :COUNT :END :START :TEST-NOT :TEST :FROM-END)"
"((& (+ (>> val 12) (>> val 24)) 7))")
@@ -1776,8 +1788,5 @@
(#(A49305EF D0241AE7 E55E7F8C EE9A5410)
"(SB-PCL::%CLASS SB-PCL::%PARAMETER SB-PCL::%VARIABLE-REBINDING SPECIAL)"
"((& (>> val 8) 3))")
-(#(359CB801 4D28C61A 53351B33 A2DD0906 B9B79FF6)
- "(FUNCTION SB-IMPL::PREDICATE SB-IMPL::KEY SB-IMPL::TEST SB-IMPL::TEST-NOT)"
- "((& (^ (>> val 3) (>> val 6)) 7))")
)
;; EOF
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL