1.0.24.39: mutex changes

- do what a FIXME suggests and rename MUTEX-VALUE to MUTEX-OWNER
- in the process, make sure that the value returned is less stale
- keep MUTEX-VALUE around for compatibility for a while
- also add HOLDING-MUTEX-P
- to make MUTEX-OWNER and HOLDING-MUTEX-P useful make unithread builds
  keep track of the owner of mutex

NEWS

@@ -4,6 +4,11 @@ changes in sbcl-1.0.25 relative to 1.0.24:
     removed later. Please use SB-INTROSPECT:FUNCTION-LAMBDA-LIST instead.
   * new feature: SB-INTROSPECT:DEFTYPE-LAMBDA-LIST allows retrieval of
     DEFTYPE lambda lists. (thanks to Tobias Rittweiler)
+  * enhancement: MUTEX-VALUE is to be superseded by MUTEX-OWNER that has a
+    better name and does not return values so stale on multiprocessor systems.
+    Also, HOLDING-MUTEX-P was added for about the only sane usage of
+    MUTEX-OWNER.
+  * improvement: unithread builds keep track of MUTEX-VALUE.
   * improvement: reading from a TWO-WAY-STREAM does not touch the output
     stream anymore making it thread safe to have a concurrent reader and
     a writer, for instance, in a pipe.
@@ -252,7 +257,7 @@ changes in sbcl-1.0.19 relative to 1.0.18:
     type is not know sufficiently well a compile-time are now compiled
     correctly. (reported by John Morrison)
   * bug fix: compiler no longer makes erronous assumptions in the
-    presense of non-foldable SATISFIES types.
+    presence of non-foldable SATISFIES types.
   * bug fix: stack analysis missed cleanups of dynamic-extent
     arguments in non-let-converted calls to local functions.
   * improvements to the Windows port:

package-data-list.lisp-expr

@@ -1846,7 +1846,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "INTERRUPT-THREAD-ERROR-THREAD"
                "INTERRUPT-THREAD" "TERMINATE-THREAD" "DESTROY-THREAD"
                "THREAD-YIELD"
-               "MUTEX" "MAKE-MUTEX" "MUTEX-NAME" "MUTEX-VALUE"
+               "MUTEX" "MAKE-MUTEX" "MUTEX-NAME" "MUTEX-OWNER" "MUTEX-VALUE"
+               "HOLDING-MUTEX-P"
                "GET-MUTEX" "RELEASE-MUTEX" "WITH-MUTEX"
                "WITH-RECURSIVE-LOCK"
                "WAITQUEUE" "MAKE-WAITQUEUE" "WAITQUEUE-NAME"

src/code/gc.lisp

@@ -197,8 +197,7 @@ run in any thread.")
 (defvar *gc-epoch* (cons nil nil))
 
 (defun sub-gc (&key (gen 0))
-  (unless (eq sb!thread:*current-thread*
-              (sb!thread:mutex-value *already-in-gc*))
+  (unless (sb!thread:holding-mutex-p *already-in-gc*)
     ;; With gencgc, unless *GC-PENDING* every allocation in this
     ;; function triggers another gc, potentially exceeding maximum
     ;; interrupt nesting. If *GC-INHIBIT* is not true, however,

src/code/target-thread.lisp

@@ -257,6 +257,15 @@ in future versions."
   (defconstant +lock-taken+ 1)
   (defconstant +lock-contested+ 2))
 
+(defun mutex-owner (mutex)
+  "Current owner of the mutex, NIL if the mutex is free. Naturally,
+this is racy by design (another thread may acquire the mutex after
+this function returns), it is intended for informative purposes. For
+testing whether the current thread is holding a mutex see
+HOLDING-MUTEX-P."
+  ;; Make sure to get the current value.
+  (sb!ext:compare-and-swap (mutex-%owner mutex) nil nil))
+
 (defun get-mutex (mutex &optional (new-owner *current-thread*) (waitp t))
   #!+sb-doc
   "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If
@@ -287,9 +296,10 @@ directly."
     (when (eq new-owner old)
       (error "Recursive lock attempt ~S." mutex))
     #!-sb-thread
-    (if old
-        (error "Strange deadlock on ~S in an unithreaded build?" mutex)
-        (setf (mutex-%owner mutex) new-owner)))
+    (when old
+      (error "Strange deadlock on ~S in an unithreaded build?" mutex)))
+  #!-sb-thread
+  (setf (mutex-%owner mutex) new-owner)
   #!+sb-thread
   (progn
     ;; FIXME: Lutexes do not currently support deadlines, as at least
@@ -309,6 +319,8 @@ directly."
       (setf (mutex-%owner mutex) new-owner)
       t)
     #!-sb-lutex
+    ;; This is a direct tranlation of the Mutex 2 algorithm from
+    ;; "Futexes are Tricky" by Ulrich Drepper.
     (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
                                         +lock-free+
                                         +lock-taken+)))
