X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=afb63cc96a1aaa79e639398cea65f36ceadbda22;hb=7bb4c044e09f02a2115095af3733b0673b98a726;hp=0361ec52ada5c2dca5d2a14b63bec94f58535205;hpb=1ecff2d1bc56850bf2f262a56402df4683fc57d9;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 0361ec5..afb63cc 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -35,32 +35,37 @@ 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 (progn + (barrier (:read)) + ,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 until (loop repeat 100 + when (and (progn + (barrier (:read)) + (not ,read-form)) + (not (setf ,owner ,cas-form))) + return t + else + 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) - (sb!ext:compare-and-swap ,place ,self nil))))))) + (let ((,old ,self) + (,new nil)) + (unless (eq ,old ,cas-form) + (bug "Failed to release CAS lock!"))))))))) ;;; Conditions @@ -108,11 +113,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 @@ -161,7 +173,9 @@ arbitrary printable objects, and need not be unique.") (multiple-value-list (join-thread thread :default cookie)))) (state (if (eq :running info) - (let* ((thing (thread-waiting-for thread))) + (let* ((thing (progn + (barrier (:read)) + (thread-waiting-for thread)))) (typecase thing (cons (list "waiting on:" (cdr thing) @@ -193,9 +207,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 +311,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) @@ -321,66 +330,13 @@ created and old ones may exit at any time." (unwind-protect (progn (setf (thread-waiting-for ,n-thread) ,new) + (barrier (:write)) ,@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. -(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))) + (setf (thread-waiting-for ,n-thread) nil) + (barrier (:write)))))) - ;;;; Mutexes #!+sb-doc @@ -413,15 +369,11 @@ HOLDING-MUTEX-P." ;;; 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)))) - (lock-p (thing) - (typep thing '(or mutex spinlock))) - (detect-deadlock (lock) - (let ((other-thread (lock-owner lock))) + (origin (progn + (barrier (:read)) + (thread-waiting-for self)))) + (labels ((detect-deadlock (lock) + (let ((other-thread (mutex-%owner lock))) (cond ((not other-thread)) ((eq self other-thread) (let* ((chain (deadlock-chain self origin)) @@ -440,15 +392,18 @@ HOLDING-MUTEX-P." :thread *current-thread* :cycle chain))) (t - (let ((other-lock (thread-waiting-for other-thread))) + (let ((other-lock (progn + (barrier (:read)) + (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 (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 + (barrier (:read)) (thread-waiting-for other-thread)))) (cond ((not other-thread) ;; The deadlock is gone -- maybe someone unwound @@ -470,7 +425,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)))) @@ -484,7 +439,8 @@ HOLDING-MUTEX-P." (when old (error "Strange deadlock on ~S in an unithreaded build?" mutex)) #!-sb-futex - (and (not (mutex-%owner mutex)) + (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 ;; From the Mutex 2 algorithm from "Futexes are Tricky" by Ulrich Drepper. @@ -503,11 +459,16 @@ HOLDING-MUTEX-P." (declare (ignore to-sec to-usec)) #!-sb-futex (flet ((cas () - (loop repeat 24 - when (and (not (mutex-%owner mutex)) + (loop repeat 100 + when (and (progn + (barrier (:read)) + (not (mutex-%owner mutex))) (not (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner))) - do (return-from cas t)) + do (return-from cas t) + else + do + (sb!ext:spin-loop-hint)) ;; Check for pending interrupts. (with-interrupts nil))) (declare (dynamic-extent #'cas)) @@ -552,6 +513,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)) @@ -731,7 +693,8 @@ IF-NOT-OWNER is :FORCE)." (setf (waitqueue-%head queue) (cdr head))) (car head))) while next - do (when (eq queue (sb!ext:compare-and-swap (thread-waiting-for next) queue nil)) + do (when (eq queue (sb!ext:compare-and-swap + (thread-waiting-for next) queue nil)) (decf n))) nil)) @@ -791,10 +754,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 - (wait-for nil :timeout timeout) ; Yeah... + (sb!ext:wait-for nil :timeout timeout) ; Yeah... #!+sb-thread (let ((me *current-thread*)) (barrier (:read)) @@ -809,11 +773,14 @@ around the call, checking the the associated data: (progn #!-sb-futex (progn - (%waitqueue-enqueue me queue) + (%with-cas-lock ((waitqueue-%owner queue)) + (%waitqueue-enqueue me queue)) (release-mutex mutex) (setf status (or (flet ((wakeup () - (when (neq queue (thread-waiting-for me)) + (barrier (:read)) + (when (neq queue + (thread-waiting-for me)) :ok))) (declare (dynamic-extent #'wakeup)) (allow-with-interrupts @@ -1301,18 +1268,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