* 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.
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
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"))
@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
@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
;;; 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
(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)
(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)
#'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)
(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))))))
#!-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)
;;; 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))))))
(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
(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))
(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)))
(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))
(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")))
(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)
(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.
(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))
(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)
projects / sbcl.git / commitdiff