1.0.37.15: Make SB-THREAD:TRY-SEMAPHORE decrement count by N.

Add an &optional N parameter to SB-THREAD:TRY-SEMAPHORE as an
optimization so a user who wants to do so does not need to
acquire a semaphore's lock multiple times but just once.

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 72d0af4..6f31ada 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -691,17 +691,15 @@ negative. Else blocks until the semaphore can be decremented."
             ;; may unwind without the lock being held due to timeouts.
             (atomic-decf (semaphore-waitcount semaphore)))))))
 
-(defun try-semaphore (semaphore)
+(defun try-semaphore (semaphore &optional (n 1))
   #!+sb-doc
-  "Try to decrement the count of SEMAPHORE if the count would not be
-negative. Else return NIL."
-  ;; No need for disabling interrupts; the mutex prevents interleaved
-  ;; modifications, and we don't leave temporarily inconsistent state
-  ;; around.
+  "Try to decrement the count of SEMAPHORE by N. If the count were to
+become negative, punt and return NIL, otherwise return true."
+  (declare (type (integer 1) n))
   (with-mutex ((semaphore-mutex semaphore))
-    (let ((count (semaphore-%count semaphore)))
-      (when (plusp count)
-        (setf (semaphore-%count semaphore) (1- count))))))
+    (let ((new-count (- (semaphore-%count semaphore) n)))
+      (when (not (minusp new-count))
+        (setf (semaphore-%count semaphore) new-count)))))
 
 (defun signal-semaphore (semaphore &optional (n 1))
   #!+sb-doc

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 3937dad..113744d 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -387,6 +387,15 @@
     (assert (try-semaphore sem))
     (assert (zerop (semaphore-count sem)))))
 
+(with-test (:name (:try-semaphore :trivial-fail :n>1))
+  (assert (eq (try-semaphore (make-semaphore :count 1) 2) 'nil)))
+
+(with-test (:name (:try-semaphore :trivial-success :n>1))
+  (let ((sem (make-semaphore :count 10)))
+    (assert (try-semaphore sem 5))
+    (assert (try-semaphore sem 5))
+    (assert (zerop (semaphore-count sem)))))
+
 (with-test (:name (:try-semaphore :emulate-wait-on-semaphore))
   (flet ((busy-wait-on-semaphore (sem)
            (loop until (try-semaphore sem) do (sleep 0.001))))
@@ -406,12 +415,12 @@
     ;; threads-being-interrupted will perform TRY-SEMAPHORE on that
     ;; semaphore, and MORE-WAITERS are new threads trying to wait on
     ;; the semaphore during the interruption-fire.
-    (let* ((sem (make-semaphore :count 50))
+    (let* ((sem (make-semaphore :count 100))
            (waiters (make-threads 20 #'(lambda ()
                                          (wait-on-semaphore sem))))
            (triers  (make-threads 40 #'(lambda ()
                                          (sleep (random 0.01))
-                                         (try-semaphore sem))))
+                                         (try-semaphore sem (1+ (random 5))))))
            (more-waiters
             (loop repeat 10
                   do (kill-thread (nth (random 40) triers))

diff --git a/version.lisp-expr b/version.lisp-expr
index 5093ca6..79735f6 100644 (file)
--- 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".)
-"1.0.37.14"
+"1.0.37.15"
\ No newline at end of file