From 1f74e4e97ddf3b7f74a8f96cafb6cbc8223ff165 Mon Sep 17 00:00:00 2001
From: Douglas Katzman <dougk@google.com>
Date: Sun, 8 Mar 2026 20:45:55 -0400
Subject: [PATCH] Improve assoc transform on constant lists

I thought that the case of sequential integers was already handled specially by
the ASSOC transform but aparently not. Consequently +sigfpe-code-error-alist+
demanded a new MPH function when building for Haiku though the range of FPE_*
constants is contiguous.
---
 src/compiler/seqtran.lisp  | 28 ++++++++++++++++++++++++++++
 tests/fast-assoc.pure.lisp | 15 +++++++++++++++
 2 files changed, 43 insertions(+)

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 76bb80a74..d6d27d865 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -3541,6 +3541,34 @@
         (return-from try-perfect-find/position-map conditional))
       (when (eq fun-name 'find) ; nothing to do. Wasted some time, no big deal
         (return-from try-perfect-find/position-map 'item))) ; transform arg is always named ITEM
+
+    ;; Use a linear mapping for [R]ASSOC if the key set is a nearly contiguous range.
+    (when (and (member fun-name '(assoc rassoc))
+               (or (every #'characterp keys) (every #'fixnump keys)))
+      (let* ((characterp (characterp (car keys)))
+             (to-fixnum (if characterp #'char-code #'identity))
+             (min (reduce #'min keys :key to-fixnum))
+             (max (reduce #'max keys :key to-fixnum))
+             (theoretical-nkeys (1+ (- max min))))
+        ;; Allow at most (arbitrarily) 5 unused keys in the range to avoid wasting space.
+        (when (>= (hash-table-count map) (- theoretical-nkeys 5))
+          (let ((result (make-array theoretical-nkeys :initial-element nil)))
+            (dohash ((k v) map) (setf (aref result (- (funcall to-fixnum k) min)) v))
+            (when (eq alistp :synthetic)
+              ;; once-and-only-once-more, of course
+              (let* ((car/cdr (node-dest node))
+                     (fun (lvar-use (combination-fun car/cdr))))
+                (aver (ref-p fun))
+                (change-full-call car/cdr 'values :recklessly t)
+                (derive-node-type node (specifier-type 't) :from-scratch t)
+                (reoptimize-node car/cdr)))
+            (return-from try-perfect-find/position-map
+              (if characterp
+                  `(if (typep item '(character-set ((,min . ,max))))
+                       (aref ,result (- (char-code item) ,min)))
+                  `(if (typep item '(integer ,min ,max))
+                       (aref ,result (- item ,min)))))))))
+    ;;
     (binding* ((hashfn (prehash-function-for-mph-generator
                         (minperfhash-key-universe-type keys)))
                (hashes (map '(simple-array (unsigned-byte 32) (*)) hashfn keys))
diff --git a/tests/fast-assoc.pure.lisp b/tests/fast-assoc.pure.lisp
index 4c94d9b06..d03c7154f 100644
--- a/tests/fast-assoc.pure.lisp
+++ b/tests/fast-assoc.pure.lisp
@@ -171,3 +171,18 @@
     (dotimes (i (or #+sb-unicode 1000 256))
       (assert (eql (position (code-char i) +averylongstring+)
                    (funcall f (code-char i)))))))
+
+(defglobal *assoc-char-example*
+    '((#\g . 100) (#\d . 102) (#\i . 103) (#\f . 104) (#\e . 105)))
+(defun rassoc-int-range (x) (car (rassoc x '#.*assoc-char-example*)))
+(with-test (:name :assoc-dense-ranges)
+  (let* ((f (compile nil '(lambda (x) (cdr (assoc x '#.*assoc-char-example*)))))
+         (vector (car (ctu:find-code-constants f))))
+    (assert (equalp vector #(102 105 104 100 NIL 103)))
+    (dolist (x *assoc-char-example*)
+      (assert (eql (funcall f (car x)) (cdr x)))))
+  (let* ((f (compile nil '(lambda (x) (car (rassoc x '#.*assoc-char-example*)))))
+         (vector (car (ctu:find-code-constants f))))
+    (assert (equalp vector #(#\g NIL #\d #\i #\f #\e)))
+    (dolist (x *assoc-char-example*)
+      (assert (eql (funcall f (cdr x)) (car x))))))