From 5502b6348a7471021b39b926a2b9d2b457f5ca62 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Fri, 7 Oct 2005 11:18:10 +0000 Subject: [PATCH] 0.9.5.31: * simpler WITH-RECURSIVE-LOCK * improved async unwind safety of WITH-MUTEX * WITH-RECURSIVE-LOCK can be nested in a WITH-MUTEX for the same lock --- NEWS | 8 +++--- src/code/target-thread.lisp | 5 ++-- src/code/thread.lisp | 60 ++++++++++++++++++++----------------------- tests/threads.impure.lisp | 11 +++++--- version.lisp-expr | 2 +- 5 files changed, 44 insertions(+), 42 deletions(-) diff --git a/NEWS b/NEWS index a05e24f..0774b12 100644 --- a/NEWS +++ b/NEWS @@ -14,9 +14,11 @@ changes in sbcl-0.9.6 relative to sbcl-0.9.5: on MIPS/Linux in addition to the previously supported platforms. * bug fix: division by zero in sb-sprof when no samples were collected * bug fix: a race when a slow to arrive sigprof signal killed sbcl - * bug fix: threads stacks belonging to dead threads are freed by the - next exiting thread, no need to gc to collect thread stacks anymore - * minor incompatible change: INTERRUPT-THREAD-ERROR-ERRNO removed + * threads + ** bug fix: threads stacks belonging to dead threads are freed by the + next exiting thread, no need to gc to collect thread stacks anymore + ** minor incompatible change: INTERRUPT-THREAD-ERROR-ERRNO removed + ** WITH-RECURSIVE-LOCK can be nested in a WITH-MUTEX for the same lock changes in sbcl-0.9.5 relative to sbcl-0.9.4: * new feature: timers based on Zach Beane's excellent timer package diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 18832b4..08ea191 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -176,13 +176,14 @@ in future versions." (+ (sb!kernel:get-lisp-obj-address mutex) (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))) -(defun get-mutex (mutex &optional new-value (wait-p t)) +(defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t)) #!+sb-doc "Acquire MUTEX, setting it to NEW-VALUE or some suitable default value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep until it is available" (declare (type mutex mutex) (optimize (speed 3))) - (unless new-value (setf new-value *current-thread*)) + (unless new-value + (setq new-value *current-thread*)) #!-sb-thread (let ((old-value (mutex-value mutex))) (when (and old-value wait-p) diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 9671d60..ab393f5 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -11,19 +11,24 @@ (in-package "SB!THREAD") -(sb!xc:defmacro with-mutex ((mutex &key value (wait-p t)) &body body) +(sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t)) + &body body) #!+sb-doc "Acquire MUTEX for the dynamic scope of BODY, setting it to NEW-VALUE or some suitable default value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep until it is available" #!-sb-thread (declare (ignore mutex value wait-p)) #!+sb-thread - (with-unique-names (got) - `(let ((,got (get-mutex ,mutex ,value ,wait-p))) - (when ,got - (unwind-protect - (locally ,@body) - (release-mutex ,mutex))))) + (with-unique-names (got mutex1) + `(let ((,mutex1 ,mutex) + ,got) + (unwind-protect + ;; FIXME: async unwind in SETQ form + (when (setq ,got (get-mutex ,mutex1 ,value ,wait-p)) + (locally + ,@body)) + (when ,got + (release-mutex ,mutex1))))) ;; KLUDGE: this separate expansion 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 @@ -34,30 +39,21 @@ and the mutex is in use, sleep until it is available" (sb!xc:defmacro with-recursive-lock ((mutex) &body body) #!+sb-doc "Acquires MUTEX for the dynamic scope of BODY. Within that scope -further recursive lock attempts for the same mutex succeed. However, -it is an error to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same -mutex." - #!-sb-thread (declare (ignore mutex)) - #!+sb-thread - (with-unique-names (cfp inner-lock) - `(let ((,cfp (sb!kernel:current-fp)) - (,inner-lock - (and (mutex-value ,mutex) - (sb!vm:control-stack-pointer-valid-p - (sb!sys:int-sap - (sb!kernel:get-lisp-obj-address (mutex-value ,mutex))))))) - (unless ,inner-lock - ;; this punning with MAKE-LISP-OBJ depends for its safety on - ;; the frame pointer being a lispobj-aligned integer. While - ;; it is, then MAKE-LISP-OBJ will always return a FIXNUM, so - ;; we're safe to do that. Should this ever change, this - ;; MAKE-LISP-OBJ could return something that looks like a - ;; pointer, but pointing into neverneverland, which will - ;; confuse GC completely. -- CSR, 2003-06-03 - (get-mutex ,mutex (sb!kernel:make-lisp-obj (sb!sys:sap-int ,cfp)))) - (unwind-protect - (locally ,@body) - (unless ,inner-lock - (release-mutex ,mutex))))) +further recursive lock attempts for the same mutex succeed. It is +allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex +provided the default value is used for the mutex." + #!-sb-thread + (declare (ignore mutex)) #!+sb-thread + (with-unique-names (mutex1 inner-lock-p) + `(let* ((,mutex1 ,mutex) + (,inner-lock-p (eq (mutex-value ,mutex1) *current-thread*))) + (unwind-protect + (progn + (unless ,inner-lock-p + (get-mutex ,mutex1)) + (locally + ,@body)) + (unless ,inner-lock-p + (release-mutex ,mutex1))))) #!-sb-thread `(locally ,@body)) diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index b4e5bba..cc47f12 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -99,8 +99,7 @@ (assert (eql (mutex-value l) nil) nil "5")) (labels ((ours-p (value) - (sb-vm:control-stack-pointer-valid-p - (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))) + (eq *current-thread* value))) (let ((l (make-mutex :name "rec"))) (assert (eql (mutex-value l) nil) nil "1") (sb-thread:with-recursive-lock (l) @@ -110,6 +109,11 @@ (assert (ours-p (mutex-value l)) nil "5")) (assert (eql (mutex-value l) nil) nil "6"))) +(with-test (:name (:mutex :nesting-mutex-and-recursive-lock)) + (let ((l (make-mutex :name "a mutex"))) + (with-mutex (l) + (with-recursive-lock (l))))) + (let ((l (make-spinlock :name "spinlock")) (p *current-thread*)) (assert (eql (spinlock-value l) 0) nil "1") @@ -151,8 +155,7 @@ (let ((queue (make-waitqueue :name "queue")) (lock (make-mutex :name "lock"))) (labels ((ours-p (value) - (sb-vm:control-stack-pointer-valid-p - (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))) + (eq *current-thread* value)) (in-new-thread () (with-recursive-lock (lock) (assert (ours-p (mutex-value lock))) diff --git a/version.lisp-expr b/version.lisp-expr index 6c7133a..433ed63 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".) -"0.9.5.30" +"0.9.5.31" -- 1.7.10.4