X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=cf6ceb5de790972a8e47c136360bc16ec1e45446;hb=79c4a7fec90e697d1a5896c7883ff24d562bad6d;hp=4b566f6a5330f23cb1fca2ed581ce1a4a09e3cb1;hpb=d6f9676ae94419cb5544c45821a8d31adbc1fbe8;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 4b566f6..cf6ceb5 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -35,32 +35,24 @@ WITH-CAS-LOCK can be entered recursively." (%with-cas-lock (,place) ,@body))) (defmacro %with-cas-lock ((place) &body body &environment env) - (with-unique-names (self owner) - ;; Take care not to multiply-evaluate anything. - ;; - ;; FIXME: Once we get DEFCAS this can use GET-CAS-EXPANSION. - (let* ((placex (sb!xc:macroexpand place env)) - (place-op (if (consp placex) - (car placex) - (error "~S: ~S is not a valid place for ~S" - 'with-cas-lock - place 'sb!ext:compare-and-swap))) - (place-args (cdr placex)) - (temps (make-gensym-list (length place-args) t)) - (place `(,place-op ,@temps))) - `(let* (,@(mapcar #'list temps place-args) + (with-unique-names (owner self) + (multiple-value-bind (vars vals old new cas-form read-form) + (sb!ext:get-cas-expansion place env) + `(let* (,@(mapcar #'list vars vals) + (,owner ,read-form) (,self *current-thread*) - (,owner ,place)) + (,old nil) + (,new ,self)) (unwind-protect (progn (unless (eq ,owner ,self) - (loop while (setf ,owner - (or ,place - (sb!ext:compare-and-swap ,place nil ,self))) + (loop while (setf ,owner (or ,read-form ,cas-form)) do (thread-yield))) ,@body) (unless (eq ,owner ,self) - (sb!ext:compare-and-swap ,place ,self nil))))))) + (let ((,old ,self) + (,new nil)) + ,cas-form))))))) ;;; Conditions @@ -108,11 +100,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 +192,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 +296,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 +319,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 +353,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 +377,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 +403,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 +485,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,9 +725,11 @@ 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 (error "Not supported in unithread builds.") + #!-sb-thread + (sb!ext:wait-for nil :timeout timeout) ; Yeah... #!+sb-thread (let ((me *current-thread*)) (barrier (:read)) @@ -861,23 +797,27 @@ around the call, checking the the associated data: (when (and (eq :timeout status) deadlinep) (let ((got-it (%try-mutex mutex me))) (allow-with-interrupts - (signal-deadline)) - (cond (got-it - (return-from condition-wait t)) - (t - (setf (values to-sec to-usec stop-sec stop-usec deadlinep) - (decode-timeout timeout)))))) + (signal-deadline) + (cond (got-it + (return-from condition-wait t)) + (t + ;; The deadline may have changed. + (setf (values to-sec to-usec stop-sec stop-usec deadlinep) + (decode-timeout timeout)) + (setf status :ok)))))) ;; Re-acquire the mutex for normal return. - (unless (or (%try-mutex mutex me) - (allow-with-interrupts - (%wait-for-mutex mutex me timeout - to-sec to-usec - stop-sec stop-usec deadlinep))) + (when (eq :ok status) + (unless (or (%try-mutex mutex me) + (allow-with-interrupts + (%wait-for-mutex mutex me timeout + to-sec to-usec + stop-sec stop-usec deadlinep))) + (setf status :timeout))))) + (or (eq :ok status) + (unless (eq :timeout status) ;; The only case we return normally without re-acquiring the ;; mutex is when there is a :TIMEOUT that runs out. - (aver (and timeout (not deadlinep))) - (return-from condition-wait nil))))))) - t) + (bug "CONDITION-WAIT: invalid status on normal return: ~S" status))))))) (defun condition-notify (queue &optional (n 1)) #!+sb-doc @@ -951,16 +891,22 @@ future." "Create a semaphore with the supplied COUNT and NAME." (%make-semaphore name count)) -(defun wait-on-semaphore (semaphore) +(defun wait-on-semaphore (semaphore &key timeout) #!+sb-doc - "Decrement the count of SEMAPHORE if the count would not be -negative. Else blocks until the semaphore can be decremented." + "Decrement the count of SEMAPHORE if the count would not be negative. Else +blocks until the semaphore can be decremented. Returns T on success. + +If TIMEOUT is given, it is the maximum number of seconds to wait. If the count +cannot be decremented in that time, returns NIL without decrementing the +count." ;; A more direct implementation based directly on futexes should be ;; possible. ;; ;; We need to disable interrupts so that we don't forget to ;; decrement the waitcount (which would happen if an asynch ;; interrupt should catch us on our way out from the loop.) + ;; + ;; FIXME: No timeout on initial mutex acquisition. (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) ;; Quick check: is it positive? If not, enter the wait loop. (let ((count (semaphore-%count semaphore))) @@ -975,12 +921,15 @@ negative. Else blocks until the semaphore can be decremented." ;; at most one increment per thread waiting on the semaphore. (sb!ext:atomic-incf (semaphore-waitcount semaphore)) (loop until (plusp (setf count (semaphore-%count semaphore))) - do (condition-wait (semaphore-queue semaphore) - (semaphore-mutex semaphore))) + do (or (condition-wait (semaphore-queue semaphore) + (semaphore-mutex semaphore) + :timeout timeout) + (return-from wait-on-semaphore nil))) (setf (semaphore-%count semaphore) (1- count))) ;; Need to use ATOMIC-DECF instead of DECF, as CONDITION-WAIT ;; may unwind without the lock being held due to timeouts. - (sb!ext:atomic-decf (semaphore-waitcount semaphore))))))) + (sb!ext:atomic-decf (semaphore-waitcount semaphore)))))) + t) (defun try-semaphore (semaphore &optional (n 1)) #!+sb-doc @@ -1287,18 +1236,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