1 ;;;; Tests of the hashtable routines used by gencgc
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 ;;; All these tests have to be in without-gcing because the GC expects
15 ;;; exclusive use of the "cached" memory allocator.
16 ;;; Were it not for that, these tests would have nothing to do with GC.
18 (defun new-hh-table ()
19 (let ((ht (sb-alien::%make-alien
100))) ; overestimate the C structure size
21 (alien-funcall (extern-alien "hopscotch_create"
22 (function void system-area-pointer int int int
))
29 (defun hhput (table key value
)
31 (alien-funcall (extern-alien "hopscotch_put"
32 (function int system-area-pointer int unsigned
))
35 (sb-kernel:get-lisp-obj-address
36 (the (or fixnum character
) value
)))))
38 (defun hhget (table key
)
39 ;; GET doesn't need to inhibit GC
41 (alien-funcall (extern-alien "hopscotch_get"
42 (function int system-area-pointer unsigned
))
45 (unless (eql result -
1)
46 (sb-kernel:make-lisp-obj
47 (logand result sb-ext
:most-positive-word
)))))
49 (defun fill-table (table n-things
)
50 (let ((lisp-ht (make-hash-table :test
'eq
)))
52 ;; Pick a random small integer key, but don't pick the empty marker (0).
53 ;; Also shift left left by N-LOWTAG-BITS, because the hash function
54 ;; is optimized specifically for object addresses.
55 ;; In particular it discards that many bits from the hash, and the table
56 ;; is unable to handle collisions to such a degree that the max hop
57 ;; is exceeded. Resize will keep happening until mmap() fails.
58 ;; This is not something worth "fixing" unless someone reports a real
59 ;; problem. GC is much faster with a dumb hash but fast table.
60 (let ((k (ash (max 1 (random (ash 1 20))) sb-vm
:n-lowtag-bits
))
61 (v (random (ash 1 29))))
62 ;; The C code can't deal with a key already present
63 (loop while
(gethash k lisp-ht
)
64 do
(setq k
(max 1 (random (ash 1 20)))))
65 (setf (gethash k lisp-ht
) v
)
67 (maphash (lambda (k v
)
68 (assert (eq (hhget table k
) v
)))
72 (defun randomly-bang-on-table (&optional
(n-iter 10))
73 (setq *random-state
* (sb-ext:seed-random-state t
))
75 (let ((c-table (new-hh-table))
76 (sizes-list '(10 20 50 100 1000
77 2000 5000 10000 15000 20000
79 ;; The table has a heuristic for selecting a hop range
80 ;; and resizing based on the size at last reset.
81 ;; Make sure these work with the table count
82 ;; not strictly increasing on each test.
83 (loop for n-items in
(test-util:shuffle sizes-list
)
85 ; (format t "~&Filling table with ~D things" n-items)
86 (alien-funcall (extern-alien "hopscotch_reset"
87 (function void system-area-pointer
))
89 (let ((lisp-table (fill-table c-table n-items
)))
90 ;; We already checked that everything that should be found
91 ;; in both is found. Also check that things that should not
92 ;; be found are not found.
93 ;; This also acts to increase the miss rate when gathering stats.
94 (loop for i from
1 to
(ash 1 15)
95 do
(assert (eq (hhget c-table i
)
96 (gethash i lisp-table
))))
97 ;; If statistics collection is enabled, show the performance
98 (alien-funcall (extern-alien "hopscotch_log_stats"
99 (function void system-area-pointer
))
101 (alien-funcall (extern-alien "hopscotch_delete"
102 (function void system-area-pointer
))
105 (with-test (:name
:hopscotch-hash
)
106 (randomly-bang-on-table 1))