1.0.37.8: add ATOMIC-DECF, fix WAIT-ON-SEMAPHORE-BUGLET

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

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 3496854..eaf1692 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
@@ -679,7 +683,21 @@ negative. Else blocks until the semaphore can be decremented."
                        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)
+  #!+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
@@ -879,7 +897,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.
             ;;
@@ -904,9 +922,6 @@ around and can be retrieved by JOIN-THREAD."
                    ;; 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