From 7bb4c044e09f02a2115095af3733b0673b98a726 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 16 Nov 2011 17:27:15 +0200 Subject: [PATCH] missing CAS-locks and barriers * %WAITQUEUE-ENQUEUE was missing the CAS-lock, as was checking for the wakeup. * Put back the spin-before-yielding loop into WITH-CAS-LOCK, which I'd removed for some reason. * PPC has threads, and really needs barriers. x86oids have made me lazy, and now we pay the price. In particular: ** THREAD-WAITING-FOR: a read barrier in the non-futex CONDITION-WAIT -- the corresponding writes are protected by CAS and hence provide a write barrier already. ...and just for symmetry and because this makes my poor head hurt add write and read barriers to other places where it is read from / written to. ** WITH-CAS-LOCK: a read barrier for the READ-FORM. Not strictly necessary perhaps, as THREAD-YIELD most probably provides a barrier, but this is easier to read. Since the corresponding writes should use CAS, we're OK. --- src/code/barrier.lisp | 2 +- src/code/cross-thread.lisp | 3 +++ src/code/target-thread.lisp | 60 +++++++++++++++++++++++++++++++++---------- src/code/thread.lisp | 8 ++++-- 4 files changed, 56 insertions(+), 17 deletions(-) diff --git a/src/code/barrier.lisp b/src/code/barrier.lisp index 80ff65c..84da322 100644 --- a/src/code/barrier.lisp +++ b/src/code/barrier.lisp @@ -45,7 +45,7 @@ (or (getf *barrier-kind-functions* kind) (error "Unknown barrier kind ~S" kind))) -(defmacro barrier ((kind) &body forms) +(def!macro barrier ((kind) &body forms) "Insert a barrier in the code stream, preventing some sort of reordering. diff --git a/src/code/cross-thread.lisp b/src/code/cross-thread.lisp index 3682330..ddc0127 100644 --- a/src/code/cross-thread.lisp +++ b/src/code/cross-thread.lisp @@ -23,3 +23,6 @@ (declare (ignore mutex)) `(locally ,@body)) +(defmacro barrier ((kind) &body body) + (declare (ignore kind)) + `(progn ,@body)) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index cf6ceb5..afb63cc 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -39,20 +39,33 @@ WITH-CAS-LOCK can be entered recursively." (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) + (,owner (progn + (barrier (:read)) + ,read-form)) (,self *current-thread*) (,old nil) (,new ,self)) (unwind-protect (progn (unless (eq ,owner ,self) - (loop while (setf ,owner (or ,read-form ,cas-form)) + (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) (let ((,old ,self) (,new nil)) - ,cas-form))))))) + (unless (eq ,old ,cas-form) + (bug "Failed to release CAS lock!"))))))))) ;;; Conditions @@ -160,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) @@ -315,10 +330,12 @@ 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))))) + (setf (thread-waiting-for ,n-thread) nil) + (barrier (:write)))))) ;;;; Mutexes @@ -352,7 +369,9 @@ 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))) + (origin (progn + (barrier (:read)) + (thread-waiting-for self)))) (labels ((detect-deadlock (lock) (let ((other-thread (mutex-%owner lock))) (cond ((not other-thread)) @@ -373,7 +392,9 @@ 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. @@ -382,6 +403,7 @@ HOLDING-MUTEX-P." (deadlock-chain (thread 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 @@ -417,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. @@ -436,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)) @@ -665,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)) @@ -744,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 diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 6e42788..4d6a83c 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -107,15 +107,19 @@ stale value, use MUTEX-OWNER instead." 'progn 'with-local-interrupts))) `(let* ((,thread *current-thread*) - (,prev (thread-waiting-for ,thread))) + (,prev (progn + (barrier (:read)) + (thread-waiting-for ,thread)))) (flet ((exec () ,@body)) (if ,prev (,without (unwind-protect (progn (setf (thread-waiting-for ,thread) nil) + (barrier (:write)) (,with (exec))) - (setf (thread-waiting-for ,thread) ,prev))) + (setf (thread-waiting-for ,thread) ,prev) + (barrier (:write)))) (exec))))))) (sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t)) -- 1.7.10.4