+(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))
+
+;;; 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 (thread-waiting-for self)))
+ (labels ((lock-owner (lock)
+ (etypecase lock
+ (mutex (mutex-%owner lock))
+ (spinlock (spinlock-value lock))))
+ (detect-deadlock (lock)
+ (let ((other-thread (lock-owner lock)))
+ (cond ((not other-thread))
+ ((eq self other-thread)
+ (let* ((chain (deadlock-chain self origin))
+ (barf
+ (format nil
+ "~%WARNING: DEADLOCK CYCLE DETECTED:~%~@< ~@;~
+ ~{~:@_~S~:@_~}~:@>~
+ ~%END OF CYCLE~%"
+ (mapcar #'car chain))))
+ ;; Barf to stderr in case the system is too tied up
+ ;; to report the error properly -- to avoid cross-talk
+ ;; build the whole string up first.
+ (write-string barf sb!sys:*stderr*)
+ (finish-output sb!sys:*stderr*)
+ (error 'thread-deadlock
+ :thread *current-thread*
+ :cycle chain)))
+ (t
+ (let ((other-lock (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 (and other-lock (not (consp other-lock)))
+ (detect-deadlock other-lock)))))))
+ (deadlock-chain (thread lock)
+ (let* ((other-thread (lock-owner lock))
+ (other-lock (when other-thread
+ (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))
+ ((eq self other-thread)
+ ;; Done
+ (list (list thread lock)))
+ (t
+ (if other-lock
+ (cons (list thread lock)
+ (deadlock-chain other-thread other-lock))
+ ;; Again, the deadlock is gone?
+ (return-from check-deadlock nil)))))))
+ ;; Timeout means there is no deadlock
+ (unless (consp origin)
+ (detect-deadlock origin)
+ t))))
+
+(defun get-mutex (mutex &optional new-owner
+ (waitp t) (timeout nil))