The offending thread is initialized by the :THREAD initialization argument and
read by the function THREAD-ERROR-THREAD."))
+(define-condition thread-deadlock (thread-error)
+ ((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)))))))
+
#!+sb-doc
(setf
(fdocumentation 'thread-error-thread 'function)
(multiple-value-list
(join-thread thread :default cookie))))
(state (if (eq :running info)
- info
+ (let* ((lock (thread-waiting-for thread)))
+ (typecase lock
+ (cons
+ (list "waiting for:" (cdr lock)
+ "timeout: " (car lock)))
+ (null
+ (list info))
+ (t
+ (list "waiting for:" lock))))
(if (eq cookie (car info))
- :aborted
+ (list :aborted)
:finished)))
- (values (when (eq :finished state) info)))
+ (values (when (eq :finished state)
+ info))
+ (*print-level* 4))
(format stream
- "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
+ "~@[~S ~]~:[~{~I~A~^~2I~_ ~}~_~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
(thread-name thread)
(eq :finished state)
state
values))))
+(defun print-lock (lock name owner stream)
+ (let ((*print-circle* t))
+ (print-unreadable-object (lock stream :type t :identity (not name))
+ (if owner
+ (format stream "~@[~S ~]~2I~_owner: ~S" name owner)
+ (format stream "~@[~S ~](free)" name)))))
+
+(def!method print-object ((mutex mutex) stream)
+ (print-lock mutex (mutex-name mutex) (mutex-owner mutex) stream))
+
+(def!method print-object ((spinlock spinlock) stream)
+ (print-lock spinlock (spinlock-name spinlock) (spinlock-value spinlock) stream))
+
(defun thread-alive-p (thread)
#!+sb-doc
"Return T if THREAD is still alive. Note that the return value is
;;;; Spinlocks
+(defmacro with-deadlocks ((thread lock &optional timeout) &body forms)
+ (declare (ignorable timeout))
+ (with-unique-names (n-thread n-lock n-timeout new)
+ `(let* ((,n-thread ,thread)
+ (,n-lock ,lock)
+ (,n-timeout #!-sb-lutex
+ ,(when timeout
+ `(or ,timeout
+ (when sb!impl::*deadline*
+ sb!impl::*deadline-seconds*))))
+ (,new (if ,n-timeout
+ (cons ,n-timeout ,n-lock)
+ ,n-lock)))
+ (declare (dynamic-extent ,new))
+ ;; No WITHOUT-INTERRUPTS, since WITH-DEADLOCKS is used
+ ;; in places where interrupts should already be disabled.
+ (unwind-protect
+ (progn
+ (setf (thread-waiting-for ,n-thread) ,new)
+ ,@forms)
+ ;; Interrupt handlers and GC save and restore any
+ ;; previous wait marks using WITHOUT-DEADLOCKS below.
+ (setf (thread-waiting-for ,n-thread) nil)))))
+
(declaim (inline get-spinlock release-spinlock))
;;; Should always be called with interrupts disabled.
(when (eq old new)
(error "Recursive lock attempt on ~S." spinlock))
#!+sb-thread
- (flet ((cas ()
- (if (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)
- (thread-yield)
- (return-from get-spinlock t))))
- (if (and (not *interrupts-enabled*) *allow-with-interrupts*)
- ;; If interrupts are disabled, but we are allowed to
- ;; enabled them, check for pending interrupts every once
- ;; in a while. %CHECK-INTERRUPTS is taking shortcuts, make
- ;; sure that deferrables are unblocked by doing an empty
- ;; WITH-INTERRUPTS once.
- (progn
- (with-interrupts)
- (loop
- (loop repeat 128 do (cas)) ; 128 is arbitrary here
- (sb!unix::%check-interrupts)))
- (loop (cas)))))
- t))
+ (with-deadlocks (new spinlock)
+ (flet ((cas ()
+ (if (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)
+ (thread-yield)
+ (return-from get-spinlock t))))
+ ;; Try once.
+ (cas)
+ ;; Check deadlocks
+ (with-interrupts (check-deadlock))
+ (if (and (not *interrupts-enabled*) *allow-with-interrupts*)
+ ;; If interrupts are disabled, but we are allowed to
+ ;; enabled them, check for pending interrupts every once
+ ;; in a while. %CHECK-INTERRUPTS is taking shortcuts, make
+ ;; sure that deferrables are unblocked by doing an empty
+ ;; WITH-INTERRUPTS once.
+ (progn
+ (with-interrupts)
+ (loop
+ (loop repeat 128 do (cas)) ; 128 is arbitrary here
+ (sb!unix::%check-interrupts)))
+ (loop (cas)))))))
+ t)
(defun release-spinlock (spinlock)
(declare (optimize (speed 3) (safety 0)))
;; Make sure to get the current value.
(sb!ext:compare-and-swap (mutex-%owner mutex) nil nil))
-(defun get-mutex (mutex &optional (new-owner *current-thread*)
+;;; 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))
#!+sb-doc
"Deprecated in favor of GRAB-MUTEX."
#!-sb-thread
(setf (mutex-%owner mutex) new-owner)
#!+sb-thread
- (progn
+ (with-deadlocks (new-owner mutex timeout)
;; FIXME: Lutexes do not currently support deadlines, as at least
;; on Darwin pthread_foo_timedbar functions are not supported:
;; this means that we probably need to use the Carbon multiprocessing
(when timeout
(error "Mutex timeouts not supported on this platform."))
(when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
- (if waitp
- (with-interrupts (%lutex-lock lutex))
- (%lutex-trylock lutex))))
- (setf (mutex-%owner mutex) new-owner)
- (barrier (:write))
- t))
+ (if waitp
+ (let ((once (%lutex-trylock lutex)))
+ (cond ((zerop once)
+ ;; No need to wait.
+ once)
+ (t
+ (with-interrupts
+ ;; Check for deadlocks before waiting
+ (check-deadlock)
+ (%lutex-lock lutex)))))
+ (%lutex-trylock lutex))))
+ ;; FIXME: If %LUTEX-LOCK unwinds due to a signal, we may actually
+ ;; be holding the lock already -- and but neglect to mark ourselves
+ ;; as the owner here. This is bad.
+ (setf (mutex-%owner mutex) new-owner)
+ (barrier (:write))
+ t))
#!-sb-lutex
;; This is a direct translation of the Mutex 2 algorithm from
;; "Futexes are Tricky" by Ulrich Drepper.
+lock-taken+
+lock-contested+))))
;; Wait on the contested lock.
- (loop
- (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
- (decode-timeout timeout)
- (declare (ignore stop-sec stop-usec))
- (case (with-pinned-objects (mutex)
- (futex-wait (mutex-state-address mutex)
- (get-lisp-obj-address +lock-contested+)
- (or to-sec -1)
- (or to-usec 0)))
- ((1) (if deadlinep
- (signal-deadline)
- (return-from get-mutex nil)))
- ((2))
- (otherwise (return))))))
+ (with-interrupts
+ (check-deadlock)
+ (loop
+ (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
+ (decode-timeout timeout)
+ (declare (ignore stop-sec stop-usec))
+ (case (with-pinned-objects (mutex)
+ (futex-wait (mutex-state-address mutex)
+ (get-lisp-obj-address +lock-contested+)
+ (or to-sec -1)
+ (or to-usec 0)))
+ ((1) (if deadlinep
+ (signal-deadline)
+ (return-from get-mutex nil)))
+ ((2))
+ (otherwise (return)))))))
(setf old (sb!ext:compare-and-swap (mutex-state mutex)
+lock-free+
+lock-contested+))
#!-sb-lutex
(token nil))
+(def!method print-object ((waitqueue waitqueue) stream)
+ (print-unreadable-object (waitqueue stream :type t :identity t)
+ (format stream "~@[~A~]" (waitqueue-name waitqueue))))
+
(defun make-waitqueue (&key name)
#!+sb-doc
"Create a waitqueue."
;;;; The beef
-(defun make-thread (function &key name)
+(defun make-thread (function &key name arguments)
#!+sb-doc
- "Create a new thread of NAME that runs FUNCTION. When the function
+ "Create a new thread of NAME that runs FUNCTION with the argument
+list designator provided (defaults to no argument). When the function
returns the thread exits. The return values of FUNCTION are kept
around and can be retrieved by JOIN-THREAD."
- #!-sb-thread (declare (ignore function name))
+ #!-sb-thread (declare (ignore function name arguments))
#!-sb-thread (error "Not supported in unithread builds.")
+ #!+sb-thread (assert (or (atom arguments)
+ (null (cdr (last arguments))))
+ (arguments)
+ "Argument passed to ~S, ~S, is an improper list."
+ 'make-thread arguments)
#!+sb-thread
(let* ((thread (%make-thread :name name))
(setup-sem (make-semaphore :name "Thread setup semaphore"))
(real-function (coerce function 'function))
+ (arguments (if (listp arguments)
+ arguments
+ (list arguments)))
(initial-function
(named-lambda initial-thread-function ()
;; In time we'll move some of the binding presently done in C
(setf (thread-result thread)
(cons t
(multiple-value-list
- (funcall real-function))))
+ (apply real-function arguments))))
;; Try to block deferrables. An
;; interrupt may unwind it, but for a
;; normal exit it prevents interrupt
(loop
(if (thread-alive-p thread)
(let* ((epoch sb!kernel::*gc-epoch*)
- (offset (* sb!vm:n-word-bytes
- (sb!vm::symbol-tls-index symbol)))
+ (offset (sb!kernel:get-lisp-obj-address
+ (sb!vm::symbol-tls-index symbol)))
(tl-val (sap-ref-word (%thread-sap thread) offset)))
(cond ((zerop offset)
(return (values nil :no-tls-value)))
;; area...
(with-all-threads-lock
(if (thread-alive-p thread)
- (let ((offset (* sb!vm:n-word-bytes
- (sb!vm::symbol-tls-index symbol))))
+ (let ((offset (sb!kernel:get-lisp-obj-address
+ (sb!vm::symbol-tls-index symbol))))
(cond ((zerop offset)
(values nil :no-tls-value))
(t
(setf (sap-ref-word (%thread-sap thread) offset)
(get-lisp-obj-address value))
(values value :ok))))
- (values nil :thread-dead))))))
+ (values nil :thread-dead)))))
+
+ (define-alien-variable tls-index-start unsigned-int)
+
+ ;; Get values from the TLS area of the current thread.
+ (defun %thread-local-references ()
+ (without-gcing
+ (let ((sap (%thread-sap *current-thread*)))
+ (loop for index from tls-index-start
+ below (symbol-value 'sb!vm::*free-tls-index*)
+ for value = (sap-ref-word sap (* sb!vm:n-word-bytes index))
+ for (obj ok) = (multiple-value-list (sb!kernel:make-lisp-obj value nil))
+ unless (or (not ok)
+ (typep obj '(or fixnum character))
+ (member value
+ '(#.sb!vm:no-tls-value-marker-widetag
+ #.sb!vm:unbound-marker-widetag))
+ (member obj seen :test #'eq))
+ collect obj into seen
+ finally (return seen))))))
(defun symbol-value-in-thread (symbol thread &optional (errorp t))
"Return the local value of SYMBOL in THREAD, and a secondary value of T
projects / sbcl.git / blobdiff