((cycle :initarg :cycle :reader thread-deadlock-cycle))
(:report
(lambda (condition stream)
- (let ((*print-circle* t))
- (format stream "Deadlock cycle detected:~%~@< ~@;~
- ~{~:@_~S~:@_~}~:@>"
- (mapcar #'car (thread-deadlock-cycle condition)))))))
+ (let* ((*print-circle* t)
+ (cycle (thread-deadlock-cycle condition))
+ (start (caar cycle)))
+ (format stream "Deadlock cycle detected:~%")
+ (loop for part = (pop cycle)
+ while part
+ do (format stream " ~S~% waited for:~% ~S~% owned by:~%"
+ (car part)
+ (cdr part)))
+ (format stream " ~S~%" start)))))
#!+sb-doc
(setf
;; 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 ((other-thread (mutex-%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*)
+ (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)))
(list (list thread lock)))
(t
(if other-lock
- (cons (list thread lock)
+ (cons (cons thread lock)
(deadlock-chain other-thread other-lock))
;; Again, the deadlock is gone?
(return-from check-deadlock nil)))))))
#!-sb-thread
(when old
(error "Strange deadlock on ~S in an unithreaded build?" mutex))
- #!-sb-futex
+ #!-(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)))
- #!+sb-futex
+ #!+(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+
;; FIXME: Is a :memory barrier too strong here? Can we use a :write
;; barrier instead?
(barrier (:memory)))
- #!+sb-futex
+ #!+(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:
#!+sb-doc
"Waitqueue type."
(name nil :type (or null thread-name))
- #!+sb-futex
+ #!+(and sb-thread sb-futex)
(token nil))
#!+(and sb-thread (not sb-futex))
(when (not (minusp new-count))
(setf (semaphore-%count semaphore) new-count)
(when notification
- (setf (semaphore-notifiction-%status notification) t))
+ (setf (semaphore-notification-%status notification) t))
;; FIXME: We don't actually document this -- should we just
;; return T, or document new count as the return?
new-count))))