1.0.14.18: fix bogus STYLE-WARNING for MAKE-HASH-TABLE :SYNCHRONIZED

 * Add :SYNCHRONIZED to thr DEFKNOWN.

 * Also fix a bit of totally broken indentation in the
   hash-table code.

 * Cautionary comment about a potential type-error in parallel code.

 * More threaded hash-table tests.

diff --git a/NEWS b/NEWS
index bc52ee2..d45bce7 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,8 @@ changes in sbcl-1.0.15 relative to sbcl-1.0.14:
     now supported, and tracing a whole package using (TRACE "FOO") now
     traces SETF-functions as well.
   * enhancement: implement SB-POSIX:MKTEMP and SB-POSIX:MKDTEMP.
+  * bug fix: compiler gave a bogus STYLE-WARNING for the :SYNCHRONIZED
+    keyword with MAKE-HASH-TABLE.
   * bug fix: export SB-POSIX:MKSTEMP.
   * bug fix: SORT was not interrupt safe.
   * bug fix: XREF accounts for the last node of each basic-block as

diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp
index 366ffdf..1389875 100644 (file)
--- a/src/code/target-hash-table.lisp
+++ b/src/code/target-hash-table.lisp
@@ -732,14 +732,14 @@ if there is no such entry. Entries can be added using SETF."
   (aver (hash-table-index-vector hash-table))
   (macrolet ((put-it (lockedp)
                `(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)
-        ;; Otherwise do things the hard way
+                      (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)
+                      ;; Otherwise do things the hard way
                       ,(if lockedp
                            '(%%puthash key hash-table value)
                            '(with-hash-table-locks
@@ -791,6 +791,8 @@ if there is no such entry. Entries can be added using SETF."
                (when hash-vector
                  (setf (aref hash-vector slot-location)
                        +magic-hash-vector-value+))
+               ;; On parallel accesses this may turn out to be a
+               ;; type-error, so don't turn down the safety!
                (decf (hash-table-number-entries hash-table))
                t))
         (cond ((zerop next)

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 30fe77d..1d3f521 100644 (file)
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -783,7 +783,8 @@
   (&key (:test callable) (:size unsigned-byte)
         (:rehash-size (or (integer 1) (float (1.0))))
         (:rehash-threshold (real 0 1))
-        (:weakness (member nil :key :value :key-and-value :key-or-value)))
+        (:weakness (member nil :key :value :key-and-value :key-or-value))
+        (:synchronized t))
   hash-table
   (flushable unsafe))
 (defknown hash-table-p (t) boolean (movable foldable flushable))

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index c68b615..58693e1 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -631,31 +631,153 @@
 
 (format t "~&binding test done~%")
 
-;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a
-;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form
-;; causing the next gc hang SBCL.
-(with-test (:name (:hash-table-thread-safety))
+;;; HASH TABLES
+
+(defvar *errors* nil)
+
+(defun oops (e)
+  (setf *errors* e)
+  (format t "~&oops: ~A in ~S~%" e *current-thread*)
+  (sb-debug:backtrace)
+  (catch 'done))
+
+(with-test (:name (:unsynchronized-hash-table))
+  ;; We expect a (probable) error here: parellel readers and writers
+  ;; on a hash-table are not expected to work -- but we also don't
+  ;; expect this to corrupt the image.
   (let* ((hash (make-hash-table))
+         (*errors* nil)
          (threads (list (sb-thread:make-thread
                          (lambda ()
-                           (loop
-                            ;;(princ "1") (force-output)
-                            (setf (gethash (random 100) hash) 'h))))
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 ;;(princ "1") (force-output)
+                                 (setf (gethash (random 100) hash) 'h)))))
+                         :name "writer")
                         (sb-thread:make-thread
                          (lambda ()
-                           (loop
-                            ;;(princ "2") (force-output)
-                            (remhash (random 100) hash))))
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 ;;(princ "2") (force-output)
+                                 (remhash (random 100) hash)))))
+                         :name "reader")
                         (sb-thread:make-thread
                          (lambda ()
-                           (loop
-                            (sleep (random 1.0))
-                            (sb-ext:gc :full t)))))))
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 (sleep (random 1.0))
+                                 (sb-ext:gc :full t)))))
+                         :name "collector"))))
     (unwind-protect
-         (sleep 5)
+         (sleep 10)
       (mapc #'sb-thread:terminate-thread threads))))
 
-(format t "~&hash table test done~%")
+(format t "~&unsynchronized hash table test done~%")
+
+(with-test (:name (:synchronized-hash-table))
+  (let* ((hash (make-hash-table :synchronized t))
+         (*errors* nil)
+         (threads (list (sb-thread:make-thread
+                         (lambda ()
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 ;;(princ "1") (force-output)
+                                 (setf (gethash (random 100) hash) 'h)))))
+                         :name "writer")
+                        (sb-thread:make-thread
+                         (lambda ()
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 ;;(princ "2") (force-output)
+                                 (remhash (random 100) hash)))))
+                         :name "reader")
+                        (sb-thread:make-thread
+                         (lambda ()
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 (sleep (random 1.0))
+                                 (sb-ext:gc :full t)))))
+                         :name "collector"))))
+    (unwind-protect
+         (sleep 10)
+      (mapc #'sb-thread:terminate-thread threads))
+    (assert (not *errors*))))
+
+(format t "~&synchronized hash table test done~%")
+
+(with-test (:name (:hash-table-parallel-readers))
+  (let ((hash (make-hash-table))
+        (*errors* nil))
+    (loop repeat 50
+          do (setf (gethash (random 100) hash) 'xxx))
+    (let ((threads (list (sb-thread:make-thread
+                          (lambda ()
+                            (catch 'done
+                              (handler-bind ((serious-condition 'oops))
+                                (loop
+                                      until (eq t (gethash (random 100) hash))))))
+                          :name "reader 1")
+                         (sb-thread:make-thread
+                          (lambda ()
+                            (catch 'done
+                              (handler-bind ((serious-condition 'oops))
+                                (loop
+                                      until (eq t (gethash (random 100) hash))))))
+                          :name "reader 2")
+                         (sb-thread:make-thread
+                          (lambda ()
+                            (catch 'done
+                              (handler-bind ((serious-condition 'oops))
+                                (loop
+                                      until (eq t (gethash (random 100) hash))))))
+                          :name "reader 3")
+                         (sb-thread:make-thread
+                          (lambda ()
+                            (catch 'done
+                              (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 (sleep (random 1.0))
+                                 (sb-ext:gc :full t)))))
+                          :name "collector"))))
+      (unwind-protect
+           (sleep 10)
+        (mapc #'sb-thread:terminate-thread threads))
+      (assert (not *errors*)))))
+
+(format t "~&multiple reader hash table test done~%")
+
+(with-test (:name (:hash-table-single-accessor-parallel-gc))
+  (let ((hash (make-hash-table))
+        (*errors* nil))
+    (let ((threads (list (sb-thread:make-thread
+                          (lambda ()
+                            (handler-bind ((serious-condition 'oops))
+                              (loop
+                                (let ((n (random 100)))
+                                  (if (gethash n hash)
+                                      (remhash n hash)
+                                      (setf (gethash n hash) 'h))))))
+                          :name "accessor")
+                         (sb-thread:make-thread
+                          (lambda ()
+                            (handler-bind ((serious-condition 'oops))
+                              (loop
+                                (sleep (random 1.0))
+                                (sb-ext:gc :full t))))
+                          :name "collector"))))
+      (unwind-protect
+           (sleep 10)
+        (mapc #'sb-thread:terminate-thread threads))
+      (assert (not *errors*)))))
+
+(format t "~&single accessor hash table test~%")
+
 #|  ;; a cll post from eric marsden
 | (defun crash ()
 |   (setq *debugger-hook*

diff --git a/version.lisp-expr b/version.lisp-expr
index bc97d87..9b95dbc 100644 (file)
--- 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.14.17"
+"1.0.14.18"