From 386e4a5a86c7b02ab8d546771233b47a5d9d2a65 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 28 Jun 2007 23:13:45 +0000
Subject: [PATCH] 1.0.7.3: non-consing GETHASH and (SETF GETHASH)

 * Add a BLOCK for RETURN-FROM inside WITH-SPINLOCK-AND-WITHOUT-GCING,
   so that the compiler will not need to generate code to verify the
   tag existence at runtime -- which causes value-cell allocation.

   (Performance regression since new WITHOUT-INTERRUPTS implementation.)

 * Add a test-case to make sure basic hash-table functionality is non-consing.
---
 NEWS                             |    1 +
 src/code/target-hash-table.lisp  |  396 +++++++++++++++++++-------------------
 tests/dynamic-extent.impure.lisp |    9 +
 version.lisp-expr                |    2 +-
 4 files changed, 211 insertions(+), 197 deletions(-)

diff --git a/NEWS b/NEWS
index 209e9bf..40b05d7 100644
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,7 @@
 changes in sbcl-1.0.8 relative to sbcl-1.0.7:
   * enhancement: closed over variables can be stack-allocated on x86 and
     x86-64.
+  * performance bug fix: GETHASH and (SETF GETHASH) are once again non-consing.
   * bug fix: backtrace construction is now more careful when
     making lisp-objects from pointers on the stack, to avoid creating
     bogus objects that can be seen by the GC.
diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp
index 79a9cbd..d00d684 100644
--- a/src/code/target-hash-table.lisp
+++ b/src/code/target-hash-table.lisp
@@ -19,7 +19,7 @@
 ;;; and who knows what else.
 ;;;
 ;;; WITHOUT-GCING implies WITHOUT-INTERRUPTS.
-(defmacro with-spinlock-and-without-gcing ((spinlock) &body body)
+(defmacro with-spinlock-and-without-gcing ((spinlock) block &body body)
   #!-sb-thread
   (declare (ignore spinlock))
   `(without-gcing
@@ -27,7 +27,7 @@
           (progn
             #!+sb-thread
             (sb!thread::get-spinlock ,spinlock)
-            ,@body)
+            (block ,block ,@body))
        #!+sb-thread
        (sb!thread::release-spinlock ,spinlock))))
 
@@ -479,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/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)))))))))))
+    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)
@@ -530,91 +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 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)))))))
+    %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)
@@ -624,74 +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)
-                (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)))))))))))
+    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
@@ -699,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))
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index ead5757..3ac193f 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -146,6 +146,13 @@
   (sb-thread::with-spinlock (*slock*)
     (true *slock*)))
 
+;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
+
+(defvar *table* (make-hash-table))
+
+(defun test-hash-table ()
+  (setf (gethash 5 *table*) 13)
+  (gethash 5 *table*))
 
 (defmacro assert-no-consing (form &optional times)
   `(%assert-no-consing (lambda () ,form) ,times))
@@ -169,6 +176,8 @@
   (assert-no-consing (test-let-var-subst2 17))
   (assert-no-consing (test-lvar-subst 11))
   (assert-no-consing (dx-value-cell 13))
+  ;; Not strictly DX..
+  (assert-no-consing (test-hash-table))
   #+sb-thread
   (assert-no-consing (test-spinlock)))
 
diff --git a/version.lisp-expr b/version.lisp-expr
index 3d0bd29..86f1d87 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.7.2"
+"1.0.7.3"
-- 
1.7.10.4