.8.2.21

	Fixes for a couple of threading bugs found by Gilbert Baumann

	... CONDITION-WAIT should acquire the lock with the correct
	    value (i.e. the one it had when it went to sleep), not
	    just the default value.
	... CONDITION-NOTIFY should get the queue spinlock before
	    signalling, making it atomic wrt WAIT-ON-QUEUE

	Added rudimentary thread test script that I thought I'd
	committed on some previous occasion

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index c7d40d9..9142ee2 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -153,21 +153,23 @@
   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
 thread may subsequently notify us using CONDITION-NOTIFY, at which
 time we reacquire LOCK and return to the caller."
-  (unwind-protect
-       (progn
-        (get-spinlock queue 2 (current-thread-id))
-        (wait-on-queue queue lock))
-    ;; If we are interrupted while waiting, we should do these things
-    ;; before returning.  Ideally, in the case of an unhandled signal,
-    ;; we should do them before entering the debugger, but this is
-    ;; better than nothing.
-    (with-spinlock (queue)
-      (dequeue queue))
-    (get-mutex lock)))
+  (assert lock)
+  (let ((value (mutex-value lock)))
+    (unwind-protect
+        (progn
+          (get-spinlock queue 2 (current-thread-id))
+          (wait-on-queue queue lock))
+      ;; If we are interrupted while waiting, we should do these things
+      ;; before returning.  Ideally, in the case of an unhandled signal,
+      ;; we should do them before entering the debugger, but this is
+      ;; better than nothing.
+      (with-spinlock (queue)
+       (dequeue queue))
+      (get-mutex lock value))))
 
 (defun condition-notify (queue)
   "Notify one of the processes waiting on QUEUE"
-  (signal-queue-head queue))
+  (with-spinlock (queue) (signal-queue-head queue)))
 
 
 ;;;; multiple independent listeners

diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp
index 2bd37ce..ab31744 100644 (file)
--- a/tests/interface.impure.lisp
+++ b/tests/interface.impure.lisp
@@ -38,4 +38,4 @@
 
 \f
 ;;;; success
-(sb-ext:quit :unix-code 104)
+(sb-ext:quit :unix-status 104)

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
new file mode 100644 (file)
index 0000000..9cb119f
--- /dev/null
+++ b/tests/threads.impure.lisp
@@ -0,0 +1,75 @@
+;;;; miscellaneous tests of thread stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;; 
+;;;; This software is in the public domain and is provided with
+;;;; absoluely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+#-sb-thread (quit :unix-status 104)
+
+(in-package "SB-THREAD") ; this is white-box testing, really
+
+;;; elementary "can we get a lock and release it again"
+(let ((l (make-mutex :name "foo"))
+      (p (current-thread-id)))
+  (assert (eql (mutex-value l) nil))
+  (assert (eql (mutex-lock l) 0))
+  (sb-thread:get-mutex l)
+  (assert (eql (mutex-value l) p))
+  (assert (eql (mutex-lock l) 0))
+  (sb-thread:release-mutex l)
+  (assert (eql (mutex-value l) nil))
+  (assert (eql (mutex-lock l) 0)))
+
+(let ((queue (make-waitqueue :name "queue"))
+      (lock (make-mutex :name "lock")))
+  (labels ((in-new-thread ()
+            (with-mutex (lock)
+              (assert (eql (mutex-value lock) (current-thread-id)))
+              (format t "~A got mutex~%" (current-thread-id))
+              ;; now drop it and sleep
+              (condition-wait queue lock)
+              ;; after waking we should have the lock again
+              (assert (eql (mutex-value lock) (current-thread-id))))))
+    (make-thread #'in-new-thread)
+    (sleep 2)                          ; give it  a chance to start
+    ;; check the lock is free while it's asleep
+    (format t "parent thread ~A~%" (current-thread-id))
+    (assert (eql (mutex-value lock) nil))    
+    (assert (eql (mutex-lock lock) 0))
+    (with-mutex (lock)
+      (condition-notify queue))
+    (sleep 1)))
+
+(let ((queue (make-waitqueue :name "queue"))
+      (lock (make-mutex :name "lock")))
+  (labels ((ours-p (value)
+            (sb-vm:control-stack-pointer-valid-p
+             (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))
+          (in-new-thread ()
+            (with-recursive-lock (lock)
+              (assert (ours-p (mutex-value lock)))
+              (format t "~A got mutex~%" (mutex-value lock))
+              ;; now drop it and sleep
+              (condition-wait queue lock)
+              ;; after waking we should have the lock again
+              (format t "woken, ~A got mutex~%" (mutex-value lock))
+              (assert (ours-p (mutex-value lock))))))
+    (make-thread #'in-new-thread)
+    (sleep 2)                          ; give it  a chance to start
+    ;; check the lock is free while it's asleep
+    (format t "parent thread ~A~%" (current-thread-id))
+    (assert (eql (mutex-value lock) nil))    
+    (assert (eql (mutex-lock lock) 0))
+    (with-recursive-lock (lock)
+      (condition-notify queue))
+    (sleep 1)))
+
+;;; success
+(sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 4fbbb0c..00c4750 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".)
-"0.8.2.20"
+"0.8.2.21"