From 46f3e101a821097f653fdff78fcd34673cf58cc9 Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Mon, 3 Nov 1997 16:08:42 +0000 Subject: [PATCH] Re-write of the hash table algorithms to improve the memory efficiency and solve problems with rehashing during hash traversal. --- code/hash-new.lisp | 943 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 943 insertions(+) create mode 100644 code/hash-new.lisp diff --git a/code/hash-new.lisp b/code/hash-new.lisp new file mode 100644 index 000000000..e4aa64889 --- /dev/null +++ b/code/hash-new.lisp @@ -0,0 +1,943 @@ +;;; -*- Package: CL -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.1 1997/11/03 16:08:42 dtc Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Hashing and hash table functions for Spice Lisp. +;;; Originally written by Skef Wholey. +;;; Everything except SXHASH rewritten by William Lott. +;;; Hash table functions rewritten by Douglas Crosher, 1997. +;;; +(in-package :common-lisp) + +(export '(hash-table hash-table-p make-hash-table + gethash remhash maphash clrhash + hash-table-count with-hash-table-iterator + hash-table-rehash-size hash-table-rehash-threshold + hash-table-size hash-table-test sxhash)) + +(in-package :ext) +(export '(define-hash-table-test)) + +(in-package :common-lisp) + + +;;;; The hash-table structures. + +;;; HASH-TABLE -- defstruct. +;;; +(defstruct (hash-table + (:constructor %make-hash-table) + (:print-function %print-hash-table) + (:make-load-form-fun make-hash-table-load-form)) + "Structure used to implement hash tables." + ;; + ;; The type of hash table this is. Only used for printing and as part of + ;; the exported interface. + (test (required-argument) :type symbol :read-only t) + ;; + ;; The function used to compare two keys. Returns T if they are the same + ;; and NIL if not. + (test-fun (required-argument) :type function :read-only t) + ;; + ;; The function used to compute the hashing of a key. Returns two values: + ;; the index hashing and T if that might change with the next GC. + (hash-fun (required-argument) :type function :read-only t) + ;; + ;; How much to grow the hash table by when it fills up. If an index, then + ;; add that amount. If a floating point number, then multiple it by that. + (rehash-size (required-argument) :type (or index (single-float (1.0))) + :read-only t) + ;; + ;; How full the hash table has to get before we rehash. + (rehash-threshold (required-argument) :type (single-float (0.0) 1.0) + :read-only t) + ;; + ;; The number of entries before a rehash, just the one less than the + ;; size of the next-vector, hash-vector, and half the size of the + ;; kv-vector. + (rehash-trigger (required-argument) :type index) + ;; + ;; The current number of entries in the table. + (number-entries 0 :type index) + ;; + ;; The Key-Value pair vector. + (table (required-argument) :type simple-vector) + ;; + ;; True if this is a weak hash table, meaning that key->value mappings will + ;; disappear if there are no other references to the key. Note: this only + ;; matters if the hash function indicates that the hashing is EQ based. + (weak-p nil :type (member t nil)) + ;; + ;; Index into the next-vector, chaining together buckets that need + ;; to be rehashed because their hashing is EQ based and the key has + ;; been moved by the garbage collector. + (needing-rehash 0 :type index) + ;; + ;; Index into the Next vector chaining together free slots in the KV + ;; vector. + (next-free-kv 0 :type index) + ;; + ;; The index vector. This may be larger than the hash size to help + ;; reduce collisions. + (index-vector (required-argument) + :type (simple-array (unsigned-byte 32) (*))) + ;; + ;; This table parallels the KV vector, and is used to chain together + ;; the hash buckets, the free list, and the values needing rehash, a + ;; slot will only ever be in one of these lists. + (next-vector (required-argument) :type (simple-array (unsigned-byte 32) (*))) + ;; + ;; This table parallels the KV table, and can be used to store the + ;; hash associated with the key, saving recalculation. Could be + ;; useful for EQL, and EQUAL hash tables. This table is not needed + ;; for EQ hash tables, and when present the value of #x8000000 + ;; represents EQ-based hashing on the respective Key. + (hash-vector nil :type (or null (simple-array (unsigned-byte 32) (*))))) +;;; +(defun %print-hash-table (ht stream depth) + (declare (ignore depth) (stream stream)) + (print-unreadable-object (ht stream :identity t) + (format stream "~A hash table, ~D entr~@:P" + (symbol-name (hash-table-test ht)) + (hash-table-number-entries ht)))) + +(defconstant max-hash most-positive-fixnum) + +(deftype hash () + `(integer 0 ,max-hash)) + + +;;;; Utility functions. + +(declaim (inline pointer-hash)) +(defun pointer-hash (key) + (declare (values hash)) + (truly-the hash (%primitive make-fixnum key))) + +(declaim (inline eq-hash)) +(defun eq-hash (key) + (declare (values hash (member t nil))) + (values (pointer-hash key) + (oddp (get-lisp-obj-address key)))) + +(declaim (inline eql-hash)) +(defun eql-hash (key) + (declare (values hash (member t nil))) + (if (numberp key) + (equal-hash key) + (eq-hash key))) + +(declaim (inline equal-hash)) +(defun equal-hash (key) + (declare (values hash (member t nil))) + (values (sxhash key) nil)) + + +(defun almost-primify (num) + (declare (type index num)) + "Almost-Primify returns an almost prime number greater than or equal + to NUM." + (if (= (rem num 2) 0) + (setq num (+ 1 num))) + (if (= (rem num 3) 0) + (setq num (+ 2 num))) + (if (= (rem num 7) 0) + (setq num (+ 4 num))) + num) + + + +;;;; User defined hash table tests. + +;;; *HASH-TABLE-TESTS* -- Internal. +;;; +(defvar *hash-table-tests* nil) + +;;; DEFINE-HASH-TABLE-TEST -- Public. +;;; +(defun define-hash-table-test (name test-fun hash-fun) + "Define a new kind of hash table test." + (declare (type symbol name) + (type function test-fun hash-fun)) + (setf *hash-table-tests* + (cons (list name test-fun hash-fun) + (remove name *hash-table-tests* :test #'eq :key #'car))) + name) + + +;;;; Construction and simple accessors. + +;;; MAKE-HASH-TABLE -- public. +;;; +(defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5) + (rehash-threshold 1) (weak-p nil)) + "Creates and returns a new hash table. The keywords are as follows: + :TEST -- Indicates what kind of test to use. Only EQ, EQL, and EQUAL + are currently supported. + :SIZE -- A hint as to how many elements will be put in this hash + table. + :REHASH-SIZE -- Indicates how to expand the table when it fills up. + If an integer, add space for that many elements. If a floating + point number (which must be greater than 1.0), multiple the size + by that amount. + :REHASH-THRESHOLD -- Indicates how dense the table can become before + forcing a rehash. Can be any positive number <= to 1, with density + approaching zero as the threshold approaches 0. Density 1 means an + average of one entry per bucket. + CMUCL Extension: + :WEAK-P -- If T, don't keep entries if the key would otherwise be + garbage." + (declare (type (or function symbol) test) + (type index size) (type (member t nil) weak-p)) + (let ((rehash-size (if (integerp rehash-size) + rehash-size + (float rehash-size 1.0))) + (rehash-threshold (float rehash-threshold 1.0))) + (multiple-value-bind + (test test-fun hash-fun) + (cond ((or (eq test #'eq) (eq test 'eq)) + (values 'eq #'eq #'eq-hash)) + ((or (eq test #'eql) (eq test 'eql)) + (values 'eql #'eql #'eql-hash)) + ((or (eq test #'equal) (eq test 'equal)) + (values 'equal #'equal #'equal-hash)) + (t + (dolist (info *hash-table-tests* + (error "Unknown :TEST for MAKE-HASH-TABLE: ~S" + test)) + (destructuring-bind + (test-name test-fun hash-fun) + info + (when (or (eq test test-name) (eq test test-fun)) + (return (values test-name test-fun hash-fun))))))) + (let* ((size (max 36 size)) ; Needs to be at least 1, say 36. + (size+1 (1+ size)) ; The first element is not usable. + (scaled-size (round (/ (float size+1) rehash-threshold))) + (length (if (<= scaled-size 37) 37 (almost-primify scaled-size)))) + (declare (type index size+1 scaled-size length)) + (when weak-p + (format t "* Creating unsupported weak-p hash table~%")) + (let* ((index-vector + (make-array length :element-type '(unsigned-byte 32) + :initial-element 0)) + ;; Needs to be the same length as the KV vector + (next-vector + (make-array size+1 :element-type '(unsigned-byte 32))) + (kv-vector (make-array (* 2 size+1) :initial-element :empty)) + (table + (%make-hash-table + :test test + :test-fun test-fun + :hash-fun hash-fun + :rehash-size rehash-size + :rehash-threshold rehash-threshold + :rehash-trigger size + :table kv-vector + :weak-p weak-p + :index-vector index-vector + :next-vector next-vector + :hash-vector (unless (eq test 'eq) + (make-array size+1 + :element-type '(unsigned-byte 32) + :initial-element #x80000000))))) + ;; Setup the free list, all free. These lists are 0 + ;; terminated. + (do ((i 1 (1+ i))) + ((>= i size)) + (setf (aref next-vector i) (1+ i))) + (setf (aref next-vector size) 0) + (setf (hash-table-next-free-kv table) 1) + (setf (hash-table-needing-rehash table) 0) + (setf (aref kv-vector 0) table) + table))))) + + +(defun hash-table-count (hash-table) + "Returns the number of entries in the given HASH-TABLE." + (declare (type hash-table hash-table) + (values index)) + (hash-table-number-entries hash-table)) + +(setf (documentation 'hash-table-rehash-size 'function) + "Return the rehash-size HASH-TABLE was created with.") + +(setf (documentation 'hash-table-rehash-threshold 'function) + "Return the rehash-threshold HASH-TABLE was created with.") + +(defun hash-table-size (hash-table) + "Return a size that can be used with MAKE-HASH-TABLE to create a hash + table that can hold however many entries HASH-TABLE can hold without + having to be grown." + (hash-table-rehash-trigger hash-table)) + +(setf (documentation 'hash-table-test 'function) + "Return the test HASH-TABLE was created with.") + +(setf (documentation 'hash-table-weak-p 'function) + "Return T if HASH-TABLE will not keep entries for keys that would + otherwise be garbage, and NIL if it will.") + + +;;;; Accessing functions. + +;;; REHASH -- internal. +;;; +;;; Make new vectors for the table, extending the table based on the +;;; rehash-size. +;;; +(defun rehash (table) + (declare (type hash-table table)) + (let* ((old-kv-vector (hash-table-table table)) + (old-next-vector (hash-table-next-vector table)) + (old-hash-vector (hash-table-hash-vector table)) + (old-size (length old-next-vector)) + (new-size + (let ((rehash-size (hash-table-rehash-size table))) + (etypecase rehash-size + (fixnum + (+ rehash-size old-size)) + (float + (the index (round (* rehash-size old-size))))))) + (new-kv-vector (make-array (* 2 new-size) :initial-element :empty)) + (new-next-vector (make-array new-size + :element-type '(unsigned-byte 32) + :initial-element 0)) + (new-hash-vector (when old-hash-vector + (make-array new-size + :element-type '(unsigned-byte 32) + :initial-element #x80000000))) + (old-index-vector (hash-table-index-vector table)) + (new-length (almost-primify + (round (/ (float new-size) + (hash-table-rehash-threshold table))))) + (new-index-vector (make-array new-length + :element-type '(unsigned-byte 32) + :initial-element 0))) + (declare (type index new-size new-length old-size)) + + ;; Disable GC tricks on the old-kv-vector. + (set-header-data old-kv-vector vm:vector-normal-subtype) + + ;; Copy over the kv-vector, the element positions should not move + ;; in case there are active scans. + (dotimes (i (* old-size 2)) + (declare (type index i)) + (setf (aref new-kv-vector i) (aref old-kv-vector i))) + + ;; Copy over the hash-vector. + (when old-hash-vector + (dotimes (i old-size) + (setf (aref new-hash-vector i) (aref old-hash-vector i)))) + + (setf (hash-table-next-free-kv table) 0) + (setf (hash-table-needing-rehash table) 0) + ;; Rehash all the entries; last to first so that after the pushes + ;; the chains are first to last. + (do ((i (1- new-size) (1- i))) + ((zerop i)) + (let ((key (aref new-kv-vector (* 2 i))) + (value (aref new-kv-vector (1+ (* 2 i))))) + ;; Use Key and Value of :empty to indicate an empty slot. X + ;; Most certainly not valid. + (cond ((and (eq key :empty) (eq value :empty)) + ;; Push this slot onto the free list. + (setf (aref new-next-vector i) + (hash-table-next-free-kv table)) + (setf (hash-table-next-free-kv table) i)) + ((and new-hash-vector + (not (= (aref new-hash-vector i) #x80000000))) + ;; Can use the existing hash value (not EQ based) + (let* ((hashing (aref new-hash-vector i)) + (index (rem hashing new-length)) + (next (aref new-index-vector index))) + (declare (type index index) + (type hash hashing)) + ;; Push this slot into the next chain. + (setf (aref new-next-vector i) next) + (setf (aref new-index-vector index) i))) + (t + ;; EQ base hash. + ;; Enamble GC tricks. + (set-header-data new-kv-vector vm:vector-valid-hashing-subtype) + (let* ((hashing (pointer-hash key)) + (index (rem hashing new-length)) + (next (aref new-index-vector index))) + (declare (type index index) + (type hash hashing)) + ;; Push this slot onto the next chain. + (setf (aref new-next-vector i) next) + (setf (aref new-index-vector index) i)))))) + (setf (hash-table-table table) new-kv-vector) + (setf (hash-table-index-vector table) new-index-vector) + (setf (hash-table-next-vector table) new-next-vector) + (setf (hash-table-hash-vector table) new-hash-vector) + ;; Shrink the old vectors to 0 size to help the conservative GC. + (shrink-vector old-kv-vector 0) + (shrink-vector old-index-vector 0) + (shrink-vector old-next-vector 0) + (when old-hash-vector + (shrink-vector old-hash-vector 0)) + (setf (hash-table-rehash-trigger table) new-size)) + (undefined-value)) + +;;; REHASH-WITHOUT-GROWING -- internal. +;;; +;;; Use the same size as before, re-using the vectors. +;;; +(defun rehash-without-growing (table) + (declare (type hash-table table)) + (let* ((kv-vector (hash-table-table table)) + (next-vector (hash-table-next-vector table)) + (hash-vector (hash-table-hash-vector table)) + (size (length next-vector)) + (index-vector (hash-table-index-vector table)) + (length (length index-vector))) + (declare (type index size length) + (type (simple-array (unsigned-byte 32) (*)))) + + ;; Disable GC tricks, they will be re-enabled during the re-hash + ;; if necesary. + (set-header-data kv-vector vm:vector-normal-subtype) + + ;; Rehash all the entries. + (setf (hash-table-next-free-kv table) 0) + (setf (hash-table-needing-rehash table) 0) + (dotimes (i size) + (setf (aref next-vector i) 0)) + (dotimes (i length) + (setf (aref index-vector i) 0)) + (do ((i (1- size) (1- i))) + ((zerop i)) + (let ((key (aref kv-vector (* 2 i))) + (value (aref kv-vector (1+ (* 2 i))))) + ;; Use Key and Value of :empty to indicate an empty slot. X + ;; Most certainly not valid. + (cond ((and (eq key :empty) (eq value :empty)) + ;; Push this slot onto the free list. + (setf (aref next-vector i) (hash-table-next-free-kv table)) + (setf (hash-table-next-free-kv table) i)) + ((and hash-vector (not (= (aref hash-vector i) #x80000000))) + ;; Can use the existing hash value (not EQ based) + (let* ((hashing (aref hash-vector i)) + (index (rem hashing length)) + (next (aref index-vector index))) + (declare (type index index)) + ;; Push this slot into the next chain. + (setf (aref next-vector i) next) + (setf (aref index-vector index) i))) + (t + ;; EQ base hash. + ;; Enable GC tricks. + (set-header-data kv-vector vm:vector-valid-hashing-subtype) + (let* ((hashing (pointer-hash key)) + (index (rem hashing length)) + (next (aref index-vector index))) + (declare (type index index) + (type hash hashing)) + ;; Push this slot into the next chain. + (setf (aref next-vector i) next) + (setf (aref index-vector index) i))))))) + (undefined-value)) + +(defun flush-needing-rehash (table) + (let* ((kv-vector (hash-table-table table)) + (index-vector (hash-table-index-vector table)) + (next-vector (hash-table-next-vector table)) + (length (length index-vector))) + (do ((next (hash-table-needing-rehash table))) + ((zerop next)) + (declare (type index next)) + (let* ((key (aref kv-vector (* 2 next))) + (hashing (pointer-hash key)) + (index (rem hashing length)) + (temp (aref next-vector next))) + (setf (aref next-vector next) (aref index-vector index)) + (setf (aref index-vector index) next) + (setf next temp)))) + (setf (hash-table-needing-rehash table) 0) + (undefined-value)) + +;;; GETHASH -- Public. +;;; +(defun gethash (key hash-table &optional default) + "Finds the entry in HASH-TABLE whose key is KEY and returns the associated + value and T as multiple values, or returns DEFAULT and NIL if there is no + such entry. Entries can be added using SETF." + (declare (type hash-table hash-table) + (values t (member t nil))) + (without-gcing + (cond ((= (get-header-data (hash-table-table hash-table)) + vm:vector-must-rehash-subtype) + (rehash-without-growing hash-table)) + ((not (zerop (hash-table-needing-rehash hash-table))) + (flush-needing-rehash hash-table))) + ;; Search for key in the hash table. + (multiple-value-bind + (hashing eq-based) + (funcall (hash-table-hash-fun hash-table) key) + (declare (type hash hashing)) + (let* ((index-vector (hash-table-index-vector hash-table)) + (length (length index-vector)) + (index (rem hashing length)) + (next (aref index-vector index)) + (table (hash-table-table hash-table)) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (test-fun (hash-table-test-fun hash-table))) + (declare (type index index)) + ;; Search next-vector chain for a matching key. + (if (or eq-based (not hash-vector)) + (do ((next next (aref next-vector next))) + ((zerop next) (values default nil)) + (declare (type index next)) + (when (eq key (aref table (* 2 next))) + (return (values (aref table (1+ (* 2 next))) t)))) + (do ((next next (aref next-vector next))) + ((zerop next) (values default nil)) + (declare (type index next)) + (when (and (= hashing (aref hash-vector next)) + (funcall test-fun key (aref table (* 2 next)))) + ;; Found. + (return (values (aref table (1+ (* 2 next))) t))))))))) + +;;; So people can call #'(setf gethash). +;;; +(defun (setf gethash) (new-value key table &optional default) + (declare (ignore default)) + (%puthash key table new-value)) + +;;; %PUTHASH -- public setf method. +;;; +(defun %puthash (key hash-table value) + (declare (type hash-table hash-table)) + (assert (hash-table-index-vector hash-table)) + (without-gcing + ;; Need to rehash here so that a current key can be found if it + ;; exists. Check that there is room for one more entry. May not be + ;; needed if the key is already present. + (cond ((zerop (hash-table-next-free-kv hash-table)) + (rehash hash-table)) + ((= (get-header-data (hash-table-table hash-table)) + vm:vector-must-rehash-subtype) + (rehash-without-growing hash-table)) + ((not (zerop (hash-table-needing-rehash hash-table))) + (flush-needing-rehash hash-table))) + + ;; Search for key in the hash table. + (multiple-value-bind + (hashing eq-based) + (funcall (hash-table-hash-fun hash-table) key) + (declare (type hash hashing)) + (let* ((index-vector (hash-table-index-vector hash-table)) + (length (length index-vector)) + (index (rem hashing length)) + (next (aref index-vector index)) + (kv-vector (hash-table-table hash-table)) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (test-fun (hash-table-test-fun hash-table))) + (declare (type index index)) + + (cond ((or eq-based (not hash-vector)) + (when eq-based + (set-header-data kv-vector vm:vector-valid-hashing-subtype)) + + ;; Search next-vector chain for a matching key. + (do ((next next (aref next-vector next))) + ((zerop next)) + (declare (type index next)) + (when (eq key (aref kv-vector (* 2 next))) + ;; Found, just replace the value. + (setf (aref kv-vector (1+ (* 2 next))) value) + (return-from %puthash value)))) + (t + ;; Search next-vector chain for a matching key. + (do ((next next (aref next-vector next))) + ((zerop next)) + (declare (type index next)) + (when (and (= hashing (aref hash-vector next)) + (funcall test-fun key + (aref kv-vector (* 2 next)))) + ;; Found, just replace the value. + (setf (aref kv-vector (1+ (* 2 next))) value) + (return-from %puthash value))))) + + ;; Pop a KV slot off the free list + (let ((free-kv-slot (hash-table-next-free-kv hash-table))) + ;; Double-check for overflow. + (assert (not (zerop free-kv-slot))) + (setf (hash-table-next-free-kv hash-table) + (aref next-vector free-kv-slot)) + (incf (hash-table-number-entries hash-table)) + + (setf (aref kv-vector (* 2 free-kv-slot)) key) + (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value) + + ;; Setup the hash-vector if necessary. + (when hash-vector + (if (not eq-based) + (setf (aref hash-vector free-kv-slot) hashing) + (assert (= (aref hash-vector free-kv-slot) #x80000000)))) + + ;; Push this slot into the next chain. + (setf (aref next-vector free-kv-slot) next) + (setf (aref index-vector index) free-kv-slot))))) + value) + +;;; REMHASH -- public. +;;; +(defun remhash (key hash-table) + "Remove the entry in HASH-TABLE associated with KEY. Returns T if there + was such an entry, and NIL if not." + (declare (type hash-table hash-table) + (values (member t nil))) + (without-gcing + ;; Need to rehash here so that a current key can be found if it + ;; exists. + (cond ((= (get-header-data (hash-table-table hash-table)) + vm:vector-must-rehash-subtype) + (rehash-without-growing hash-table)) + ((not (zerop (hash-table-needing-rehash hash-table))) + (flush-needing-rehash hash-table))) + + ;; Search for key in the hash table. + (multiple-value-bind (hashing eq-based) + (funcall (hash-table-hash-fun hash-table) key) + (declare (type hash hashing)) + (let* ((index-vector (hash-table-index-vector hash-table)) + (length (length index-vector)) + (index (rem hashing length)) + (next (aref index-vector index)) + (table (hash-table-table hash-table)) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (test-fun (hash-table-test-fun hash-table))) + (declare (type index index next)) + (cond ((zerop next) + nil) + ((if (or eq-based (not hash-vector)) + (eq key (aref table (* 2 next))) + (and (= hashing (aref hash-vector next)) + (funcall test-fun key (aref table (* 2 next))))) + ;; :empty out Key and Value. + (setf (aref table (* 2 next)) :empty) + (setf (aref table (1+ (* 2 next))) :empty) + ;; Update the index-vector pointer. + (setf (aref index-vector index) (aref next-vector next)) + ;; Push KV slot onto free chain. + (setf (aref next-vector next) + (hash-table-next-free-kv hash-table)) + (setf (hash-table-next-free-kv hash-table) next) + (when hash-vector + (setf (aref hash-vector next) #x80000000)) + (decf (hash-table-number-entries hash-table)) + t) + ;; Search next-vector chain for a matching key. + ((or eq-based (not hash-vector)) + ;; EQ based. + (do ((prior next next) + (next (aref next-vector next) (aref next-vector next))) + ((zerop next) nil) + (declare (type index next)) + (when (eq key (aref table (* 2 next))) + ;; :empty out Key and Value. + (setf (aref table (* 2 next)) :empty) + (setf (aref table (1+ (* 2 next))) :empty) + ;; Update the prior pointer in the chain to skip this. + (setf (aref next-vector prior) (aref next-vector next)) + ;; Push KV slot onto free chain. + (setf (aref next-vector next) + (hash-table-next-free-kv hash-table)) + (setf (hash-table-next-free-kv hash-table) next) + (when hash-vector + (setf (aref hash-vector next) #x80000000)) + (decf (hash-table-number-entries hash-table)) + t))) + (t + ;; Not EQ based + (do ((prior next next) + (next (aref next-vector next) (aref next-vector next))) + ((zerop next) nil) + (declare (type index next)) + (when (and (= hashing (aref hash-vector next)) + (funcall test-fun key (aref table (* 2 next)))) + ;; :empty out Key and Value. + (setf (aref table (* 2 next)) :empty) + (setf (aref table (1+ (* 2 next))) :empty) + ;; Update the prior pointer in the chain to skip this. + (setf (aref next-vector prior) (aref next-vector next)) + ;; Push KV slot onto free chain. + (setf (aref next-vector next) + (hash-table-next-free-kv hash-table)) + (setf (hash-table-next-free-kv hash-table) next) + (when hash-vector + (setf (aref hash-vector next) #x80000000)) + (decf (hash-table-number-entries hash-table)) + t)))))))) + +;;; CLRHASH -- public. +;;; +(defun clrhash (hash-table) + "This removes all the entries from HASH-TABLE and returns the hash table + itself." + (let* ((kv-vector (hash-table-table hash-table)) + (kv-length (length kv-vector)) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (size (length next-vector)) + (index-vector (hash-table-index-vector hash-table)) + (length (length index-vector))) + ;; Disable GC tricks. + (set-header-data kv-vector vm:vector-normal-subtype) + ;; :empty out the Keys and Values. + (do ((i 2 (1+ i))) + ((>= i kv-length)) + (setf (aref kv-vector i) :empty)) + (assert (eq (aref kv-vector 0) hash-table)) + ;; Setup the free list, all free. + (do ((i 1 (1+ i))) + ((>= i (1- size))) + (setf (aref next-vector i) (1+ i))) + (setf (aref next-vector (1- size)) 0) + (setf (hash-table-next-free-kv hash-table) 1) + (setf (hash-table-needing-rehash hash-table) 0) + ;; Clear the index-vector + (dotimes (i length) + (setf (aref index-vector i) 0)) + ;; Clear the hash-vector + (when hash-vector + (dotimes (i size) + (setf (aref hash-vector i) #x80000000)))) + (setf (hash-table-number-entries hash-table) 0) + hash-table) + +;;; CLOBBER-HASH -- public. +;;; +(defun clobber-hash (hash-table) + "This removes all the entries from HASH-TABLE and returns the hash table + itself, shrinking the size to free memory." + (let* ((old-kv-vector (hash-table-table hash-table)) + (old-index-vector (hash-table-index-vector hash-table)) + (old-next-vector (hash-table-next-vector hash-table)) + (old-hash-vector (hash-table-hash-vector hash-table)) + (new-size 37) + (new-kv-vector (make-array (* 2 new-size) :initial-element :empty)) + (new-next-vector (make-array new-size + :element-type '(unsigned-byte 32) + :initial-element 0)) + (new-hash-vector + (when old-hash-vector + (make-array new-size :element-type '(unsigned-byte 32) + :initial-element #x80000000))) + (new-length 37) + (new-index-vector (make-array new-length + :element-type '(unsigned-byte 32) + :initial-element 0))) + (declare (type index new-size new-length)) + ;; Disable GC tricks. + (set-header-data old-kv-vector vm:vector-normal-subtype) + ;; Setup the free list, all free. + (do ((i 1 (1+ i))) + ((>= i (1- new-size))) + (setf (aref new-next-vector i) (1+ i))) + (setf (aref new-next-vector (1- new-size)) 0) + (setf (hash-table-rehash-trigger hash-table) new-size) + (setf (hash-table-next-free-kv hash-table) 1) + (setf (hash-table-needing-rehash hash-table) 0) + (setf (hash-table-number-entries hash-table) 0) + (setf (hash-table-table hash-table) new-kv-vector) + (setf (hash-table-index-vector hash-table) new-index-vector) + (setf (hash-table-next-vector hash-table) new-next-vector) + (setf (hash-table-hash-vector hash-table) new-hash-vector) + ;; Shrink the old vectors to 0 size to help the conservative GC. + (shrink-vector old-kv-vector 0) + (shrink-vector old-index-vector 0) + (shrink-vector old-next-vector 0) + (when old-hash-vector + (shrink-vector old-hash-vector 0))) + hash-table) + + +;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR + +(declaim (maybe-inline maphash)) +(defun maphash (map-function hash-table) + "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value + of the entry; returns NIL." + (declare (type (or function symbol) map-function) + (type hash-table hash-table)) + (let ((fun (etypecase map-function + (function + map-function) + (symbol + (symbol-function map-function)))) + (size (length (hash-table-next-vector hash-table)))) + (declare (type function fun)) + (do ((i 1 (1+ i))) + ((>= i size)) + (declare (type index i)) + (let* ((kv-vector (hash-table-table hash-table)) + (key (aref kv-vector (* 2 i))) + (value (aref kv-vector (1+ (* 2 i))))) + ;; X hack + (unless (and (eq key :empty) (eq value :empty)) + (funcall fun key value)))))) + +(defmacro with-hash-table-iterator ((function hash-table) &body body) + "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body) + provides a method of manually looping over the elements of a hash-table. + function is bound to a generator-macro that, withing the scope of the + invocation, returns three values. First, whether there are any more objects + in the hash-table, second, the key, and third, the value." + (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-"))) + `(let ((,n-function + (let* ((table ,hash-table) + (length (length (hash-table-next-vector table))) + (index 1)) + (labels + ((,function () + ;; Grab the table again on each itteration just + ;; in-case it was rehashed by a puthash. + (let ((kv-vector (hash-table-table table))) + (do () + ((>= index length) (values nil)) + (let ((key (aref kv-vector (* 2 index))) + (value (aref kv-vector (1+ (* 2 index))))) + (incf index) + (unless (and (eq key :empty) (eq value :empty)) + (return (values t key value)))))))) + #',function)))) + (macrolet ((,function () '(funcall ,n-function))) + ,@body)))) + + + +;;;; SXHASH and support functions + +;;; The maximum length and depth to which we hash lists. +(defconstant sxhash-max-len 7) +(defconstant sxhash-max-depth 3) + +(eval-when (compile eval) + +(defconstant sxhash-bits-byte (byte 23 0)) +(defconstant sxmash-total-bits 26) +(defconstant sxmash-rotate-bits 7) + +(defmacro sxmash (place with) + `(setf ,place + (logxor (truly-the hash + (ash ,place + ,(- sxmash-rotate-bits sxmash-total-bits))) + (truly-the hash + (ash (logand + ,place + ,(1- (ash 1 + (- sxmash-total-bits + sxmash-rotate-bits)))) + ,sxmash-rotate-bits)) + (truly-the hash ,with)))) + +(defmacro sxhash-simple-string (sequence) + `(%sxhash-simple-string ,sequence)) + +(defmacro sxhash-string (sequence) + (let ((data (gensym)) + (start (gensym)) + (end (gensym))) + `(with-array-data ((,data (the string ,sequence)) + (,start) + (,end)) + (if (zerop ,start) + (%sxhash-simple-substring ,data ,end) + (sxhash-simple-string (coerce (the string ,sequence) + 'simple-string)))))) + +(defmacro sxhash-list (sequence depth) + `(if (= ,depth sxhash-max-depth) + 0 + (do ((sequence ,sequence (cdr (the list sequence))) + (index 0 (1+ index)) + (hash 2)) + ((or (atom sequence) (= index sxhash-max-len)) hash) + (declare (fixnum hash index)) + (sxmash hash (internal-sxhash (car sequence) (1+ ,depth)))))) + + +); eval-when (compile eval) + + +(defun sxhash (s-expr) + "Computes a hash code for S-EXPR and returns it as an integer." + (internal-sxhash s-expr 0)) + + +(defun internal-sxhash (s-expr depth) + (declare (type index depth) (values hash)) + (typecase s-expr + ;; The pointers and immediate types. + (list (sxhash-list s-expr depth)) + (fixnum (logand s-expr (1- most-positive-fixnum))) + (instance + (if (typep s-expr 'structure-object) + (internal-sxhash (class-name (layout-class (%instance-layout s-expr))) + depth) + 42)) + ;; Other-pointer types. + (simple-string (sxhash-simple-string s-expr)) + (symbol (sxhash-simple-string (symbol-name s-expr))) + (number + (etypecase s-expr + (integer (ldb sxhash-bits-byte s-expr)) + (single-float + (let ((bits (single-float-bits s-expr))) + (ldb sxhash-bits-byte + (logxor (ash bits (- sxmash-rotate-bits)) + bits)))) + (double-float + (let* ((val s-expr) + (lo (double-float-low-bits val)) + (hi (ldb sxhash-bits-byte (double-float-high-bits val)))) + (ldb sxhash-bits-byte + (logxor (ash lo (- sxmash-rotate-bits)) + (ash hi (- sxmash-rotate-bits)) + lo hi)))) + (ratio (logxor (internal-sxhash (numerator s-expr) 0) + (internal-sxhash (denominator s-expr) 0))) + (complex (logxor (internal-sxhash (realpart s-expr) 0) + (internal-sxhash (imagpart s-expr) 0))))) + (array + (typecase s-expr + (string (sxhash-string s-expr)) + (t (array-rank s-expr)))) + ;; Everything else. + (t 42))) + + +;;;; Dumping one as a constant. + +(defun make-hash-table-load-form (table) + (values + `(make-hash-table + :test ',(hash-table-test table) :size ',(hash-table-size table) + :rehash-size ',(hash-table-rehash-size table) + :rehash-threshold ',(hash-table-rehash-threshold table)) + (let ((values nil)) + (declare (inline maphash)) + (maphash #'(lambda (key value) + (push (cons key value) values)) + table) + (if values + `(stuff-hash-table ,table ',values) + nil)))) + +(defun stuff-hash-table (table alist) + (dolist (x alist) + (setf (gethash (car x) table) (cdr x)))) -- GitLab