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.
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:
(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
(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
(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+)))
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.
(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+)
#!+(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))
,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)
#'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))
;;; 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
(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))))))
(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*))
projects / sbcl.git / commitdiff