+(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))))
+ (barf
+ (with-output-to-string (s)
+ (funcall (formatter
+ "~%WARNING: DEADLOCK CYCLE DETECTED:~%~@< ~@;~
+ ~{~:@_~S~:@_~}~:@>~
+ ~%END OF CYCLE~%")
+ s
+ (mapcar #'car chain)))))
+ ;; Barf to stderr in case the system is too tied up
+ ;; to report the error properly -- and to avoid cross-talk
+ ;; build the whole string up first.
+ ;;
+ ;; ...would be even better if we had
+ ;; sensible locks on streams, but what can
+ ;; you do...
+ (write-string barf sb!sys:*stderr*)
+ (finish-output sb!sys:*stderr*)
+ (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 (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
+ (when (mutex-p origin)
+ (detect-deadlock origin)
+ t))))
+
+(defun %try-mutex (mutex new-owner)
+ (declare (type mutex mutex) (optimize (speed 3)))
+ (barrier (:read))