(defconstant +min-hash-table-size+ 16)
(defconstant +min-hash-table-rehash-threshold+ (float 1/16 1.0))
+;; as explained by pmai on openprojects #lisp IRC 2002-07-30: #x80000000
+;; is bigger than any possible nonEQ hash value, and thus indicates an
+;; empty slot; and EQ hash tables don't use HASH-TABLE-HASH-VECTOR
+(defconstant +magic-hash-vector-value+ #x80000000)
(defun make-hash-table (&key (test 'eql)
(size +min-hash-table-size+)
:element-type '(unsigned-byte 32)
:initial-element 0))
;; needs to be the same length as the KV vector
+ ;; (FIXME: really? why doesn't the code agree?)
(next-vector (make-array size+1
:element-type '(unsigned-byte 32)))
(kv-vector (make-array (* 2 size+1)
:hash-vector (unless (eq test 'eq)
(make-array size+1
:element-type '(unsigned-byte 32)
- ;; as explained by pmai on
- ;; openprojects #lisp IRC
- ;; 2002-07-30: #x80000000 is
- ;; bigger than any possible nonEQ
- ;; hash value, and thus indicates
- ;; an empty slot; and EQ hash
- ;; tables don't use
- ;; HASH-TABLE-HASH-VECTOR
- :initial-element #x80000000)))))
+ :initial-element +magic-hash-vector-value+)))))
(declare (type index size+1 scaled-size length))
;; Set up the free list, all free. These lists are 0 terminated.
(do ((i 1 (1+ i)))
(new-hash-vector (when old-hash-vector
(make-array new-size
:element-type '(unsigned-byte 32)
- :initial-element #x80000000)))
+ :initial-element +magic-hash-vector-value+)))
(old-index-vector (hash-table-index-vector table))
(new-length (almost-primify
(truncate (/ (float new-size)
;; Disable GC tricks on the OLD-KV-VECTOR.
(set-header-data old-kv-vector sb!vm:vector-normal-subtype)
+ ;; FIXME: here and in several other places in the hash table code,
+ ;; loops like this one are used when FILL or REPLACE would be
+ ;; appropriate. why are standard CL functions not used?
+ ;; Performance issues? General laziness? -- NJF, 2004-03-10
+
;; Copy over the kv-vector. The element positions should not move
;; in case there are active scans.
(dotimes (i (* old-size 2))
(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)))
+ (not (= (aref new-hash-vector i) +magic-hash-vector-value+)))
;; Can use the existing hash value (not EQ based)
(let* ((hashing (aref new-hash-vector i))
(index (rem hashing new-length))
(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) (*))))
+ (declare (type index size length))
;; Disable GC tricks, they will be re-enabled during the re-hash
;; if necesary.
;; Slot is empty, push it onto 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)))
+ ((and hash-vector (not (= (aref hash-vector i) +magic-hash-vector-value+)))
;; Can use the existing hash value (not EQ based)
(let* ((hashing (aref hash-vector i))
(index (rem hashing length))
(when hash-vector
(if (not eq-based)
(setf (aref hash-vector free-kv-slot) hashing)
- (aver (= (aref hash-vector free-kv-slot) #x80000000))))
+ (aver (= (aref hash-vector free-kv-slot) +magic-hash-vector-value+))))
;; Push this slot into the next chain.
(setf (aref next-vector free-kv-slot) next)
(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)))))
-
- ;; FIXME: Substantially the same block of code seems to
- ;; appear in all three cases. (In the first case, it
- ;; appear bare; in the other two cases, it's wrapped in
- ;; DO.) It should be defined in a separate (possibly
- ;; inline) DEFUN or FLET.
-
- ;; Mark slot as empty.
- (setf (aref table (* 2 next)) +empty-ht-slot+
- (aref table (1+ (* 2 next))) +empty-ht-slot+)
- ;; 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)))
- ;; Mark slot as empty.
- (setf (aref table (* 2 next)) +empty-ht-slot+
- (aref table (1+ (* 2 next))) +empty-ht-slot+)
- ;; 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))
- (return 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))))
- ;; Mark slot as empty.
- (setf (aref table (* 2 next)) +empty-ht-slot+)
- (setf (aref table (1+ (* 2 next))) +empty-ht-slot+)
- ;; 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))
- (return t)))))))))
+ (flet ((clear-slot (chain-vector prior-slot-location slot-location)
+ ;; Mark slot as empty.
+ (setf (aref table (* 2 slot-location)) +empty-ht-slot+
+ (aref table (1+ (* 2 slot-location))) +empty-ht-slot+)
+ ;; Update the prior pointer in the chain to skip this.
+ (setf (aref chain-vector prior-slot-location)
+ (aref next-vector slot-location))
+ ;; Push KV slot onto free chain.
+ (setf (aref next-vector slot-location)
+ (hash-table-next-free-kv hash-table))
+ (setf (hash-table-next-free-kv hash-table) slot-location)
+ (when hash-vector
+ (setf (aref hash-vector slot-location) +magic-hash-vector-value+))
+ (decf (hash-table-number-entries hash-table))
+ t))
+ (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)))))
+ (clear-slot index-vector index next))
+ ;; 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)))
+ (return-from remhash (clear-slot next-vector prior next)))))
+ (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))))
+ (return-from remhash (clear-slot next-vector prior next)))))))))))
(defun clrhash (hash-table)
#!+sb-doc
;; Clear the hash-vector.
(when hash-vector
(dotimes (i size)
- (setf (aref hash-vector i) #x80000000))))
+ (setf (aref hash-vector i) +magic-hash-vector-value+))))
(setf (hash-table-number-entries hash-table) 0)
hash-table)
\f
projects / sbcl.git / commitdiff