@@ -351,7 +363,7 @@ this mutex.
 RELEASE-MUTEX is not interrupt safe: interrupts should be disabled
 around calls to it.
 
-Signals a WARNING is current thread is not the current owner of the
+Signals a WARNING if current thread is not the current owner of the
 mutex."
   (declare (type mutex mutex))
   ;; Order matters: set owner to NIL before releasing state.
@@ -366,6 +378,14 @@ mutex."
     (with-lutex-address (lutex (mutex-lutex mutex))
       (%lutex-unlock lutex))
     #!-sb-lutex
+    ;; FIXME: once ATOMIC-INCF supports struct slots with word sized
+    ;; unsigned-byte type this can be used:
+    ;;
+    ;;     (let ((old (sb!ext:atomic-incf (mutex-state mutex) -1)))
+    ;;       (unless (eql old +lock-free+)
+    ;;         (setf (mutex-state mutex) +lock-free+)
+    ;;         (with-pinned-objects (mutex)
+    ;;           (futex-wake (mutex-state-address mutex) 1))))
     (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
                                         +lock-taken+ +lock-free+)))
       (when (eql old +lock-contested+)

src/code/thread.lisp

@@ -21,11 +21,17 @@
   #!+(and sb-lutex sb-thread)
   (lutex (make-lutex)))
 
-;;; FIXME: We probably want to rename the accessor MUTEX-OWNER.
 (defun mutex-value (mutex)
-  "Current owner of the mutex, NIL if the mutex is free."
+  "Current owner of the mutex, NIL if the mutex is free. May return a
+stale value, use MUTEX-OWNER instead."
   (mutex-%owner mutex))
 
+(defun holding-mutex-p (mutex)
+  "Test whether the current thread is holding MUTEX."
+  ;; This is about the only use for which a stale value of owner is
+  ;; sufficient.
+  (eq sb!thread:*current-thread* (mutex-%owner mutex)))
+
 (defsetf mutex-value set-mutex-value)
 
 (declaim (inline set-mutex-value))
@@ -58,7 +64,9 @@ and the mutex is in use, sleep until it is available"
       ,value
       ,wait-p)))
 
