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 (defconstant max-hash most-positive-fixnum)
  18
  19 (deftype hash ()
  20   `(integer 0 ,max-hash))
  21
  22 #!-sb-fluid (declaim (inline pointer-hash))
  23 (defun pointer-hash (key)
  24   (declare (values hash))
  25   (truly-the hash (%primitive sb!c:make-fixnum key)))
  26
  27 #!-sb-fluid (declaim (inline eq-hash))
  28 (defun eq-hash (key)
  29   (declare (values hash (member t nil)))
  30   (values (pointer-hash key)
  31           (oddp (get-lisp-obj-address key))))
  32
  33 #!-sb-fluid (declaim (inline equal-hash))
  34 (defun equal-hash (key)
  35   (declare (values hash (member t nil)))
  36   (values (sxhash key) nil))
  37
  38 #!-sb-fluid (declaim (inline eql-hash))
  39 (defun eql-hash (key)
  40   (declare (values hash (member t nil)))
  41   (if (numberp key)
  42       (equal-hash key)
  43       (eq-hash key)))
  44
  45 (defun equalp-hash (key)
  46   (declare (values hash (member t nil)))
  47   (values (psxhash key) nil))
  48
  49 (defun almost-primify (num)
  50   (declare (type index num))
  51   #!+sb-doc
  52   "Return an almost prime number greater than or equal to NUM."
  53   (if (= (rem num 2) 0)
  54       (setq num (+ 1 num)))
  55   (if (= (rem num 3) 0)
  56       (setq num (+ 2 num)))
  57   (if (= (rem num 7) 0)
  58       (setq num (+ 4 num)))
  59   num)
  60 \f
  61 ;;;; user-defined hash table tests
  62
  63 (defvar *hash-table-tests* nil)
  64
  65 (defun define-hash-table-test (name test-fun hash-fun)
  66   #!+sb-doc
  67   "Define a new kind of hash table test."
  68   (declare (type symbol name)
  69            (type function test-fun hash-fun))
  70   (setf *hash-table-tests*
  71         (cons (list name test-fun hash-fun)
  72               (remove name *hash-table-tests* :test #'eq :key #'car)))
  73   name)
  74 \f
  75 ;;;; construction and simple accessors
  76
  77 (defconstant +min-hash-table-size+ 16)
  78
  79 (defun make-hash-table (&key (test 'eql)
  80                              (size +min-hash-table-size+)
  81                              (rehash-size 1.5)
  82                              (rehash-threshold 1)
  83                              (weak-p nil))
  84   #!+sb-doc
  85   "Create and return a new hash table. The keywords are as follows:
  86      :TEST -- Indicates what kind of test to use.
  87      :SIZE -- A hint as to how many elements will be put in this hash
  88        table.
  89      :REHASH-SIZE -- Indicates how to expand the table when it fills up.
  90        If an integer, add space for that many elements. If a floating
  91        point number (which must be greater than 1.0), multiply the size
  92        by that amount.
  93      :REHASH-THRESHOLD -- Indicates how dense the table can become before
  94        forcing a rehash. Can be any positive number <=1, with density
  95        approaching zero as the threshold approaches 0. Density 1 means an
  96        average of one entry per bucket.
  97      :WEAK-P -- (This is an extension from CMU CL, not currently supported
  98        in SBCL 0.6.6, but perhaps supported in a future version.) If T,
  99        don't keep entries if the key would otherwise be garbage."
 100   (declare (type (or function symbol) test))
 101   (declare (type unsigned-byte size))
 102   (when weak-p
 103     (error "stub: unsupported WEAK-P option"))
 104   (multiple-value-bind (test test-fun hash-fun)
 105       (cond ((or (eq test #'eq) (eq test 'eq))
 106              (values 'eq #'eq #'eq-hash))
 107             ((or (eq test #'eql) (eq test 'eql))
 108              (values 'eql #'eql #'eql-hash))
 109             ((or (eq test #'equal) (eq test 'equal))
 110              (values 'equal #'equal #'equal-hash))
 111             ((or (eq test #'equalp) (eq test 'equalp))
 112              (values 'equalp #'equalp #'equalp-hash))
 113             (t
 114              ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff.
 115              ;; Failing that, I'd like to rename it to
 116              ;; *USER-HASH-TABLE-TESTS*.
 117              (dolist (info *hash-table-tests*
 118                            (error "unknown :TEST for MAKE-HASH-TABLE: ~S"
 119                                   test))
 120                (destructuring-bind (test-name test-fun hash-fun) info
 121                  (when (or (eq test test-name) (eq test test-fun))
 122                    (return (values test-name test-fun hash-fun)))))))
 123     (let* ((size (max +min-hash-table-size+
 124                       (min size
 125                            ;; SIZE is just a hint, so if the user asks
 126                            ;; for a SIZE which'd be too big for us to
 127                            ;; easily implement, we bump it down.
 128                            (floor array-dimension-limit 16))))
 129            (rehash-size (if (integerp rehash-size)
 130                             rehash-size
 131                             (float rehash-size 1.0)))
 132            ;; FIXME: Original REHASH-THRESHOLD default should be 1.0,
 133            ;; not 1, to make it easier for the compiler to avoid
 134            ;; boxing.
 135            (rehash-threshold (float rehash-threshold 1.0))
 136            (size+1 (1+ size))           ; The first element is not usable.
 137            (scaled-size (round (/ (float size+1) rehash-threshold)))
 138            (length (almost-primify (max scaled-size
 139                                         (1+ +min-hash-table-size+))))
 140            (index-vector (make-array length
 141                                      :element-type '(unsigned-byte 32)
 142                                      :initial-element 0))
 143            ;; needs to be the same length as the KV vector
 144            (next-vector (make-array size+1
 145                                     :element-type '(unsigned-byte 32)))
 146            (kv-vector (make-array (* 2 size+1)
 147                                   :initial-element +empty-ht-slot+))
 148            (table (%make-hash-table
 149                    :test test
 150                    :test-fun test-fun
 151                    :hash-fun hash-fun
 152                    :rehash-size rehash-size
 153                    :rehash-threshold rehash-threshold
 154                    :rehash-trigger size
 155                    :table kv-vector
 156                    :weak-p weak-p
 157                    :index-vector index-vector
 158                    :next-vector next-vector
 159                    :hash-vector (unless (eq test 'eq)
 160                                   (make-array size+1
 161                                               :element-type '(unsigned-byte 32)
 162                                               :initial-element #x80000000)))))
 163       (declare (type index size+1 scaled-size length))
 164       ;; Set up the free list, all free. These lists are 0 terminated.
 165       (do ((i 1 (1+ i)))
 166           ((>= i size))
 167         (setf (aref next-vector i) (1+ i)))
 168       (setf (aref next-vector size) 0)
 169       (setf (hash-table-next-free-kv table) 1)
 170       (setf (hash-table-needing-rehash table) 0)
 171       (setf (aref kv-vector 0) table)
 172       table)))
 173
 174 (defun hash-table-count (hash-table)
 175   #!+sb-doc
 176   "Returns the number of entries in the given HASH-TABLE."
 177   (declare (type hash-table hash-table)
 178            (values index))
 179   (hash-table-number-entries hash-table))
 180
 181 #!+sb-doc
 182 (setf (fdocumentation 'hash-table-rehash-size 'function)
 183       "Return the rehash-size HASH-TABLE was created with.")
 184
 185 #!+sb-doc
 186 (setf (fdocumentation 'hash-table-rehash-threshold 'function)
 187       "Return the rehash-threshold HASH-TABLE was created with.")
 188
 189 (defun hash-table-size (hash-table)
 190   #!+sb-doc
 191   "Return a size that can be used with MAKE-HASH-TABLE to create a hash
 192    table that can hold however many entries HASH-TABLE can hold without
 193    having to be grown."
 194   (hash-table-rehash-trigger hash-table))
 195
 196 #!+sb-doc
 197 (setf (fdocumentation 'hash-table-test 'function)
 198       "Return the test HASH-TABLE was created with.")
 199
 200 #!+sb-doc
 201 (setf (fdocumentation 'hash-table-weak-p 'function)
 202       "Return T if HASH-TABLE will not keep entries for keys that would
 203    otherwise be garbage, and NIL if it will.")
 204 \f
 205 ;;;; accessing functions
 206
 207 ;;; Make new vectors for the table, extending the table based on the
 208 ;;; rehash-size.
 209 (defun rehash (table)
 210   (declare (type hash-table table))
 211   (let* ((old-kv-vector (hash-table-table table))
 212          (old-next-vector (hash-table-next-vector table))
 213          (old-hash-vector (hash-table-hash-vector table))
 214          (old-size (length old-next-vector))
 215          (new-size
 216           (let ((rehash-size (hash-table-rehash-size table)))
 217             (etypecase rehash-size
 218               (fixnum
 219                (+ rehash-size old-size))
 220               (float
 221                (the index (round (* rehash-size old-size)))))))
 222          (new-kv-vector (make-array (* 2 new-size)
 223                                     :initial-element +empty-ht-slot+))
 224          (new-next-vector (make-array new-size
 225                                       :element-type '(unsigned-byte 32)
 226                                       :initial-element 0))
 227          (new-hash-vector (when old-hash-vector
 228                             (make-array new-size
 229                                         :element-type '(unsigned-byte 32)
 230                                         :initial-element #x80000000)))
 231          (old-index-vector (hash-table-index-vector table))
 232          (new-length (almost-primify
 233                       (round (/ (float new-size)
 234                                 (hash-table-rehash-threshold table)))))
 235          (new-index-vector (make-array new-length
 236                                        :element-type '(unsigned-byte 32)
 237                                        :initial-element 0)))
 238     (declare (type index new-size new-length old-size))
 239
 240     ;; Disable GC tricks on the OLD-KV-VECTOR.
 241     (set-header-data old-kv-vector sb!vm:vector-normal-subtype)
 242
 243     ;; Copy over the kv-vector. The element positions should not move
 244     ;; in case there are active scans.
 245     (dotimes (i (* old-size 2))
 246       (declare (type index i))
 247       (setf (aref new-kv-vector i) (aref old-kv-vector i)))
 248
 249     ;; Copy over the hash-vector.
 250     (when old-hash-vector
 251       (dotimes (i old-size)
 252         (setf (aref new-hash-vector i) (aref old-hash-vector i))))
 253
 254     (setf (hash-table-next-free-kv table) 0)
 255     (setf (hash-table-needing-rehash table) 0)
 256     ;; Rehash all the entries; last to first so that after the pushes
 257     ;; the chains are first to last.
 258     (do ((i (1- new-size) (1- i)))
 259         ((zerop i))
 260       (let ((key (aref new-kv-vector (* 2 i)))
 261             (value (aref new-kv-vector (1+ (* 2 i)))))
 262         (cond ((and (eq key +empty-ht-slot+)
 263                     (eq value +empty-ht-slot+))
 264                ;; Slot is empty, push it onto the free list.
 265                (setf (aref new-next-vector i)
 266                      (hash-table-next-free-kv table))
 267                (setf (hash-table-next-free-kv table) i))
 268               ((and new-hash-vector
 269                     (not (= (aref new-hash-vector i) #x80000000)))
 270                ;; Can use the existing hash value (not EQ based)
 271                (let* ((hashing (aref new-hash-vector i))
 272                       (index (rem hashing new-length))
 273                       (next (aref new-index-vector index)))
 274                  (declare (type index index)
 275                           (type hash hashing))
 276                  ;; Push this slot into the next chain.
 277                  (setf (aref new-next-vector i) next)
 278                  (setf (aref new-index-vector index) i)))
 279               (t
 280                ;; EQ base hash.
 281                ;; Enable GC tricks.
 282                (set-header-data new-kv-vector
 283                                 sb!vm:vector-valid-hashing-subtype)
 284                (let* ((hashing (pointer-hash key))
 285                       (index (rem hashing new-length))
 286                       (next (aref new-index-vector index)))
 287                  (declare (type index index)
 288                           (type hash hashing))
 289                  ;; Push this slot onto the next chain.
 290                  (setf (aref new-next-vector i) next)
 291                  (setf (aref new-index-vector index) i))))))
 292     (setf (hash-table-table table) new-kv-vector)
 293     (setf (hash-table-index-vector table) new-index-vector)
 294     (setf (hash-table-next-vector table) new-next-vector)
 295     (setf (hash-table-hash-vector table) new-hash-vector)
 296     ;; Shrink the old vectors to 0 size to help the conservative GC.
 297     (shrink-vector old-kv-vector 0)
 298     (shrink-vector old-index-vector 0)
 299     (shrink-vector old-next-vector 0)
 300     (when old-hash-vector
 301       (shrink-vector old-hash-vector 0))
 302     (setf (hash-table-rehash-trigger table) new-size))
 303   (values))
 304
 305 ;;; Use the same size as before, re-using the vectors.
 306 (defun rehash-without-growing (table)
 307   (declare (type hash-table table))
 308   (let* ((kv-vector (hash-table-table table))
 309          (next-vector (hash-table-next-vector table))
 310          (hash-vector (hash-table-hash-vector table))
 311          (size (length next-vector))
 312          (index-vector (hash-table-index-vector table))
 313          (length (length index-vector)))
 314     (declare (type index size length)
 315              (type (simple-array (unsigned-byte 32) (*))))
 316
 317     ;; Disable GC tricks, they will be re-enabled during the re-hash
 318     ;; if necesary.
 319     (set-header-data kv-vector sb!vm:vector-normal-subtype)
 320
 321     ;; Rehash all the entries.
 322     (setf (hash-table-next-free-kv table) 0)
 323     (setf (hash-table-needing-rehash table) 0)
 324     (dotimes (i size)
 325       (setf (aref next-vector i) 0))
 326     (dotimes (i length)
 327       (setf (aref index-vector i) 0))
 328     (do ((i (1- size) (1- i)))
 329         ((zerop i))
 330       (let ((key (aref kv-vector (* 2 i)))
 331             (value (aref kv-vector (1+ (* 2 i)))))
 332         (cond ((and (eq key +empty-ht-slot+)
 333                     (eq value +empty-ht-slot+))
 334                ;; Slot is empty, push it onto free list.
 335                (setf (aref next-vector i) (hash-table-next-free-kv table))
 336                (setf (hash-table-next-free-kv table) i))
 337               ((and hash-vector (not (= (aref hash-vector i) #x80000000)))
 338                ;; Can use the existing hash value (not EQ based)
 339                (let* ((hashing (aref hash-vector i))
 340                       (index (rem hashing length))
 341                       (next (aref index-vector index)))
 342                  (declare (type index index))
 343                  ;; Push this slot into the next chain.
 344                  (setf (aref next-vector i) next)
 345                  (setf (aref index-vector index) i)))
 346               (t
 347                ;; EQ base hash.
 348                ;; Enable GC tricks.
 349                (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)
 350                (let* ((hashing (pointer-hash key))
 351                       (index (rem hashing length))
 352                       (next (aref index-vector index)))
 353                  (declare (type index index)
 354                           (type hash hashing))
 355                  ;; Push this slot into the next chain.
 356                  (setf (aref next-vector i) next)
 357                  (setf (aref index-vector index) i)))))))
 358   (values))
 359
 360 (defun flush-needing-rehash (table)
 361   (let* ((kv-vector (hash-table-table table))
 362          (index-vector (hash-table-index-vector table))
 363          (next-vector (hash-table-next-vector table))
 364          (length (length index-vector)))
 365     (do ((next (hash-table-needing-rehash table)))
 366         ((zerop next))
 367       (declare (type index next))
 368       (let* ((key (aref kv-vector (* 2 next)))
 369              (hashing (pointer-hash key))
 370              (index (rem hashing length))
 371              (temp (aref next-vector next)))
 372         (setf (aref next-vector next) (aref index-vector index))
 373         (setf (aref index-vector index) next)
 374         (setf next temp))))
 375   (setf (hash-table-needing-rehash table) 0)
 376   (values))
 377
 378 (defun gethash (key hash-table &optional default)
 379   #!+sb-doc
 380   "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
 381    value and T as multiple values, or returns DEFAULT and NIL if there is no
 382    such entry. Entries can be added using SETF."
 383   (declare (type hash-table hash-table)
 384            (values t (member t nil)))
 385   (without-gcing
 386    (cond ((= (get-header-data (hash-table-table hash-table))
 387              sb!vm:vector-must-rehash-subtype)
 388           (rehash-without-growing hash-table))
 389          ((not (zerop (hash-table-needing-rehash hash-table)))
 390           (flush-needing-rehash hash-table)))
 391    ;; Search for key in the hash table.
 392    (multiple-value-bind (hashing eq-based)
 393        (funcall (hash-table-hash-fun hash-table) key)
 394      (declare (type hash hashing))
 395      (let* ((index-vector (hash-table-index-vector hash-table))
 396             (length (length index-vector))
 397             (index (rem hashing length))
 398             (next (aref index-vector index))
 399             (table (hash-table-table hash-table))
 400             (next-vector (hash-table-next-vector hash-table))
 401             (hash-vector (hash-table-hash-vector hash-table))
 402             (test-fun (hash-table-test-fun hash-table)))
 403        (declare (type index index))
 404        ;; Search next-vector chain for a matching key.
 405        (if (or eq-based (not hash-vector))
 406            (do ((next next (aref next-vector next)))
 407                ((zerop next) (values default nil))
 408              (declare (type index next))
 409              (when (eq key (aref table (* 2 next)))
 410                (return (values (aref table (1+ (* 2 next))) t))))
 411            (do ((next next (aref next-vector next)))
 412                ((zerop next) (values default nil))
 413              (declare (type index next))
 414              (when (and (= hashing (aref hash-vector next))
 415                         (funcall test-fun key (aref table (* 2 next))))
 416                ;; Found.
 417                (return (values (aref table (1+ (* 2 next))) t)))))))))
 418
 419 ;;; so people can call #'(SETF GETHASH)
 420 (defun (setf gethash) (new-value key table &optional default)
 421   (declare (ignore default))
 422   (%puthash key table new-value))
 423
 424 (defun %puthash (key hash-table value)
 425   (declare (type hash-table hash-table))
 426   (assert (hash-table-index-vector hash-table))
 427   (without-gcing
 428    ;; We need to rehash here so that a current key can be found if it
 429    ;; exists. Check that there is room for one more entry. May not be
 430    ;; needed if the key is already present.
 431    (cond ((zerop (hash-table-next-free-kv hash-table))
 432           (rehash hash-table))
 433          ((= (get-header-data (hash-table-table hash-table))
 434              sb!vm:vector-must-rehash-subtype)
 435           (rehash-without-growing hash-table))
 436          ((not (zerop (hash-table-needing-rehash hash-table)))
 437           (flush-needing-rehash hash-table)))
 438
 439    ;; Search for key in the hash table.
 440    (multiple-value-bind (hashing eq-based)
 441        (funcall (hash-table-hash-fun hash-table) key)
 442      (declare (type hash hashing))
 443      (let* ((index-vector (hash-table-index-vector hash-table))
 444             (length (length index-vector))
 445             (index (rem hashing length))
 446             (next (aref index-vector index))
 447             (kv-vector (hash-table-table hash-table))
 448             (next-vector (hash-table-next-vector hash-table))
 449             (hash-vector (hash-table-hash-vector hash-table))
 450             (test-fun (hash-table-test-fun hash-table)))
 451        (declare (type index index))
 452
 453        (cond ((or eq-based (not hash-vector))
 454               (when eq-based
 455                 (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype))
 456
 457               ;; Search next-vector chain for a matching key.
 458               (do ((next next (aref next-vector next)))
 459                   ((zerop next))
 460                 (declare (type index next))
 461                 (when (eq key (aref kv-vector (* 2 next)))
 462                   ;; Found, just replace the value.
 463                   (setf (aref kv-vector (1+ (* 2 next))) value)
 464                   (return-from %puthash value))))
 465              (t
 466               ;; Search next-vector chain for a matching key.
 467               (do ((next next (aref next-vector next)))
 468                   ((zerop next))
 469                 (declare (type index next))
 470                 (when (and (= hashing (aref hash-vector next))
 471                            (funcall test-fun key
 472                                     (aref kv-vector (* 2 next))))
 473                   ;; Found, just replace the value.
 474                   (setf (aref kv-vector (1+ (* 2 next))) value)
 475                   (return-from %puthash value)))))
 476
 477        ;; Pop a KV slot off the free list
 478        (let ((free-kv-slot (hash-table-next-free-kv hash-table)))
 479          ;; Double-check for overflow.
 480          (assert (not (zerop free-kv-slot)))
 481          (setf (hash-table-next-free-kv hash-table)
 482                (aref next-vector free-kv-slot))
 483          (incf (hash-table-number-entries hash-table))
 484
 485          (setf (aref kv-vector (* 2 free-kv-slot)) key)
 486          (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value)
 487
 488          ;; Setup the hash-vector if necessary.
 489          (when hash-vector
 490            (if (not eq-based)
 491                (setf (aref hash-vector free-kv-slot) hashing)
 492                (assert (= (aref hash-vector free-kv-slot) #x80000000))))
 493
 494          ;; Push this slot into the next chain.
 495          (setf (aref next-vector free-kv-slot) next)
 496          (setf (aref index-vector index) free-kv-slot)))))
 497   value)
 498
 499 (defun remhash (key hash-table)
 500   #!+sb-doc
 501   "Remove the entry in HASH-TABLE associated with KEY. Returns T if there
 502    was such an entry, and NIL if not."
 503   (declare (type hash-table hash-table)
 504            (values (member t nil)))
 505   (without-gcing
 506    ;; We need to rehash here so that a current key can be found if it
 507    ;; exists.
 508    (cond ((= (get-header-data (hash-table-table hash-table))
 509              sb!vm:vector-must-rehash-subtype)
 510           (rehash-without-growing hash-table))
 511          ((not (zerop (hash-table-needing-rehash hash-table)))
 512           (flush-needing-rehash hash-table)))
 513
 514    ;; Search for key in the hash table.
 515    (multiple-value-bind (hashing eq-based)
 516        (funcall (hash-table-hash-fun hash-table) key)
 517      (declare (type hash hashing))
 518      (let* ((index-vector (hash-table-index-vector hash-table))
 519             (length (length index-vector))
 520             (index (rem hashing length))
 521             (next (aref index-vector index))
 522             (table (hash-table-table hash-table))
 523             (next-vector (hash-table-next-vector hash-table))
 524             (hash-vector (hash-table-hash-vector hash-table))
 525             (test-fun (hash-table-test-fun hash-table)))
 526        (declare (type index index next))
 527        (cond ((zerop next)
 528               nil)
 529              ((if (or eq-based (not hash-vector))
 530                   (eq key (aref table (* 2 next)))
 531                   (and (= hashing (aref hash-vector next))
 532                        (funcall test-fun key (aref table (* 2 next)))))
 533
 534               ;; FIXME: Substantially the same block of code seems to
 535               ;; appear in all three cases. (In the first case, it
 536               ;; appear bare; in the other two cases, it's wrapped in
 537               ;; DO.) It should be defined in a separate (possibly
 538               ;; inline) DEFUN or FLET.
 539
 540               ;; Mark slot as empty.
 541               (setf (aref table (* 2 next)) +empty-ht-slot+
 542                     (aref table (1+ (* 2 next))) +empty-ht-slot+)
 543               ;; Update the index-vector pointer.
 544               (setf (aref index-vector index) (aref next-vector next))
 545               ;; Push KV slot onto free chain.
 546               (setf (aref next-vector next)
 547                     (hash-table-next-free-kv hash-table))
 548               (setf (hash-table-next-free-kv hash-table) next)
 549               (when hash-vector
 550                 (setf (aref hash-vector next) #x80000000))
 551               (decf (hash-table-number-entries hash-table))
 552               t)
 553              ;; Search next-vector chain for a matching key.
 554              ((or eq-based (not hash-vector))
 555               ;; EQ based
 556               (do ((prior next next)
 557                    (next (aref next-vector next) (aref next-vector next)))
 558                   ((zerop next) nil)
 559                 (declare (type index next))
 560                 (when (eq key (aref table (* 2 next)))
 561                   ;; Mark slot as empty.
 562                   (setf (aref table (* 2 next)) +empty-ht-slot+
 563                         (aref table (1+ (* 2 next))) +empty-ht-slot+)
 564                   ;; Update the prior pointer in the chain to skip this.
 565                   (setf (aref next-vector prior) (aref next-vector next))
 566                   ;; Push KV slot onto free chain.
 567                   (setf (aref next-vector next)
 568                         (hash-table-next-free-kv hash-table))
 569                   (setf (hash-table-next-free-kv hash-table) next)
 570                   (when hash-vector
 571                     (setf (aref hash-vector next) #x80000000))
 572                   (decf (hash-table-number-entries hash-table))
 573                   (return t))))
 574              (t
 575               ;; not EQ based
 576               (do ((prior next next)
 577                    (next (aref next-vector next) (aref next-vector next)))
 578                   ((zerop next) nil)
 579                 (declare (type index next))
 580                 (when (and (= hashing (aref hash-vector next))
 581                            (funcall test-fun key (aref table (* 2 next))))
 582                   ;; Mark slot as empty.
 583                   (setf (aref table (* 2 next)) +empty-ht-slot+)
 584                   (setf (aref table (1+ (* 2 next))) +empty-ht-slot+)
 585                   ;; Update the prior pointer in the chain to skip this.
 586                   (setf (aref next-vector prior) (aref next-vector next))
 587                   ;; Push KV slot onto free chain.
 588                   (setf (aref next-vector next)
 589                         (hash-table-next-free-kv hash-table))
 590                   (setf (hash-table-next-free-kv hash-table) next)
 591                   (when hash-vector
 592                     (setf (aref hash-vector next) #x80000000))
 593                   (decf (hash-table-number-entries hash-table))
 594                   (return t)))))))))
 595
 596 (defun clrhash (hash-table)
 597   #!+sb-doc
 598   "This removes all the entries from HASH-TABLE and returns the hash table
 599    itself."
 600   (let* ((kv-vector (hash-table-table hash-table))
 601          (kv-length (length kv-vector))
 602          (next-vector (hash-table-next-vector hash-table))
 603          (hash-vector (hash-table-hash-vector hash-table))
 604          (size (length next-vector))
 605          (index-vector (hash-table-index-vector hash-table))
 606          (length (length index-vector)))
 607     ;; Disable GC tricks.
 608     (set-header-data kv-vector sb!vm:vector-normal-subtype)
 609     ;; Mark all slots as empty by setting all keys and values to magic
 610     ;; tag.
 611     (do ((i 2 (1+ i)))
 612         ((>= i kv-length))
 613       (setf (aref kv-vector i) +empty-ht-slot+))
 614     (assert (eq (aref kv-vector 0) hash-table))
 615     ;; Set up the free list, all free.
 616     (do ((i 1 (1+ i)))
 617         ((>= i (1- size)))
 618       (setf (aref next-vector i) (1+ i)))
 619     (setf (aref next-vector (1- size)) 0)
 620     (setf (hash-table-next-free-kv hash-table) 1)
 621     (setf (hash-table-needing-rehash hash-table) 0)
 622     ;; Clear the index-vector.
 623     (dotimes (i length)
 624       (setf (aref index-vector i) 0))
 625     ;; Clear the hash-vector.
 626     (when hash-vector
 627       (dotimes (i size)
 628         (setf (aref hash-vector i) #x80000000))))
 629   (setf (hash-table-number-entries hash-table) 0)
 630   hash-table)
 631 \f
 632 ;;;; MAPHASH
 633
 634 ;;; FIXME: This should be made into a compiler transform for two reasons:
 635 ;;;   1. It would then be available for compiling the entire system,
 636 ;;;      not only parts of the system which are defined after DEFUN MAPHASH.
 637 ;;;   2. It could be conditional on compilation policy, so that
 638 ;;;      it could be compiled as a full call instead of an inline
 639 ;;;      expansion when SPACE>SPEED. (Not only would this save space,
 640 ;;;      it might actually be faster when a call is made from byte-compiled
 641 ;;;      code.)
 642 (declaim (inline maphash))
 643 (defun maphash (function-designator hash-table)
 644   #!+sb-doc
 645   "For each entry in HASH-TABLE, call the designated function on the key
 646    and value of the entry. Return NIL."
 647   (let ((fun (%coerce-callable-to-function function-designator))
 648         (size (length (hash-table-next-vector hash-table))))
 649     (declare (type function fun))
 650     (do ((i 1 (1+ i)))
 651         ((>= i size))
 652       (declare (type index i))
 653       (let* ((kv-vector (hash-table-table hash-table))
 654              (key (aref kv-vector (* 2 i)))
 655              (value (aref kv-vector (1+ (* 2 i)))))
 656         (unless (and (eq key +empty-ht-slot+)
 657                      (eq value +empty-ht-slot+))
 658           (funcall fun key value))))))
 659 \f
 660 ;;;; methods on HASH-TABLE
 661
 662 (def!method print-object ((ht hash-table) stream)
 663   (declare (type stream stream))
 664   (print-unreadable-object (ht stream :type t :identity t)
 665     (format stream
 666             ":TEST ~S :COUNT ~D"
 667             (hash-table-test ht)
 668             (hash-table-number-entries ht))))
 669
 670 (def!method make-load-form ((hash-table hash-table) &optional environment)
 671   (declare (ignorable environment))
 672   (values
 673    `(make-hash-table
 674      :test             ',(hash-table-test hash-table)
 675      :size             ',(hash-table-size hash-table)
 676      :rehash-size      ',(hash-table-rehash-size hash-table)
 677      :rehash-threshold ',(hash-table-rehash-threshold hash-table))
 678    (let ((alist nil))
 679      (maphash (lambda (key value)
 680                 (push (cons key value) alist))
 681               hash-table)
 682      (if alist
 683          ;; FIXME: It'd probably be more efficient here to write the
 684          ;; hash table values as a SIMPLE-VECTOR rather than an alist.
 685          ;; (Someone dumping a huge hash table might well thank us..)
 686          `(stuff-hash-table ,hash-table ',alist)
 687          nil))))
 688
 689 (defun stuff-hash-table (table alist)
 690   (dolist (x alist)
 691     (setf (gethash (car x) table) (cdr x))))