From 6893cb1b25387d1131371649b709398fea78d6f1 Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Fri, 8 Aug 2003 13:41:48 +0000 Subject: [PATCH] .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 --- src/code/target-thread.lisp | 26 ++++++++------- tests/interface.impure.lisp | 2 +- tests/threads.impure.lisp | 75 +++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 91 insertions(+), 14 deletions(-) create mode 100644 tests/threads.impure.lisp diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index c7d40d9..9142ee2 100644 --- 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 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -38,4 +38,4 @@ ;;;; 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 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 --- 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" -- 1.7.10.4