-(sb!xc:defmacro with-system-mutex ((mutex &key without-gcing allow-with-interrupts) &body body)
+(sb!xc:defmacro with-system-mutex ((mutex
+                                    &key without-gcing allow-with-interrupts)
+                                   &body body)
   `(dx-flet ((with-system-mutex-thunk () ,@body))
      (,(cond (without-gcing
                'call-with-system-mutex/without-gcing)
@@ -109,25 +117,44 @@ provided the default value is used for the mutex."
       #'with-spinlock-thunk
       ,spinlock)))
 
-;;; KLUDGE: this separate implementation for (NOT SB-THREAD) is not
-;;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented.
-;;; However, there would be a (possibly slight) performance hit in
-;;; using them.
+(macrolet ((def (name &optional variant)
+             `(defun ,(if variant (symbolicate name "/" variant) name)
+                  (function mutex)
+                (declare (function function))
+                (flet ((%call-with-system-mutex ()
+                         (dx-let (got-it)
+                           (unwind-protect
+                                (when (setf got-it (get-mutex mutex))
+                                  (funcall function))
+                             (when got-it
+                               (release-mutex mutex))))))
+                  (declare (inline %call-with-system-mutex))
+                  ,(ecase variant
+                     (:without-gcing
+                       `(without-gcing (%call-with-system-mutex)))
+                     (:allow-with-interrupts
+                       `(without-interrupts
+                          (allow-with-interrupts (%call-with-system-mutex))))
+                     ((nil)
+                      `(without-interrupts (%call-with-system-mutex))))))))
+  (def call-with-system-mutex)
+  (def call-with-system-mutex :without-gcing)
+  (def call-with-system-mutex :allow-with-interrupts))
+
 #!-sb-thread
 (progn
   (macrolet ((def (name &optional variant)
-               `(defun ,(if variant (symbolicate name "/" variant) name) (function lock)
+               `(defun ,(if variant (symbolicate name "/" variant) name)
+                    (function lock)
                   (declare (ignore lock) (function function))
                   ,(ecase variant
                     (:without-gcing
                       `(without-gcing (funcall function)))
                     (:allow-with-interrupts
-                      `(without-interrupts (allow-with-interrupts (funcall function))))
+                      `(without-interrupts
+                         (allow-with-interrupts (funcall function))))
                     ((nil)
                       `(without-interrupts (funcall function)))))))
-    (def call-with-system-mutex)
-    (def call-with-system-mutex :without-gcing)
-    (def call-with-system-mutex :allow-with-interrupts)
     (def call-with-system-spinlock)
     (def call-with-recursive-system-spinlock)
     (def call-with-recursive-system-spinlock :without-gcing))
@@ -154,28 +181,6 @@ provided the default value is used for the mutex."
 ;;; closes over GOT-IT causes a value-cell to be allocated for it --
 ;;; and we prefer that to go on the stack since it can.
 (progn
-  (macrolet ((def (name &optional variant)
-               `(defun ,(if variant (symbolicate name "/" variant) name) (function mutex)
-                  (declare (function function))
-                  (flet ((%call-with-system-mutex ()
-                           (dx-let (got-it)
-                             (unwind-protect
-                                  (when (setf got-it (get-mutex mutex))
-                                    (funcall function))
-                               (when got-it
-                                 (release-mutex mutex))))))
-                    (declare (inline %call-with-system-mutex))
-                    ,(ecase variant
-                      (:without-gcing
-                        `(without-gcing (%call-with-system-mutex)))
-                      (:allow-with-interrupts
-                        `(without-interrupts (allow-with-interrupts (%call-with-system-mutex))))
-                      ((nil)
-                        `(without-interrupts (%call-with-system-mutex))))))))
-    (def call-with-system-mutex)
-    (def call-with-system-mutex :without-gcing)
-    (def call-with-system-mutex :allow-with-interrupts))
-
   (defun call-with-system-spinlock (function spinlock)
     (declare (function function))
     (without-interrupts
@@ -187,13 +192,18 @@ provided the default value is used for the mutex."
             (release-spinlock spinlock))))))
 
   (macrolet ((def (name &optional variant)
-               `(defun ,(if variant (symbolicate name "/" variant) name) (function spinlock)
+               `(defun ,(if variant (symbolicate name "/" variant) name)
+                    (function spinlock)
                   (declare (function function))
                   (flet ((%call-with-system-spinlock ()
-                           (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value spinlock)))
+                           (dx-let ((inner-lock-p
+                                     (eq *current-thread*
+                                         (spinlock-value spinlock)))
                                     (got-it nil))
                              (unwind-protect
-                                  (when (or inner-lock-p (setf got-it (get-spinlock spinlock)))
+                                  (when (or inner-lock-p
+                                            (setf got-it
+                                                  (get-spinlock spinlock)))
                                     (funcall function))
                                (when got-it
                                  (release-spinlock spinlock))))))
@@ -240,8 +250,6 @@ provided the default value is used for the mutex."
           (when got-it
             (release-mutex mutex))))))
 
-
-
   (defun call-with-recursive-spinlock (function spinlock)
     (declare (function function))
     (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))

src/code/timer.lisp

@@ -205,10 +205,7 @@ from now. For timers with a repeat interval it returns true."
      ,@body))
 
 (defun under-scheduler-lock-p ()
-  #!-sb-thread
-  t
-  #!+sb-thread
-  (eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*)))
+  (sb!thread:holding-mutex-p *scheduler-lock*))
 
 (defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
 

version.lisp-expr

@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.24.38"
+"1.0.24.39"