X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-hash-table.lisp;h=51d6537cd521c01d0922ab9dfc3b8e465cc895d5;hb=970dd272dc84f7420252eadb4829cc193f795716;hp=d3a9bdb57d439369bc8e4d6dbc63d3099dfc704d;hpb=bc1783335d78be988465e4fc7cf9c5fdb88a3fa4;p=sbcl.git diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index d3a9bdb..51d6537 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -14,6 +14,27 @@ ;;;; utilities +;; This stuff is performance critical and unwind-protect is too +;; slow. And without the locking the next vector can get cyclic +;; causing looping in a WITHOUT-GCING form, SHRINK-VECTOR can corrupt +;; memory and who knows what else. +(defmacro with-spinlock-and-without-gcing ((spinlock) &body body) + #!-sb-thread + (declare (ignore spinlock)) + (with-unique-names (old-gc-inhibit) + `(let ((,old-gc-inhibit *gc-inhibit*) + (*gc-inhibit* t)) + (unwind-protect + (progn + #!+sb-thread + (sb!thread::get-spinlock ,spinlock) + ,@body) + #!+sb-thread + (sb!thread::release-spinlock ,spinlock) + (let ((*gc-inhibit* ,old-gc-inhibit)) + ;; the test is racy, but it can err only on the overeager side + (sb!kernel::maybe-handle-pending-gc)))))) + (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant max-hash sb!xc:most-positive-fixnum)) @@ -82,10 +103,6 @@ (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+) @@ -182,10 +199,13 @@ :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 #.sb!vm:n-word-bits) - :initial-element +magic-hash-vector-value+))))) + :hash-vector + (unless (eq test 'eq) + (make-array size+1 + :element-type '(unsigned-byte + #.sb!vm:n-word-bits) + :initial-element +magic-hash-vector-value+)) + :spinlock (sb!thread::make-spinlock)))) (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))) @@ -247,20 +267,23 @@ (the index (truncate (* rehash-size old-size))))))) (new-kv-vector (make-array (* 2 new-size) :initial-element +empty-ht-slot+)) - (new-next-vector (make-array new-size - :element-type '(unsigned-byte #.sb!vm:n-word-bits) - :initial-element 0)) - (new-hash-vector (when old-hash-vector - (make-array new-size - :element-type '(unsigned-byte #.sb!vm:n-word-bits) - :initial-element +magic-hash-vector-value+))) + (new-next-vector + (make-array new-size + :element-type '(unsigned-byte #.sb!vm:n-word-bits) + :initial-element 0)) + (new-hash-vector + (when old-hash-vector + (make-array new-size + :element-type '(unsigned-byte #.sb!vm:n-word-bits) + :initial-element +magic-hash-vector-value+))) (old-index-vector (hash-table-index-vector table)) (new-length (almost-primify (truncate (/ (float new-size) (hash-table-rehash-threshold table))))) - (new-index-vector (make-array new-length - :element-type '(unsigned-byte #.sb!vm:n-word-bits) - :initial-element 0))) + (new-index-vector + (make-array new-length + :element-type '(unsigned-byte #.sb!vm:n-word-bits) + :initial-element 0))) (declare (type index new-size new-length old-size)) ;; Disable GC tricks on the OLD-KV-VECTOR. @@ -297,7 +320,8 @@ (hash-table-next-free-kv table)) (setf (hash-table-next-free-kv table) i)) ((and new-hash-vector - (not (= (aref new-hash-vector i) +magic-hash-vector-value+))) + (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)) @@ -325,11 +349,11 @@ (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) + (%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)) + (%shrink-vector old-hash-vector 0)) (setf (hash-table-rehash-trigger table) new-size)) (values)) @@ -364,7 +388,8 @@ ;; 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) +magic-hash-vector-value+))) + ((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)) @@ -426,7 +451,7 @@ "Three argument version of GETHASH" (declare (type hash-table hash-table) (values t (member t nil))) - (without-gcing + (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table)) (cond ((= (get-header-data (hash-table-table hash-table)) sb!vm:vector-must-rehash-subtype) (rehash-without-growing hash-table)) @@ -436,7 +461,7 @@ ;; First check the cache. Use EQ here for speed. (let ((cache (hash-table-cache hash-table)) (table (hash-table-table hash-table))) - + (if (and cache (< cache (length table)) (eq (aref table cache) key)) (values (aref table (1+ cache)) t) @@ -477,7 +502,7 @@ (defun %puthash (key hash-table value) (declare (type hash-table hash-table)) (aver (hash-table-index-vector hash-table)) - (without-gcing + (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table)) ;; We 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. @@ -493,7 +518,8 @@ (kv-vector (hash-table-table hash-table))) ;; Check the cache - (if (and cache (< cache (length kv-vector)) (eq (aref kv-vector cache) key)) + (if (and cache (< cache (length kv-vector)) + (eq (aref kv-vector cache) key)) ;; If cached, just store here (setf (aref kv-vector (1+ cache)) value) @@ -510,11 +536,12 @@ (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 sb!vm:vector-valid-hashing-subtype)) - + (set-header-data kv-vector + sb!vm:vector-valid-hashing-subtype)) + ;; Search next-vector chain for a matching key. (do ((next next (aref next-vector next))) ((zerop next)) @@ -536,7 +563,7 @@ (setf (hash-table-cache hash-table) (* 2 next)) (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. @@ -544,17 +571,18 @@ (setf (hash-table-next-free-kv hash-table) (aref next-vector free-kv-slot)) (incf (hash-table-number-entries hash-table)) - + (setf (hash-table-cache hash-table) (* 2 free-kv-slot)) (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) - (aver (= (aref hash-vector free-kv-slot) +magic-hash-vector-value+)))) - + (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) (setf (aref index-vector index) free-kv-slot))))))) @@ -566,7 +594,7 @@ was such an entry, or NIL if not." (declare (type hash-table hash-table) (values (member t nil))) - (without-gcing + (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table)) ;; We need to rehash here so that a current key can be found if it ;; exists. (cond ((= (get-header-data (hash-table-table hash-table)) @@ -575,7 +603,7 @@ ((not (zerop (hash-table-needing-rehash hash-table))) (flush-needing-rehash hash-table))) - ;; For now, just clear the cache + ;; For now, just clear the cache (setf (hash-table-cache hash-table) nil) ;; Search for key in the hash table. @@ -603,7 +631,8 @@ (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+)) + (setf (aref hash-vector slot-location) + +magic-hash-vector-value+)) (decf (hash-table-number-entries hash-table)) t)) (cond ((zerop next) @@ -630,38 +659,40 @@ (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))))))))))) + (return-from remhash + (clear-slot next-vector prior next))))))))))) (defun clrhash (hash-table) #!+sb-doc "This removes all the entries from HASH-TABLE and returns the hash table itself." (declare (optimize speed)) - (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) - (setf (hash-table-needing-rehash hash-table) 0) - ;; 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) + (with-spinlock-and-without-gcing ((hash-table-spinlock 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) + (setf (hash-table-needing-rehash hash-table) 0) + ;; 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 @@ -725,14 +756,12 @@ (def!method print-object ((hash-table hash-table) stream) (declare (type stream stream)) - (cond ((not *print-readably*) + (cond ((or (not *print-readably*) (not *read-eval*)) (print-unreadable-object (hash-table stream :type t :identity t) (format stream ":TEST ~S :COUNT ~S" (hash-table-test hash-table) (hash-table-count hash-table)))) - ((not *read-eval*) - (error "can't print hash tables readably without *READ-EVAL*")) (t (with-standard-io-syntax (format stream