X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=4059d14491909f5679a6f78ef587848e69c7ff1f;hb=a00ea11a89c9db677e60edf6832c905a4527b5cb;hp=06d49c29bd75e575c50977bb34e86a9e148f2ed5;hpb=d6e6a3798dc767045cd7495f483bd4d0b6250d00;p=sbcl.git

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 06d49c2..4059d14 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -362,6 +362,8 @@ 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 ()
@@ -373,16 +375,36 @@ HOLDING-MUTEX-P."
                (let ((other-thread (mutex-%owner lock)))
                  (cond ((not other-thread))
                        ((eq self other-thread)
-                        (let* ((chain (deadlock-chain self origin))
+                        (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
-                                (format nil
-                                        "~%WARNING: DEADLOCK CYCLE DETECTED:~%~@<   ~@;~
-                                         ~{~:@_~S~:@_~}~:@>~
-                                         ~%END OF CYCLE~%"
-                                        (mapcar #'car chain))))
+                                 (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 -- to avoid cross-talk
+                          ;; 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
@@ -435,11 +457,11 @@ HOLDING-MUTEX-P."
     #!-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+
@@ -606,7 +628,7 @@ IF-NOT-OWNER is :FORCE)."
       ;; 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:
@@ -633,7 +655,7 @@ IF-NOT-OWNER is :FORCE)."
   #!+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))
@@ -1023,7 +1045,7 @@ the status is set to T."
       (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))))