src/code/target-hash-table.lisp

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