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.

diff --git a/src/code/barrier.lisp b/src/code/barrier.lisp
index 80ff65c..84da322 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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))))))
 \f
 ;;;; 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 (file)
--- 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))