-(defun get-mutex (mutex &optional (new-owner *current-thread*) (waitp t))
- #!+sb-doc
- "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If
-NEW-OWNER is NIL, it defaults to the current thread. If WAITP is
-non-NIL and the mutex is in use, sleep until it is available.
-
-Note: using GET-MUTEX to assign a MUTEX to another thread then the
-current one is not recommended, and liable to be deprecated.
-
-GET-MUTEX is not interrupt safe. The correct way to call it is:
-
- (WITHOUT-INTERRUPTS
- ...
- (ALLOW-WITH-INTERRUPTS (GET-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.
-
-It is recommended that you use WITH-MUTEX instead of calling GET-MUTEX
-directly."
- (declare (type mutex mutex) (optimize (speed 3))
- #!-sb-thread (ignore waitp))
- (unless new-owner
- (setq new-owner *current-thread*))
- (when (eql new-owner (mutex-%owner mutex))
- (error "Recursive lock attempt ~S." mutex))
- #!+sb-thread
- (progn
- ;; FIXME: Lutexes do not currently support deadlines, as at least
- ;; on Darwin pthread_foo_timedbar functions are not supported:
- ;; this means that we probably need to use the Carbon multiprocessing
- ;; functions on Darwin.
- ;;
- ;; FIXME: This is definitely not interrupt safe: what happens if
- ;; we get hit (1) during the lutex calls (ok, they may be safe,
- ;; but has that been checked?) (2) after the lutex call, but
- ;; before setting the mutex owner.
- #!+sb-lutex
- (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
- (if waitp
- (with-interrupts (%lutex-lock lutex))
- (%lutex-trylock lutex))))
- (setf (mutex-%owner mutex) new-owner)
- t)
- #!-sb-lutex
- (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
- +lock-free+
- +lock-taken+)))
- (unless (or (eql +lock-free+ old) (not waitp))
- (tagbody
- :retry
- (when (or (eql +lock-contested+ old)
- (not (eql +lock-free+
- (sb!ext:compare-and-swap (mutex-state mutex)
- +lock-taken+
- +lock-contested+))))
- ;; Wait on the contested lock.
- (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
- (when (= 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))))
- (signal-deadline))))
- (setf old (sb!ext:compare-and-swap (mutex-state mutex)
- +lock-free+
- +lock-contested+))
- ;; Did we get it?
- (unless (eql +lock-free+ old)
- (go :retry))))
- (cond ((eql +lock-free+ old)
+(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)