common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Improve assoc transform on constant lists

Browse source 
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.
This commit is contained in:
Douglas Katzman 2026-03-08 20:45:55 -04:00
parent 1e8316ef19
commit 1f74e4e97d
2 changed files with 43 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
src/compiler/seqtran.lisp
View file

@ -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))

15
tests/fast-assoc.pure.lisp
View file

@ -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))))))