X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=080c17323b7f8a16df28af8eee3a7a01d84811a6;hb=3f3033a6c0ddf0af8dd1b5a17c2a4b82ea59b94f;hp=5eb0e8abf3cfeaf2430e31f24f1a8df19f706eb8;hpb=cb557a29b8b833b7753c2940e776eaa981633a9f;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 5eb0e8a..080c173 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -58,9 +58,6 @@ WITH-CAS-LOCK can be entered recursively." do (sb!ext:spin-loop-hint)) do (thread-yield))) ,@body) - ;; FIXME: SETF + write barrier should to be enough here. - ;; ...but GET-CAS-EXPANSION doesn't return a WRITE-FORM. - ;; ...maybe it should? (unless (eq ,owner ,self) (let ((,old ,self) (,new nil)) @@ -81,10 +78,16 @@ read by the function THREAD-ERROR-THREAD.")) ((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 @@ -365,6 +368,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 () @@ -376,18 +381,21 @@ HOLDING-MUTEX-P." (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))) @@ -420,7 +428,7 @@ HOLDING-MUTEX-P." (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))))))) @@ -438,11 +446,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+ @@ -609,7 +617,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: @@ -636,7 +644,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)) @@ -1026,7 +1034,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)))) @@ -1530,34 +1538,17 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD." (with-all-threads-lock (loop (if (thread-alive-p thread) - (let* ((epoch sb!kernel::*gc-epoch*) - (offset (sb!kernel:get-lisp-obj-address + (let* ((offset (sb!kernel:get-lisp-obj-address (sb!vm::symbol-tls-index symbol))) - (tl-val (sap-ref-word (%thread-sap thread) offset))) + (obj (sap-ref-lispobj (%thread-sap thread) offset)) + (tl-val (sb!kernel:get-lisp-obj-address obj))) (cond ((zerop offset) (return (values nil :no-tls-value))) ((or (eql tl-val sb!vm:no-tls-value-marker-widetag) (eql tl-val sb!vm:unbound-marker-widetag)) (return (values nil :unbound-in-thread))) (t - (multiple-value-bind (obj ok) (make-lisp-obj tl-val nil) - ;; The value we constructed may be invalid if a GC has - ;; occurred. That is harmless, though, since OBJ is - ;; either in a register or on stack, and we are - ;; conservative on both on GENCGC -- so a bogus object - ;; is safe here as long as we don't return it. If we - ;; ever port threads to a non-conservative GC we must - ;; pin the TL-VAL address before constructing OBJ, or - ;; make WITH-ALL-THREADS-LOCK imply WITHOUT-GCING. - ;; - ;; The reason we don't just rely on TL-VAL pinning the - ;; object is that the call to MAKE-LISP-OBJ may cause - ;; bignum allocation, at which point TL-VAL might not - ;; be alive anymore -- hence the epoch check. - (when (eq epoch sb!kernel::*gc-epoch*) - (if ok - (return (values obj :ok)) - (return (values obj :invalid-tls-value)))))))) + (return (values obj :ok))))) (return (values nil :thread-dead)))))) (defun %set-symbol-value-in-thread (symbol thread value) @@ -1571,8 +1562,8 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD." (cond ((zerop offset) (values nil :no-tls-value)) (t - (setf (sap-ref-word (%thread-sap thread) offset) - (get-lisp-obj-address value)) + (setf (sap-ref-lispobj (%thread-sap thread) offset) + value) (values value :ok)))) (values nil :thread-dead)))))