mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Change to a simpler hash in solist algorithm
A single multiplication will suffice. Also change MASKED-HASH to avoid use of the large constant - instead require that the the hash function return only non-negative fixnums. The benchmark shows that for 20 concurrent readers, solist outperforms a synchronized hash-table by up to 50x now.
This commit is contained in:
Douglas Katzman
parent
2aae8c6dd7
commit
141c02585c
|
|
@ -2,6 +2,9 @@
|
|||
(load "src/code/redblack.lisp")
|
||||
(with-compilation-unit () (load "tests/test-util.lisp"))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(import 'sb-int:dovector))
|
||||
|
||||
(in-package "SB-RBTREE.WORD")
|
||||
(defun height (tree)
|
||||
(sb-int:named-let recurse ((tree tree))
|
||||
|
|
@ -35,48 +38,54 @@
|
|||
(defvar *hash-table* nil)
|
||||
|
||||
(defvar *lotta-strings*
|
||||
(mapcar (lambda (x)
|
||||
(sb-kernel:%make-lisp-obj
|
||||
(logandc2 (sb-kernel:get-lisp-obj-address x)
|
||||
sb-vm:lowtag-mask)))
|
||||
(sb-vm:list-allocated-objects
|
||||
:read-only
|
||||
:type sb-vm:simple-base-string-widetag)))
|
||||
(coerce
|
||||
;; Collect al pseudostatic symbols and all readonly strings
|
||||
(mapcar (lambda (x)
|
||||
(sb-kernel:%make-lisp-obj
|
||||
(logandc2 (sb-kernel:get-lisp-obj-address x)
|
||||
sb-vm:lowtag-mask)))
|
||||
(nconc (sb-vm:list-allocated-objects
|
||||
:dynamic
|
||||
:type sb-vm:symbol-widetag
|
||||
:test (lambda (x) (= (sb-kernel:generation-of x)
|
||||
sb-vm:+pseudo-static-generation+)))
|
||||
(sb-vm:list-allocated-objects
|
||||
:read-only
|
||||
:type sb-vm:simple-base-string-widetag)))
|
||||
'vector))
|
||||
(declaim (simple-vector *lotta-strings*))
|
||||
|
||||
(defun insert-all-brothertree ()
|
||||
(let ((tree nil))
|
||||
(dolist (str *lotta-strings*)
|
||||
(dovector (str *lotta-strings*)
|
||||
(setq tree (sb-brothertree:insert str tree)))
|
||||
(setq *brothertree* tree)))
|
||||
|
||||
(defun insert-all-redblack ()
|
||||
(let ((tree nil))
|
||||
(dolist (str *lotta-strings*)
|
||||
(dovector (str *lotta-strings*)
|
||||
;; because OF COURSE the arg orders are opposite
|
||||
(setq tree (sb-rbtree.word:insert tree str)))
|
||||
(setq *rbtree* tree)))
|
||||
|
||||
(defun insert-all-solist ()
|
||||
(let ((set (let ((sb-lockless::*desired-elts-per-bin* 1))
|
||||
(let ((set (let ((sb-lockless::*desired-elts-per-bin* 2))
|
||||
(sb-lockless:make-so-set/addr))))
|
||||
(dolist (str *lotta-strings*)
|
||||
(dovector (str *lotta-strings*)
|
||||
(sb-lockless:so-insert set str))
|
||||
(setq *solist* set)))
|
||||
|
||||
(defun insert-all-hash-table ()
|
||||
(let ((set (make-hash-table :test 'eq)))
|
||||
(dolist (str *lotta-strings*)
|
||||
(let ((set (make-hash-table :test 'eq :synchronized t)))
|
||||
(dovector (str *lotta-strings*)
|
||||
(setf (gethash str set) t))
|
||||
(setq *hash-table* set)))
|
||||
|
||||
(gc)
|
||||
(time (insert-all-redblack))
|
||||
(gc)
|
||||
(time (insert-all-brothertree))
|
||||
(gc)
|
||||
(time (insert-all-solist))
|
||||
(gc)
|
||||
(time (insert-all-hash-table))
|
||||
(dolist (test '(insert-all-redblack insert-all-brothertree insert-all-solist insert-all-hash-table))
|
||||
(gc)
|
||||
(format t "Running ~S~%" test)
|
||||
(time (funcall test)))
|
||||
|
||||
(let ((n (length *lotta-strings*)))
|
||||
(format t "~&Memory:~:{~% ~8a=~8D ~3,1f~}~%"
|
||||
(loop for (name . val) in `(("brother" . ,*brothertree*)
|
||||
|
|
@ -91,27 +100,80 @@
|
|||
(sb-rbtree.word::height *rbtree*)
|
||||
(sb-brothertree::height *brothertree*))
|
||||
|
||||
(defun find-all-in-brothertree (&aux (tree *brothertree*))
|
||||
(loop for str in *lotta-strings*
|
||||
count (sb-brothertree:find= str tree)))
|
||||
(defun find-all-in-redblack-tree (&aux (tree *rbtree*))
|
||||
(loop for str in *lotta-strings*
|
||||
count (sb-rbtree.word:find= str tree)))
|
||||
(defun find-all-in-solist (&aux (set *solist*))
|
||||
(loop for str in *lotta-strings*
|
||||
count (sb-lockless:so-find set str)))
|
||||
(defun find-all-in-hash-table (&aux (set *hash-table*))
|
||||
(loop for str in *lotta-strings*
|
||||
count (gethash str set)))
|
||||
(macrolet ((exercise (find-it)
|
||||
`(ecase direction
|
||||
(:up (loop for str across *lotta-strings*
|
||||
count ,find-it))
|
||||
(:down (let ((v *lotta-strings*))
|
||||
(loop for i downfrom (1- (length v)) to 0
|
||||
count (let ((str (svref v i))) ,find-it)))))))
|
||||
(defun find-all-in-brothertree (&optional (direction :up) &aux (tree *brothertree*))
|
||||
(exercise (sb-brothertree:find= str tree)))
|
||||
(defun find-all-in-redblack-tree (&optional (direction :up) &aux (tree *rbtree*))
|
||||
(exercise (sb-rbtree.word:find= str tree)))
|
||||
(defun find-all-in-solist (&optional (direction :up) &aux (set *solist*))
|
||||
(exercise (sb-lockless:so-find set str)))
|
||||
(defun find-all-in-hash-table (&optional (direction :up) &aux (set *hash-table*))
|
||||
(exercise (gethash str set))))
|
||||
|
||||
(find-all-in-brothertree)
|
||||
(find-all-in-redblack-tree)
|
||||
(find-all-in-solist)
|
||||
(find-all-in-hash-table)
|
||||
(time (find-all-in-brothertree))
|
||||
(time (find-all-in-redblack-tree))
|
||||
(time (find-all-in-solist))
|
||||
(time (find-all-in-hash-table))
|
||||
;;; Each test will run *nthreads* threads and each thread will find each item.
|
||||
(defvar *start-sem* (sb-thread:make-semaphore))
|
||||
(defvar *completion-sem* (sb-thread:make-semaphore))
|
||||
(defvar *function-to-run* nil)
|
||||
(defglobal *results* nil)
|
||||
(defun say (s)
|
||||
(declare (simple-base-string s))
|
||||
(sb-sys:with-pinned-objects (s)
|
||||
;; avoid interleaved output, usually
|
||||
(sb-unix:unix-write 2 s 0 (length s))))
|
||||
|
||||
(defmacro with-cycle-counter (form)
|
||||
`(multiple-value-bind (hi0 lo0) (sb-vm::%read-cycle-counter)
|
||||
(values ,form
|
||||
(multiple-value-bind (hi1 lo1) (sb-vm::%read-cycle-counter)
|
||||
(+ (ash (- hi1 hi0) 32) (- lo1 lo0))))))
|
||||
|
||||
(defun workfun (my-index)
|
||||
(let ((direction-to-scan (if (oddp my-index) :up :down)))
|
||||
(loop ; (say (format nil "thread ~d waiting~%" my-index))
|
||||
(sb-thread:wait-on-semaphore *start-sem*)
|
||||
; (say (format nil "thread ~d starting function under test~%" my-index))
|
||||
(let ((test-fun *function-to-run*))
|
||||
(when (null test-fun)
|
||||
;(say (format nil "thread ~d exiting~%" my-index))
|
||||
(return))
|
||||
;(say (format nil "thread ~d working~%" my-index))
|
||||
(multiple-value-bind (answer cycle-time)
|
||||
(with-cycle-counter (funcall test-fun direction-to-scan))
|
||||
(assert (= answer (length *lotta-strings*)))
|
||||
(sb-ext:atomic-push cycle-time *results*))
|
||||
(sb-thread:signal-semaphore *completion-sem*)))))
|
||||
|
||||
(defun perform-work-in-threads (test nthreads)
|
||||
(setf *function-to-run* test
|
||||
*results* nil)
|
||||
(sb-thread:signal-semaphore *start-sem* nthreads)
|
||||
(sb-thread:wait-on-semaphore *completion-sem* :n nthreads))
|
||||
|
||||
(defvar *find-tests* '(find-all-in-brothertree find-all-in-redblack-tree
|
||||
find-all-in-solist find-all-in-hash-table))
|
||||
|
||||
(defun test-nthreads (&optional (nthreads 6))
|
||||
(let ((threads (make-array nthreads)))
|
||||
(dotimes (i nthreads)
|
||||
(setf (aref threads i) (sb-thread:make-thread #'workfun :arguments (list i))))
|
||||
(dolist (test *find-tests*)
|
||||
(format t "~&Testing ~S~%" test)
|
||||
(time (perform-work-in-threads test nthreads))
|
||||
(let* ((cycle-times *results*)
|
||||
(min (reduce #'min cycle-times))
|
||||
(max (reduce #'max cycle-times))
|
||||
(sum (reduce #'+ cycle-times)))
|
||||
(format t " ==> min=~E max=~E avg=~E~2%"
|
||||
min max (/ sum nthreads))))
|
||||
(setq *function-to-run* nil)
|
||||
(sb-thread:signal-semaphore *start-sem* nthreads)
|
||||
(map nil #'sb-thread:join-thread threads)))
|
||||
|
||||
#|
|
||||
* (load"benchmarks/bbtrees")
|
||||
|
|
|
|||
|
|
@ -1834,7 +1834,9 @@
|
|||
(= (#x-4000000000000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
|
||||
(= (#x-1000000000000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
|
||||
(= (#x-1000000000000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
|
||||
(= (#x-80000000 #.(MAKE-DOUBLE-FLOAT #x-3E200000 #x0)) T)
|
||||
(= (#x-20000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
|
||||
(= (#x-20000000 #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0)) T)
|
||||
(= (#x-20000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
|
||||
(= (#x-3 #.(MAKE-DOUBLE-FLOAT #x-3FF80000 #x0)) T)
|
||||
(= (#x-2 #.(MAKE-DOUBLE-FLOAT #x-40000000 #x0)) T)
|
||||
|
|
@ -1890,6 +1892,7 @@
|
|||
(= (#x16 #.(MAKE-DOUBLE-FLOAT #x40360000 #x0)) T)
|
||||
(= (#x19 #.(MAKE-DOUBLE-FLOAT #x40390000 #x0)) T)
|
||||
(= (#x1C #.(MAKE-DOUBLE-FLOAT #x403C0000 #x0)) T)
|
||||
(= (#x1E #.(MAKE-DOUBLE-FLOAT #x403E0000 #x0)) T)
|
||||
(= (#x1F #.(MAKE-DOUBLE-FLOAT #x403F0000 #x0)) T)
|
||||
(= (#x20 #.(MAKE-DOUBLE-FLOAT #x40400000 #x0)) T)
|
||||
(= (#x23 #.(MAKE-DOUBLE-FLOAT #x40418000 #x0)) T)
|
||||
|
|
@ -1899,15 +1902,21 @@
|
|||
(= (#x3F #.(MAKE-DOUBLE-FLOAT #x404F8000 #x0)) T)
|
||||
(= (#x40 #.(MAKE-DOUBLE-FLOAT #x40500000 #x0)) T)
|
||||
(= (#x45 #.(MAKE-DOUBLE-FLOAT #x40514000 #x0)) T)
|
||||
(= (#x4A #.(MAKE-DOUBLE-FLOAT #x40528000 #x0)) T)
|
||||
(= (#x4E #.(MAKE-DOUBLE-FLOAT #x40538000 #x0)) T)
|
||||
(= (#x51 #.(MAKE-DOUBLE-FLOAT #x40544000 #x0)) T)
|
||||
(= (#x60 #.(MAKE-DOUBLE-FLOAT #x40580000 #x0)) T)
|
||||
(= (#x70 #.(MAKE-DOUBLE-FLOAT #x405C0000 #x0)) T)
|
||||
(= (#x80 #.(MAKE-DOUBLE-FLOAT #x40600000 #x0)) T)
|
||||
(= (#x81 #.(MAKE-DOUBLE-FLOAT #x40602000 #x0)) T)
|
||||
(= (#x82 #.(MAKE-DOUBLE-FLOAT #x40604000 #x0)) T)
|
||||
(= (#x85 #.(MAKE-DOUBLE-FLOAT #x4060A000 #x0)) T)
|
||||
(= (#x86 #.(MAKE-DOUBLE-FLOAT #x4060C000 #x0)) T)
|
||||
(= (#x89 #.(MAKE-DOUBLE-FLOAT #x40612000 #x0)) T)
|
||||
(= (#x8A #.(MAKE-DOUBLE-FLOAT #x40614000 #x0)) T)
|
||||
(= (#xC0 #.(MAKE-DOUBLE-FLOAT #x40680000 #x0)) T)
|
||||
(= (#xD2 #.(MAKE-DOUBLE-FLOAT #x406A4000 #x0)) T)
|
||||
(= (#xD6 #.(MAKE-DOUBLE-FLOAT #x406AC000 #x0)) T)
|
||||
(= (#xDA #.(MAKE-DOUBLE-FLOAT #x406B4000 #x0)) T)
|
||||
(= (#xE0 #.(MAKE-DOUBLE-FLOAT #x406C0000 #x0)) T)
|
||||
(= (#xE1 #.(MAKE-DOUBLE-FLOAT #x406C2000 #x0)) T)
|
||||
|
|
@ -1927,11 +1936,14 @@
|
|||
(= (#xFFFF #.(MAKE-DOUBLE-FLOAT #x40EFFFE0 #x0)) T)
|
||||
(= (#x1FFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL)
|
||||
(= (#x1FFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
|
||||
(= (#x1FFFFFFF #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) T)
|
||||
(= (#x20000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
|
||||
(= (#x20000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
|
||||
(= (#x3F800000 #.(MAKE-DOUBLE-FLOAT #x41CFC000 #x0)) T)
|
||||
(= (#x3FF00000 #.(MAKE-DOUBLE-FLOAT #x41CFF800 #x0)) T)
|
||||
(= (#x3FFFFFFB #.(MAKE-SINGLE-FLOAT #x31800000)) NIL)
|
||||
(= (#x7FF00000 #.(MAKE-DOUBLE-FLOAT #x41DFFC00 #x0)) T)
|
||||
(= (#x80000000 #.(MAKE-DOUBLE-FLOAT #x41E00000 #x0)) T)
|
||||
(= (#xFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x41EFFFFF #xFFE00000)) T)
|
||||
(= (#xFFFFFFFFFFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL)
|
||||
(= (#xFFFFFFFFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
|
||||
|
|
@ -3908,6 +3920,7 @@
|
|||
(COERCE (#x16 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40360000 #x0))
|
||||
(COERCE (#x19 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40390000 #x0))
|
||||
(COERCE (#x1C DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x403C0000 #x0))
|
||||
(COERCE (#x1E DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x403E0000 #x0))
|
||||
(COERCE (#x1F DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x403F0000 #x0))
|
||||
(COERCE (#x20 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40400000 #x0))
|
||||
(COERCE (#x23 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40418000 #x0))
|
||||
|
|
@ -3917,15 +3930,21 @@
|
|||
(COERCE (#x3F DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x404F8000 #x0))
|
||||
(COERCE (#x40 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40500000 #x0))
|
||||
(COERCE (#x45 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40514000 #x0))
|
||||
(COERCE (#x4A DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40528000 #x0))
|
||||
(COERCE (#x4E DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40538000 #x0))
|
||||
(COERCE (#x51 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40544000 #x0))
|
||||
(COERCE (#x60 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40580000 #x0))
|
||||
(COERCE (#x70 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x405C0000 #x0))
|
||||
(COERCE (#x80 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40600000 #x0))
|
||||
(COERCE (#x81 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40602000 #x0))
|
||||
(COERCE (#x82 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40604000 #x0))
|
||||
(COERCE (#x85 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x4060A000 #x0))
|
||||
(COERCE (#x86 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x4060C000 #x0))
|
||||
(COERCE (#x89 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40612000 #x0))
|
||||
(COERCE (#x8A DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40614000 #x0))
|
||||
(COERCE (#xC0 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x40680000 #x0))
|
||||
(COERCE (#xD2 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x406A4000 #x0))
|
||||
(COERCE (#xD6 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x406AC000 #x0))
|
||||
(COERCE (#xDA DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x406B4000 #x0))
|
||||
(COERCE (#xE0 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x406C0000 #x0))
|
||||
(COERCE (#xE1 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x406C2000 #x0))
|
||||
|
|
@ -3961,6 +3980,7 @@
|
|||
(COERCE (#x1FFFFFFF SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E000000))
|
||||
(COERCE (#x20000000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0))
|
||||
(COERCE (#x20000000 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E000000))
|
||||
(COERCE (#x3F800000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41CFC000 #x0))
|
||||
(COERCE (#x3FF00000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41CFF800 #x0))
|
||||
(COERCE (#x7FF00000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41DFFC00 #x0))
|
||||
(COERCE (#x7FFFFFFF DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41DFFFFF #xFFC00000))
|
||||
|
|
|
|||
|
|
@ -96,16 +96,18 @@
|
|||
|
||||
(defun %so-search/addr (head hash key)
|
||||
;; KEY is any object, which either has to be immobile, or else GC has to repair the table.
|
||||
(declare (list-node head) (fixnum hash))
|
||||
(macrolet ((cast-to-word (x) `(get-lisp-obj-address ,x))
|
||||
(compare (x y)
|
||||
(declare (ignore x y))
|
||||
`(let ((x (node-hash (|the| so-node this))))
|
||||
(cond ((< x hash) t)
|
||||
((= x hash)
|
||||
(< (cast-to-word (so-key (|the| so-key-node this)))
|
||||
(cast-to-word key)))))))
|
||||
(lfl-search-macro compare t)))
|
||||
(let ((head (truly-the list-node head))
|
||||
(hash (truly-the fixnum hash)))
|
||||
(macrolet ((cast-to-word (x)
|
||||
`(get-lisp-obj-address ,x))
|
||||
(compare (x y)
|
||||
(declare (ignore x y))
|
||||
`(let ((x (node-hash (|the| so-node this))))
|
||||
(cond ((< x hash) t)
|
||||
((= x hash)
|
||||
(< (cast-to-word (so-key (|the| so-key-node this)))
|
||||
(cast-to-word key)))))))
|
||||
(lfl-search-macro compare t))))
|
||||
|
||||
(defun %so-search/string (head hash key)
|
||||
(declare (list-node head) (fixnum hash) (string key))
|
||||
|
|
@ -188,8 +190,9 @@
|
|||
)
|
||||
|
||||
(declaim (inline masked-hash))
|
||||
(defun masked-hash (hash) (mask-field (byte (1- +hash-nbits+) 1) hash))
|
||||
|
||||
;;(defun masked-hash (hash) (mask-field (byte (1- +hash-nbits+) 1) hash))
|
||||
;; HASH *must* be non-negative. We don't mask out the sign bit any more.
|
||||
(defun masked-hash (hash) (logior hash 1))
|
||||
(defmacro with-bin ((table-var ; input
|
||||
hash-var node-var &rest rest) ; output
|
||||
hash-expr &body body)
|
||||
|
|
@ -296,6 +299,24 @@
|
|||
(atomic-decf (so-count table)))
|
||||
deleted)))
|
||||
|
||||
(defmacro multiplicative-hash (x)
|
||||
;; Use Knuth's hash multiplier of 2^32 * (-1 + sqrt(5)) / 2.
|
||||
;; This constant works quite well for our variant of the solist algorithm
|
||||
;; which consumes hash bits from most-significant to least-significant.
|
||||
;; Note that most descriptions of this require a right-shift, but here it's
|
||||
;; exactly the correct answer by itself because the solist algorithm consumes
|
||||
;; bits from left-to-right (most-to-least-significant).
|
||||
#-64-bit
|
||||
`(ash (logand (* ,x 2654435769) sb-ext:most-positive-word)
|
||||
,(- (1+ sb-vm:n-fixnum-tag-bits))) ; Ensure a positive fixnum result
|
||||
;; Same thing but with 64 bits of precision. I used MPFR to compute this
|
||||
;; (also https://asecuritysite.com/hash/smh_fib gives the same number).
|
||||
;; The number 11400714819323198486 is slightly more correct, but an odd multiplier
|
||||
;; is better than even, otherwise the rightmost result bit would be always 0.
|
||||
#+64-bit
|
||||
`(ash (logand (* ,x 11400714819323198485) sb-ext:most-positive-word)
|
||||
,(- (1+ sb-vm:n-fixnum-tag-bits))))
|
||||
|
||||
(macrolet ((guts (key-hash searcher equality-fn)
|
||||
`(with-bin (table hash start-node) ,key-hash
|
||||
(let ((node (,searcher start-node (logior hash 1) key)))
|
||||
|
|
@ -309,7 +330,8 @@
|
|||
(guts (murmur-hash-word/fixnum key) %so-search/fixnum =))
|
||||
(defun so-find/addr (table key)
|
||||
(declare (split-ordered-list table))
|
||||
(guts (funcall (so-hashfun table) key) %so-search/addr eq))
|
||||
(let ((h (multiplicative-hash (get-lisp-obj-address key))))
|
||||
(guts h %so-search/addr eq)))
|
||||
(defun so-find/string (table key)
|
||||
(declare (split-ordered-list table))
|
||||
(declare (string key))
|
||||
|
|
@ -345,7 +367,7 @@
|
|||
(setq node next))))))
|
||||
|
||||
(flet ((make (valuesp)
|
||||
(%make-so-list #'murmur-hash-word/fixnum
|
||||
(%make-so-list #'murmur-hash-word/+fixnum
|
||||
#'%so-insert/fixnum
|
||||
#'%so-delete/fixnum
|
||||
#'so-find/fixnum
|
||||
|
|
@ -363,7 +385,7 @@
|
|||
(defun make-so-map/string () (make t)))
|
||||
|
||||
(flet ((make (valuesp)
|
||||
(%make-so-list (lambda (x) (murmur-hash-word/+fixnum (get-lisp-obj-address x)))
|
||||
(%make-so-list (lambda (x) (multiplicative-hash (get-lisp-obj-address x)))
|
||||
#'%so-insert/addr #'%so-delete/addr #'so-find/addr
|
||||
#'nofun #'nofun valuesp)))
|
||||
(defun make-so-set/addr () (make nil))
|
||||
|
|
|
|||
Loading…
Reference in a new issue