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 ;; This stuff is performance critical and unwind-protect is too
  18 ;; slow. And without the locking the next vector can get cyclic
  19 ;; causing looping in a WITHOUT-GCING form, SHRINK-VECTOR can corrupt
  20 ;; memory and who knows what else.
  21 (defmacro with-spinlock-and-without-gcing ((spinlock) &body body)
  22   #!-sb-thread
  23   (declare (ignore spinlock))
  24   (with-unique-names (old-gc-inhibit)
  25     `(let ((,old-gc-inhibit *gc-inhibit*)
  26            (*gc-inhibit* t))
  27        (unwind-protect
  28             (progn
  29               #!+sb-thread
  30               (sb!thread::get-spinlock ,spinlock)
  31               ,@body)
  32          #!+sb-thread
  33          (sb!thread::release-spinlock ,spinlock)
  34          (let ((*gc-inhibit* ,old-gc-inhibit))
  35            ;; the test is racy, but it can err only on the overeager side
  36            (sb!kernel::maybe-handle-pending-gc))))))
  37
  38 (eval-when (:compile-toplevel :load-toplevel :execute)
  39   (defconstant max-hash sb!xc:most-positive-fixnum))
  40
  41 (deftype hash ()
  42   `(integer 0 ,max-hash))
  43
  44 ;;; FIXME: Does this always make a nonnegative FIXNUM? If so, then
  45 ;;; explain why. If not (or if the reason it always makes a
  46 ;;; nonnegative FIXNUM is only the accident that pointers in supported
  47 ;;; architectures happen to be in the lower half of the address
  48 ;;; space), then fix it.
  49 #!-sb-fluid (declaim (inline pointer-hash))
  50 (defun pointer-hash (key)
  51   (declare (values hash))
  52   (truly-the hash (%primitive sb!c:make-fixnum key)))
  53
  54 #!-sb-fluid (declaim (inline eq-hash))
  55 (defun eq-hash (key)
  56   (declare (values hash (member t nil)))
  57   (values (pointer-hash key)
  58           (oddp (get-lisp-obj-address key))))
  59
  60 #!-sb-fluid (declaim (inline equal-hash))
  61 (defun equal-hash (key)
  62   (declare (values hash (member t nil)))
  63   (values (sxhash key) nil))
  64
  65 #!-sb-fluid (declaim (inline eql-hash))
  66 (defun eql-hash (key)
  67   (declare (values hash (member t nil)))
  68   (if (numberp key)
  69       (equal-hash key)
  70       (eq-hash key)))
  71
  72 (defun equalp-hash (key)
  73   (declare (values hash (member t nil)))
  74   (values (psxhash key) nil))
  75
  76 (defun almost-primify (num)
  77   (declare (type index num))
  78   #!+sb-doc
  79   "Return an almost prime number greater than or equal to NUM."
  80   (if (= (rem num 2) 0)
  81       (setq num (+ 1 num)))
  82   (if (= (rem num 3) 0)
  83       (setq num (+ 2 num)))
  84   (if (= (rem num 7) 0)
  85       (setq num (+ 4 num)))
  86   num)
  87 \f
  88 ;;;; user-defined hash table tests
  89
  90 (defvar *hash-table-tests* nil)
  91
  92 (defun define-hash-table-test (name test-fun hash-fun)
  93   #!+sb-doc
  94   "Define a new kind of hash table test."
  95   (declare (type symbol name)
  96            (type function test-fun hash-fun))
  97   (setf *hash-table-tests*
  98         (cons (list name test-fun hash-fun)
  99               (remove name *hash-table-tests* :test #'eq :key #'car)))
 100   name)
 101 \f
 102 ;;;; construction and simple accessors
 103
 104 (defconstant +min-hash-table-size+ 16)
 105 (defconstant +min-hash-table-rehash-threshold+ (float 1/16 1.0))
 106
 107 (defun make-hash-table (&key (test 'eql)
 108                         (size +min-hash-table-size+)
 109                         (rehash-size 1.5)
 110                         (rehash-threshold 1)
 111                         (weakness nil))
 112   #!+sb-doc
 113   "Create and return a new hash table. The keywords are as follows:
 114      :TEST -- Indicates what kind of test to use.
 115      :SIZE -- A hint as to how many elements will be put in this hash
 116        table.
 117      :REHASH-SIZE -- Indicates how to expand the table when it fills up.
 118        If an integer, add space for that many elements. If a floating
 119        point number (which must be greater than 1.0), multiply the size
 120        by that amount.
 121      :REHASH-THRESHOLD -- Indicates how dense the table can become before
 122        forcing a rehash. Can be any positive number <=1, with density
 123        approaching zero as the threshold approaches 0. Density 1 means an
 124        average of one entry per bucket.
 125      :WEAKNESS -- IF NIL (the default) it is a normal non-weak hash table.
 126        If one of :KEY, :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE it is a weak
 127        hash table.
 128        Depending on the type of weakness the lack of references to the
 129        key and the value may allow for removal of the entry. If WEAKNESS
 130        is :KEY and the key would otherwise be garbage the entry is eligible
 131        for removal from the hash table. Similarly, if WEAKNESS is :VALUE
 132        the life of an entry depends on its value's references. If WEAKNESS
 133        is :KEY-AND-VALUE and either the key or the value would otherwise be
 134        garbage the entry can be removed. If WEAKNESS is :KEY-OR-VALUE and
 135        both the key and the value would otherwise be garbage the entry can
 136        be removed."
 137   (declare (type (or function symbol) test))
 138   (declare (type unsigned-byte size))
 139   (multiple-value-bind (test test-fun hash-fun)
 140       (cond ((or (eq test #'eq) (eq test 'eq))
 141              (values 'eq #'eq #'eq-hash))
 142             ((or (eq test #'eql) (eq test 'eql))
 143              (values 'eql #'eql #'eql-hash))
 144             ((or (eq test #'equal) (eq test 'equal))
 145              (values 'equal #'equal #'equal-hash))
 146             ((or (eq test #'equalp) (eq test 'equalp))
 147              (values 'equalp #'equalp #'equalp-hash))
 148             (t
 149              ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff.
 150              ;; Failing that, I'd like to rename it to
 151              ;; *USER-HASH-TABLE-TESTS*.
 152              (dolist (info *hash-table-tests*
 153                       (error "unknown :TEST for MAKE-HASH-TABLE: ~S"
 154                              test))
 155                (destructuring-bind (test-name test-fun hash-fun) info
 156                  (when (or (eq test test-name) (eq test test-fun))
 157                    (return (values test-name test-fun hash-fun)))))))
 158     (let* ((size (max +min-hash-table-size+
 159                       (min size
 160                            ;; SIZE is just a hint, so if the user asks
 161                            ;; for a SIZE which'd be too big for us to
 162                            ;; easily implement, we bump it down.
 163                            (floor array-dimension-limit 1024))))
 164            (rehash-size (if (integerp rehash-size)
 165                             rehash-size
 166                             (float rehash-size 1.0)))
 167            ;; FIXME: Original REHASH-THRESHOLD default should be 1.0,
 168            ;; not 1, to make it easier for the compiler to avoid
 169            ;; boxing.
 170            (rehash-threshold (max +min-hash-table-rehash-threshold+
 171                                   (float rehash-threshold 1.0)))
 172            (size+1 (1+ size))       ; The first element is not usable.
 173            ;; KLUDGE: The most natural way of expressing the below is
 174            ;; (round (/ (float size+1) rehash-threshold)), and indeed
 175            ;; it was expressed like that until 0.7.0. However,
 176            ;; MAKE-HASH-TABLE is called very early in cold-init, and
 177            ;; the SPARC has no primitive instructions for rounding,
 178            ;; but only for truncating; therefore, we fudge this issue
 179            ;; a little. The other uses of truncate, below, similarly
 180            ;; used to be round. -- CSR, 2002-10-01
 181            ;;
 182            ;; Note that this has not yet been audited for
 183            ;; correctness. It just seems to work. -- CSR, 2002-11-02
 184            (scaled-size (truncate (/ (float size+1) rehash-threshold)))
 185            (length (almost-primify (max scaled-size
 186                                         (1+ +min-hash-table-size+))))
 187            (index-vector (make-array length
 188                                      :element-type
 189                                      '(unsigned-byte #.sb!vm:n-word-bits)
 190                                      :initial-element 0))
 191            ;; Needs to be the half the length of the KV vector to link
 192            ;; KV entries - mapped to indeces at 2i and 2i+1 -
 193            ;; together.
 194            (next-vector (make-array size+1
 195                                     :element-type
 196                                     '(unsigned-byte #.sb!vm:n-word-bits)))
 197            (kv-vector (make-array (* 2 size+1)
 198                                   :initial-element +empty-ht-slot+))
 199            (table (%make-hash-table
 200                    :test test
 201                    :test-fun test-fun
 202                    :hash-fun hash-fun
 203                    :rehash-size rehash-size
 204                    :rehash-threshold rehash-threshold
 205                    :rehash-trigger size
 206                    :table kv-vector
 207                    :weakness weakness
 208                    :index-vector index-vector
 209                    :next-vector next-vector
 210                    :hash-vector
 211                    (unless (eq test 'eq)
 212                      (make-array size+1
 213                                  :element-type '(unsigned-byte
 214                                                  #.sb!vm:n-word-bits)
 215                                  :initial-element +magic-hash-vector-value+))
 216                    :spinlock (sb!thread::make-spinlock))))
 217       (declare (type index size+1 scaled-size length))
 218       ;; Set up the free list, all free. These lists are 0 terminated.
 219       (do ((i 1 (1+ i)))
 220           ((>= i size))
 221         (setf (aref next-vector i) (1+ i)))
 222       (setf (aref next-vector size) 0)
 223       (setf (hash-table-next-free-kv table) 1)
 224       (setf (hash-table-needing-rehash table) 0)
 225       (setf (aref kv-vector 0) table)
 226       table)))
 227
 228 (defun hash-table-count (hash-table)
 229   #!+sb-doc
 230   "Return the number of entries in the given HASH-TABLE."
 231   (declare (type hash-table hash-table)
 232            (values index))
 233   (hash-table-number-entries hash-table))
 234
 235 #!+sb-doc
 236 (setf (fdocumentation 'hash-table-rehash-size 'function)
 237       "Return the rehash-size HASH-TABLE was created with.")
 238
 239 #!+sb-doc
 240 (setf (fdocumentation 'hash-table-rehash-threshold 'function)
 241       "Return the rehash-threshold HASH-TABLE was created with.")
 242
 243 (defun hash-table-size (hash-table)
 244   #!+sb-doc
 245   "Return a size that can be used with MAKE-HASH-TABLE to create a hash
 246    table that can hold however many entries HASH-TABLE can hold without
 247    having to be grown."
 248   (hash-table-rehash-trigger hash-table))
 249
 250 #!+sb-doc
 251 (setf (fdocumentation 'hash-table-test 'function)
 252       "Return the test HASH-TABLE was created with.")
 253
 254 #!+sb-doc
 255 (setf (fdocumentation 'hash-table-weakness 'function)
 256       "Return the WEAKNESS of HASH-TABLE which is one of NIL, :KEY,
 257 :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE.")
 258 \f
 259 ;;;; accessing functions
 260
 261 ;;; Make new vectors for the table, extending the table based on the
 262 ;;; rehash-size.
 263 (defun rehash (table)
 264   (declare (type hash-table table))
 265   (let* ((old-kv-vector (hash-table-table table))
 266          (old-next-vector (hash-table-next-vector table))
 267          (old-hash-vector (hash-table-hash-vector table))
 268          (old-size (length old-next-vector))
 269          (new-size
 270           (let ((rehash-size (hash-table-rehash-size table)))
 271             (etypecase rehash-size
 272               (fixnum
 273                (+ rehash-size old-size))
 274               (float
 275                (the index (truncate (* rehash-size old-size)))))))
 276          (new-kv-vector (make-array (* 2 new-size)
 277                                     :initial-element +empty-ht-slot+))
 278          (new-next-vector
 279           (make-array new-size
 280                       :element-type '(unsigned-byte #.sb!vm:n-word-bits)
 281                       :initial-element 0))
 282          (new-hash-vector
 283           (when old-hash-vector
 284             (make-array new-size
 285                         :element-type '(unsigned-byte #.sb!vm:n-word-bits)
 286                         :initial-element +magic-hash-vector-value+)))
 287          (old-index-vector (hash-table-index-vector table))
 288          (new-length (almost-primify
 289                       (truncate (/ (float new-size)
 290                                    (hash-table-rehash-threshold table)))))
 291          (new-index-vector
 292           (make-array new-length
 293                       :element-type '(unsigned-byte #.sb!vm:n-word-bits)
 294                       :initial-element 0)))
 295     (declare (type index new-size new-length old-size))
 296
 297     ;; Disable GC tricks on the OLD-KV-VECTOR.
 298     (set-header-data old-kv-vector sb!vm:vector-normal-subtype)
 299
 300     ;; Non-empty weak hash tables always need GC support.
 301     (when (and (hash-table-weakness table) (plusp (hash-table-count table)))
 302       (set-header-data new-kv-vector sb!vm:vector-valid-hashing-subtype))
 303
 304     ;; FIXME: here and in several other places in the hash table code,
 305     ;; loops like this one are used when FILL or REPLACE would be
 306     ;; appropriate.  why are standard CL functions not used?
 307     ;; Performance issues?  General laziness?  -- NJF, 2004-03-10
 308
 309     ;; Copy over the kv-vector. The element positions should not move
 310     ;; in case there are active scans.
 311     (dotimes (i (* old-size 2))
 312       (declare (type index i))
 313       (setf (aref new-kv-vector i) (aref old-kv-vector i)))
 314
 315     ;; Copy over the hash-vector.
 316     (when old-hash-vector
 317       (dotimes (i old-size)
 318         (setf (aref new-hash-vector i) (aref old-hash-vector i))))
 319
 320     (setf (hash-table-next-free-kv table) 0)
 321     (setf (hash-table-needing-rehash table) 0)
 322     ;; Rehash all the entries; last to first so that after the pushes
 323     ;; the chains are first to last.
 324     (do ((i (1- new-size) (1- i)))
 325         ((zerop i))
 326       (let ((key (aref new-kv-vector (* 2 i)))
 327             (value (aref new-kv-vector (1+ (* 2 i)))))
 328         (cond ((and (eq key +empty-ht-slot+)
 329                     (eq value +empty-ht-slot+))
 330                ;; Slot is empty, push it onto the free list.
 331                (setf (aref new-next-vector i)
 332                      (hash-table-next-free-kv table))
 333                (setf (hash-table-next-free-kv table) i))
 334               ((and new-hash-vector
 335                     (not (= (aref new-hash-vector i)
 336                             +magic-hash-vector-value+)))
 337                ;; Can use the existing hash value (not EQ based)
 338                (let* ((hashing (aref new-hash-vector i))
 339                       (index (rem hashing new-length))
 340                       (next (aref new-index-vector index)))
 341                  (declare (type index index)
 342                           (type hash hashing))
 343                  ;; Push this slot into the next chain.
 344                  (setf (aref new-next-vector i) next)
 345                  (setf (aref new-index-vector index) i)))
 346               (t
 347                ;; EQ base hash.
 348                ;; Enable GC tricks.
 349                (set-header-data new-kv-vector
 350                                 sb!vm:vector-valid-hashing-subtype)
 351                (let* ((hashing (pointer-hash key))
 352                       (index (rem hashing new-length))
 353                       (next (aref new-index-vector index)))
 354                  (declare (type index index)
 355                           (type hash hashing))
 356                  ;; Push this slot onto the next chain.
 357                  (setf (aref new-next-vector i) next)
 358                  (setf (aref new-index-vector index) i))))))
 359     (setf (hash-table-table table) new-kv-vector)
 360     (setf (hash-table-index-vector table) new-index-vector)
 361     (setf (hash-table-next-vector table) new-next-vector)
 362     (setf (hash-table-hash-vector table) new-hash-vector)
 363     ;; Shrink the old vectors to 0 size to help the conservative GC.
 364     (%shrink-vector old-kv-vector 0)
 365     (%shrink-vector old-index-vector 0)
 366     (%shrink-vector old-next-vector 0)
 367     (when old-hash-vector
 368       (%shrink-vector old-hash-vector 0))
 369     (setf (hash-table-rehash-trigger table) new-size))
 370   (values))
 371
 372 ;;; Use the same size as before, re-using the vectors.
 373 (defun rehash-without-growing (table)
 374   (declare (type hash-table table))
 375   (let* ((kv-vector (hash-table-table table))
 376          (next-vector (hash-table-next-vector table))
 377          (hash-vector (hash-table-hash-vector table))
 378          (size (length next-vector))
 379          (index-vector (hash-table-index-vector table))
 380          (length (length index-vector)))
 381     (declare (type index size length))
 382
 383     ;; Non-empty weak hash tables always need GC support.
 384     (unless (and (hash-table-weakness table) (plusp (hash-table-count table)))
 385       ;; Disable GC tricks, they will be re-enabled during the re-hash
 386       ;; if necessary.
 387       (set-header-data kv-vector sb!vm:vector-normal-subtype))
 388
 389     ;; Rehash all the entries.
 390     (setf (hash-table-next-free-kv table) 0)
 391     (setf (hash-table-needing-rehash table) 0)
 392     (dotimes (i size)
 393       (setf (aref next-vector i) 0))
 394     (dotimes (i length)
 395       (setf (aref index-vector i) 0))
 396     (do ((i (1- size) (1- i)))
 397         ((zerop i))
 398       (let ((key (aref kv-vector (* 2 i)))
 399             (value (aref kv-vector (1+ (* 2 i)))))
 400         (cond ((and (eq key +empty-ht-slot+)
 401                     (eq value +empty-ht-slot+))
 402                ;; Slot is empty, push it onto free list.
 403                (setf (aref next-vector i) (hash-table-next-free-kv table))
 404                (setf (hash-table-next-free-kv table) i))
 405               ((and hash-vector (not (= (aref hash-vector i)
 406                                         +magic-hash-vector-value+)))
 407                ;; Can use the existing hash value (not EQ based)
 408                (let* ((hashing (aref hash-vector i))
 409                       (index (rem hashing length))
 410                       (next (aref index-vector index)))
 411                  (declare (type index index))
 412                  ;; Push this slot into the next chain.
 413                  (setf (aref next-vector i) next)
 414                  (setf (aref index-vector index) i)))
 415               (t
 416                ;; EQ base hash.
 417                ;; Enable GC tricks.
 418                (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)
 419                (let* ((hashing (pointer-hash key))
 420                       (index (rem hashing length))
 421                       (next (aref index-vector index)))
 422                  (declare (type index index)
 423                           (type hash hashing))
 424                  ;; Push this slot into the next chain.
 425                  (setf (aref next-vector i) next)
 426                  (setf (aref index-vector index) i)))))))
 427   (values))
 428
 429 (defun flush-needing-rehash (table)
 430   (let* ((kv-vector (hash-table-table table))
 431          (index-vector (hash-table-index-vector table))
 432          (next-vector (hash-table-next-vector table))
 433          (length (length index-vector)))
 434     (do ((next (hash-table-needing-rehash table)))
 435         ((zerop next))
 436       (declare (type index next))
 437       (let* ((key (aref kv-vector (* 2 next)))
 438              (hashing (pointer-hash key))
 439              (index (rem hashing length))
 440              (temp (aref next-vector next)))
 441         (setf (aref next-vector next) (aref index-vector index))
 442         (setf (aref index-vector index) next)
 443         (setf next temp))))
 444   (setf (hash-table-needing-rehash table) 0)
 445   (values))
 446
 447 (defun gethash (key hash-table &optional default)
 448   #!+sb-doc
 449   "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
 450    value and T as multiple values, or returns DEFAULT and NIL if there is no
 451    such entry. Entries can be added using SETF."
 452   (declare (type hash-table hash-table)
 453            (values t (member t nil)))
 454   (gethash3 key hash-table default))
 455
 456 (defun gethash2 (key hash-table)
 457   #!+sb-doc
 458   "Two argument version of GETHASH"
 459   (declare (type hash-table hash-table)
 460            (values t (member t nil)))
 461   (gethash3 key hash-table nil))
 462
 463 (defun gethash3 (key hash-table default)
 464   #!+sb-doc
 465   "Three argument version of GETHASH"
 466   (declare (type hash-table hash-table)
 467            (values t (member t nil)))
 468   (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
 469    (cond ((= (get-header-data (hash-table-table hash-table))
 470              sb!vm:vector-must-rehash-subtype)
 471           (rehash-without-growing hash-table))
 472          ((not (zerop (hash-table-needing-rehash hash-table)))
 473           (flush-needing-rehash hash-table)))
 474
 475    ;; First check the cache.  Use EQ here for speed.
 476    (let ((cache (hash-table-cache hash-table))
 477          (table (hash-table-table hash-table)))
 478
 479      (if (and cache (< cache (length table)) (eq (aref table cache) key))
 480          (values (aref table (1+ cache)) t)
 481
 482        ;; Search for key in the hash table.
 483        (multiple-value-bind (hashing eq-based)
 484            (funcall (hash-table-hash-fun hash-table) key)
 485          (declare (type hash hashing))
 486          (let* ((index-vector (hash-table-index-vector hash-table))
 487                 (length (length index-vector))
 488                 (index (rem hashing length))
 489                 (next (aref index-vector index))
 490                 (next-vector (hash-table-next-vector hash-table))
 491                 (hash-vector (hash-table-hash-vector hash-table))
 492                 (test-fun (hash-table-test-fun hash-table)))
 493            (declare (type index index))
 494            ;; Search next-vector chain for a matching key.
 495            (if (or eq-based (not hash-vector))
 496                (do ((next next (aref next-vector next)))
 497                    ((zerop next) (values default nil))
 498                  (declare (type index next))
 499                  (when (eq key (aref table (* 2 next)))
 500                    (setf (hash-table-cache hash-table) (* 2 next))
 501                    (return (values (aref table (1+ (* 2 next))) t))))
 502              (do ((next next (aref next-vector next)))
 503                  ((zerop next) (values default nil))
 504                (declare (type index next))
 505                (when (and (= hashing (aref hash-vector next))
 506                           (funcall test-fun key (aref table (* 2 next))))
 507                  ;; Found.
 508                  (setf (hash-table-cache hash-table) (* 2 next))
 509                  (return (values (aref table (1+ (* 2 next))) t)))))))))))
 510
 511 ;;; so people can call #'(SETF GETHASH)
 512 (defun (setf gethash) (new-value key table &optional default)
 513   (declare (ignore default))
 514   (%puthash key table new-value))
 515
 516 (defun %puthash (key hash-table value)
 517   (declare (type hash-table hash-table))
 518   (aver (hash-table-index-vector hash-table))
 519   (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
 520    ;; We need to rehash here so that a current key can be found if it
 521    ;; exists. Check that there is room for one more entry. May not be
 522    ;; needed if the key is already present.
 523    (cond ((zerop (hash-table-next-free-kv hash-table))
 524           (rehash hash-table))
 525          ((= (get-header-data (hash-table-table hash-table))
 526              sb!vm:vector-must-rehash-subtype)
 527           (rehash-without-growing hash-table))
 528          ((not (zerop (hash-table-needing-rehash hash-table)))
 529           (flush-needing-rehash hash-table)))
 530
 531    (let ((cache (hash-table-cache hash-table))
 532          (kv-vector (hash-table-table hash-table)))
 533
 534      ;; Check the cache
 535      (if (and cache (< cache (length kv-vector))
 536               (eq (aref kv-vector cache) key))
 537          ;; If cached, just store here
 538          (setf (aref kv-vector (1+ cache)) value)
 539
 540        ;; Search for key in the hash table.
 541        (multiple-value-bind (hashing eq-based)
 542            (funcall (hash-table-hash-fun hash-table) key)
 543          (declare (type hash hashing))
 544          (let* ((index-vector (hash-table-index-vector hash-table))
 545                 (length (length index-vector))
 546                 (index (rem hashing length))
 547                 (next (aref index-vector index))
 548                 (kv-vector (hash-table-table hash-table))
 549                 (next-vector (hash-table-next-vector hash-table))
 550                 (hash-vector (hash-table-hash-vector hash-table))
 551                 (test-fun (hash-table-test-fun hash-table)))
 552            (declare (type index index))
 553            (when (hash-table-weakness hash-table)
 554              (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype))
 555            (cond ((or eq-based (not hash-vector))
 556                   (when eq-based
 557                     (set-header-data kv-vector
 558                                      sb!vm:vector-valid-hashing-subtype))
 559
 560                   ;; Search next-vector chain for a matching key.
 561                   (do ((next next (aref next-vector next)))
 562                       ((zerop next))
 563                     (declare (type index next))
 564                     (when (eq key (aref kv-vector (* 2 next)))
 565                       ;; Found, just replace the value.
 566                       (setf (hash-table-cache hash-table) (* 2 next))
 567                       (setf (aref kv-vector (1+ (* 2 next))) value)
 568                       (return-from %puthash value))))
 569                  (t
 570                   ;; Search next-vector chain for a matching key.
 571                   (do ((next next (aref next-vector next)))
 572                       ((zerop next))
 573                     (declare (type index next))
 574                     (when (and (= hashing (aref hash-vector next))
 575                                (funcall test-fun key
 576                                         (aref kv-vector (* 2 next))))
 577                       ;; Found, just replace the value.
 578                       (setf (hash-table-cache hash-table) (* 2 next))
 579                       (setf (aref kv-vector (1+ (* 2 next))) value)
 580                       (return-from %puthash value)))))
 581
 582            ;; Pop a KV slot off the free list
 583            (let ((free-kv-slot (hash-table-next-free-kv hash-table)))
 584              ;; Double-check for overflow.
 585              (aver (not (zerop free-kv-slot)))
 586              (setf (hash-table-next-free-kv hash-table)
 587                    (aref next-vector free-kv-slot))
 588              (incf (hash-table-number-entries hash-table))
 589
 590              (setf (hash-table-cache hash-table) (* 2 free-kv-slot))
 591              (setf (aref kv-vector (* 2 free-kv-slot)) key)
 592              (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value)
 593
 594              ;; Setup the hash-vector if necessary.
 595              (when hash-vector
 596                (if (not eq-based)
 597                    (setf (aref hash-vector free-kv-slot) hashing)
 598                    (aver (= (aref hash-vector free-kv-slot)
 599                             +magic-hash-vector-value+))))
 600
 601              ;; Push this slot into the next chain.
 602              (setf (aref next-vector free-kv-slot) next)
 603              (setf (aref index-vector index) free-kv-slot)))))))
 604   value)
 605
 606 (defun remhash (key hash-table)
 607   #!+sb-doc
 608   "Remove the entry in HASH-TABLE associated with KEY. Return T if there
 609    was such an entry, or NIL if not."
 610   (declare (type hash-table hash-table)
 611            (values (member t nil)))
 612   (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
 613    ;; We need to rehash here so that a current key can be found if it
 614    ;; exists.
 615    (cond ((= (get-header-data (hash-table-table hash-table))
 616              sb!vm:vector-must-rehash-subtype)
 617           (rehash-without-growing hash-table))
 618          ((not (zerop (hash-table-needing-rehash hash-table)))
 619           (flush-needing-rehash hash-table)))
 620
 621    ;; For now, just clear the cache
 622    (setf (hash-table-cache hash-table) nil)
 623
 624    ;; Search for key in the hash table.
 625    (multiple-value-bind (hashing eq-based)
 626        (funcall (hash-table-hash-fun hash-table) key)
 627      (declare (type hash hashing))
 628      (let* ((index-vector (hash-table-index-vector hash-table))
 629             (length (length index-vector))
 630             (index (rem hashing length))
 631             (next (aref index-vector index))
 632             (table (hash-table-table hash-table))
 633             (next-vector (hash-table-next-vector hash-table))
 634             (hash-vector (hash-table-hash-vector hash-table))
 635             (test-fun (hash-table-test-fun hash-table)))
 636        (declare (type index index next))
 637        (flet ((clear-slot (chain-vector prior-slot-location slot-location)
 638                 ;; Mark slot as empty.
 639                 (setf (aref table (* 2 slot-location)) +empty-ht-slot+
 640                       (aref table (1+ (* 2 slot-location))) +empty-ht-slot+)
 641                 ;; Update the prior pointer in the chain to skip this.
 642                 (setf (aref chain-vector prior-slot-location)
 643                       (aref next-vector slot-location))
 644                 ;; Push KV slot onto free chain.
 645                 (setf (aref next-vector slot-location)
 646                       (hash-table-next-free-kv hash-table))
 647                 (setf (hash-table-next-free-kv hash-table) slot-location)
 648                 (when hash-vector
 649                   (setf (aref hash-vector slot-location)
 650                         +magic-hash-vector-value+))
 651                 (decf (hash-table-number-entries hash-table))
 652                 t))
 653          (cond ((zerop next)
 654                 nil)
 655                ((if (or eq-based (not hash-vector))
 656                     (eq key (aref table (* 2 next)))
 657                     (and (= hashing (aref hash-vector next))
 658                          (funcall test-fun key (aref table (* 2 next)))))
 659                 (clear-slot index-vector index next))
 660                ;; Search next-vector chain for a matching key.
 661                ((or eq-based (not hash-vector))
 662                 ;; EQ based
 663                 (do ((prior next next)
 664                      (next (aref next-vector next) (aref next-vector next)))
 665                     ((zerop next) nil)
 666                   (declare (type index next))
 667                   (when (eq key (aref table (* 2 next)))
 668                     (return-from remhash (clear-slot next-vector prior next)))))
 669                (t
 670                 ;; not EQ based
 671                 (do ((prior next next)
 672                      (next (aref next-vector next) (aref next-vector next)))
 673                     ((zerop next) nil)
 674                   (declare (type index next))
 675                   (when (and (= hashing (aref hash-vector next))
 676                              (funcall test-fun key (aref table (* 2 next))))
 677                     (return-from remhash
 678                       (clear-slot next-vector prior next)))))))))))
 679
 680 (defun clrhash (hash-table)
 681   #!+sb-doc
 682   "This removes all the entries from HASH-TABLE and returns the hash table
 683    itself."
 684   (declare (optimize speed))
 685   (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
 686     (let* ((kv-vector (hash-table-table hash-table))
 687            (next-vector (hash-table-next-vector hash-table))
 688            (hash-vector (hash-table-hash-vector hash-table))
 689            (size (length next-vector))
 690            (index-vector (hash-table-index-vector hash-table)))
 691       ;; Disable GC tricks.
 692       (set-header-data kv-vector sb!vm:vector-normal-subtype)
 693       ;; Mark all slots as empty by setting all keys and values to magic
 694       ;; tag.
 695       (aver (eq (aref kv-vector 0) hash-table))
 696       (fill kv-vector +empty-ht-slot+ :start 2)
 697       ;; Set up the free list, all free.
 698       (do ((i 1 (1+ i)))
 699           ((>= i (1- size)))
 700         (setf (aref next-vector i) (1+ i)))
 701       (setf (aref next-vector (1- size)) 0)
 702       (setf (hash-table-next-free-kv hash-table) 1)
 703       (setf (hash-table-needing-rehash hash-table) 0)
 704       ;; Clear the index-vector.
 705       (fill index-vector 0)
 706       ;; Clear the hash-vector.
 707       (when hash-vector
 708         (fill hash-vector +magic-hash-vector-value+)))
 709     (setf (hash-table-cache hash-table) nil)
 710     (setf (hash-table-number-entries hash-table) 0))
 711   hash-table)
 712 \f
 713 ;;;; MAPHASH
 714
 715 ;;; FIXME: This should be made into a compiler transform for two reasons:
 716 ;;;   1. It would then be available for compiling the entire system,
 717 ;;;      not only parts of the system which are defined after DEFUN MAPHASH.
 718 ;;;   2. It could be conditional on compilation policy, so that
 719 ;;;      it could be compiled as a full call instead of an inline
 720 ;;;      expansion when SPACE>SPEED.
 721 (declaim (inline maphash))
 722 (defun maphash (function-designator hash-table)
 723   #!+sb-doc
 724   "For each entry in HASH-TABLE, call the designated two-argument function
 725    on the key and value of the entry. Return NIL."
 726   (let ((fun (%coerce-callable-to-fun function-designator))
 727         (size (length (hash-table-next-vector hash-table))))
 728     (declare (type function fun))
 729     (do ((i 1 (1+ i)))
 730         ((>= i size))
 731       (declare (type index i))
 732       (let* ((kv-vector (hash-table-table hash-table))
 733              (key (aref kv-vector (* 2 i)))
 734              (value (aref kv-vector (1+ (* 2 i)))))
 735         ;; We are running without locking or WITHOUT-GCING. For a weak
 736         ;; :VALUE hash table it's possible that the GC hit after KEY
 737         ;; was read and now the entry is gone. So check if either the
 738         ;; key or the value is empty.
 739         (unless (or (eq key +empty-ht-slot+)
 740                     (eq value +empty-ht-slot+))
 741           (funcall fun key value))))))
 742 \f
 743 ;;;; methods on HASH-TABLE
 744
 745 ;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE
 746 ;;; when reconstructing HASH-TABLE.
 747 (defun %hash-table-ctor-args (hash-table)
 748   `(:test             ',(hash-table-test             hash-table)
 749     :size             ',(hash-table-size             hash-table)
 750     :rehash-size      ',(hash-table-rehash-size      hash-table)
 751     :rehash-threshold ',(hash-table-rehash-threshold hash-table)
 752     :weakness         ',(hash-table-weakness         hash-table)))
 753
 754 ;;; Return an association list representing the same data as HASH-TABLE.
 755 (defun %hash-table-alist (hash-table)
 756   (let ((result nil))
 757     (maphash (lambda (key value)
 758                (push (cons key value) result))
 759              hash-table)
 760     result))
 761
 762 ;;; Stuff an association list into HASH-TABLE. Return the hash table,
 763 ;;; so that we can use this for the *PRINT-READABLY* case in
 764 ;;; PRINT-OBJECT (HASH-TABLE T) without having to worry about LET
 765 ;;; forms and readable gensyms and stuff.
 766 (defun %stuff-hash-table (hash-table alist)
 767   (dolist (x alist)
 768     (setf (gethash (car x) hash-table) (cdr x)))
 769   hash-table)
 770
 771 (def!method print-object ((hash-table hash-table) stream)
 772   (declare (type stream stream))
 773   (cond ((or (not *print-readably*) (not *read-eval*))
 774          (print-unreadable-object (hash-table stream :type t :identity t)
 775            (format stream
 776                    ":TEST ~S :COUNT ~S"
 777                    (hash-table-test hash-table)
 778                    (hash-table-count hash-table))))
 779         (t
 780          (with-standard-io-syntax
 781           (format stream
 782                   "#.~W"
 783                   `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args
 784                                                           hash-table))
 785                                      ',(%hash-table-alist hash-table)))))))
 786
 787 (def!method make-load-form ((hash-table hash-table) &optional environment)
 788   (declare (ignore environment))
 789   (values `(make-hash-table ,@(%hash-table-ctor-args hash-table))
 790           `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table))))