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