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,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

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

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

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)

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))))))

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)))

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.

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)