1.0.37.6: Add SB-THREAD:TRY-SEMAPHORE.

diff --git a/NEWS b/NEWS
index f4daf3c..521281b 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (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.5"
+"1.0.37.6"