Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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.
  • Loading branch information...
commit 239125681cb03e2cce08a50e9bf03589956fd125 1 parent af3fdb9
@nikodemus nikodemus authored
View
2  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
View
14 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
View
2  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
View
5 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)
View
76 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))))))
View
10 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)))
View
56 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.
View
8 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)
Please sign in to comment.
Something went wrong with that request. Please try again.