From ddcb2eeafdaa1c6a2cbb7b4b4dd420ad6b83d732 Mon Sep 17 00:00:00 2001 From: "Tobias C. Rittweiler" Date: Mon, 29 Mar 2010 10:54:08 +0000 Subject: [PATCH] 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. --- src/code/target-thread.lisp | 16 +++++++--------- tests/threads.impure.lisp | 13 +++++++++++-- version.lisp-expr | 2 +- 3 files changed, 19 insertions(+), 12 deletions(-) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 72d0af4..6f31ada 100644 --- 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 --- 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 --- 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 -- 1.7.10.4