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