X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=553dc675e8804803229542be4ba385f2a2736500;hb=cdd026dddac3eaddbaa0221503e49e2673d54545;hp=0361ec52ada5c2dca5d2a14b63bec94f58535205;hpb=1ecff2d1bc56850bf2f262a56402df4683fc57d9;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 0361ec5..553dc67 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -108,11 +108,18 @@ the symbol not having a thread-local value, or the target thread having exited. The offending symbol can be accessed using CELL-ERROR-NAME, and the offending thread using THREAD-ERROR-THREAD.")) -(define-condition join-thread-error (thread-error) () +(define-condition join-thread-error (thread-error) + ((problem :initarg :problem :reader join-thread-problem)) (:report (lambda (c s) - (format s "Joining thread failed: thread ~A ~ - did not return normally." - (thread-error-thread c)))) + (ecase (join-thread-problem c) + (:abort + (format s "Joining thread failed: thread ~A ~ + did not return normally." + (thread-error-thread c))) + (:timeout + (format s "Joining thread timed out: thread ~A ~ + did not exit in time." + (thread-error-thread c)))))) #!+sb-doc (:documentation "Signalled when joining a thread fails due to abnormal exit of the thread @@ -193,9 +200,6 @@ arbitrary printable objects, and need not be unique.") (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 @@ -300,8 +304,6 @@ created and old ones may exit at any time." (sb!vm::current-thread-offset-sap n)) -;;;; Spinlocks - (defmacro with-deadlocks ((thread lock &optional (timeout nil timeoutp)) &body forms) (with-unique-names (n-thread n-lock new n-timeout) `(let* ((,n-thread ,thread) @@ -325,62 +327,7 @@ created and old ones may exit at any time." ;; 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. -(defun get-spinlock (spinlock) - (declare (optimize (speed 3) (safety 0))) - (let* ((new *current-thread*) - (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new))) - (when old - (when (eq old new) - (error "Recursive lock attempt on ~S." spinlock)) - #!+sb-thread - (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))) - ;; On x86 and x86-64 we can get away with no memory barriers, (see - ;; Linux kernel mailing list "spin_unlock optimization(i386)" - ;; thread, summary at - ;; http://kt.iserv.nl/kernel-traffic/kt19991220_47.html#1. - ;; - ;; If the compiler may reorder this with other instructions, insert - ;; compiler barrier here. - ;; - ;; FIXME: this does not work on SMP Pentium Pro and OOSTORE systems, - ;; neither on most non-x86 architectures (but we don't have threads - ;; on those). - (setf (spinlock-value spinlock) nil) - - ;; FIXME: Is a :memory barrier too strong here? Can we use a :write - ;; barrier instead? - #!+(not (or x86 x86-64)) - (barrier (:memory))) - ;;;; Mutexes #!+sb-doc @@ -414,14 +361,8 @@ HOLDING-MUTEX-P." (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)))) - (lock-p (thing) - (typep thing '(or mutex spinlock))) - (detect-deadlock (lock) - (let ((other-thread (lock-owner lock))) + (labels ((detect-deadlock (lock) + (let ((other-thread (mutex-%owner lock))) (cond ((not other-thread)) ((eq self other-thread) (let* ((chain (deadlock-chain self origin)) @@ -444,10 +385,10 @@ HOLDING-MUTEX-P." ;; 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 (lock-p other-lock) + (when (mutex-p other-lock) (detect-deadlock other-lock))))))) (deadlock-chain (thread lock) - (let* ((other-thread (lock-owner lock)) + (let* ((other-thread (mutex-owner lock)) (other-lock (when other-thread (thread-waiting-for other-thread)))) (cond ((not other-thread) @@ -470,7 +411,7 @@ HOLDING-MUTEX-P." ;; Again, the deadlock is gone? (return-from check-deadlock nil))))))) ;; Timeout means there is no deadlock - (when (lock-p origin) + (when (mutex-p origin) (detect-deadlock origin) t)))) @@ -552,6 +493,7 @@ HOLDING-MUTEX-P." ;; Spin. (go :retry)))) +#!+sb-thread (defun %wait-for-mutex (mutex self timeout to-sec to-usec stop-sec stop-usec deadlinep) (with-deadlocks (self mutex timeout) (with-interrupts (check-deadlock)) @@ -791,7 +733,8 @@ around the call, checking the the associated data: (push data *data*) (condition-notify *queue*))) " - #!-sb-thread (declare (ignore queue timeout)) + #!-sb-thread + (declare (ignore queue)) (assert mutex) #!-sb-thread (wait-for nil :timeout timeout) ; Yeah... @@ -1301,18 +1244,37 @@ around and can be retrieved by JOIN-THREAD." (wait-on-semaphore setup-sem) thread))))) -(defun join-thread (thread &key (default nil defaultp)) +(defun join-thread (thread &key (default nil defaultp) timeout) #!+sb-doc - "Suspend current thread until THREAD exits. Returns the result -values of the thread function. If the thread does not exit normally, -return DEFAULT if given or else signal JOIN-THREAD-ERROR." - (with-system-mutex ((thread-result-lock thread) :allow-with-interrupts t) - (cond ((car (thread-result thread)) - (return-from join-thread - (values-list (cdr (thread-result thread))))) - (defaultp - (return-from join-thread default)))) - (error 'join-thread-error :thread thread)) + "Suspend current thread until THREAD exits. Return the result values of the +thread function. + +If the thread does not exit normally within TIMEOUT seconds return DEFAULT if +given, or else signal JOIN-THREAD-ERROR. + +NOTE: Return convention in case of a timeout is exprimental and subject to +change." + (let ((lock (thread-result-lock thread)) + (got-it nil) + (problem :timeout)) + (without-interrupts + (unwind-protect + (if (setf got-it + (allow-with-interrupts + ;; Don't use the timeout if the thread is not alive anymore. + (grab-mutex lock :timeout (and (thread-alive-p thread) timeout)))) + (cond ((car (thread-result thread)) + (return-from join-thread + (values-list (cdr (thread-result thread))))) + (defaultp + (return-from join-thread default)) + (t + (setf problem :abort))) + (when defaultp + (return-from join-thread default))) + (when got-it + (release-mutex lock)))) + (error 'join-thread-error :thread thread :problem problem))) (defun destroy-thread (thread) #!+sb-doc