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