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

[sbcl.git] / src / code / target-thread.lisp

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 3496854..6f31ada 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -524,7 +524,10 @@ IF-NOT-OWNER is :FORCE)."
   #!+sb-doc
   "Atomically release MUTEX and enqueue ourselves on QUEUE.  Another
 thread may subsequently notify us using CONDITION-NOTIFY, at which
-time we reacquire MUTEX and return to the caller."
+time we reacquire MUTEX and return to the caller.
+
+Note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of
+returning normally, it may do so without holding the mutex."
   #!-sb-thread (declare (ignore queue))
   (assert mutex)
   #!-sb-thread (error "Not supported in unithread builds.")
@@ -556,7 +559,8 @@ time we reacquire MUTEX and return to the caller."
         ;; continuing after a deadline or EINTR.
         (setf (waitqueue-data queue) me)
         (loop
-         (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
+         (multiple-value-bind (to-sec to-usec)
+             (allow-with-interrupts (decode-timeout nil))
            (case (unwind-protect
                       (with-pinned-objects (queue me)
                         ;; RELEASE-MUTEX is purposefully as close to
@@ -674,12 +678,28 @@ negative. Else blocks until the semaphore can be decremented."
           (setf (semaphore-%count semaphore) (1- count))
           (unwind-protect
                (progn
-                 (incf (semaphore-waitcount semaphore))
+                 ;; Need to use ATOMIC-INCF despite the lock, because on our
+                 ;; way out from here we might not be locked anymore -- so
+                 ;; another thread might be tweaking this in parallel using
+                 ;; ATOMIC-DECF.
+                 (atomic-incf (semaphore-waitcount semaphore))
                  (loop until (plusp (setf count (semaphore-%count semaphore)))
                        do (condition-wait (semaphore-queue semaphore)
                                           (semaphore-mutex semaphore)))
                  (setf (semaphore-%count semaphore) (1- count)))
-            (decf (semaphore-waitcount semaphore)))))))
+            ;; Need to use ATOMIC-DECF instead of DECF, as CONDITION-WAIT
+            ;; may unwind without the lock being held due to timeouts.
+            (atomic-decf (semaphore-waitcount semaphore)))))))
+
+(defun try-semaphore (semaphore &optional (n 1))
+  #!+sb-doc
+  "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 ((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
@@ -688,7 +708,7 @@ on this semaphore, then N of them is woken up."
   (declare (type (integer 1) n))
   ;; Need to disable interrupts so that we don't lose a wakeup after
   ;; we have incremented the count.
-  (with-system-mutex ((semaphore-mutex semaphore))
+  (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t)
     (let ((waitcount (semaphore-waitcount semaphore))
           (count (incf (semaphore-%count semaphore) n)))
       (when (plusp waitcount)
@@ -879,7 +899,7 @@ around and can be retrieved by JOIN-THREAD."
          (setup-sem (make-semaphore :name "Thread setup semaphore"))
          (real-function (coerce function 'function))
          (initial-function
-          (lambda ()
+          (named-lambda initial-thread-function ()
             ;; In time we'll move some of the binding presently done in C
             ;; here too.
             ;;
@@ -900,13 +920,11 @@ around and can be retrieved by JOIN-THREAD."
                    (*handler-clusters* (sb!kernel::initial-handler-clusters))
                    (*condition-restarts* nil)
                    (sb!impl::*deadline* nil)
+                   (sb!impl::*deadline-seconds* nil)
                    (sb!impl::*step-out* nil)
                    ;; internal printer variables
                    (sb!impl::*previous-case* nil)
                    (sb!impl::*previous-readtable-case* nil)
-                   (empty (vector))
-                   (sb!impl::*merge-sort-temp-vector* empty)
-                   (sb!impl::*zap-array-data-temp* empty)
                    (sb!impl::*internal-symbol-output-fun* nil)
                    (sb!impl::*descriptor-handlers* nil)) ; serve-event
               ;; Binding from C