[Sbcl-commits] CVS: sbcl/src/code gc.lisp, 1.79, 1.80 target-thread.lisp, 1.100, 1.101 thread.lisp, 1.29, 1.30 timer.lisp, 1.13, 1.14

[Gábor M. <me...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv29198/src/code

Modified Files:
	gc.lisp target-thread.lisp thread.lisp timer.lisp 
Log Message:
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


Index: gc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/gc.lisp,v
retrieving revision 1.79
retrieving revision 1.80
diff -u -d -r1.79 -r1.80
--- gc.lisp	6 May 2008 16:43:52 -0000	1.79
+++ gc.lisp	12 Jan 2009 15:00:21 -0000	1.80
@@ -197,8 +197,7 @@
 (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,

Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.100
retrieving revision 1.101
diff -u -d -r1.100 -r1.101
--- target-thread.lisp	11 Jan 2009 15:56:03 -0000	1.100
+++ target-thread.lisp	12 Jan 2009 15:00:21 -0000	1.101
@@ -257,6 +257,15 @@
   (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 @@
     (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 @@
       (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 @@
 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 @@
     (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+)

Index: thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/thread.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- thread.lisp	26 May 2008 07:38:29 -0000	1.29
+++ thread.lisp	12 Jan 2009 15:00:22 -0000	1.30
@@ -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 @@
       ,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 @@
       #'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 @@
 ;;; 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 @@
             (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 @@
           (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*))

Index: timer.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/timer.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- timer.lisp	12 Mar 2008 18:32:46 -0000	1.13
+++ timer.lisp	12 Jan 2009 15:00:22 -0000	1.14
@@ -205,10 +205,7 @@
      ,@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))