From: Juho Snellman <jsnell@iki.fi>
Date: Thu, 3 Jan 2008 03:54:05 +0000 (+0000)
Subject: 1.0.13.12: Make :SB-HASH-TABLE-DEBUG feature more useful
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=fbb458f162a01f658b318ba684b58874cbee5bb1;p=sbcl.git

1.0.13.12: Make :SB-HASH-TABLE-DEBUG feature more useful

        * Only signal errors for concurrent writer/writer or reader/writer
          accesses, not reader/reader. (The latter is basically intended to
          always be safe).
        * Patch by Attila Lendvai
---

diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp
index f018119..5eb7a3c 100644
--- a/src/code/hash-table.lisp
+++ b/src/code/hash-table.lisp
@@ -81,9 +81,11 @@
   (synchronized-p nil :type (member nil t) :read-only t)
   ;; For detecting concurrent accesses.
   #!+sb-hash-table-debug
-  (concurrent-access-error t :type (member nil t))
+  (signal-concurrent-access t :type (member nil t))
   #!+sb-hash-table-debug
-  (accessing-thread nil))
+  (reading-thread nil)
+  #!+sb-hash-table-debug
+  (writing-thread nil))
 
 ;; as explained by pmai on openprojects #lisp IRC 2002-07-30: #x80000000
 ;; is bigger than any possible nonEQ hash value, and thus indicates an
diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp
index 8d65255..366ffdf 100644
--- a/src/code/target-hash-table.lisp
+++ b/src/code/target-hash-table.lisp
@@ -25,34 +25,54 @@
 ;;; internal hash-table has been corrupted. It's plausible that this
 ;;; could be useful for some user code too, but the runtime cost is
 ;;; really too high to enable it by default.
-(defmacro with-concurrent-access-check (hash-table &body body)
-  (declare (ignorable hash-table))
+(defmacro with-concurrent-access-check (hash-table operation &body body)
+  (declare (ignorable hash-table operation)
+           (type (member :read :write) operation))
   #!-sb-hash-table-debug
   `(progn ,@body)
   #!+sb-hash-table-debug
-  (once-only ((hash-table hash-table))
-    `(progn
-       (flet ((body-fun ()
-                ,@body)
-              (error-fun ()
-                ;; Don't signal more errors for this table.
-                (setf (hash-table-concurrent-access-error ,hash-table) nil)
-                (error "Concurrent access to ~A" ,hash-table)))
-         (if (hash-table-concurrent-access-error ,hash-table)
-             (let ((thread (hash-table-accessing-thread ,hash-table)))
+  (let ((thread-slot-accessor (if (eq operation :read)
+                                  'hash-table-reading-thread
+                                  'hash-table-writing-thread)))
+    (once-only ((hash-table hash-table))
+      `(progn
+         (flet ((body-fun ()
+                  ,@body)
+                (error-fun ()
+                  ;; Don't signal more errors for this table.
+                  (setf (hash-table-signal-concurrent-access ,hash-table) nil)
+                  (cerror "Ignore the concurrent access"
+                          "Concurrent access to ~A" ,hash-table)))
+           (declare (inline body-fun))
+           (if (hash-table-signal-concurrent-access ,hash-table)
                (unwind-protect
                     (progn
-                      (when (and thread
-                                 (not (eql thread sb!thread::*current-thread*)))
+                      (unless (and (null (hash-table-writing-thread
+                                          ,hash-table))
+                                   ,@(when (eq operation :write)
+                                           `((null (hash-table-reading-thread
+                                                    ,hash-table)))))
                         (error-fun))
-                      (setf (hash-table-accessing-thread ,hash-table)
+                      (setf (,thread-slot-accessor ,hash-table)
                             sb!thread::*current-thread*)
                       (body-fun))
-                 (unless (eql (hash-table-accessing-thread ,hash-table)
-                              sb!thread::*current-thread*)
+                 (unless (and ,@(when (eq operation :read)
+                                  `((null (hash-table-writing-thread
+                                           ,hash-table))))
+                              ,@(when (eq operation :write)
+                                  ;; no readers are allowed while writing
+                                  `((null (hash-table-reading-thread
+                                           ,hash-table))
+                                    (eq (hash-table-writing-thread
+                                         ,hash-table)
+                                        sb!thread::*current-thread*))))
                    (error-fun))
-                 (setf (hash-table-accessing-thread ,hash-table) thread)))
-             (body-fun))))))
+                 (when (eq (,thread-slot-accessor ,hash-table)
+                           sb!thread::*current-thread*)
+                   ;; this is not 100% correct here and may hide
+                   ;; concurrent access in rare circumstances.
+                   (setf (,thread-slot-accessor ,hash-table) nil)))
+               (body-fun)))))))
 
 (deftype hash ()
   `(integer 0 ,max-hash))
@@ -514,11 +534,12 @@ multiple threads accessing the same hash-table without locking."
     (setf (hash-table-cache hash-table) index)))
 
 (defmacro with-hash-table-locks ((hash-table
-                                  &key inline pin
+                                  &key (operation :write) inline pin
                                   (synchronized `(hash-table-synchronized-p ,hash-table)))
                                  &body body)
+  (declare (type (member :read :write) operation))
   (with-unique-names (body-fun)
-    `(with-concurrent-access-check ,hash-table
+    `(with-concurrent-access-check ,hash-table ,operation
        (flet ((,body-fun ()
                 (locally (declare (inline ,@inline))
                   ,@body)))
@@ -622,7 +643,8 @@ if there is no such entry. Entries can be added using SETF."
 (defun gethash3 (key hash-table default)
   "Three argument version of GETHASH"
   (declare (type hash-table hash-table))
-  (with-hash-table-locks (hash-table :inline (%gethash3) :pin (key))
+  (with-hash-table-locks (hash-table :operation :read :inline (%gethash3)
+                                     :pin (key))
     (%gethash3 key hash-table default)))
 
 ;;; so people can call #'(SETF GETHASH)
diff --git a/version.lisp-expr b/version.lisp-expr
index 8e4dd51..cc85eff 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.13.11"
+"1.0.13.12"