tests/hopscotch.impure-cload.lisp

   1 ;;;; Tests of the hashtable routines used by gencgc
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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
   8 ;;;; from CMU CL.
   9 ;;;;
  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.
  13
  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.
  17
  18 (defun new-hh-table (bytes-per-value)
  19   (let ((ht (sb-alien::%make-alien 100))) ; overestimate the C structure size
  20     (sb-sys:without-gcing
  21         (alien-funcall (extern-alien "hopscotch_create"
  22                                      (function void system-area-pointer int int int int))
  23                        ht
  24                        1 ; default hash function
  25                        bytes-per-value
  26                        32 ; size
  27                        8)) ; hop range
  28     ht))
  29
  30 (defun hhinsert (table key value)
  31   (sb-sys:without-gcing
  32       (alien-funcall (extern-alien "hopscotch_insert"
  33                                    (function int system-area-pointer int unsigned))
  34                      table
  35                      (the fixnum key)
  36                      (sb-kernel:get-lisp-obj-address
  37                       (the (or fixnum character) value)))))
  38
  39 (defun hhget (table key)
  40   ;; GET doesn't need to inhibit GC
  41   (let ((result
  42          (alien-funcall (extern-alien "hopscotch_get"
  43                                       (function long system-area-pointer unsigned long))
  44                         table
  45                         (the fixnum key)
  46                         -1)))
  47     (unless (eql result -1)
  48       (sb-kernel:make-lisp-obj
  49        (logand result sb-ext:most-positive-word)))))
  50
  51 (defun fill-table (table n-things value-bits)
  52   (let ((lisp-ht (make-hash-table :test 'eq))
  53         ;; Don't feel like dealing with signed-ness.
  54         (max-value (ash 1 (- value-bits 1 sb-vm:n-fixnum-tag-bits)))) ; exclusive bound
  55     (dotimes (i n-things)
  56       ;; Pick a random small integer key, but don't pick the empty marker (0).
  57       ;; Also shift left left by N-LOWTAG-BITS, because the hash function
  58       ;; is optimized specifically for object addresses.
  59       ;; In particular it discards that many bits from the hash, and the table
  60       ;; is unable to handle collisions to such a degree that the max hop
  61       ;; is exceeded. Resize will keep happening until mmap() fails.
  62       ;; This is not something worth "fixing" unless someone reports a real
  63       ;; problem.  GC is much faster with a dumb hash but fast table.
  64       (let ((k (ash (max 1 (random (ash 1 20))) sb-vm:n-lowtag-bits))
  65             (v (random max-value)))
  66         ;; The C code can't deal with a key already present
  67         (loop while (gethash k lisp-ht)
  68               do (setq k (max 1 (random (ash 1 20)))))
  69         (setf (gethash k lisp-ht) v)
  70         (hhinsert table k v)))
  71     (maphash (lambda (k v)
  72                (assert (eq (hhget table k) v)))
  73              lisp-ht)
  74     lisp-ht))
  75
  76 (defun randomly-bang-on-table (sizeof-value &optional (n-iter 10))
  77   (setq *random-state* (sb-ext:seed-random-state t))
  78   (dotimes (i n-iter)
  79     (let ((c-table (new-hh-table sizeof-value))
  80           (sizes-list '(10 20 50 100 1000
  81                         2000 5000 10000 15000 20000
  82                         99999)))
  83       ;; The table has a heuristic for selecting a hop range
  84       ;; and resizing based on the size at last reset.
  85       ;; Make sure these work with the table count
  86       ;; not strictly increasing on each test.
  87       (loop for n-items in (test-util:shuffle sizes-list)
  88             do
  89          ; (format t "~&Filling table with ~D things" n-items)
  90          (alien-funcall (extern-alien "hopscotch_reset"
  91                                       (function void system-area-pointer))
  92                         c-table)
  93          (let ((lisp-table (fill-table c-table n-items (* 8 sizeof-value))))
  94            ;; We already checked that everything that should be found
  95            ;; in both is found. Also check that things that should not
  96            ;; be found are not found.
  97            ;; This also acts to increase the miss rate when gathering stats.
  98            (loop for i from 1 to (ash 1 15)
  99                  do (assert (eq (hhget c-table i)
 100                                 (gethash i lisp-table))))
 101            ;; If statistics collection is enabled, show the performance
 102            (alien-funcall (extern-alien "hopscotch_log_stats"
 103                                         (function void system-area-pointer))
 104                           c-table)))
 105       (alien-funcall (extern-alien "hopscotch_destroy"
 106                                    (function void system-area-pointer))
 107                      c-table))))
 108
 109 (with-test (:name :hopscotch-hash)
 110   ;; Try for values[] array being int16 and int32
 111   (dolist (sizeof-value '(2 4))
 112     (randomly-bang-on-table sizeof-value 1)))