From 5234b3ca36406aef45d5665b8bb0cf6ff5300dca Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Mon, 12 Jan 2009 15:00:21 +0000 Subject: [PATCH 1/1] 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 | 7 +++- package-data-list.lisp-expr | 3 +- src/code/gc.lisp | 3 +- src/code/target-thread.lisp | 28 ++++++++++++-- src/code/thread.lisp | 86 +++++++++++++++++++++++-------------------- src/code/timer.lisp | 5 +-- version.lisp-expr | 2 +- 7 files changed, 82 insertions(+), 52 deletions(-) diff --git a/NEWS b/NEWS index 286d928..0c86bf1 100644 --- a/NEWS +++ b/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: diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 7c1f98b..6dfe859 100644 --- a/package-data-list.lisp-expr +++ b/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" diff --git a/src/code/gc.lisp b/src/code/gc.lisp index e6abbb1..30384f2 100644 --- a/src/code/gc.lisp +++ b/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, diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 091ed8d..9145270 100644 --- a/src/code/target-thread.lisp +++ b/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+) diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 6e6ebec..a44b763 100644 --- a/src/code/thread.lisp +++ b/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*)) diff --git a/src/code/timer.lisp b/src/code/timer.lisp index 36235ac..29a121c 100644 --- a/src/code/timer.lisp +++ b/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)) diff --git a/version.lisp-expr b/version.lisp-expr index 7fdd6c7..51ddad1 100644 --- a/version.lisp-expr +++ b/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" -- 1.7.10.4