src/code/target-hash-table.lisp

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