src/code/hash-table.lisp

   1 ;;;; the needed-on-the-cross-compilation-host part of HASH-TABLE
   2 ;;;; implementation
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!IMPL")
  14
  15 (file-comment
  16   "$Header$")
  17
  18 ;;; an internal tag for marking empty slots
  19 ;;;
  20 ;;; CMU CL 18b used :EMPTY for this purpose, which was somewhat nasty
  21 ;;; since it's easily accessible to the user, so that e.g.
  22 ;;;     (DEFVAR *HT* (MAKE-HASH-TABLE))
  23 ;;;     (SETF (GETHASH :EMPTY *HT*) :EMPTY)
  24 ;;;     (MAPHASH (LAMBDA (K V) (FORMAT T "~&~S ~S~%" K V)))
  25 ;;; gives no output -- oops!
  26 ;;;
  27 ;;; Note that as of version 0.6.6 there's a dependence in the gencgc.c
  28 ;;; code on this value being a symbol. (This is only one of many nasty
  29 ;;; dependencies between that code and this, alas.)
  30 (defconstant +empty-ht-slot+ '%empty-ht-slot%)
  31 ;;; KLUDGE: Using a private symbol still leaves us vulnerable to users
  32 ;;; getting nonconforming behavior by messing around with
  33 ;;; DO-ALL-SYMBOLS. That seems like a fairly obscure problem, so for
  34 ;;; now we just don't worry about it. If for some reason it becomes
  35 ;;; worrisome and the magic value needs replacement:
  36 ;;;   * The replacement value needs to be LOADable with EQL preserved,
  37 ;;;     so that macroexpansion for WITH-HASH-TABLE-ITERATOR will work
  38 ;;;     when compiled into a file and loaded back into SBCL.
  39 ;;;     (Thus, just uninterning %EMPTY-HT-SLOT% doesn't work.)
  40 ;;;   * The replacement value needs to be acceptable to the
  41 ;;;     low-level gencgc.lisp hash table scavenging code.
  42 ;;;   * The change will break binary compatibility, since comparisons
  43 ;;;     against the value used at the time of compilation are wired
  44 ;;;     into FASL files.
  45 ;;; -- WHN 20000622
  46
  47 ;;; HASH-TABLE is implemented as a STRUCTURE-OBJECT.
  48 (sb!xc:defstruct (hash-table (:constructor %make-hash-table))
  49   ;; The type of hash table this is. Only used for printing and as part of
  50   ;; the exported interface.
  51   (test (required-argument) :type symbol :read-only t)
  52   ;; The function used to compare two keys. Returns T if they are the same
  53   ;; and NIL if not.
  54   (test-fun (required-argument) :type function :read-only t)
  55   ;; The function used to compute the hashing of a key. Returns two values:
  56   ;; the index hashing and T if that might change with the next GC.
  57   (hash-fun (required-argument) :type function :read-only t)
  58   ;; How much to grow the hash table by when it fills up. If an index, then
  59   ;; add that amount. If a floating point number, then multiple it by that.
  60   (rehash-size (required-argument) :type (or index (single-float (1.0)))
  61                :read-only t)
  62   ;; How full the hash table has to get before we rehash.
  63   (rehash-threshold (required-argument) :type (single-float (0.0) 1.0)
  64                     :read-only t)
  65   ;; The number of entries before a rehash, just the one less than the
  66   ;; size of the next-vector, hash-vector, and half the size of the
  67   ;; kv-vector.
  68   (rehash-trigger (required-argument) :type index)
  69   ;; The current number of entries in the table.
  70   (number-entries 0 :type index)
  71   ;; The Key-Value pair vector.
  72   (table (required-argument) :type simple-vector)
  73   ;; True if this is a weak hash table, meaning that key->value mappings will
  74   ;; disappear if there are no other references to the key. Note: this only
  75   ;; matters if the hash function indicates that the hashing is EQ based.
  76   (weak-p nil :type (member t nil))
  77   ;; Index into the next-vector, chaining together buckets that need
  78   ;; to be rehashed because their hashing is EQ based and the key has
  79   ;; been moved by the garbage collector.
  80   (needing-rehash 0 :type index)
  81   ;; Index into the Next vector chaining together free slots in the KV
  82   ;; vector.
  83   (next-free-kv 0 :type index)
  84   ;; The index vector. This may be larger than the hash size to help
  85   ;; reduce collisions.
  86   (index-vector (required-argument)
  87                 :type (simple-array (unsigned-byte 32) (*)))
  88   ;; This table parallels the KV vector, and is used to chain together
  89   ;; the hash buckets, the free list, and the values needing rehash, a
  90   ;; slot will only ever be in one of these lists.
  91   (next-vector (required-argument) :type (simple-array (unsigned-byte 32) (*)))
  92   ;; This table parallels the KV table, and can be used to store the
  93   ;; hash associated with the key, saving recalculation. Could be
  94   ;; useful for EQL, and EQUAL hash tables. This table is not needed
  95   ;; for EQ hash tables, and when present the value of #x8000000
  96   ;; represents EQ-based hashing on the respective Key.
  97   (hash-vector nil :type (or null (simple-array (unsigned-byte 32) (*)))))
  98 \f
  99 (defmacro-mundanely with-hash-table-iterator ((function hash-table) &body body)
 100   #!+sb-doc
 101   "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
 102    provides a method of manually looping over the elements of a hash-table.
 103    FUNCTION is bound to a generator-macro that, within the scope of the
 104    invocation, returns one or three values. The first value tells whether
 105    any objects remain in the hash table. When the first value is non-NIL,
 106    the second and third values are the key and the value of the next object."
 107   (let ((n-function (gensym "WITH-HASH-TABLE-ITERATOR-")))
 108     `(let ((,n-function
 109             (let* ((table ,hash-table)
 110                    (length (length (hash-table-next-vector table)))
 111                    (index 1))
 112               (declare (type (mod #.(floor most-positive-fixnum 2)) index))
 113               (labels
 114                   ((,function ()
 115                      ;; (We grab the table again on each iteration just in
 116                      ;; case it was rehashed by a PUTHASH.)
 117                      (let ((kv-vector (hash-table-table table)))
 118                        (do ()
 119                            ((>= index length) (values nil))
 120                          (let ((key (aref kv-vector (* 2 index)))
 121                                (value (aref kv-vector (1+ (* 2 index)))))
 122                            (incf index)
 123                            (unless (and (eq key '#.+empty-ht-slot+)
 124                                         (eq value '#.+empty-ht-slot+))
 125                              (return (values t key value))))))))
 126                 #',function))))
 127       (macrolet ((,function () '(funcall ,n-function)))
 128         ,@body))))