X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-hash-table.lisp;h=d00d68435fa20b1a710281a5c7d88fe454d33eef;hb=7f2a87e987b70891684cafe8c71e057b9cdc6092;hp=8947388e22dba2dc75559eb43b386fb2aab1ac8b;hpb=1479483c5f40fc470053da0fc5cd8e42fc77676e;p=sbcl.git

diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp
index 8947388..d00d684 100644
--- a/src/code/target-hash-table.lisp
+++ b/src/code/target-hash-table.lisp
@@ -14,26 +14,22 @@
 
 ;;;; 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)
+;;; 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.
+;;;
+;;; WITHOUT-GCING implies WITHOUT-INTERRUPTS.
+(defmacro with-spinlock-and-without-gcing ((spinlock) block &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))))))
+  `(without-gcing
+     (unwind-protect
+          (progn
+            #!+sb-thread
+            (sb!thread::get-spinlock ,spinlock)
+            (block ,block ,@body))
+       #!+sb-thread
+       (sb!thread::release-spinlock ,spinlock))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defconstant max-hash sb!xc:most-positive-fixnum))
@@ -60,7 +56,16 @@
 #!-sb-fluid (declaim (inline equal-hash))
 (defun equal-hash (key)
   (declare (values hash (member t nil)))
-  (values (sxhash key) nil))
+  (typecase key
+    ;; For some types the definition of EQUAL implies a special hash
+    ((or string cons number bit-vector pathname)
+     (values (sxhash key) nil))
+    ;; Otherwise use an EQ hash, rather than SXHASH, since the values
+    ;; of SXHASH will be extremely badly distributed due to the
+    ;; requirements of the spec fitting badly with our implementation
+    ;; strategy.
+    (t
+     (eq-hash key))))
 
 #!-sb-fluid (declaim (inline eql-hash))
 (defun eql-hash (key)
@@ -71,7 +76,13 @@
 
 (defun equalp-hash (key)
   (declare (values hash (member t nil)))
-  (values (psxhash key) nil))
+  (typecase key
+    ;; Types requiring special treatment. Note that PATHNAME and
+    ;; HASH-TABLE are caught by the STRUCTURE-OBJECT test.
+    ((or array cons number character structure-object)
+     (values (psxhash key) nil))
+    (t
+     (eq-hash key))))
 
 (defun almost-primify (num)
   (declare (type index num))
@@ -323,6 +334,7 @@
     ;; the chains are first to last.
     (do ((i (1- new-size) (1- i)))
         ((zerop i))
+      (declare (type index/2 i))
       (let ((key (aref new-kv-vector (* 2 i)))
             (value (aref new-kv-vector (1+ (* 2 i)))))
         (cond ((and (eq key +empty-ht-slot+)
@@ -395,6 +407,7 @@
       (setf (aref index-vector i) 0))
     (do ((i (1- size) (1- i)))
         ((zerop i))
+      (declare (type index/2 i))
       (let ((key (aref kv-vector (* 2 i)))
             (value (aref kv-vector (1+ (* 2 i)))))
         (cond ((and (eq key +empty-ht-slot+)
@@ -433,7 +446,7 @@
          (length (length index-vector)))
     (do ((next (hash-table-needing-rehash table)))
         ((zerop next))
-      (declare (type index next))
+      (declare (type index/2 next))
       (let* ((key (aref kv-vector (* 2 next)))
              (hashing (pointer-hash key))
              (index (rem hashing length))
@@ -466,47 +479,48 @@
   (declare (type hash-table hash-table)
            (values t (member t nil)))
   (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))
-         ((not (zerop (hash-table-needing-rehash hash-table)))
-          (flush-needing-rehash hash-table)))
-
-   ;; 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)
-
-       ;; 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))
-                (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)))
-                   (setf (hash-table-cache hash-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.
-                 (setf (hash-table-cache hash-table) (* 2 next))
-                 (return (values (aref table (1+ (* 2 next))) t)))))))))))
+    gethash3
+    (cond ((= (get-header-data (hash-table-table hash-table))
+              sb!vm:vector-must-rehash-subtype)
+           (rehash-without-growing hash-table))
+          ((not (zerop (hash-table-needing-rehash hash-table)))
+           (flush-needing-rehash hash-table)))
+
+    ;; 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)
+
+          ;; 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))
+                   (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/2 next))
+                    (when (eq key (aref table (* 2 next)))
+                      (setf (hash-table-cache hash-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/2 next))
+                    (when (and (= hashing (aref hash-vector next))
+                               (funcall test-fun key (aref table (* 2 next))))
+                      ;; Found.
+                      (setf (hash-table-cache hash-table) (* 2 next))
+                      (return (values (aref table (1+ (* 2 next))) t)))))))))))
 
 ;;; so people can call #'(SETF GETHASH)
 (defun (setf gethash) (new-value key table &optional default)
@@ -517,90 +531,92 @@
   (declare (type hash-table hash-table))
   (aver (hash-table-index-vector hash-table))
   (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.
-   (cond ((zerop (hash-table-next-free-kv hash-table))
-          (rehash hash-table))
-         ((= (get-header-data (hash-table-table hash-table))
-             sb!vm:vector-must-rehash-subtype)
-          (rehash-without-growing hash-table))
-         ((not (zerop (hash-table-needing-rehash hash-table)))
-          (flush-needing-rehash hash-table)))
-
-   (let ((cache (hash-table-cache hash-table))
-         (kv-vector (hash-table-table hash-table)))
-
-     ;; Check the cache
-     (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)
-
-       ;; 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))
-           (when (hash-table-weakness hash-table)
-             (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype))
-           (cond ((or eq-based (not hash-vector))
-                  (when eq-based
-                    (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))
-                    (declare (type index next))
-                    (when (eq key (aref kv-vector (* 2 next)))
-                      ;; Found, just replace the value.
-                      (setf (hash-table-cache hash-table) (* 2 next))
-                      (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 (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.
-             (aver (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 (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+))))
-
-             ;; Push this slot into the next chain.
-             (setf (aref next-vector free-kv-slot) next)
-             (setf (aref index-vector index) free-kv-slot)))))))
+    %puthash
+    ;; 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.
+    (cond ((zerop (hash-table-next-free-kv hash-table))
+           (rehash hash-table))
+          ((= (get-header-data (hash-table-table hash-table))
+              sb!vm:vector-must-rehash-subtype)
+           (rehash-without-growing hash-table))
+          ((not (zerop (hash-table-needing-rehash hash-table)))
+           (flush-needing-rehash hash-table)))
+
+    (let ((cache (hash-table-cache hash-table))
+          (kv-vector (hash-table-table hash-table)))
+
+      ;; Check the cache
+      (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)
+
+          ;; 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 next))
+              (when (hash-table-weakness hash-table)
+                (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype))
+              (cond ((or eq-based (not hash-vector))
+                     (when eq-based
+                       (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))
+                       (declare (type index/2 next))
+                       (when (eq key (aref kv-vector (* 2 next)))
+                         ;; Found, just replace the value.
+                         (setf (hash-table-cache hash-table) (* 2 next))
+                         (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/2 next))
+                       (when (and (= hashing (aref hash-vector next))
+                                  (funcall test-fun key
+                                           (aref kv-vector (* 2 next))))
+                         ;; Found, just replace the value.
+                         (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)))
+                (declare (type index/2 free-kv-slot))
+                ;; Double-check for overflow.
+                (aver (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 (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+))))
+
+                ;; Push this slot into the next chain.
+                (setf (aref next-vector free-kv-slot) next)
+                (setf (aref index-vector index) free-kv-slot)))))))
   value)
 
 (defun remhash (key hash-table)
@@ -610,72 +626,75 @@
   (declare (type hash-table hash-table)
            (values (member t nil)))
   (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))
-             sb!vm:vector-must-rehash-subtype)
-          (rehash-without-growing hash-table))
-         ((not (zerop (hash-table-needing-rehash hash-table)))
-          (flush-needing-rehash hash-table)))
-
-   ;; For now, just clear the cache
-   (setf (hash-table-cache hash-table) nil)
-
-   ;; 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))
-       (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)))))))))))
+    remhash
+    ;; 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))
+              sb!vm:vector-must-rehash-subtype)
+           (rehash-without-growing hash-table))
+          ((not (zerop (hash-table-needing-rehash hash-table)))
+           (flush-needing-rehash hash-table)))
+
+    ;; For now, just clear the cache
+    (setf (hash-table-cache hash-table) nil)
+
+    ;; 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)
+                 (type index/2 next))
+        (flet ((clear-slot (chain-vector prior-slot-location slot-location)
+                 (declare (type index/2 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/2 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
@@ -683,6 +702,7 @@
    itself."
   (declare (optimize speed))
   (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
+    clrhash
     (let* ((kv-vector (hash-table-table hash-table))
            (next-vector (hash-table-next-vector hash-table))
            (hash-vector (hash-table-hash-vector hash-table))
@@ -721,14 +741,16 @@
 (declaim (inline maphash))
 (defun maphash (function-designator hash-table)
   #!+sb-doc
-  "For each entry in HASH-TABLE, call the designated two-argument function
-   on the key and value of the entry. Return NIL."
+  "For each entry in HASH-TABLE, call the designated two-argument function on
+the key and value of the entry. Return NIL."
+  ;; This essentially duplicates WITH-HASH-TABLE-ITERATOR, so
+  ;; any changes here should be reflected there as well.
   (let ((fun (%coerce-callable-to-fun function-designator))
         (size (length (hash-table-next-vector hash-table))))
     (declare (type function fun))
     (do ((i 1 (1+ i)))
         ((>= i size))
-      (declare (type index i))
+      (declare (type index/2 i))
       (let* ((kv-vector (hash-table-table hash-table))
              (key (aref kv-vector (* 2 i)))
              (value (aref kv-vector (1+ (* 2 i)))))