src/code/target-hash-table.lisp

   1 ;;;; that part of the implementation of HASH-TABLE which lives solely
   2 ;;;; on the target system, not on the cross-compilation host
   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 \f
  15 ;;;; utilities
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (defconstant max-hash sb!xc:most-positive-fixnum))
  19
  20 ;;; Code for detecting concurrent accesses to the same table from
  21 ;;; multiple threads. Only compiled in when the :SB-HASH-TABLE-DEBUG
  22 ;;; feature is enabled. The main reason for the existence of this code
  23 ;;; is to detect thread-unsafe uses of hash-tables in sbcl itself,
  24 ;;; where debugging anythign can be impossible after an important
  25 ;;; internal hash-table has been corrupted. It's plausible that this
  26 ;;; could be useful for some user code too, but the runtime cost is
  27 ;;; really too high to enable it by default.
  28 (defmacro with-concurrent-access-check (hash-table &body body)
  29   (declare (ignorable hash-table))
  30   #!-sb-hash-table-debug
  31   `(progn ,@body)
  32   #!+sb-hash-table-debug
  33   (once-only ((hash-table hash-table))
  34     `(progn
  35        (flet ((body-fun ()
  36                 ,@body)
  37               (error-fun ()
  38                 ;; Don't signal more errors for this table.
  39                 (setf (hash-table-concurrent-access-error ,hash-table) nil)
  40                 (error "Concurrent access to ~A" ,hash-table)))
  41          (if (hash-table-concurrent-access-error ,hash-table)
  42              (let ((thread (hash-table-accessing-thread ,hash-table)))
  43                (unwind-protect
  44                     (progn
  45                       (when (and thread
  46                                  (not (eql thread sb!thread::*current-thread*)))
  47                         (error-fun))
  48                       (setf (hash-table-accessing-thread ,hash-table)
  49                             sb!thread::*current-thread*)
  50                       (body-fun))
  51                  (unless (eql (hash-table-accessing-thread ,hash-table)
  52                               sb!thread::*current-thread*)
  53                    (error-fun))
  54                  (setf (hash-table-accessing-thread ,hash-table) thread)))
  55              (body-fun))))))
  56
  57 (deftype hash ()
  58   `(integer 0 ,max-hash))
  59
  60 ;;; FIXME: Does this always make a nonnegative FIXNUM? If so, then
  61 ;;; explain why. If not (or if the reason it always makes a
  62 ;;; nonnegative FIXNUM is only the accident that pointers in supported
  63 ;;; architectures happen to be in the lower half of the address
  64 ;;; space), then fix it.
  65 #!-sb-fluid (declaim (inline pointer-hash))
  66 (defun pointer-hash (key)
  67   (declare (values hash))
  68   (truly-the hash (%primitive sb!c:make-fixnum key)))
  69
  70 #!-sb-fluid (declaim (inline eq-hash))
  71 (defun eq-hash (key)
  72   (declare (values hash (member t nil)))
  73   (values (pointer-hash key)
  74           (oddp (get-lisp-obj-address key))))
  75
  76 #!-sb-fluid (declaim (inline equal-hash))
  77 (defun equal-hash (key)
  78   (declare (values hash (member t nil)))
  79   (typecase key
  80     ;; For some types the definition of EQUAL implies a special hash
  81     ((or string cons number bit-vector pathname)
  82      (values (sxhash key) nil))
  83     ;; Otherwise use an EQ hash, rather than SXHASH, since the values
  84     ;; of SXHASH will be extremely badly distributed due to the
  85     ;; requirements of the spec fitting badly with our implementation
  86     ;; strategy.
  87     (t
  88      (eq-hash key))))
  89
  90 #!-sb-fluid (declaim (inline eql-hash))
  91 (defun eql-hash (key)
  92   (declare (values hash (member t nil)))
  93   (if (numberp key)
  94       (equal-hash key)
  95       (eq-hash key)))
  96
  97 (defun equalp-hash (key)
  98   (declare (values hash (member t nil)))
  99   (typecase key
 100     ;; Types requiring special treatment. Note that PATHNAME and
 101     ;; HASH-TABLE are caught by the STRUCTURE-OBJECT test.
 102     ((or array cons number character structure-object)
 103      (values (psxhash key) nil))
 104     (t
 105      (eq-hash key))))
 106
 107 (defun ceil-power-of-two (num)
 108   (declare (type index num))
 109   (ash 1 (integer-length num)))
 110
 111 (declaim (inline index-for-hashing))
 112 (defun index-for-hashing (index length)
 113   (declare (type index index length))
 114   ;; We're using power of two tables which obviously are very
 115   ;; sensitive to the exact values of the low bits in the hash
 116   ;; value. Do a little shuffling of the value to mix the high bits in
 117   ;; there too.
 118   (logand (1- length)
 119           (+ (logxor #b11100101010001011010100111
 120                      index)
 121              (ash index -6)
 122              (ash index -15)
 123              (ash index -23))))
 124
 125 \f
 126 ;;;; user-defined hash table tests
 127
 128 (defvar *hash-table-tests* nil)
 129
 130 (defun define-hash-table-test (name test-fun hash-fun)
 131   #!+sb-doc
 132   "Define a new kind of hash table test."
 133   (declare (type symbol name)
 134            (type function test-fun hash-fun))
 135   (setf *hash-table-tests*
 136         (cons (list name test-fun hash-fun)
 137               (remove name *hash-table-tests* :test #'eq :key #'car)))
 138   name)
 139 \f
 140 ;;;; construction and simple accessors
 141
 142 (defconstant +min-hash-table-size+ 16)
 143 (defconstant +min-hash-table-rehash-threshold+ (float 1/16 1.0))
 144
 145 (defun make-hash-table (&key (test 'eql)
 146                         (size +min-hash-table-size+)
 147                         (rehash-size 1.5)
 148                         (rehash-threshold 1)
 149                         (weakness nil)
 150                         (synchronized))
 151   #!+sb-doc
 152   "Create and return a new hash table. The keywords are as follows:
 153      :TEST -- Indicates what kind of test to use.
 154      :SIZE -- A hint as to how many elements will be put in this hash
 155        table.
 156      :REHASH-SIZE -- Indicates how to expand the table when it fills up.
 157        If an integer, add space for that many elements. If a floating
 158        point number (which must be greater than 1.0), multiply the size
 159        by that amount.
 160      :REHASH-THRESHOLD -- Indicates how dense the table can become before
 161        forcing a rehash. Can be any positive number <=1, with density
 162        approaching zero as the threshold approaches 0. Density 1 means an
 163        average of one entry per bucket.
 164      :WEAKNESS -- If NIL (the default) it is a normal non-weak hash table.
 165        If one of :KEY, :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE it is a weak
 166        hash table.
 167        Depending on the type of weakness the lack of references to the
 168        key and the value may allow for removal of the entry. If WEAKNESS
 169        is :KEY and the key would otherwise be garbage the entry is eligible
 170        for removal from the hash table. Similarly, if WEAKNESS is :VALUE
 171        the life of an entry depends on its value's references. If WEAKNESS
 172        is :KEY-AND-VALUE and either the key or the value would otherwise be
 173        garbage the entry can be removed. If WEAKNESS is :KEY-OR-VALUE and
 174        both the key and the value would otherwise be garbage the entry can
 175        be removed.
 176      :SYNCHRONIZED -- If NIL (the default), the hash-table may have
 177        multiple concurrent readers, but results are undefined if a
 178        thread writes to the hash-table concurrently with another
 179        reader or writer. If T, all concurrent accesses are safe, but
 180        note that CLHS 3.6 (Traversal Rules and Side Effects) remains
 181        in force. See also: SB-EXT:WITH-LOCKED-HASH-TABLE. This keyword
 182        argument is experimental, and may change incompatibly or be
 183        removed in the future."
 184   (declare (type (or function symbol) test))
 185   (declare (type unsigned-byte size))
 186   (multiple-value-bind (test test-fun hash-fun)
 187       (cond ((or (eq test #'eq) (eq test 'eq))
 188              (values 'eq #'eq #'eq-hash))
 189             ((or (eq test #'eql) (eq test 'eql))
 190              (values 'eql #'eql #'eql-hash))
 191             ((or (eq test #'equal) (eq test 'equal))
 192              (values 'equal #'equal #'equal-hash))
 193             ((or (eq test #'equalp) (eq test 'equalp))
 194              (values 'equalp #'equalp #'equalp-hash))
 195             (t
 196              ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff.
 197              ;; Failing that, I'd like to rename it to
 198              ;; *USER-HASH-TABLE-TESTS*.
 199              (dolist (info *hash-table-tests*
 200                       (error "unknown :TEST for MAKE-HASH-TABLE: ~S"
 201                              test))
 202                (destructuring-bind (test-name test-fun hash-fun) info
 203                  (when (or (eq test test-name) (eq test test-fun))
 204                    (return (values test-name test-fun hash-fun)))))))
 205     (let* ((size (max +min-hash-table-size+
 206                       (min size
 207                            ;; SIZE is just a hint, so if the user asks
 208                            ;; for a SIZE which'd be too big for us to
 209                            ;; easily implement, we bump it down.
 210                            (floor array-dimension-limit 1024))))
 211            (rehash-size (if (integerp rehash-size)
 212                             rehash-size
 213                             (float rehash-size 1.0)))
 214            ;; FIXME: Original REHASH-THRESHOLD default should be 1.0,
 215            ;; not 1, to make it easier for the compiler to avoid
 216            ;; boxing.
 217            (rehash-threshold (max +min-hash-table-rehash-threshold+
 218                                   (float rehash-threshold 1.0)))
 219            (size+1 (1+ size))       ; The first element is not usable.
 220            ;; KLUDGE: The most natural way of expressing the below is
 221            ;; (round (/ (float size+1) rehash-threshold)), and indeed
 222            ;; it was expressed like that until 0.7.0. However,
 223            ;; MAKE-HASH-TABLE is called very early in cold-init, and
 224            ;; the SPARC has no primitive instructions for rounding,
 225            ;; but only for truncating; therefore, we fudge this issue
 226            ;; a little. The other uses of truncate, below, similarly
 227            ;; used to be round. -- CSR, 2002-10-01
 228            ;;
 229            ;; Note that this has not yet been audited for
 230            ;; correctness. It just seems to work. -- CSR, 2002-11-02
 231            (scaled-size (truncate (/ (float size+1) rehash-threshold)))
 232            (length (ceil-power-of-two (max scaled-size
 233                                            (1+ +min-hash-table-size+))))
 234            (index-vector (make-array length
 235                                      :element-type
 236                                      '(unsigned-byte #.sb!vm:n-word-bits)
 237                                      :initial-element 0))
 238            ;; Needs to be the half the length of the KV vector to link
 239            ;; KV entries - mapped to indeces at 2i and 2i+1 -
 240            ;; together.
 241            (next-vector (make-array size+1
 242                                     :element-type
 243                                     '(unsigned-byte #.sb!vm:n-word-bits)))
 244            (kv-vector (make-array (* 2 size+1)
 245                                   :initial-element +empty-ht-slot+))
 246            (table (%make-hash-table
 247                    :test test
 248                    :test-fun test-fun
 249                    :hash-fun hash-fun
 250                    :rehash-size rehash-size
 251                    :rehash-threshold rehash-threshold
 252                    :rehash-trigger size
 253                    :table kv-vector
 254                    :weakness weakness
 255                    :index-vector index-vector
 256                    :next-vector next-vector
 257                    :hash-vector
 258                    (unless (eq test 'eq)
 259                      (make-array size+1
 260                                  :element-type '(unsigned-byte
 261                                                  #.sb!vm:n-word-bits)
 262                                  :initial-element +magic-hash-vector-value+))
 263                    :synchronized-p synchronized)))
 264       (declare (type index size+1 scaled-size length))
 265       ;; Set up the free list, all free. These lists are 0 terminated.
 266       (do ((i 1 (1+ i)))
 267           ((>= i size))
 268         (setf (aref next-vector i) (1+ i)))
 269       (setf (aref next-vector size) 0)
 270       (setf (hash-table-next-free-kv table) 1)
 271       (setf (aref kv-vector 0) table)
 272       table)))
 273
 274 (defun hash-table-count (hash-table)
 275   #!+sb-doc
 276   "Return the number of entries in the given HASH-TABLE."
 277   (declare (type hash-table hash-table)
 278            (values index))
 279   (hash-table-number-entries hash-table))
 280
 281 #!+sb-doc
 282 (setf (fdocumentation 'hash-table-rehash-size 'function)
 283       "Return the rehash-size HASH-TABLE was created with.")
 284
 285 #!+sb-doc
 286 (setf (fdocumentation 'hash-table-rehash-threshold 'function)
 287       "Return the rehash-threshold HASH-TABLE was created with.")
 288
 289 (defun hash-table-size (hash-table)
 290   #!+sb-doc
 291   "Return a size that can be used with MAKE-HASH-TABLE to create a hash
 292    table that can hold however many entries HASH-TABLE can hold without
 293    having to be grown."
 294   (hash-table-rehash-trigger hash-table))
 295
 296 #!+sb-doc
 297 (setf (fdocumentation 'hash-table-test 'function)
 298       "Return the test HASH-TABLE was created with.")
 299
 300 #!+sb-doc
 301 (setf (fdocumentation 'hash-table-weakness 'function)
 302       "Return the WEAKNESS of HASH-TABLE which is one of NIL, :KEY,
 303 :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE.")
 304
 305 ;;; Called when we detect circular chains in a hash-table.
 306 (defun signal-corrupt-hash-table (hash-table)
 307   (error "Corrupt NEXT-chain in ~A. This is probably caused by ~
 308 multiple threads accessing the same hash-table without locking."
 309          hash-table))
 310
 311 \f
 312 ;;;; accessing functions
 313
 314 ;;; Make new vectors for the table, extending the table based on the
 315 ;;; rehash-size.
 316 (defun rehash (table)
 317   (declare (type hash-table table))
 318   (aver *gc-inhibit*)
 319   (let* ((old-kv-vector (hash-table-table table))
 320          (old-next-vector (hash-table-next-vector table))
 321          (old-hash-vector (hash-table-hash-vector table))
 322          (old-size (length old-next-vector))
 323          (new-size
 324           (ceil-power-of-two
 325            (let ((rehash-size (hash-table-rehash-size table)))
 326              (etypecase rehash-size
 327                (fixnum
 328                 (+ rehash-size old-size))
 329                (float
 330                 (the index (truncate (* rehash-size old-size))))))))
 331          (new-kv-vector (make-array (* 2 new-size)
 332                                     :initial-element +empty-ht-slot+))
 333          (new-next-vector
 334           (make-array new-size
 335                       :element-type '(unsigned-byte #.sb!vm:n-word-bits)
 336                       :initial-element 0))
 337          (new-hash-vector
 338           (when old-hash-vector
 339             (make-array new-size
 340                         :element-type '(unsigned-byte #.sb!vm:n-word-bits)
 341                         :initial-element +magic-hash-vector-value+)))
 342          (new-length new-size)
 343          (new-index-vector
 344           (make-array new-length
 345                       :element-type '(unsigned-byte #.sb!vm:n-word-bits)
 346                       :initial-element 0)))
 347     (declare (type index new-size new-length old-size))
 348
 349     ;; Disable GC tricks on the OLD-KV-VECTOR.
 350     (set-header-data old-kv-vector sb!vm:vector-normal-subtype)
 351
 352     ;; Non-empty weak hash tables always need GC support.
 353     (when (and (hash-table-weakness table) (plusp (hash-table-count table)))
 354       (set-header-data new-kv-vector sb!vm:vector-valid-hashing-subtype))
 355
 356     ;; FIXME: here and in several other places in the hash table code,
 357     ;; loops like this one are used when FILL or REPLACE would be
 358     ;; appropriate.  why are standard CL functions not used?
 359     ;; Performance issues?  General laziness?  -- NJF, 2004-03-10
 360
 361     ;; Copy over the kv-vector. The element positions should not move
 362     ;; in case there are active scans.
 363     (dotimes (i (* old-size 2))
 364       (declare (type index i))
 365       (setf (aref new-kv-vector i) (aref old-kv-vector i)))
 366
 367     ;; Copy over the hash-vector.
 368     (when old-hash-vector
 369       (dotimes (i old-size)
 370         (setf (aref new-hash-vector i) (aref old-hash-vector i))))
 371
 372     (setf (hash-table-next-free-kv table) 0)
 373     ;; Rehash all the entries; last to first so that after the pushes
 374     ;; the chains are first to last.
 375     (do ((i (1- new-size) (1- i)))
 376         ((zerop i))
 377       (declare (type index/2 i))
 378       (let ((key (aref new-kv-vector (* 2 i)))
 379             (value (aref new-kv-vector (1+ (* 2 i)))))
 380         (cond ((and (eq key +empty-ht-slot+)
 381                     (eq value +empty-ht-slot+))
 382                ;; Slot is empty, push it onto the free list.
 383                (setf (aref new-next-vector i)
 384                      (hash-table-next-free-kv table))
 385                (setf (hash-table-next-free-kv table) i))
 386               ((and new-hash-vector
 387                     (not (= (aref new-hash-vector i)
 388                             +magic-hash-vector-value+)))
 389                ;; Can use the existing hash value (not EQ based)
 390                (let* ((hashing (aref new-hash-vector i))
 391                       (index (index-for-hashing hashing new-length))
 392                       (next (aref new-index-vector index)))
 393                  (declare (type index index)
 394                           (type hash hashing))
 395                  ;; Push this slot into the next chain.
 396                  (setf (aref new-next-vector i) next)
 397                  (setf (aref new-index-vector index) i)))
 398               (t
 399                ;; EQ base hash.
 400                ;; Enable GC tricks.
 401                (set-header-data new-kv-vector
 402                                 sb!vm:vector-valid-hashing-subtype)
 403                (let* ((hashing (pointer-hash key))
 404                       (index (index-for-hashing hashing new-length))
 405                       (next (aref new-index-vector index)))
 406                  (declare (type index index)
 407                           (type hash hashing))
 408                  ;; Push this slot onto the next chain.
 409                  (setf (aref new-next-vector i) next)
 410                  (setf (aref new-index-vector index) i))))))
 411     (setf (hash-table-table table) new-kv-vector)
 412     (setf (hash-table-index-vector table) new-index-vector)
 413     (setf (hash-table-next-vector table) new-next-vector)
 414     (setf (hash-table-hash-vector table) new-hash-vector)
 415     ;; Fill the old kv-vector with 0 to help the conservative GC. Even
 416     ;; if nothing else were zeroed, it's important to clear the
 417     ;; special first cells in old-kv-vector.
 418     (fill old-kv-vector 0)
 419     (setf (hash-table-rehash-trigger table) new-size)
 420     (setf (hash-table-needs-rehash-p table) nil))
 421   (values))
 422
 423 ;;; Use the same size as before, re-using the vectors.
 424 (defun rehash-without-growing (table)
 425   (declare (type hash-table table))
 426   (aver *gc-inhibit*)
 427   (let* ((kv-vector (hash-table-table table))
 428          (next-vector (hash-table-next-vector table))
 429          (hash-vector (hash-table-hash-vector table))
 430          (size (length next-vector))
 431          (index-vector (hash-table-index-vector table))
 432          (length (length index-vector)))
 433     (declare (type index size length))
 434
 435     ;; Non-empty weak hash tables always need GC support.
 436     (unless (and (hash-table-weakness table) (plusp (hash-table-count table)))
 437       ;; Disable GC tricks, they will be re-enabled during the re-hash
 438       ;; if necessary.
 439       (set-header-data kv-vector sb!vm:vector-normal-subtype))
 440
 441     ;; Rehash all the entries.
 442     (setf (hash-table-next-free-kv table) 0)
 443     (dotimes (i size)
 444       (setf (aref next-vector i) 0))
 445     (dotimes (i length)
 446       (setf (aref index-vector i) 0))
 447     (do ((i (1- size) (1- i)))
 448         ((zerop i))
 449       (declare (type index/2 i))
 450       (let ((key (aref kv-vector (* 2 i)))
 451             (value (aref kv-vector (1+ (* 2 i)))))
 452         (cond ((and (eq key +empty-ht-slot+)
 453                     (eq value +empty-ht-slot+))
 454                ;; Slot is empty, push it onto free list.
 455                (setf (aref next-vector i) (hash-table-next-free-kv table))
 456                (setf (hash-table-next-free-kv table) i))
 457               ((and hash-vector (not (= (aref hash-vector i)
 458                                         +magic-hash-vector-value+)))
 459                ;; Can use the existing hash value (not EQ based)
 460                (let* ((hashing (aref hash-vector i))
 461                       (index (index-for-hashing hashing length))
 462                       (next (aref index-vector index)))
 463                  (declare (type index index))
 464                  ;; Push this slot into the next chain.
 465                  (setf (aref next-vector i) next)
 466                  (setf (aref index-vector index) i)))
 467               (t
 468                ;; EQ base hash.
 469                ;; Enable GC tricks.
 470                (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)
 471                (let* ((hashing (pointer-hash key))
 472                       (index (index-for-hashing hashing length))
 473                       (next (aref index-vector index)))
 474                  (declare (type index index)
 475                           (type hash hashing))
 476                  ;; Push this slot into the next chain.
 477                  (setf (aref next-vector i) next)
 478                  (setf (aref index-vector index) i)))))))
 479   ;; Clear the rehash bit only at the very end, otherwise another thread
 480   ;; might see a partially rehashed table as a normal one.
 481   (setf (hash-table-needs-rehash-p table) nil)
 482   (values))
 483
 484 (declaim (inline maybe-rehash))
 485 (defun maybe-rehash (hash-table ensure-free-slot-p)
 486   (when (hash-table-weakness hash-table)
 487     (aver *gc-inhibit*))
 488   (flet ((rehash-p ()
 489            (and ensure-free-slot-p
 490                 (zerop (hash-table-next-free-kv hash-table))))
 491          (rehash-without-growing-p ()
 492            (hash-table-needs-rehash-p hash-table)))
 493     (declare (inline rehash-p rehash-without-growing-p))
 494     (cond ((rehash-p)
 495            ;; Use recursive spinlocks since for weak tables the
 496            ;; spinlock has already been acquired. GC must be inhibited
 497            ;; to prevent the GC from seeing a rehash in progress.
 498            (sb!thread::with-recursive-system-spinlock
 499                ((hash-table-spinlock hash-table) :without-gcing t)
 500              ;; Repeat the condition inside the lock to ensure that if
 501              ;; two reader threads enter MAYBE-REHASH at the same time
 502              ;; only one rehash is performed.
 503              (when (rehash-p)
 504                (rehash hash-table))))
 505           ((rehash-without-growing-p)
 506            (sb!thread::with-recursive-system-spinlock
 507                ((hash-table-spinlock hash-table) :without-gcing t)
 508              (when (rehash-without-growing-p)
 509                (rehash-without-growing hash-table)))))))
 510
 511 (declaim (inline update-hash-table-cache))
 512 (defun update-hash-table-cache (hash-table index)
 513   (unless (hash-table-weakness hash-table)
 514     (setf (hash-table-cache hash-table) index)))
 515
 516 (defmacro with-hash-table-locks ((hash-table
 517                                   &key inline pin
 518                                   (synchronized `(hash-table-synchronized-p ,hash-table)))
 519                                  &body body)
 520   (with-unique-names (body-fun)
 521     `(with-concurrent-access-check ,hash-table
 522        (flet ((,body-fun ()
 523                 (locally (declare (inline ,@inline))
 524                   ,@body)))
 525          (if (hash-table-weakness ,hash-table)
 526              (sb!thread::with-recursive-system-spinlock
 527                  ((hash-table-spinlock ,hash-table) :without-gcing t)
 528                (,body-fun))
 529              (with-pinned-objects ,pin
 530                (if ,synchronized
 531                    ;; We use a "system" spinlock here because it is very
 532                    ;; slightly faster, as it doesn't re-enable interrupts.
 533                    (sb!thread::with-recursive-system-spinlock
 534                        ((hash-table-spinlock ,hash-table))
 535                      (,body-fun))
 536                    (,body-fun))))))))
 537
 538 (defun gethash (key hash-table &optional default)
 539   #!+sb-doc
 540   "Finds the entry in HASH-TABLE whose key is KEY and returns the
 541 associated value and T as multiple values, or returns DEFAULT and NIL
 542 if there is no such entry. Entries can be added using SETF."
 543   (declare (type hash-table hash-table)
 544            (values t (member t nil)))
 545   (gethash3 key hash-table default))
 546
 547 (declaim (maybe-inline %gethash3))
 548 (defun %gethash3 (key hash-table default)
 549   (declare (type hash-table hash-table)
 550            (optimize speed)
 551            (values t (member t nil)))
 552   (tagbody
 553    start
 554      (let ((start-epoch sb!kernel::*gc-epoch*))
 555        (macrolet ((result (value foundp)
 556                     ;; When the table has multiple concurrent readers,
 557                     ;; it's possible that there was a GC after this
 558                     ;; thread called MAYBE-REHASH from %GETHASH3, and
 559                     ;; some other thread then rehashed the table. If
 560                     ;; this happens, we might not find the key even if
 561                     ;; it's in the table. To protect against this,
 562                     ;; redo the lookup if the GC epoch counter has changed.
 563                     ;; -- JES,  2007-09-30
 564                     `(if (and (not ,foundp)
 565                               (not (eql start-epoch sb!kernel::*gc-epoch*)))
 566                          (go start)
 567                          (return-from %gethash3 (values ,value ,foundp))))
 568                   (overflow ()
 569                     ;; The next-vector chain is circular. This is caused
 570                     ;; caused by thread-unsafe mutations of the table.
 571                     `(signal-corrupt-hash-table hash-table)))
 572          (maybe-rehash hash-table nil)
 573          ;; Note that it's OK for a GC + a REHASH-WITHOUT-GROWING to
 574          ;; be triggered by another thread after this point, since the
 575          ;; GC epoch check will catch it.
 576          (let ((cache (hash-table-cache hash-table))
 577                (table (hash-table-table hash-table)))
 578            ;; First check the cache.  Use EQ here for speed.
 579            (if (and cache
 580                     (< cache (length table))
 581                     (eq (aref table cache) key))
 582                (let ((value (aref table (1+ cache))))
 583                  (result value t))
 584                ;; Search for key in the hash table.
 585                (multiple-value-bind (hashing eq-based)
 586                    (funcall (hash-table-hash-fun hash-table) key)
 587                  (declare (type hash hashing))
 588                  (let* ((index-vector (hash-table-index-vector hash-table))
 589                         (length (length index-vector))
 590                         (index (index-for-hashing hashing length))
 591                         (next (aref index-vector index))
 592                         (next-vector (hash-table-next-vector hash-table))
 593                         (hash-vector (hash-table-hash-vector hash-table))
 594                         (test-fun (hash-table-test-fun hash-table)))
 595                    (declare (type index index))
 596                    ;; Search next-vector chain for a matching key.
 597                    (if (or eq-based (not hash-vector))
 598                        (do ((next next (aref next-vector next))
 599                             (i 0 (1+ i)))
 600                            ((zerop next) (result default nil))
 601                          (declare (type index/2 next i))
 602                          (when (> i length)
 603                            (overflow))
 604                          (when (eq key (aref table (* 2 next)))
 605                            (update-hash-table-cache hash-table (* 2 next))
 606                            (let ((value (aref table (1+ (* 2 next)))))
 607                              (result value t))))
 608                        (do ((next next (aref next-vector next))
 609                             (i 0 (1+ i)))
 610                            ((zerop next) (result default nil))
 611                          (declare (type index/2 next i))
 612                          (when (> i length)
 613                            (overflow))
 614                          (when (and (= hashing (aref hash-vector next))
 615                                     (funcall test-fun key
 616                                              (aref table (* 2 next))))
 617                            ;; Found.
 618                            (update-hash-table-cache hash-table (* 2 next))
 619                            (let ((value (aref table (1+ (* 2 next)))))
 620                              (result value t)))))))))))))
 621
 622 (defun gethash3 (key hash-table default)
 623   "Three argument version of GETHASH"
 624   (declare (type hash-table hash-table))
 625   (with-hash-table-locks (hash-table :inline (%gethash3) :pin (key))
 626     (%gethash3 key hash-table default)))
 627
 628 ;;; so people can call #'(SETF GETHASH)
 629 (defun (setf gethash) (new-value key table &optional default)
 630   (declare (ignore default))
 631   (%puthash key table new-value))
 632
 633 (declaim (maybe-inline %%puthash))
 634 (defun %%puthash (key hash-table value)
 635   (declare (optimize speed))
 636   ;; We need to rehash here so that a current key can be found if it
 637   ;; exists. Check that there is room for one more entry. May not be
 638   ;; needed if the key is already present.
 639   (maybe-rehash hash-table t)
 640   ;; Search for key in the hash table.
 641   (multiple-value-bind (hashing eq-based)
 642       (funcall (hash-table-hash-fun hash-table) key)
 643     (declare (type hash hashing))
 644     (let* ((index-vector (hash-table-index-vector hash-table))
 645            (length (length index-vector))
 646            (index (index-for-hashing hashing length))
 647            (next (aref index-vector index))
 648            (kv-vector (hash-table-table hash-table))
 649            (next-vector (hash-table-next-vector hash-table))
 650            (hash-vector (hash-table-hash-vector hash-table))
 651            (test-fun (hash-table-test-fun hash-table)))
 652       (declare (type index index next))
 653       (when (hash-table-weakness hash-table)
 654         (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype))
 655       (cond ((or eq-based (not hash-vector))
 656              (when eq-based
 657                (set-header-data kv-vector
 658                                 sb!vm:vector-valid-hashing-subtype))
 659              ;; Search next-vector chain for a matching key.
 660              (do ((next next (aref next-vector next))
 661                   (i 0 (1+ i)))
 662                  ((zerop next))
 663                (declare (type index/2 next i))
 664                (when (> i length)
 665                  (signal-corrupt-hash-table hash-table))
 666                (when (eq key (aref kv-vector (* 2 next)))
 667                  ;; Found, just replace the value.
 668                  (update-hash-table-cache hash-table (* 2 next))
 669                  (setf (aref kv-vector (1+ (* 2 next))) value)
 670                  (return-from %%puthash value))))
 671             (t
 672              ;; Search next-vector chain for a matching key.
 673              (do ((next next (aref next-vector next))
 674                   (i 0 (1+ i)))
 675                  ((zerop next))
 676                (declare (type index/2 next i))
 677                (when (> i length)
 678                  (signal-corrupt-hash-table hash-table))
 679                (when (and (= hashing (aref hash-vector next))
 680                           (funcall test-fun key
 681                                    (aref kv-vector (* 2 next))))
 682                  ;; Found, just replace the value.
 683                  (update-hash-table-cache hash-table (* 2 next))
 684                  (setf (aref kv-vector (1+ (* 2 next))) value)
 685                  (return-from %%puthash value)))))
 686       ;; Pop a KV slot off the free list
 687       (let ((free-kv-slot (hash-table-next-free-kv hash-table)))
 688         (declare (type index/2 free-kv-slot))
 689         ;; Double-check for overflow.
 690         (aver (not (zerop free-kv-slot)))
 691         (setf (hash-table-next-free-kv hash-table)
 692               (aref next-vector free-kv-slot))
 693         (incf (hash-table-number-entries hash-table))
 694         (update-hash-table-cache hash-table (* 2 free-kv-slot))
 695         (setf (aref kv-vector (* 2 free-kv-slot)) key)
 696         (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value)
 697         ;; Setup the hash-vector if necessary.
 698         (when hash-vector
 699           (if (not eq-based)
 700               (setf (aref hash-vector free-kv-slot) hashing)
 701               (aver (= (aref hash-vector free-kv-slot)
 702                        +magic-hash-vector-value+))))
 703         ;; Push this slot into the next chain.
 704         (setf (aref next-vector free-kv-slot) next)
 705         (setf (aref index-vector index) free-kv-slot)))
 706     value))
 707
 708 (defun %puthash (key hash-table value)
 709   (declare (type hash-table hash-table))
 710   (aver (hash-table-index-vector hash-table))
 711   (macrolet ((put-it (lockedp)
 712                `(let ((cache (hash-table-cache hash-table))
 713         (kv-vector (hash-table-table hash-table)))
 714     ;; Check the cache
 715     (if (and cache
 716              (< cache (length kv-vector))
 717              (eq (aref kv-vector cache) key))
 718         ;; If cached, just store here
 719         (setf (aref kv-vector (1+ cache)) value)
 720         ;; Otherwise do things the hard way
 721                       ,(if lockedp
 722                            '(%%puthash key hash-table value)
 723                            '(with-hash-table-locks
 724                              (hash-table :inline (%%puthash) :pin (key)
 725                               :synchronized nil)
 726                              (%%puthash key hash-table value)))))))
 727     (if (hash-table-synchronized-p hash-table)
 728         (with-hash-table-locks (hash-table :pin (key) :synchronized t)
 729           (put-it t))
 730         (put-it nil))))
 731
 732 (declaim (maybe-inline %remhash))
 733 (defun %remhash (key hash-table)
 734   ;; We need to rehash here so that a current key can be found if it
 735   ;; exists.
 736   ;;
 737   ;; Note that if a GC happens after MAYBE-REHASH returns and another
 738   ;; thread the accesses the table (triggering a rehash), we might not
 739   ;; find the key even if it is in the table. But that's ok, since the
 740   ;; only concurrent case that we safely allow is multiple readers
 741   ;; with no writers.
 742   (maybe-rehash hash-table nil)
 743   ;; Search for key in the hash table.
 744   (multiple-value-bind (hashing eq-based)
 745       (funcall (hash-table-hash-fun hash-table) key)
 746     (declare (type hash hashing))
 747     (let* ((index-vector (hash-table-index-vector hash-table))
 748            (length (length index-vector))
 749            (index (index-for-hashing hashing length))
 750            (next (aref index-vector index))
 751            (table (hash-table-table hash-table))
 752            (next-vector (hash-table-next-vector hash-table))
 753            (hash-vector (hash-table-hash-vector hash-table))
 754            (test-fun (hash-table-test-fun hash-table)))
 755       (declare (type index index)
 756                (type index/2 next))
 757       (flet ((clear-slot (chain-vector prior-slot-location slot-location)
 758                (declare (type index/2 slot-location))
 759                ;; Mark slot as empty.
 760                (setf (aref table (* 2 slot-location)) +empty-ht-slot+
 761                      (aref table (1+ (* 2 slot-location))) +empty-ht-slot+)
 762                ;; Update the prior pointer in the chain to skip this.
 763                (setf (aref chain-vector prior-slot-location)
 764                      (aref next-vector slot-location))
 765                ;; Push KV slot onto free chain.
 766                (setf (aref next-vector slot-location)
 767                      (hash-table-next-free-kv hash-table))
 768                (setf (hash-table-next-free-kv hash-table) slot-location)
 769                (when hash-vector
 770                  (setf (aref hash-vector slot-location)
 771                        +magic-hash-vector-value+))
 772                (decf (hash-table-number-entries hash-table))
 773                t))
 774         (cond ((zerop next)
 775                nil)
 776               ((if (or eq-based (not hash-vector))
 777                    (eq key (aref table (* 2 next)))
 778                    (and (= hashing (aref hash-vector next))
 779                         (funcall test-fun key (aref table (* 2 next)))))
 780                (clear-slot index-vector index next))
 781               ;; Search next-vector chain for a matching key.
 782               ((or eq-based (not hash-vector))
 783                ;; EQ based
 784                (do ((prior next next)
 785                     (i 0 (1+ i))
 786                     (next (aref next-vector next) (aref next-vector next)))
 787                    ((zerop next) nil)
 788                  (declare (type index next))
 789                  (when (> i length)
 790                    (signal-corrupt-hash-table hash-table))
 791                  (when (eq key (aref table (* 2 next)))
 792                    (return-from %remhash (clear-slot next-vector prior next)))))
 793               (t
 794                ;; not EQ based
 795                (do ((prior next next)
 796                     (i 0 (1+ i))
 797                     (next (aref next-vector next) (aref next-vector next)))
 798                    ((zerop next) nil)
 799                  (declare (type index/2 next))
 800                  (when (> i length)
 801                    (signal-corrupt-hash-table hash-table))
 802                  (when (and (= hashing (aref hash-vector next))
 803                             (funcall test-fun key (aref table (* 2 next))))
 804                    (return-from %remhash
 805                      (clear-slot next-vector prior next))))))))))
 806
 807 (defun remhash (key hash-table)
 808   #!+sb-doc
 809   "Remove the entry in HASH-TABLE associated with KEY. Return T if
 810 there was such an entry, or NIL if not."
 811   (declare (type hash-table hash-table)
 812            (values (member t nil)))
 813   (with-hash-table-locks (hash-table :inline (%remhash) :pin (key))
 814   ;; For now, just clear the cache
 815   (setf (hash-table-cache hash-table) nil)
 816     (%remhash key hash-table)))
 817
 818 (defun clrhash (hash-table)
 819   #!+sb-doc
 820   "This removes all the entries from HASH-TABLE and returns the hash
 821 table itself."
 822   (with-hash-table-locks (hash-table)
 823     (let* ((kv-vector (hash-table-table hash-table))
 824            (next-vector (hash-table-next-vector hash-table))
 825            (hash-vector (hash-table-hash-vector hash-table))
 826            (size (length next-vector))
 827            (index-vector (hash-table-index-vector hash-table)))
 828       ;; Disable GC tricks.
 829       (set-header-data kv-vector sb!vm:vector-normal-subtype)
 830       ;; Mark all slots as empty by setting all keys and values to magic
 831       ;; tag.
 832       (aver (eq (aref kv-vector 0) hash-table))
 833       (fill kv-vector +empty-ht-slot+ :start 2)
 834       ;; Set up the free list, all free.
 835       (do ((i 1 (1+ i)))
 836           ((>= i (1- size)))
 837         (setf (aref next-vector i) (1+ i)))
 838       (setf (aref next-vector (1- size)) 0)
 839       (setf (hash-table-next-free-kv hash-table) 1)
 840       ;; Clear the index-vector.
 841       (fill index-vector 0)
 842       ;; Clear the hash-vector.
 843       (when hash-vector
 844         (fill hash-vector +magic-hash-vector-value+)))
 845     (setf (hash-table-cache hash-table) nil)
 846     (setf (hash-table-number-entries hash-table) 0)
 847     hash-table))
 848
 849 \f
 850 ;;;; MAPHASH
 851
 852 ;;; FIXME: This should be made into a compiler transform for two reasons:
 853 ;;;   1. It would then be available for compiling the entire system,
 854 ;;;      not only parts of the system which are defined after DEFUN MAPHASH.
 855 ;;;   2. It could be conditional on compilation policy, so that
 856 ;;;      it could be compiled as a full call instead of an inline
 857 ;;;      expansion when SPACE>SPEED.
 858 (declaim (inline maphash))
 859 (defun maphash (function-designator hash-table)
 860   #!+sb-doc
 861   "For each entry in HASH-TABLE, call the designated two-argument function on
 862 the key and value of the entry. Return NIL.
 863
 864 Consequences are undefined if HASH-TABLE is mutated during the call to
 865 MAPHASH, except for changing or removing elements corresponding to the
 866 current key. The applies to all threads, not just the current one --
 867 even for synchronized hash-tables. If the table may be mutated by
 868 another thread during iteration, use eg. SB-EXT:WITH-LOCKED-HASH-TABLE
 869 to protect the MAPHASH call."
 870   ;; This essentially duplicates WITH-HASH-TABLE-ITERATOR, so
 871   ;; any changes here should be reflected there as well.
 872   (let ((fun (%coerce-callable-to-fun function-designator))
 873         (size (length (hash-table-next-vector hash-table))))
 874     (declare (type function fun))
 875     (do ((i 1 (1+ i)))
 876         ((>= i size))
 877       (declare (type index/2 i))
 878       (let* ((kv-vector (hash-table-table hash-table))
 879              (key (aref kv-vector (* 2 i)))
 880              (value (aref kv-vector (1+ (* 2 i)))))
 881         ;; We are running without locking or WITHOUT-GCING. For a weak
 882         ;; :VALUE hash table it's possible that the GC hit after KEY
 883         ;; was read and now the entry is gone. So check if either the
 884         ;; key or the value is empty.
 885         (unless (or (eq key +empty-ht-slot+)
 886                     (eq value +empty-ht-slot+))
 887           (funcall fun key value))))))
 888 \f
 889 ;;;; methods on HASH-TABLE
 890
 891 ;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE
 892 ;;; when reconstructing HASH-TABLE.
 893 (defun %hash-table-ctor-args (hash-table)
 894   `(:test             ',(hash-table-test             hash-table)
 895     :size             ',(hash-table-size             hash-table)
 896     :rehash-size      ',(hash-table-rehash-size      hash-table)
 897     :rehash-threshold ',(hash-table-rehash-threshold hash-table)
 898     :weakness         ',(hash-table-weakness         hash-table)))
 899
 900 ;;; Return an association list representing the same data as HASH-TABLE.
 901 (defun %hash-table-alist (hash-table)
 902   (let ((result nil))
 903     (maphash (lambda (key value)
 904                (push (cons key value) result))
 905              hash-table)
 906     result))
 907
 908 ;;; Stuff an association list into HASH-TABLE. Return the hash table,
 909 ;;; so that we can use this for the *PRINT-READABLY* case in
 910 ;;; PRINT-OBJECT (HASH-TABLE T) without having to worry about LET
 911 ;;; forms and readable gensyms and stuff.
 912 (defun %stuff-hash-table (hash-table alist)
 913   (dolist (x alist)
 914     (setf (gethash (car x) hash-table) (cdr x)))
 915   hash-table)
 916
 917 (def!method print-object ((hash-table hash-table) stream)
 918   (declare (type stream stream))
 919   (cond ((or (not *print-readably*) (not *read-eval*))
 920          (print-unreadable-object (hash-table stream :type t :identity t)
 921            (format stream
 922                    ":TEST ~S :COUNT ~S"
 923                    (hash-table-test hash-table)
 924                    (hash-table-count hash-table))))
 925         (t
 926          (with-standard-io-syntax
 927           (format stream
 928                   "#.~W"
 929                   `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args
 930                                                           hash-table))
 931                                      ',(%hash-table-alist hash-table)))))))
 932
 933 (def!method make-load-form ((hash-table hash-table) &optional environment)
 934   (declare (ignore environment))
 935   (values `(make-hash-table ,@(%hash-table-ctor-args hash-table))
 936           `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table))))
 937
 938 \f