Commit 5234b3ca authored by Gabor Melis's avatar Gabor Melis
Browse files

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
parent 05854d6d

NEWS

+6 −1
Original line number Diff line number Diff line
@@ -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

+2 −1
Original line number Diff line number Diff line
@@ -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

+1 −2
Original line number Diff line number Diff line
@@ -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

+24 −4
Original line number Diff line number Diff line
@@ -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

+47 −39
Original line number Diff line number Diff line
@@ -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*))