- (progn
- (get-spinlock ,queue 2 ,pid)
- ,@body)
- (release-spinlock ,queue 2 ,pid)))))
-
-
-;;;; the higher-level locking operations are based on waitqueues
-
-(declaim (inline waitqueue-data-address mutex-value-address))
-
-(defstruct waitqueue
- (name nil :type (or null simple-string))
- (lock 0)
- (data nil))
-
-;;; The bare 4 here and 5 below are offsets of the slots in the struct.
-;;; There ought to be some better way to get these numbers
-(defun waitqueue-data-address (lock)
- (declare (optimize (speed 3)))
- (sb!ext:truly-the
- (unsigned-byte 32)
- (+ (sb!kernel:get-lisp-obj-address lock)
- (- (* 4 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
-
-(defstruct (mutex (:include waitqueue))
- (value nil))
-
-(defun mutex-value-address (lock)
- (declare (optimize (speed 3)))
- (sb!ext:truly-the
- (unsigned-byte 32)
- (+ (sb!kernel:get-lisp-obj-address lock)
- (- (* 5 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
-
-(declaim (inline futex-wait futex-wake))
-(sb!alien:define-alien-routine
- "futex_wait" int (word unsigned-long) (old-value unsigned-long))
-(sb!alien:define-alien-routine
- "futex_wake" int (word unsigned-long) (n unsigned-long))
-
-
-;;;; mutex
-
-(defun get-mutex (lock &optional new-value (wait-p t))
- "Acquire LOCK, setting it to NEW-VALUE or some suitable default value
-if NIL. If WAIT-P is non-NIL and the lock is in use, sleep until it
-is available"
- (declare (type mutex lock) (optimize (speed 3)))
- (let ((pid (current-thread-id))
- old)
- (unless new-value (setf new-value pid))
- (when (eql new-value (mutex-value lock))
- (warn "recursive lock attempt ~S~%" lock))
- (loop
- (unless
- (setf old (sb!vm::%instance-set-conditional lock 4 nil new-value))
- (return t))
- (unless wait-p (return nil))
- (futex-wait (mutex-value-address lock)
- (sb!kernel:get-lisp-obj-address old)))))
-
-(defun release-mutex (lock)
- (declare (type mutex lock))
- (setf (mutex-value lock) nil)
- (futex-wake (mutex-value-address lock) 1))
-
-;;;; condition variables
-
-(defun condition-wait (queue lock)
- "Atomically release LOCK and enqueue ourselves on QUEUE. Another
-thread may subsequently notify us using CONDITION-NOTIFY, at which
-time we reacquire LOCK and return to the caller."
- (assert lock)
- (let ((value (mutex-value lock)))
- (unwind-protect
- (let ((me (current-thread-id)))
- ;; XXX we should do something to ensure that the result of this setf
- ;; is visible to all CPUs
- (setf (waitqueue-data queue) me)
- (release-mutex lock)
- ;; Now we go to sleep using futex-wait. If anyone else
- ;; manages to grab LOCK and call CONDITION-NOTIFY during
- ;; this comment, it will change queue->data, and so
- ;; futex-wait returns immediately instead of sleeping.
- ;; Ergo, no lost wakeup
- (futex-wait (waitqueue-data-address queue)
- (sb!kernel:get-lisp-obj-address me)))
- ;; If we are interrupted while waiting, we should do these things
- ;; before returning. Ideally, in the case of an unhandled signal,
- ;; we should do them before entering the debugger, but this is
- ;; better than nothing.
- (get-mutex lock value))))
-
-
-(defun condition-notify (queue)
- "Notify one of the processes waiting on QUEUE"
- (let ((me (current-thread-id)))
- ;; no problem if >1 thread notifies during the comment in
- ;; condition-wait: as long as the value in queue-data isn't the
- ;; waiting thread's id, it matters not what it is
+ (progn
+ (setf (thread-waiting-for ,n-thread) ,new)
+ (barrier (:write))
+ ,@forms)
+ ;; Interrupt handlers and GC save and restore any
+ ;; previous wait marks using WITHOUT-DEADLOCKS below.
+ (setf (thread-waiting-for ,n-thread) nil)
+ (barrier (:write))))))
+\f
+;;;; Mutexes
+
+#!+sb-doc
+(setf (fdocumentation 'make-mutex 'function)
+ "Create a mutex."
+ (fdocumentation 'mutex-name 'function)
+ "The name of the mutex. Setfable.")
+
+#!+(and sb-thread sb-futex)
+(progn
+ (define-structure-slot-addressor mutex-state-address
+ :structure mutex
+ :slot state)
+ ;; Important: current code assumes these are fixnums or other
+ ;; lisp objects that don't need pinning.
+ (defconstant +lock-free+ 0)
+ (defconstant +lock-taken+ 1)
+ (defconstant +lock-contested+ 2))
+
+(defun mutex-owner (mutex)
+ "Current owner of the mutex, NIL if the mutex is free. Naturally,
+this is racy by design (another thread may acquire the mutex after
+this function returns), it is intended for informative purposes. For
+testing whether the current thread is holding a mutex see
+HOLDING-MUTEX-P."
+ ;; Make sure to get the current value.
+ (sb!ext:compare-and-swap (mutex-%owner mutex) nil nil))
+
+(sb!ext:defglobal **deadlock-lock** nil)
+
+;;; Signals an error if owner of LOCK is waiting on a lock whose release
+;;; depends on the current thread. Does not detect deadlocks from sempahores.
+(defun check-deadlock ()
+ (let* ((self *current-thread*)
+ (origin (progn
+ (barrier (:read))
+ (thread-waiting-for self))))
+ (labels ((detect-deadlock (lock)
+ (let ((other-thread (mutex-%owner lock)))
+ (cond ((not other-thread))
+ ((eq self other-thread)
+ (let ((chain
+ (with-cas-lock ((symbol-value '**deadlock-lock**))
+ (prog1 (deadlock-chain self origin)
+ ;; We're now committed to signaling the
+ ;; error and breaking the deadlock, so
+ ;; mark us as no longer waiting on the
+ ;; lock. This ensures that a single
+ ;; deadlock is reported in only one
+ ;; thread, and that we don't look like
+ ;; we're waiting on the lock when print
+ ;; stuff -- because that may lead to
+ ;; further deadlock checking, in turn
+ ;; possibly leading to a bogus vicious
+ ;; metacycle on PRINT-OBJECT.
+ (setf (thread-waiting-for self) nil)))))
+ (error 'thread-deadlock
+ :thread *current-thread*
+ :cycle chain)))
+ (t
+ (let ((other-lock (progn
+ (barrier (:read))
+ (thread-waiting-for other-thread))))
+ ;; If the thread is waiting with a timeout OTHER-LOCK
+ ;; is a cons, and we don't consider it a deadlock -- since
+ ;; it will time out on its own sooner or later.
+ (when (mutex-p other-lock)
+ (detect-deadlock other-lock)))))))
+ (deadlock-chain (thread lock)
+ (let* ((other-thread (mutex-owner lock))
+ (other-lock (when other-thread
+ (barrier (:read))
+ (thread-waiting-for other-thread))))
+ (cond ((not other-thread)
+ ;; The deadlock is gone -- maybe someone unwound
+ ;; from the same deadlock already?
+ (return-from check-deadlock nil))
+ ((consp other-lock)
+ ;; There's a timeout -- no deadlock.
+ (return-from check-deadlock nil))
+ ((waitqueue-p other-lock)
+ ;; Not a lock.
+ (return-from check-deadlock nil))
+ ((eq self other-thread)
+ ;; Done
+ (list (list thread lock)))
+ (t
+ (if other-lock
+ (cons (cons thread lock)
+ (deadlock-chain other-thread other-lock))
+ ;; Again, the deadlock is gone?
+ (return-from check-deadlock nil)))))))
+ ;; Timeout means there is no deadlock
+ (when (mutex-p origin)
+ (detect-deadlock origin)
+ t))))
+
+(defun %try-mutex (mutex new-owner)
+ (declare (type mutex mutex) (optimize (speed 3)))
+ (barrier (:read))
+ (let ((old (mutex-%owner mutex)))
+ (when (eq new-owner old)
+ (error "Recursive lock attempt ~S." mutex))
+ #!-sb-thread
+ (when old
+ (error "Strange deadlock on ~S in an unithreaded build?" mutex))
+ #!-(and sb-thread sb-futex)
+ (and (not old)
+ ;; Don't even bother to try to CAS if it looks bad.
+ (not (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner)))
+ #!+(and sb-thread sb-futex)
+ ;; From the Mutex 2 algorithm from "Futexes are Tricky" by Ulrich Drepper.
+ (when (eql +lock-free+ (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-free+
+ +lock-taken+))
+ (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner)))
+ (when prev
+ (bug "Old owner in free mutex: ~S" prev))
+ t))))
+
+#!+sb-thread
+(defun %%wait-for-mutex (mutex new-owner to-sec to-usec stop-sec stop-usec)
+ (declare (type mutex mutex) (optimize (speed 3)))
+ #!-sb-futex
+ (declare (ignore to-sec to-usec))
+ #!-sb-futex
+ (flet ((cas ()
+ (loop repeat 100
+ when (and (progn
+ (barrier (:read))
+ (not (mutex-%owner mutex)))
+ (not (sb!ext:compare-and-swap (mutex-%owner mutex) nil
+ new-owner)))
+ do (return-from cas t)
+ else
+ do
+ (sb!ext:spin-loop-hint))
+ ;; Check for pending interrupts.
+ (with-interrupts nil)))
+ (declare (dynamic-extent #'cas))
+ (sb!impl::%%wait-for #'cas stop-sec stop-usec))
+ #!+sb-futex
+ ;; This is a fairly direct translation of the Mutex 2 algorithm from
+ ;; "Futexes are Tricky" by Ulrich Drepper.
+ (flet ((maybe (old)
+ (when (eql +lock-free+ old)
+ (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex)
+ nil new-owner)))
+ (when prev
+ (bug "Old owner in free mutex: ~S" prev))
+ (return-from %%wait-for-mutex t)))))
+ (prog ((old (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-free+ +lock-taken+)))
+ ;; Got it right off the bat?
+ (maybe old)
+ :retry
+ ;; Mark it as contested, and sleep. (Exception: it was just released.)
+ (when (or (eql +lock-contested+ old)
+ (not (eql +lock-free+
+ (sb!ext:compare-and-swap
+ (mutex-state mutex) +lock-taken+ +lock-contested+))))
+ (when (eql 1 (with-pinned-objects (mutex)
+ (futex-wait (mutex-state-address mutex)
+ (get-lisp-obj-address +lock-contested+)
+ (or to-sec -1)
+ (or to-usec 0))))
+ ;; -1 = EWOULDBLOCK, possibly spurious wakeup
+ ;; 0 = normal wakeup
+ ;; 1 = ETIMEDOUT ***DONE***
+ ;; 2 = EINTR, a spurious wakeup
+ (return-from %%wait-for-mutex nil)))
+ ;; Try to get it, still marking it as contested.
+ (maybe
+ (sb!ext:compare-and-swap (mutex-state mutex) +lock-free+ +lock-contested+))
+ ;; Update timeout if necessary.
+ (when stop-sec
+ (setf (values to-sec to-usec)
+ (sb!impl::relative-decoded-times stop-sec stop-usec)))
+ ;; Spin.
+ (go :retry))))
+
+#!+sb-thread
+(defun %wait-for-mutex (mutex self timeout to-sec to-usec stop-sec stop-usec deadlinep)
+ (with-deadlocks (self mutex timeout)
+ (with-interrupts (check-deadlock))
+ (tagbody
+ :again
+ (return-from %wait-for-mutex
+ (or (%%wait-for-mutex mutex self to-sec to-usec stop-sec stop-usec)
+ (when deadlinep
+ (signal-deadline)
+ ;; FIXME: substract elapsed time from timeout...
+ (setf (values to-sec to-usec stop-sec stop-usec deadlinep)
+ (decode-timeout timeout))
+ (go :again)))))))
+
+(define-deprecated-function :early "1.0.37.33" get-mutex (grab-mutex)
+ (mutex &optional new-owner (waitp t) (timeout nil))
+ (declare (ignorable waitp timeout))
+ (let ((new-owner (or new-owner *current-thread*)))
+ (or (%try-mutex mutex new-owner)
+ #!+sb-thread
+ (when waitp
+ (multiple-value-call #'%wait-for-mutex
+ mutex new-owner timeout (decode-timeout timeout))))))
+
+(defun grab-mutex (mutex &key (waitp t) (timeout nil))
+ #!+sb-doc
+ "Acquire MUTEX for the current thread. If WAITP is true (the default) and
+the mutex is not immediately available, sleep until it is available.
+
+If TIMEOUT is given, it specifies a relative timeout, in seconds, on how long
+GRAB-MUTEX should try to acquire the lock in the contested case.
+
+If GRAB-MUTEX returns T, the lock acquisition was successful. In case of WAITP
+being NIL, or an expired TIMEOUT, GRAB-MUTEX may also return NIL which denotes
+that GRAB-MUTEX did -not- acquire the lock.
+
+Notes:
+
+ - GRAB-MUTEX is not interrupt safe. The correct way to call it is:
+
+ (WITHOUT-INTERRUPTS
+ ...
+ (ALLOW-WITH-INTERRUPTS (GRAB-MUTEX ...))
+ ...)
+
+ WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding the call
+ while the mutex is in an inconsistent state while ALLOW-WITH-INTERRUPTS
+ allows the call to be interrupted from sleep.
+
+ - (GRAB-MUTEX <mutex> :timeout 0.0) differs from
+ (GRAB-MUTEX <mutex> :waitp nil) in that the former may signal a
+ DEADLINE-TIMEOUT if the global deadline was due already on entering
+ GRAB-MUTEX.
+
+ The exact interplay of GRAB-MUTEX and deadlines are reserved to change in
+ future versions.
+
+ - It is recommended that you use WITH-MUTEX instead of calling GRAB-MUTEX
+ directly.
+"
+ (declare (ignorable waitp timeout))
+ (let ((self *current-thread*))
+ (or (%try-mutex mutex self)
+ #!+sb-thread
+ (when waitp
+ (multiple-value-call #'%wait-for-mutex
+ mutex self timeout (decode-timeout timeout))))))
+
+(defun release-mutex (mutex &key (if-not-owner :punt))
+ #!+sb-doc
+ "Release MUTEX by setting it to NIL. Wake up threads waiting for
+this mutex.
+
+RELEASE-MUTEX is not interrupt safe: interrupts should be disabled
+around calls to it.
+
+If the current thread is not the owner of the mutex then it silently
+returns without doing anything (if IF-NOT-OWNER is :PUNT), signals a
+WARNING (if IF-NOT-OWNER is :WARN), or releases the mutex anyway (if
+IF-NOT-OWNER is :FORCE)."
+ (declare (type mutex mutex))
+ ;; Order matters: set owner to NIL before releasing state.
+ (let* ((self *current-thread*)
+ (old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil)))
+ (unless (eq self old-owner)
+ (ecase if-not-owner
+ ((:punt) (return-from release-mutex nil))
+ ((:warn)
+ (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner))
+ ((:force)))
+ (setf (mutex-%owner mutex) nil)
+ ;; FIXME: Is a :memory barrier too strong here? Can we use a :write
+ ;; barrier instead?
+ (barrier (:memory)))
+ #!+(and sb-thread sb-futex)
+ (when old-owner
+ ;; FIXME: once ATOMIC-INCF supports struct slots with word sized
+ ;; unsigned-byte type this can be used:
+ ;;
+ ;; (let ((old (sb!ext:atomic-incf (mutex-state mutex) -1)))
+ ;; (unless (eql old +lock-free+)
+ ;; (setf (mutex-state mutex) +lock-free+)
+ ;; (with-pinned-objects (mutex)
+ ;; (futex-wake (mutex-state-address mutex) 1))))
+ (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-taken+ +lock-free+)))
+ (when (eql old +lock-contested+)
+ (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-contested+ +lock-free+)
+ (with-pinned-objects (mutex)
+ (futex-wake (mutex-state-address mutex) 1))))
+ nil)))
+\f
+
+;;;; Waitqueues/condition variables
+
+#!+(or (not sb-thread) sb-futex)
+(defstruct (waitqueue (:constructor %make-waitqueue))
+ #!+sb-doc
+ "Waitqueue type."
+ (name nil :type (or null thread-name))
+ #!+(and sb-thread sb-futex)
+ (token nil))
+
+#!+(and sb-thread (not sb-futex))
+(progn
+ (defstruct (waitqueue (:constructor %make-waitqueue))
+ #!+sb-doc
+ "Waitqueue type."
+ (name nil :type (or null thread-name))
+ ;; For WITH-CAS-LOCK: because CONDITION-WAIT must be able to call
+ ;; %WAITQUEUE-WAKEUP without re-aquiring the mutex, we need a separate
+ ;; lock. In most cases this should be uncontested thanks to the mutex --
+ ;; the only case where that might not be true is when CONDITION-WAIT
+ ;; unwinds and %WAITQUEUE-DROP is called.
+ %owner
+ %head
+ %tail)
+
+ (defun %waitqueue-enqueue (thread queue)
+ (setf (thread-waiting-for thread) queue)
+ (let ((head (waitqueue-%head queue))
+ (tail (waitqueue-%tail queue))
+ (new (list thread)))
+ (unless head
+ (setf (waitqueue-%head queue) new))
+ (when tail
+ (setf (cdr tail) new))
+ (setf (waitqueue-%tail queue) new)
+ nil))
+ (defun %waitqueue-drop (thread queue)
+ (setf (thread-waiting-for thread) nil)
+ (let ((head (waitqueue-%head queue)))
+ (do ((list head (cdr list))
+ (prev nil list))
+ ((or (null list)
+ (eq (car list) thread))
+ (when list
+ (let ((rest (cdr list)))
+ (cond (prev
+ (setf (cdr prev) rest))
+ (t
+ (setf (waitqueue-%head queue) rest
+ prev rest)))
+ (unless rest
+ (setf (waitqueue-%tail queue) prev)))))))
+ nil)
+ (defun %waitqueue-wakeup (queue n)
+ (declare (fixnum n))
+ (loop while (plusp n)
+ for next = (let ((head (waitqueue-%head queue))
+ (tail (waitqueue-%tail queue)))
+ (when head
+ (if (eq head tail)
+ (setf (waitqueue-%head queue) nil
+ (waitqueue-%tail queue) nil)
+ (setf (waitqueue-%head queue) (cdr head)))
+ (car head)))
+ while next
+ do (when (eq queue (sb!ext:compare-and-swap
+ (thread-waiting-for next) queue nil))
+ (decf n)))
+ nil))
+
+(def!method print-object ((waitqueue waitqueue) stream)
+ (print-unreadable-object (waitqueue stream :type t :identity t)
+ (format stream "~@[~A~]" (waitqueue-name waitqueue))))
+
+(defun make-waitqueue (&key name)
+ #!+sb-doc
+ "Create a waitqueue."
+ (%make-waitqueue :name name))
+
+#!+sb-doc
+(setf (fdocumentation 'waitqueue-name 'function)
+ "The name of the waitqueue. Setfable.")
+
+#!+(and sb-thread sb-futex)
+(define-structure-slot-addressor waitqueue-token-address
+ :structure waitqueue
+ :slot token)
+
+(defun condition-wait (queue mutex &key timeout)
+ #!+sb-doc
+ "Atomically release MUTEX and start waiting on QUEUE for till another thread
+wakes us up using either CONDITION-NOTIFY or CONDITION-BROADCAST on that
+queue, at which point we re-acquire MUTEX and return T.
+
+Spurious wakeups are possible.
+
+If TIMEOUT is given, it is the maximum number of seconds to wait, including
+both waiting for the wakeup and the time to re-acquire MUTEX. Unless both
+wakeup and re-acquisition do not occur within the given time, returns NIL
+without re-acquiring the mutex.
+
+If CONDITION-WAIT unwinds, it may do so with or without the mutex being held.
+
+Important: Since CONDITION-WAIT may return without CONDITION-NOTIFY having
+occurred the correct way to write code that uses CONDITION-WAIT is to loop
+around the call, checking the the associated data:
+
+ (defvar *data* nil)
+ (defvar *queue* (make-waitqueue))
+ (defvar *lock* (make-mutex))
+
+ ;; Consumer
+ (defun pop-data (&optional timeout)
+ (with-mutex (*lock*)
+ (loop until *data*
+ do (or (condition-wait *queue* *lock* :timeout timeout)
+ ;; Lock not held, must unwind without touching *data*.
+ (return-from pop-data nil)))
+ (pop *data*)))
+
+ ;; Producer
+ (defun push-data (data)
+ (with-mutex (*lock*)
+ (push data *data*)
+ (condition-notify *queue*)))
+"
+ #!-sb-thread
+ (declare (ignore queue))
+ (assert mutex)
+ #!-sb-thread
+ (sb!ext:wait-for nil :timeout timeout) ; Yeah...
+ #!+sb-thread
+ (let ((me *current-thread*))
+ (barrier (:read))
+ (assert (eq me (mutex-%owner mutex)))
+ (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
+ (decode-timeout timeout)
+ (let ((status :interrupted))
+ ;; Need to disable interrupts so that we don't miss grabbing the
+ ;; mutex on our way out.
+ (without-interrupts
+ (unwind-protect
+ (progn
+ #!-sb-futex
+ (progn
+ (%with-cas-lock ((waitqueue-%owner queue))
+ (%waitqueue-enqueue me queue))
+ (release-mutex mutex)
+ (setf status
+ (or (flet ((wakeup ()
+ (barrier (:read))
+ (unless (eq queue (thread-waiting-for me))
+ :ok)))
+ (declare (dynamic-extent #'wakeup))
+ (allow-with-interrupts
+ (sb!impl::%%wait-for #'wakeup stop-sec stop-usec)))
+ :timeout)))
+ #!+sb-futex
+ (with-pinned-objects (queue me)
+ (setf (waitqueue-token queue) me)
+ (release-mutex mutex)
+ ;; Now we go to sleep using futex-wait. If anyone else
+ ;; manages to grab MUTEX and call CONDITION-NOTIFY during
+ ;; this comment, it will change the token, and so futex-wait
+ ;; returns immediately instead of sleeping. Ergo, no lost
+ ;; wakeup. We may get spurious wakeups, but that's ok.
+ (setf status
+ (case (allow-with-interrupts
+ (futex-wait (waitqueue-token-address queue)
+ (get-lisp-obj-address me)
+ ;; our way of saying "no
+ ;; timeout":
+ (or to-sec -1)
+ (or to-usec 0)))
+ ((1)
+ ;; 1 = ETIMEDOUT
+ :timeout)
+ (t
+ ;; -1 = EWOULDBLOCK, possibly spurious wakeup
+ ;; 0 = normal wakeup
+ ;; 2 = EINTR, a spurious wakeup
+ :ok)))))
+ #!-sb-futex
+ (%with-cas-lock ((waitqueue-%owner queue))
+ (if (eq queue (thread-waiting-for me))
+ (%waitqueue-drop me queue)
+ (unless (eq :ok status)
+ ;; CONDITION-NOTIFY thinks we've been woken up, but really
+ ;; we're unwinding. Wake someone else up.
+ (%waitqueue-wakeup queue 1))))
+ ;; Update timeout for mutex re-aquisition.
+ (when (and (eq :ok status) to-sec)
+ (setf (values to-sec to-usec)
+ (sb!impl::relative-decoded-times stop-sec stop-usec)))
+ ;; If we ran into deadline, try to get the mutex before
+ ;; signaling. If we don't unwind it will look like a normal
+ ;; return from user perspective.
+ (when (and (eq :timeout status) deadlinep)
+ (let ((got-it (%try-mutex mutex me)))
+ (allow-with-interrupts
+ (signal-deadline)
+ (cond (got-it
+ (return-from condition-wait t))
+ (t
+ ;; The deadline may have changed.
+ (setf (values to-sec to-usec stop-sec stop-usec deadlinep)
+ (decode-timeout timeout))
+ (setf status :ok))))))
+ ;; Re-acquire the mutex for normal return.
+ (when (eq :ok status)
+ (unless (or (%try-mutex mutex me)
+ (allow-with-interrupts
+ (%wait-for-mutex mutex me timeout
+ to-sec to-usec
+ stop-sec stop-usec deadlinep)))
+ (setf status :timeout)))))
+ (or (eq :ok status)
+ (unless (eq :timeout status)
+ ;; The only case we return normally without re-acquiring the
+ ;; mutex is when there is a :TIMEOUT that runs out.
+ (bug "CONDITION-WAIT: invalid status on normal return: ~S" status)))))))
+
+(defun condition-notify (queue &optional (n 1))
+ #!+sb-doc
+ "Notify N threads waiting on QUEUE.
+
+IMPORTANT: The same mutex that is used in the corresponding CONDITION-WAIT
+must be held by this thread during this call."
+ #!-sb-thread
+ (declare (ignore queue n))
+ #!-sb-thread
+ (error "Not supported in unithread builds.")
+ #!+sb-thread
+ (declare (type (and fixnum (integer 1)) n))
+ (/show0 "Entering CONDITION-NOTIFY")
+ #!+sb-thread
+ (progn
+ #!-sb-futex
+ (with-cas-lock ((waitqueue-%owner queue))
+ (%waitqueue-wakeup queue n))
+ #!+sb-futex
+ (progn
+ ;; No problem if >1 thread notifies during the comment in condition-wait:
+ ;; as long as the value in queue-data isn't the waiting thread's id, it
+ ;; matters not what it is -- using the queue object itself is handy.
+ ;;