From 239125681cb03e2cce08a50e9bf03589956fd125 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 15 Sep 2012 13:25:46 +0300 Subject: [PATCH] timeouts for WITH-MUTEX and WITH-RECURSIVE-LOCK * Also support :WAIT-P in WITH-RECUSIVE-LOCK. * Deprecate GET-MUTEX properly (been deprecated since early 2010, but didn't signal a compile-time warning, and we used it internally.) * Make WITH-MUTEX signal a runtime error when :VALUE is used and is other than current thread or NIL. Releasing it isn't going to work right if someone else holds it. --- NEWS | 2 + doc/manual/threading.texinfo | 14 +++---- src/code/early-extensions.lisp | 2 + src/code/target-thread.lisp | 5 +-- src/code/thread.lisp | 76 +++++++++++++++++++++++++--------- tests/deadline.impure.lisp | 10 ++--- tests/threads.impure.lisp | 56 ++++++++++++++++++++++++- tests/threads.pure.lisp | 8 ++-- 8 files changed, 131 insertions(+), 42 deletions(-) diff --git a/NEWS b/NEWS index 2d4b7c925..b56e28db9 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ changes relative to sbcl-1.0.58: * enhancement: New variable, sb-ext:*disassemble-annotate* for controlling source annotation of DISASSEMBLE output. Defaults to T. + * enhancement: TIMEOUT arguments added to WITH-MUTEX and WITH-RECURSIVE-LOCK, and + WAIT-P argument added to WITH-RECURSIVE-LOCK. * enhancement: SB-EXT:ATOMIC-PUSH and SB-EXT:ATOMIC-POP allow atomic operations on list heads. * optimization: CL:SORT and CL:STABLE-SORT of lists are faster and use fewer diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo index 7365510a3..aa36a5be0 100644 --- a/doc/manual/threading.texinfo +++ b/doc/manual/threading.texinfo @@ -139,10 +139,6 @@ thread is allowed to hold the mutex, others which attempt to take it will be made to wait until it's free. Threads are woken in the order that they go to sleep. -There isn't a timeout on mutex acquisition, but the usual WITH-TIMEOUT -macro (which throws a TIMEOUT condition after n seconds) can be used -if you want a bounded wait. - @lisp (defpackage :demo (:use "CL" "SB-THREAD" "SB-EXT")) @@ -162,14 +158,16 @@ if you want a bounded wait. @end lisp @include struct-sb-thread-mutex.texinfo + +@include macro-sb-thread-with-mutex.texinfo +@include macro-sb-thread-with-recursive-lock.texinfo + @include fun-sb-thread-make-mutex.texinfo @include fun-sb-thread-mutex-name.texinfo +@include fun-sb-thread-mutex-owner.texinfo @include fun-sb-thread-mutex-value.texinfo @include fun-sb-thread-grab-mutex.texinfo @include fun-sb-thread-release-mutex.texinfo -@include macro-sb-thread-with-mutex.texinfo -@include macro-sb-thread-with-recursive-lock.texinfo -@include fun-sb-thread-get-mutex.texinfo @node Semaphores @comment node-name, next, previous, up @@ -295,7 +293,7 @@ and @code{sb-ext:atomic-pop}. @item @code{sb-ext:compare-and-swap}. @item -@code{sb-thread:get-mutex}, @code{sb-thread:release-mutex}, +@code{sb-thread:grab-mutex}, @code{sb-thread:release-mutex}, @code{sb-thread:with-mutex} and @code{sb-thread:with-recursive-lock}. @item @code{sb-thread:signal-semaphore}, @code{sb-thread:try-semaphore} and diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index bde43c174..814665621 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1140,6 +1140,8 @@ ;;; deprecated.texinfo. ;;; ;;; EARLY: +;;; - SB-THREAD::GET-MUTEX, since 1.0.37.33 (04/2010) -> Late: 01/2013 +;;; ^- initially deprecated without compile-time warning, hence the schedule ;;; - SB-THREAD::SPINLOCK (type), since 1.0.53.11 (08/2011) -> Late: 08/2012 ;;; - SB-THREAD::MAKE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012 ;;; - SB-THREAD::WITH-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012 diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index bf9b2a65c..0ec0b3795 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -615,9 +615,8 @@ HOLDING-MUTEX-P." (decode-timeout timeout)) (go :again))))))) -(defun get-mutex (mutex &optional new-owner (waitp t) (timeout nil)) - #!+sb-doc - "Deprecated in favor of GRAB-MUTEX." +(define-deprecated-function :early "1.0.37.33" get-mutex (grab-mutex) + (mutex &optional new-owner (waitp t) (timeout nil)) (declare (ignorable waitp timeout)) (let ((new-owner (or new-owner *current-thread*))) (or (%try-mutex mutex new-owner) diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 09c2cc456..f73c9bd6e 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -125,18 +125,32 @@ stale value, use MUTEX-OWNER instead." (barrier (:write))))) (exec))))))) -(sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t)) +(sb!xc:defmacro with-mutex ((mutex &key (wait-p t) timeout value) &body body) #!+sb-doc - "Acquire MUTEX for the dynamic scope of BODY, setting it to VALUE or -some suitable default value if NIL. If WAIT-P is non-NIL and the mutex -is in use, sleep until it is available" + "Acquire MUTEX for the dynamic scope of BODY. If WAIT-P is true (the default), +and the MUTEX is not immediately available, sleep until it is available. + +If TIMEOUT is given, it specifies a relative timeout, in seconds, on how long +the system should try to acquire the lock in the contested case. + +If the mutex isn't acquired succesfully due to either WAIT-P or TIMEOUT, the +body is not executed, and WITH-MUTEX returns NIL. + +Otherwise body is executed with the mutex held by current thread, and +WITH-MUTEX returns the values of BODY. + +Historically WITH-MUTEX also accepted a VALUE argument, which when provided +was used as the new owner of the mutex instead of the current thread. This is +no longer supported: if VALUE is provided, it must be either NIL or the +current thread." `(dx-flet ((with-mutex-thunk () ,@body)) (call-with-mutex #'with-mutex-thunk ,mutex ,value - ,wait-p))) + ,wait-p + ,timeout))) (sb!xc:defmacro with-system-mutex ((mutex &key without-gcing allow-with-interrupts) @@ -151,16 +165,30 @@ is in use, sleep until it is available" #'with-system-mutex-thunk ,mutex))) -(sb!xc:defmacro with-recursive-lock ((mutex) &body body) +(sb!xc:defmacro with-recursive-lock ((mutex &key (wait-p t) timeout) &body body) #!+sb-doc - "Acquires MUTEX for the dynamic scope of BODY. Within that scope -further recursive lock attempts for the same mutex succeed. It is -allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex -provided the default value is used for the mutex." + "Acquire MUTEX for the dynamic scope of BODY. + +If WAIT-P is true (the default), and the MUTEX is not immediately available or +held by the current thread, sleep until it is available. + +If TIMEOUT is given, it specifies a relative timeout, in seconds, on how long +the system should try to acquire the lock in the contested case. + +If the mutex isn't acquired succesfully due to either WAIT-P or TIMEOUT, the +body is not executed, and WITH-RECURSIVE-LOCK returns NIL. + +Otherwise body is executed with the mutex held by current thread, and +WITH-RECURSIVE-LOCK returns the values of BODY. + +Unlike WITH-MUTEX, which signals an error on attempt to re-acquire an already +held mutex, WITH-RECURSIVE-LOCK allows recursive lock attempts to succeed." `(dx-flet ((with-recursive-lock-thunk () ,@body)) (call-with-recursive-lock #'with-recursive-lock-thunk - ,mutex))) + ,mutex + ,wait-p + ,timeout))) (sb!xc:defmacro with-recursive-system-lock ((lock &key without-gcing) @@ -180,7 +208,7 @@ provided the default value is used for the mutex." (flet ((%call-with-system-mutex () (dx-let (got-it) (unwind-protect - (when (setf got-it (get-mutex mutex)) + (when (setf got-it (grab-mutex mutex)) (funcall function)) (when got-it (release-mutex mutex)))))) @@ -199,13 +227,16 @@ provided the default value is used for the mutex." #!-sb-thread (progn - (defun call-with-mutex (function mutex value waitp) - (declare (ignore mutex value waitp) + (defun call-with-mutex (function mutex value waitp timeout) + (declare (ignore mutex value waitp timeout) (function function)) + (unless (or (null value) (eq *current-thread* value)) + (error "~S called with non-nil :VALUE that isn't the current thread." + 'with-mutex)) (funcall function)) - (defun call-with-recursive-lock (function mutex) - (declare (ignore mutex) (function function)) + (defun call-with-recursive-lock (function mutex waitp timeout) + (declare (ignore mutex) (function function waitp timeout)) (funcall function)) (defun call-with-recursive-system-lock (function lock) @@ -223,25 +254,30 @@ provided the default value is used for the mutex." ;;; closes over GOT-IT causes a value-cell to be allocated for it -- ;;; and we prefer that to go on the stack since it can. (progn - (defun call-with-mutex (function mutex value waitp) + (defun call-with-mutex (function mutex value waitp timeout) (declare (function function)) + (unless (or (null value) (eq *current-thread* value)) + (error "~S called with non-nil :VALUE that isn't the current thread." + 'with-mutex)) (dx-let ((got-it nil)) (without-interrupts (unwind-protect (when (setq got-it (allow-with-interrupts - (get-mutex mutex value waitp))) + (grab-mutex mutex :waitp waitp + :timeout timeout))) (with-local-interrupts (funcall function))) (when got-it (release-mutex mutex)))))) - (defun call-with-recursive-lock (function mutex) + (defun call-with-recursive-lock (function mutex waitp timeout) (declare (function function)) (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*)) (got-it nil)) (without-interrupts (unwind-protect (when (or inner-lock-p (setf got-it (allow-with-interrupts - (get-mutex mutex)))) + (grab-mutex mutex :waitp waitp + :timeout timeout)))) (with-local-interrupts (funcall function))) (when got-it (release-mutex mutex)))))) diff --git a/tests/deadline.impure.lisp b/tests/deadline.impure.lisp index 3e265a943..22d9ed035 100644 --- a/tests/deadline.impure.lisp +++ b/tests/deadline.impure.lisp @@ -65,17 +65,17 @@ (assert (= n 1)) (assert (not final)))) -(with-test (:name (:deadline :get-mutex) :skipped-on '(not :sb-thread)) +(with-test (:name (:deadline :grab-mutex) :skipped-on '(not :sb-thread)) (assert-timeout (let ((lock (sb-thread:make-mutex)) (waitp t)) (sb-thread:make-thread (lambda () - (sb-thread:get-mutex lock) + (sb-thread:grab-mutex lock) (setf waitp nil) (sleep 5))) (loop while waitp do (sleep 0.01)) (sb-sys:with-deadline (:seconds 1) - (sb-thread:get-mutex lock))))) + (sb-thread:grab-mutex lock))))) (with-test (:name (:deadline :wait-on-semaphore) :skipped-on '(not :sb-thread)) (assert-timeout @@ -93,7 +93,7 @@ (let ((lock (sb-thread:make-mutex)) (waitp t)) (sb-thread:make-thread (lambda () - (sb-thread:get-mutex lock) + (sb-thread:grab-mutex lock) (setf waitp nil) (sleep 5))) (loop while waitp do (sleep 0.01)) @@ -102,7 +102,7 @@ (let ((start (get-internal-real-time))) (handler-case (sb-sys:with-deadline (:seconds 1) - (sb-thread:get-mutex lock)) + (sb-thread:grab-mutex lock)) (sb-sys:deadline-timeout (x) (declare (ignore x)) (let ((end (get-internal-real-time))) diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 20ac538d8..2354baca2 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -37,6 +37,18 @@ (with-mutex (mutex) mutex))) +(with-test (:name (:with-mutex :timeout)) + (let ((m (make-mutex))) + (with-mutex (m) + (assert (null (join-thread (make-thread + (lambda () + (with-mutex (m :timeout 0.1) + t))))))) + (assert (join-thread (make-thread + (lambda () + (with-mutex (m :timeout 0.1) + t))))))) + (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose" void (where sb-alien:unsigned-long)) @@ -208,7 +220,7 @@ (let ((l (make-mutex :name "foo")) (p *current-thread*)) (assert (eql (mutex-value l) nil) nil "1") - (sb-thread:get-mutex l) + (sb-thread:grab-mutex l) (assert (eql (mutex-value l) p) nil "3") (sb-thread:release-mutex l) (assert (eql (mutex-value l) nil) nil "5"))) @@ -225,6 +237,46 @@ (assert (ours-p (mutex-value l)) nil "5")) (assert (eql (mutex-value l) nil) nil "6")))) +(with-test (:name (:with-recursive-lock :wait-p)) + (let ((m (make-mutex))) + (with-mutex (m) + (assert (null (join-thread (make-thread + (lambda () + (with-recursive-lock (m :wait-p nil) + t))))))) + (assert (join-thread (make-thread + (lambda () + (with-recursive-lock (m :wait-p nil) + t))))))) + +(with-test (:name (:with-recursive-lock :wait-p :recursive)) + (let ((m (make-mutex))) + (assert (join-thread (make-thread + (lambda () + (with-recursive-lock (m :wait-p nil) + (with-recursive-lock (m :wait-p nil) + t)))))))) + +(with-test (:name (:with-recursive-lock :timeout)) + (let ((m (make-mutex))) + (with-mutex (m) + (assert (null (join-thread (make-thread + (lambda () + (with-recursive-lock (m :timeout 0.1) + t))))))) + (assert (join-thread (make-thread + (lambda () + (with-recursive-lock (m :timeout 0.1) + t))))))) + +(with-test (:name (:with-recursive-lock :timeout :recursive)) + (let ((m (make-mutex))) + (assert (join-thread (make-thread + (lambda () + (with-recursive-lock (m :timeout 0.1) + (with-recursive-lock (m :timeout 0.1) + t)))))))) + (with-test (:name (:mutex :nesting-mutex-and-recursive-lock)) (let ((l (make-mutex :name "a mutex"))) (with-mutex (l) @@ -1102,7 +1154,7 @@ (handler-bind ((sb-sys:deadline-timeout #'(lambda (c) - ;; We came here through the call to GET-MUTEX + ;; We came here through the call to DECODE-TIMEOUT ;; in CONDITION-WAIT (contended case of ;; reaquiring the mutex) - so the former will ;; be NIL, but interrupts should still be enabled. diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index f99e01a06..03da75b67 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -35,7 +35,7 @@ (with-test (:name mutex-owner) ;; Make sure basics are sane on unithreaded ports as well (let ((mutex (make-mutex))) - (get-mutex mutex) + (grab-mutex mutex) (assert (eq *current-thread* (mutex-value mutex))) (handler-bind ((warning #'error)) (release-mutex mutex)) @@ -71,11 +71,11 @@ (sleep 1) (assert (not (thread-alive-p thread))))) -;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS +;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS -(with-test (:name without-interrupts+get-mutex :skipped-on '(not :sb-thread)) +(with-test (:name without-interrupts+grab-mutex :skipped-on '(not :sb-thread)) (let* ((lock (make-mutex)) - (bar (progn (get-mutex lock) nil)) + (bar (progn (grab-mutex lock) nil)) (thread (make-thread (lambda () (sb-sys:without-interrupts (with-mutex (lock)