From 168b9114fdaae539f840cf80b5b023d330239353 Mon Sep 17 00:00:00 2001 From: "Tobias C. Rittweiler" Date: Sun, 28 Mar 2010 13:37:22 +0000 Subject: [PATCH] 1.0.37.6: Add SB-THREAD:TRY-SEMAPHORE. --- NEWS | 2 ++ package-data-list.lisp-expr | 1 + src/code/target-thread.lisp | 18 +++++++++++++ tests/threads.impure.lisp | 62 ++++++++++++++++++++++++++++++++++++++++--- version.lisp-expr | 2 +- 5 files changed, 80 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index f4daf3c..521281b 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,7 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.0.36: + * new feature: added SB-THREAD:TRY-SEMAPHORE, a non-blocking variant of + SB-THREAD:WAIT-ON-SEMAPHORE. * enhancement: *STANDARD-OUTPUT*, *STANDARD-INPUT*, and *ERROR-OUTPUT* are now bivalent. * bug fix: correct restart text for the continuable error in MAKE-PACKAGE. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 42658c9..78a32b5 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1954,6 +1954,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "SEMAPHORE-NAME" "SEMAPHORE-COUNT" "SIGNAL-SEMAPHORE" + "TRY-SEMAPHORE" "WAIT-ON-SEMAPHORE")) #s(sb-cold:package-data diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 7970945..7d5a786 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -680,8 +680,26 @@ negative. Else blocks until the semaphore can be decremented." do (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore))) (setf (semaphore-%count semaphore) (1- count))) + ;; Even safe when CONDITION-WAIT is unwinded without + ;; having reacquired the lock: a) we know at this point + ;; that an INCF must have happened before, b) the DECF + ;; will become visible to other CPUs as the implicit + ;; RELEASE-MUTEX involves a CAS and hence a memory + ;; barrier. (decf (semaphore-waitcount semaphore))))))) +(defun try-semaphore (semaphore) + #!+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. + (with-mutex ((semaphore-mutex semaphore)) + (let ((count (semaphore-%count semaphore))) + (when (plusp count) + (setf (semaphore-%count semaphore) (1- count)))))) + (defun signal-semaphore (semaphore &optional (n 1)) #!+sb-doc "Increment the count of SEMAPHORE by N. If there are threads waiting diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index f32588e..602c438 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -357,11 +357,11 @@ (wait-on-semaphore sem) (assert signalled-p))) -(with-test (:name (:semaphore :multiple-signals)) +(defun test-semaphore-multiple-signals (wait-on-semaphore) (let* ((sem (make-semaphore :count 5)) - (threads (loop repeat 20 - collect (make-thread (lambda () - (wait-on-semaphore sem)))))) + (threads (loop repeat 20 collecting + (make-thread (lambda () + (funcall wait-on-semaphore sem)))))) (flet ((count-live-threads () (count-if #'thread-alive-p threads))) (sleep 0.5) @@ -376,6 +376,60 @@ (sleep 0.5) (assert (= 0 (count-live-threads)))))) +(with-test (:name (:semaphore :multiple-signals)) + (test-semaphore-multiple-signals #'wait-on-semaphore)) + +(with-test (:name (:try-semaphore :trivial-fail)) + (assert (eq (try-semaphore (make-semaphore :count 0)) 'nil))) + +(with-test (:name (:try-semaphore :trivial-success)) + (let ((sem (make-semaphore :count 1))) + (assert (try-semaphore sem)) + (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)))) + (test-semaphore-multiple-signals #'busy-wait-on-semaphore))) + +;;; Here we test that interrupting TRY-SEMAPHORE does not leave a +;;; semaphore in a bad state. +(with-test (:name (:try-semaphore :interrupt-safe)) + (flet ((make-threads (count fn) + (loop repeat count collect (make-thread fn))) + (kill-thread (thread) + (when (thread-alive-p thread) + (ignore-errors (terminate-thread thread)))) + (count-live-threads (threads) + (count-if #'thread-alive-p threads))) + ;; WAITERS will already be waiting on the semaphore while + ;; 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)) + (waiters (make-threads 20 #'(lambda () + (wait-on-semaphore sem)))) + (triers (make-threads 40 #'(lambda () + (sleep (random 0.01)) + (try-semaphore sem)))) + (more-waiters + (loop repeat 10 + do (kill-thread (nth (random 40) triers)) + collect (make-thread #'(lambda () (wait-on-semaphore sem))) + do (kill-thread (nth (random 40) triers))))) + (sleep 0.5) + ;; Now ensure that the waiting threads will all be waked up, + ;; i.e. that the semaphore is still working. + (loop repeat (+ (count-live-threads waiters) + (count-live-threads more-waiters)) + do (signal-semaphore sem)) + (sleep 0.5) + (assert (zerop (count-live-threads triers))) + (assert (zerop (count-live-threads waiters))) + (assert (zerop (count-live-threads more-waiters)))))) + + + (format t "~&semaphore tests done~%") (defun test-interrupt (function-to-interrupt &optional quit-p) diff --git a/version.lisp-expr b/version.lisp-expr index 0467b50..1e96cdc 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.5" +"1.0.37.6" -- 1.7.10.4