X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-hash-table.lisp;h=090606a6509c19ef21c1b06c447380b6f5a9543f;hb=8eee0d3a30bf39d9f201acff28c92059fe6c3e4e;hp=1389875a7e26b64427ce2bfcf5b5ab24e7d4db85;hpb=11ff63e3084c27b8a3360054bd9a60b3cdb49cf1;p=sbcl.git diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 1389875..090606a 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -14,9 +14,6 @@ ;;;; utilities -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant max-hash sb!xc:most-positive-fixnum)) - ;;; Code for detecting concurrent accesses to the same table from ;;; multiple threads. Only compiled in when the :SB-HASH-TABLE-DEBUG ;;; feature is enabled. The main reason for the existence of this code @@ -74,19 +71,6 @@ (setf (,thread-slot-accessor ,hash-table) nil))) (body-fun))))))) -(deftype hash () - `(integer 0 ,max-hash)) - -;;; FIXME: Does this always make a nonnegative FIXNUM? If so, then -;;; explain why. If not (or if the reason it always makes a -;;; nonnegative FIXNUM is only the accident that pointers in supported -;;; architectures happen to be in the lower half of the address -;;; space), then fix it. -#!-sb-fluid (declaim (inline pointer-hash)) -(defun pointer-hash (key) - (declare (values hash)) - (truly-the hash (%primitive sb!c:make-fixnum key))) - #!-sb-fluid (declaim (inline eq-hash)) (defun eq-hash (key) (declare (values hash (member t nil))) @@ -124,23 +108,20 @@ (t (eq-hash key)))) -(defun ceil-power-of-two (num) - (declare (type index num)) - (ash 1 (integer-length num))) - (declaim (inline index-for-hashing)) -(defun index-for-hashing (index length) - (declare (type index index length)) +(defun index-for-hashing (hash length) + (declare (type hash hash length)) ;; We're using power of two tables which obviously are very ;; sensitive to the exact values of the low bits in the hash ;; value. Do a little shuffling of the value to mix the high bits in ;; there too. - (logand (1- length) - (+ (logxor #b11100101010001011010100111 - index) - (ash index -6) - (ash index -15) - (ash index -23)))) + (truly-the index + (logand (1- length) + (+ (logxor #b11100101010001011010100111 + hash) + (ash hash -3) + (ash hash -12) + (ash hash -20))))) ;;;; user-defined hash table tests @@ -249,8 +230,8 @@ ;; Note that this has not yet been audited for ;; correctness. It just seems to work. -- CSR, 2002-11-02 (scaled-size (truncate (/ (float size+1) rehash-threshold))) - (length (ceil-power-of-two (max scaled-size - (1+ +min-hash-table-size+)))) + (length (power-of-two-ceiling (max scaled-size + (1+ +min-hash-table-size+)))) (index-vector (make-array length :element-type '(unsigned-byte #.sb!vm:n-word-bits) @@ -341,7 +322,7 @@ multiple threads accessing the same hash-table without locking." (old-hash-vector (hash-table-hash-vector table)) (old-size (length old-next-vector)) (new-size - (ceil-power-of-two + (power-of-two-ceiling (let ((rehash-size (hash-table-rehash-size table))) (etypecase rehash-size (fixnum @@ -539,22 +520,22 @@ multiple threads accessing the same hash-table without locking." &body body) (declare (type (member :read :write) operation)) (with-unique-names (body-fun) - `(with-concurrent-access-check ,hash-table ,operation - (flet ((,body-fun () + `(flet ((,body-fun () + (with-concurrent-access-check ,hash-table ,operation (locally (declare (inline ,@inline)) - ,@body))) - (if (hash-table-weakness ,hash-table) - (sb!thread::with-recursive-system-spinlock - ((hash-table-spinlock ,hash-table) :without-gcing t) - (,body-fun)) - (with-pinned-objects ,pin - (if ,synchronized - ;; We use a "system" spinlock here because it is very - ;; slightly faster, as it doesn't re-enable interrupts. - (sb!thread::with-recursive-system-spinlock - ((hash-table-spinlock ,hash-table)) - (,body-fun)) - (,body-fun)))))))) + ,@body)))) + (if (hash-table-weakness ,hash-table) + (sb!thread::with-recursive-system-spinlock + ((hash-table-spinlock ,hash-table) :without-gcing t) + (,body-fun)) + (with-pinned-objects ,pin + (if ,synchronized + ;; We use a "system" spinlock here because it is very + ;; slightly faster, as it doesn't re-enable interrupts. + (sb!thread::with-recursive-system-spinlock + ((hash-table-spinlock ,hash-table)) + (,body-fun)) + (,body-fun))))))) (defun gethash (key hash-table &optional default) #!+sb-doc @@ -583,7 +564,7 @@ if there is no such entry. Entries can be added using SETF." ;; redo the lookup if the GC epoch counter has changed. ;; -- JES, 2007-09-30 `(if (and (not ,foundp) - (not (eql start-epoch sb!kernel::*gc-epoch*))) + (not (eq start-epoch sb!kernel::*gc-epoch*))) (go start) (return-from %gethash3 (values ,value ,foundp)))) (overflow () @@ -835,40 +816,41 @@ there was such an entry, or NIL if not." (declare (type hash-table hash-table) (values (member t nil))) (with-hash-table-locks (hash-table :inline (%remhash) :pin (key)) - ;; For now, just clear the cache - (setf (hash-table-cache hash-table) nil) + ;; For now, just clear the cache + (setf (hash-table-cache hash-table) nil) (%remhash key hash-table))) (defun clrhash (hash-table) #!+sb-doc "This removes all the entries from HASH-TABLE and returns the hash table itself." - (with-hash-table-locks (hash-table) - (let* ((kv-vector (hash-table-table hash-table)) - (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))) - ;; Disable GC tricks. - (set-header-data kv-vector sb!vm:vector-normal-subtype) - ;; Mark all slots as empty by setting all keys and values to magic - ;; tag. - (aver (eq (aref kv-vector 0) hash-table)) - (fill kv-vector +empty-ht-slot+ :start 2) - ;; Set up 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) - ;; Clear the index-vector. - (fill index-vector 0) - ;; Clear the hash-vector. - (when hash-vector - (fill hash-vector +magic-hash-vector-value+))) - (setf (hash-table-cache hash-table) nil) - (setf (hash-table-number-entries hash-table) 0) - hash-table)) + (when (plusp (hash-table-number-entries hash-table)) + (with-hash-table-locks (hash-table) + (let* ((kv-vector (hash-table-table hash-table)) + (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))) + ;; Disable GC tricks. + (set-header-data kv-vector sb!vm:vector-normal-subtype) + ;; Mark all slots as empty by setting all keys and values to magic + ;; tag. + (aver (eq (aref kv-vector 0) hash-table)) + (fill kv-vector +empty-ht-slot+ :start 2) + ;; Set up 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) + ;; Clear the index-vector. + (fill index-vector 0) + ;; Clear the hash-vector. + (when hash-vector + (fill hash-vector +magic-hash-vector-value+))) + (setf (hash-table-cache hash-table) nil) + (setf (hash-table-number-entries hash-table) 0))) + hash-table) ;;;; MAPHASH @@ -943,16 +925,16 @@ to protect the MAPHASH call." (cond ((or (not *print-readably*) (not *read-eval*)) (print-unreadable-object (hash-table stream :type t :identity t) (format stream - ":TEST ~S :COUNT ~S" + ":TEST ~S :COUNT ~S~@[ :WEAKNESS ~S~]" (hash-table-test hash-table) - (hash-table-count hash-table)))) + (hash-table-count hash-table) + (hash-table-weakness hash-table)))) (t - (with-standard-io-syntax - (format stream - "#.~W" - `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args + (write-string "#." stream) + (write `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args hash-table)) - ',(%hash-table-alist hash-table))))))) + ',(%hash-table-alist hash-table)) + :stream stream)))) (def!method make-load-form ((hash-table hash-table) &optional environment) (declare (ignore environment))