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 ()
  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                        1 ; values
  25                        32 ; size
  26                        8)) ; hop range
  27     ht))
  28
  29 (defun hhput (table key value)
  30   (sb-sys:without-gcing
  31       (alien-funcall (extern-alien "hopscotch_put"
  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 int 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)
  50   (let ((lisp-ht (make-hash-table :test 'eq)))
  51     (dotimes (i n-things)
  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)
  66         (hhput table k v)))
  67     (maphash (lambda (k v)
  68                (assert (eq (hhget table k) v)))
  69              lisp-ht)
  70     lisp-ht))
  71
  72 (defun randomly-bang-on-table (&optional (n-iter 10))
  73   (setq *random-state* (sb-ext:seed-random-state t))
  74   (dotimes (i n-iter)
  75     (let ((c-table (new-hh-table))
  76           (sizes-list '(10 20 50 100 1000
  77                         2000 5000 10000 15000 20000
  78                         99999)))
  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)
  84             do
  85          ; (format t "~&Filling table with ~D things" n-items)
  86          (alien-funcall (extern-alien "hopscotch_reset"
  87                                       (function void system-area-pointer))
  88                         c-table)
  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))
 100                           c-table)))
 101       (alien-funcall (extern-alien "hopscotch_delete"
 102                                    (function void system-area-pointer))
 103                      c-table))))
 104
 105 (with-test (:name :hopscotch-hash)
 106   (randomly-bang-on-table 1))