From: Nikodemus Siivola Date: Mon, 4 Feb 2008 22:14:08 +0000 (+0000) Subject: 1.0.14.18: fix bogus STYLE-WARNING for MAKE-HASH-TABLE :SYNCHRONIZED X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=11ff63e3084c27b8a3360054bd9a60b3cdb49cf1;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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 --- 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"