mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
113 lines
5 KiB
Common Lisp
113 lines
5 KiB
Common Lisp
;;;; Tests of the hashtable routines used by gencgc
|
|
|
|
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
;;; All these tests have to be in without-gcing because the GC expects
|
|
;;; exclusive use of the "cached" memory allocator.
|
|
;;; Were it not for that, these tests would have nothing to do with GC.
|
|
|
|
(defun new-hh-table (bytes-per-value)
|
|
(let ((ht (sb-alien::%make-alien 100))) ; overestimate the C structure size
|
|
(sb-sys:without-gcing
|
|
(alien-funcall (extern-alien "hopscotch_create"
|
|
(function void system-area-pointer int int int int))
|
|
ht
|
|
1 ; default hash function
|
|
bytes-per-value
|
|
32 ; size
|
|
8)) ; hop range
|
|
ht))
|
|
|
|
(defun hhinsert (table key value)
|
|
(sb-sys:without-gcing
|
|
(alien-funcall (extern-alien "hopscotch_insert"
|
|
(function int system-area-pointer int unsigned))
|
|
table
|
|
(the fixnum key)
|
|
(sb-kernel:get-lisp-obj-address
|
|
(the (or fixnum character) value)))))
|
|
|
|
(defun hhget (table key)
|
|
;; GET doesn't need to inhibit GC
|
|
(let ((result
|
|
(alien-funcall (extern-alien "hopscotch_get"
|
|
(function long system-area-pointer unsigned long))
|
|
table
|
|
(the fixnum key)
|
|
-1)))
|
|
(unless (eql result -1)
|
|
(sb-kernel:make-lisp-obj
|
|
(logand result sb-ext:most-positive-word)))))
|
|
|
|
(defun fill-table (table n-things value-bits)
|
|
(let ((lisp-ht (make-hash-table :test 'eq))
|
|
;; Don't feel like dealing with signed-ness.
|
|
(max-value (ash 1 (- value-bits 1 sb-vm:n-fixnum-tag-bits)))) ; exclusive bound
|
|
(dotimes (i n-things)
|
|
;; Pick a random small integer key, but don't pick the empty marker (0).
|
|
;; Also shift left left by N-LOWTAG-BITS, because the hash function
|
|
;; is optimized specifically for object addresses.
|
|
;; In particular it discards that many bits from the hash, and the table
|
|
;; is unable to handle collisions to such a degree that the max hop
|
|
;; is exceeded. Resize will keep happening until mmap() fails.
|
|
;; This is not something worth "fixing" unless someone reports a real
|
|
;; problem. GC is much faster with a dumb hash but fast table.
|
|
(let ((k (ash (max 1 (random (ash 1 20))) sb-vm:n-lowtag-bits))
|
|
(v (random max-value)))
|
|
;; The C code can't deal with a key already present
|
|
(loop while (gethash k lisp-ht)
|
|
do (setq k (max 1 (random (ash 1 20)))))
|
|
(setf (gethash k lisp-ht) v)
|
|
(hhinsert table k v)))
|
|
(maphash (lambda (k v)
|
|
(assert (eq (hhget table k) v)))
|
|
lisp-ht)
|
|
lisp-ht))
|
|
|
|
(defun randomly-bang-on-table (sizeof-value &optional (n-iter 10))
|
|
(setq *random-state* (sb-ext:seed-random-state t))
|
|
(dotimes (i n-iter)
|
|
(let ((c-table (new-hh-table sizeof-value))
|
|
(sizes-list '(10 20 50 100 1000
|
|
2000 5000 10000 15000 20000
|
|
99999)))
|
|
;; The table has a heuristic for selecting a hop range
|
|
;; and resizing based on the size at last reset.
|
|
;; Make sure these work with the table count
|
|
;; not strictly increasing on each test.
|
|
(loop for n-items in (test-util:shuffle sizes-list)
|
|
do
|
|
; (format t "~&Filling table with ~D things" n-items)
|
|
(alien-funcall (extern-alien "hopscotch_reset"
|
|
(function void system-area-pointer))
|
|
c-table)
|
|
(let ((lisp-table (fill-table c-table n-items (* 8 sizeof-value))))
|
|
;; We already checked that everything that should be found
|
|
;; in both is found. Also check that things that should not
|
|
;; be found are not found.
|
|
;; This also acts to increase the miss rate when gathering stats.
|
|
(loop for i from 1 to (ash 1 15)
|
|
do (assert (eq (hhget c-table i)
|
|
(gethash i lisp-table))))
|
|
;; If statistics collection is enabled, show the performance
|
|
(alien-funcall (extern-alien "hopscotch_log_stats"
|
|
(function void system-area-pointer))
|
|
c-table)))
|
|
(alien-funcall (extern-alien "hopscotch_destroy"
|
|
(function void system-area-pointer))
|
|
c-table))))
|
|
|
|
(with-test (:name :hopscotch-hash)
|
|
;; Try for values[] array being int16 and int32
|
|
(dolist (sizeof-value '(2 4))
|
|
(randomly-bang-on-table sizeof-value 1)))
|