From b56c1a4dc22aa0ac827343667584aa6090b15f02 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 23 Aug 2011 15:50:04 +0300 Subject: [PATCH] unify locks Remove spinlocks, make spinlock functions redirect to mutexes instead. (Compile-time deprecation style-warning for spinlocks.) --- src/code/cross-thread.lisp | 15 ---- src/code/fd-stream.lisp | 21 ++--- src/code/hash-table.lisp | 10 +-- src/code/target-hash-table.lisp | 27 +++--- src/code/target-package.lisp | 3 - src/code/target-thread.lisp | 76 ++-------------- src/code/thread.lisp | 180 +++++++++++++++----------------------- src/pcl/boot.lisp | 2 +- src/pcl/defs.lisp | 2 +- src/pcl/dfun.lisp | 6 +- src/pcl/methods.lisp | 4 +- src/pcl/std-class.lisp | 10 +-- src/pcl/vector.lisp | 6 +- tests/dynamic-extent.impure.lisp | 16 +--- tests/threads.impure.lisp | 41 ++------- tests/threads.pure.lisp | 101 --------------------- 16 files changed, 122 insertions(+), 398 deletions(-) diff --git a/src/code/cross-thread.lisp b/src/code/cross-thread.lisp index 461f02d..3682330 100644 --- a/src/code/cross-thread.lisp +++ b/src/code/cross-thread.lisp @@ -23,18 +23,3 @@ (declare (ignore mutex)) `(locally ,@body)) -(defun make-spinlock (&key name value) - (declare (ignore name value)) - nil) - -(defun get-spinlock (spinlock) - (declare (ignore spinlock)) - t) - -(defun release-spinlock (spinlock) - (declare (ignore spinlock)) - nil) - -(defmacro with-spinlock ((spinlock) &body body) - (declare (ignore spinlock)) - `(locally ,@body)) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 69505b8..6dff66f 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -52,25 +52,16 @@ #!+sb-doc "List of available buffers.") -(defvar *available-buffers-spinlock* (sb!thread::make-spinlock - :name "lock for *AVAILABLE-BUFFERS*") +(defvar *available-buffers-lock* (sb!thread:make-mutex + :name "lock for *AVAILABLE-BUFFERS*") #!+sb-doc "Mutex for access to *AVAILABLE-BUFFERS*.") (defmacro with-available-buffers-lock ((&optional) &body body) - ;; CALL-WITH-SYSTEM-SPINLOCK because - ;; - ;; 1. streams are low-level enough to be async signal safe, and in - ;; particular a C-c that brings up the debugger while holding the - ;; mutex would lose badly - ;; - ;; 2. this can potentially be a fairly busy (but also probably - ;; uncontended) lock, so we don't want to pay the syscall per - ;; release -- hence a spinlock. - ;; - ;; ...again, once we have smarted locks the spinlock here can become - ;; a mutex. - `(sb!thread::with-system-spinlock (*available-buffers-spinlock*) + ;; CALL-WITH-SYSTEM-MUTEX because streams are low-level enough to be + ;; async signal safe, and in particular a C-c that brings up the + ;; debugger while holding the mutex would lose badly. + `(sb!thread::with-system-mutex (*available-buffers-lock*) ,@body)) (defconstant +bytes-per-buffer+ (* 4 1024) diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp index 933b390..4b3da96 100644 --- a/src/code/hash-table.lisp +++ b/src/code/hash-table.lisp @@ -67,8 +67,8 @@ ;; respective key. (hash-vector nil :type (or null (simple-array sb!vm:word (*)))) ;; Used for locking GETHASH/(SETF GETHASH)/REMHASH - (spinlock (sb!thread::make-spinlock :name "hash-table lock") - :type sb!thread::spinlock :read-only t) + (lock (sb!thread:make-mutex :name "hash-table lock") + :type sb!thread:mutex :read-only t) ;; The GC will set this to T if it moves an EQ-based key. This used ;; to be signaled by a bit in the header of the kv vector, but that ;; implementation caused some concurrency issues when we stopped @@ -144,10 +144,10 @@ unspecified." ;; Needless to say, this also excludes some internal bits, but ;; getting there is too much detail when "unspecified" says what ;; is important -- unpredictable, but harmless. - `(sb!thread::with-recursive-spinlock ((hash-table-spinlock ,hash-table)) + `(sb!thread::with-recursive-lock ((hash-table-lock ,hash-table)) ,@body)) (defmacro-mundanely with-locked-system-table ((hash-table) &body body) - `(sb!thread::with-recursive-system-spinlock - ((hash-table-spinlock ,hash-table)) + `(sb!thread::with-recursive-system-lock + ((hash-table-lock ,hash-table)) ,@body)) diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 27b7322..5c5bdb7 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -628,19 +628,19 @@ multiple threads accessing the same hash-table without locking." (hash-table-needs-rehash-p hash-table))) (declare (inline rehash-p rehash-without-growing-p)) (cond ((rehash-p) - ;; Use recursive spinlocks since for weak tables the - ;; spinlock has already been acquired. GC must be inhibited - ;; to prevent the GC from seeing a rehash in progress. - (sb!thread::with-recursive-system-spinlock - ((hash-table-spinlock hash-table) :without-gcing t) + ;; Use recursive locks since for weak tables the lock has + ;; already been acquired. GC must be inhibited to prevent + ;; the GC from seeing a rehash in progress. + (sb!thread::with-recursive-system-lock + ((hash-table-lock hash-table) :without-gcing t) ;; Repeat the condition inside the lock to ensure that if ;; two reader threads enter MAYBE-REHASH at the same time ;; only one rehash is performed. (when (rehash-p) (rehash hash-table)))) ((rehash-without-growing-p) - (sb!thread::with-recursive-system-spinlock - ((hash-table-spinlock hash-table) :without-gcing t) + (sb!thread::with-recursive-system-lock + ((hash-table-lock hash-table) :without-gcing t) (when (rehash-without-growing-p) (rehash-without-growing hash-table))))))) @@ -660,15 +660,16 @@ multiple threads accessing the same hash-table without locking." (locally (declare (inline ,@inline)) ,@body)))) (if (hash-table-weakness ,hash-table) - (sb!thread::with-recursive-system-spinlock - ((hash-table-spinlock ,hash-table) :without-gcing t) + (sb!thread::with-recursive-system-lock + ((hash-table-lock ,hash-table) :without-gcing t) (,body-fun)) (with-pinned-objects ,pin (if ,synchronized - ;; We use a "system" spinlock here because it is very - ;; slightly faster, as it doesn't re-enable interrupts. - (sb!thread::with-recursive-system-spinlock - ((hash-table-spinlock ,hash-table)) + ;; We use a "system" lock here because it is very + ;; slightly faster, as it doesn't re-enable + ;; interrupts. + (sb!thread::with-recursive-system-lock + ((hash-table-lock ,hash-table)) (,body-fun)) (,body-fun))))))) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 4569a11..87f1da1 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -61,9 +61,6 @@ (declare (function function)) ;; FIXME: Since name conflicts can be signalled while holding the ;; mutex, user code can be run leading to lock ordering problems. - ;; - ;; This used to be a spinlock, but there it can be held for a long - ;; time while the debugger waits for user input. (sb!thread:with-recursive-lock (*package-graph-lock*) (funcall function))) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 7b21c14..0d0ccb9 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -200,9 +200,6 @@ arbitrary printable objects, and need not be unique.") (def!method print-object ((mutex mutex) stream) (print-lock mutex (mutex-name mutex) (mutex-owner mutex) stream)) -(def!method print-object ((spinlock spinlock) stream) - (print-lock spinlock (spinlock-name spinlock) (spinlock-value spinlock) stream)) - (defun thread-alive-p (thread) #!+sb-doc "Return T if THREAD is still alive. Note that the return value is @@ -307,8 +304,6 @@ created and old ones may exit at any time." (sb!vm::current-thread-offset-sap n)) -;;;; Spinlocks - (defmacro with-deadlocks ((thread lock &optional (timeout nil timeoutp)) &body forms) (with-unique-names (n-thread n-lock new n-timeout) `(let* ((,n-thread ,thread) @@ -332,62 +327,7 @@ created and old ones may exit at any time." ;; Interrupt handlers and GC save and restore any ;; previous wait marks using WITHOUT-DEADLOCKS below. (setf (thread-waiting-for ,n-thread) nil))))) - -(declaim (inline get-spinlock release-spinlock)) - -;;; Should always be called with interrupts disabled. -(defun get-spinlock (spinlock) - (declare (optimize (speed 3) (safety 0))) - (let* ((new *current-thread*) - (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new))) - (when old - (when (eq old new) - (error "Recursive lock attempt on ~S." spinlock)) - #!+sb-thread - (with-deadlocks (new spinlock) - (flet ((cas () - (if (sb!ext:compare-and-swap (spinlock-value spinlock) nil new) - (thread-yield) - (return-from get-spinlock t)))) - ;; Try once. - (cas) - ;; Check deadlocks - (with-interrupts (check-deadlock)) - (if (and (not *interrupts-enabled*) *allow-with-interrupts*) - ;; If interrupts are disabled, but we are allowed to - ;; enabled them, check for pending interrupts every once - ;; in a while. %CHECK-INTERRUPTS is taking shortcuts, make - ;; sure that deferrables are unblocked by doing an empty - ;; WITH-INTERRUPTS once. - (progn - (with-interrupts) - (loop - (loop repeat 128 do (cas)) ; 128 is arbitrary here - (sb!unix::%check-interrupts))) - (loop (cas))))))) - t) - -(defun release-spinlock (spinlock) - (declare (optimize (speed 3) (safety 0))) - ;; On x86 and x86-64 we can get away with no memory barriers, (see - ;; Linux kernel mailing list "spin_unlock optimization(i386)" - ;; thread, summary at - ;; http://kt.iserv.nl/kernel-traffic/kt19991220_47.html#1. - ;; - ;; If the compiler may reorder this with other instructions, insert - ;; compiler barrier here. - ;; - ;; FIXME: this does not work on SMP Pentium Pro and OOSTORE systems, - ;; neither on most non-x86 architectures (but we don't have threads - ;; on those). - (setf (spinlock-value spinlock) nil) - - ;; FIXME: Is a :memory barrier too strong here? Can we use a :write - ;; barrier instead? - #!+(not (or x86 x86-64)) - (barrier (:memory))) - ;;;; Mutexes #!+sb-doc @@ -421,14 +361,8 @@ HOLDING-MUTEX-P." (defun check-deadlock () (let* ((self *current-thread*) (origin (thread-waiting-for self))) - (labels ((lock-owner (lock) - (etypecase lock - (mutex (mutex-%owner lock)) - (spinlock (spinlock-value lock)))) - (lock-p (thing) - (typep thing '(or mutex spinlock))) - (detect-deadlock (lock) - (let ((other-thread (lock-owner lock))) + (labels ((detect-deadlock (lock) + (let ((other-thread (mutex-%owner lock))) (cond ((not other-thread)) ((eq self other-thread) (let* ((chain (deadlock-chain self origin)) @@ -451,10 +385,10 @@ HOLDING-MUTEX-P." ;; If the thread is waiting with a timeout OTHER-LOCK ;; is a cons, and we don't consider it a deadlock -- since ;; it will time out on its own sooner or later. - (when (lock-p other-lock) + (when (mutex-p other-lock) (detect-deadlock other-lock))))))) (deadlock-chain (thread lock) - (let* ((other-thread (lock-owner lock)) + (let* ((other-thread (mutex-owner lock)) (other-lock (when other-thread (thread-waiting-for other-thread)))) (cond ((not other-thread) @@ -477,7 +411,7 @@ HOLDING-MUTEX-P." ;; Again, the deadlock is gone? (return-from check-deadlock nil))))))) ;; Timeout means there is no deadlock - (when (lock-p origin) + (when (mutex-p origin) (detect-deadlock origin) t)))) diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 4c688bf..71dc92b 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -63,11 +63,40 @@ stale value, use MUTEX-OWNER instead." '(setf mutex-value)) form) -(def!struct spinlock - #!+sb-doc +;;; SPINLOCK no longer exists as a type -- provided for backwards compatibility. + +(deftype spinlock () "Spinlock type." - (name nil :type (or null thread-name)) - (value nil)) + (deprecation-warning :early "1.0.53.11" 'spinlock 'mutex) + 'mutex) + +(define-deprecated-function :early "1.0.53.11" make-spinlock make-mutex (&key name) + (make-mutex :name name)) + +(define-deprecated-function :early "1.0.5.x" spinlock-name mutex-name (lock) + (mutex-name lock)) + +(define-deprecated-function :early "1.0.53.11" (setf spinlock-name) (setf mutex-name) (name lock) + (setf (mutex-name lock) name)) + +(define-deprecated-function :early "1.0.53.11" spinlock-value mutex-owner (lock) + (mutex-owner lock)) + +(define-deprecated-function :early "1.0.53.11" get-spinlock grab-mutex (lock) + (grab-mutex lock)) + +(define-deprecated-function :early "1.0.53.11" release-spinlock release-mutex (lock) + (release-mutex lock)) + +(sb!xc:defmacro with-recursive-spinlock ((lock) &body body) + (deprecation-warning :early "1.0.53.11" 'with-recursive-spinlock 'with-recursive-lock) + `(with-recursive-lock (,lock) + ,@body)) + +(sb!xc:defmacro with-spinlock ((lock) &body body) + (deprecation-warning :early "1.0.53.11" 'with-recursive-spinlock 'with-mutex) + `(with-lock (,lock) + ,@body)) (sb!xc:defmacro without-thread-waiting-for ((&key already-without-interrupts) &body body) (with-unique-names (thread prev) @@ -115,12 +144,6 @@ is in use, sleep until it is available" #'with-system-mutex-thunk ,mutex))) -(sb!xc:defmacro with-system-spinlock ((spinlock &key) &body body) - `(dx-flet ((with-system-spinlock-thunk () ,@body)) - (call-with-system-spinlock - #'with-system-spinlock-thunk - ,spinlock))) - (sb!xc:defmacro with-recursive-lock ((mutex) &body body) #!+sb-doc "Acquires MUTEX for the dynamic scope of BODY. Within that scope @@ -132,28 +155,16 @@ provided the default value is used for the mutex." #'with-recursive-lock-thunk ,mutex))) -(sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body) - `(dx-flet ((with-recursive-spinlock-thunk () ,@body)) - (call-with-recursive-spinlock - #'with-recursive-spinlock-thunk - ,spinlock))) - -(sb!xc:defmacro with-recursive-system-spinlock ((spinlock - &key without-gcing) - &body body) - `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body)) +(sb!xc:defmacro with-recursive-system-lock ((lock + &key without-gcing) + &body body) + `(dx-flet ((with-recursive-system-lock-thunk () ,@body)) (,(cond (without-gcing - 'call-with-recursive-system-spinlock/without-gcing) + 'call-with-recursive-system-lock/without-gcing) (t - 'call-with-recursive-system-spinlock)) - #'with-recursive-system-spinlock-thunk - ,spinlock))) - -(sb!xc:defmacro with-spinlock ((spinlock) &body body) - `(dx-flet ((with-spinlock-thunk () ,@body)) - (call-with-spinlock - #'with-spinlock-thunk - ,spinlock))) + 'call-with-recursive-system-lock)) + #'with-recursive-system-lock-thunk + ,lock))) (macrolet ((def (name &optional variant) `(defun ,(if variant (symbolicate name "/" variant) name) @@ -181,22 +192,6 @@ provided the default value is used for the mutex." #!-sb-thread (progn - (macrolet ((def (name &optional variant) - `(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)))) - ((nil) - `(without-interrupts (funcall function))))))) - (def call-with-system-spinlock) - (def call-with-recursive-system-spinlock) - (def call-with-recursive-system-spinlock :without-gcing)) - (defun call-with-mutex (function mutex value waitp) (declare (ignore mutex value waitp) (function function)) @@ -206,65 +201,21 @@ provided the default value is used for the mutex." (declare (ignore mutex) (function function)) (funcall function)) - (defun call-with-spinlock (function spinlock) - (declare (ignore spinlock) (function function)) - (funcall function)) + (defun call-with-recursive-system-lock (function lock) + (declare (function function) (ignore lock)) + (without-interrupts + (funcall function))) - (defun call-with-recursive-spinlock (function spinlock) - (declare (ignore spinlock) (function function)) - (funcall function))) + (defun call-with-recursive-system-lock/without-gcing (function mutex) + (declare (function function) (ignore lock)) + (without-gcing + (funcall function)))) #!+sb-thread ;;; KLUDGE: These need to use DX-LET, because the cleanup form that ;;; 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 - (defun call-with-system-spinlock (function spinlock) - (declare (function function)) - (without-interrupts - (dx-let (got-it) - (unwind-protect - (when (setf got-it (get-spinlock spinlock)) - (funcall function)) - (when got-it - (release-spinlock spinlock)))))) - - (macrolet ((def (name &optional variant) - `(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))) - (got-it nil)) - (unwind-protect - (when (or inner-lock-p - (setf got-it - (get-spinlock spinlock))) - (funcall function)) - (when got-it - (release-spinlock spinlock)))))) - (declare (inline %call-with-system-spinlock)) - ,(ecase variant - (:without-gcing - `(without-gcing (%call-with-system-spinlock))) - ((nil) - `(without-interrupts (%call-with-system-spinlock)))))))) - (def call-with-recursive-system-spinlock) - (def call-with-recursive-system-spinlock :without-gcing)) - - (defun call-with-spinlock (function spinlock) - (declare (function function)) - (dx-let ((got-it nil)) - (without-interrupts - (unwind-protect - (when (setf got-it (allow-with-interrupts - (get-spinlock spinlock))) - (with-local-interrupts (funcall function))) - (when got-it - (release-spinlock spinlock)))))) - (defun call-with-mutex (function mutex value waitp) (declare (function function)) (dx-let ((got-it nil)) @@ -288,14 +239,25 @@ 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*)) - (got-it nil)) - (without-interrupts - (unwind-protect - (when (or inner-lock-p (setf got-it (allow-with-interrupts - (get-spinlock spinlock)))) - (with-local-interrupts (funcall function))) - (when got-it - (release-spinlock spinlock))))))) + (macrolet ((def (name &optional variant) + `(defun ,(if variant (symbolicate name "/" variant) name) + (function lock) + (declare (function function)) + (flet ((%call-with-recursive-system-lock () + (dx-let ((inner-lock-p + (eq *current-thread* (mutex-owner lock))) + (got-it nil)) + (unwind-protect + (when (or inner-lock-p + (setf got-it (grab-mutex lock))) + (funcall function)) + (when got-it + (release-mutex lock)))))) + (declare (inline %call-with-recursive-system-lock)) + ,(ecase variant + (:without-gcing + `(without-gcing (%call-with-recursive-system-lock))) + ((nil) + `(without-interrupts (%call-with-recursive-system-lock)))))))) + (def call-with-recursive-system-lock) + (def call-with-recursive-system-lock :without-gcing))) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 1b573bc..33b76a3 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -2128,7 +2128,7 @@ bootstrapping. ((eq **boot-state** 'complete) ;; Check that we are under the lock. #+sb-thread - (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf)))) + (aver (eq sb-thread:*current-thread* (sb-thread:mutex-owner (gf-lock gf)))) (setf (safe-gf-dfun-state gf) new-state)) (t (setf (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index e7e825d..f1e50b9 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -357,7 +357,7 @@ :accessor gf-dfun-state) ;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic. (%lock - :initform (sb-thread::make-spinlock :name "GF lock") + :initform (sb-thread:make-mutex :name "GF lock") :reader gf-lock) ;; Set to true by ADD-METHOD, REMOVE-METHOD; to false by ;; MAYBE-UPDATE-INFO-FOR-GF. diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 86019d2..35e9fba 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -1700,10 +1700,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; are part of this same code path (done while the lock is held), ;; which we AVER. ;; - ;; FIXME: When our mutexes are smart about the need to wake up - ;; sleepers we can put a mutex here instead -- but in the meantime - ;; we use a spinlock to avoid a syscall for every dfun update. - ;; ;; KLUDGE: No need to lock during bootstrap. (if early-p (update) @@ -1712,7 +1708,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; where we can end up in a metacircular loop here? In ;; case there are, better fetch it while interrupts are ;; still enabled... - (sb-thread::call-with-recursive-system-spinlock #'update lock)))))) + (sb-thread::call-with-recursive-system-lock #'update lock)))))) (defvar *dfun-count* nil) (defvar *dfun-list* nil) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 3c6b614..7efb80d 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -487,7 +487,7 @@ ;; System lock because interrupts need to be disabled as ;; well: it would be bad to unwind and leave the gf in an ;; inconsistent state. - (sb-thread::with-recursive-system-spinlock (lock) + (sb-thread::with-recursive-system-lock (lock) (let ((existing (get-method generic-function qualifiers specializers @@ -574,7 +574,7 @@ ;; System lock because interrupts need to be disabled as well: ;; it would be bad to unwind and leave the gf in an inconsistent ;; state. - (sb-thread::with-recursive-system-spinlock (lock) + (sb-thread::with-recursive-system-lock (lock) (let* ((specializers (method-specializers method)) (methods (generic-function-methods generic-function)) (new-methods (remove method methods))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 101a635..261dbbd 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -202,18 +202,18 @@ ;;; This needs to be used recursively, in case a non-trivial user ;;; defined ADD/REMOVE-DIRECT-METHOD method ends up calling another ;;; function using the same lock. -(defvar *specializer-lock* (sb-thread::make-spinlock :name "Specializer lock")) +(defvar *specializer-lock* (sb-thread:make-mutex :name "Specializer lock")) (defmethod add-direct-method :around ((specializer specializer) method) ;; All the actions done under this lock are done in an order ;; that is safe to unwind at any point. - (sb-thread::with-recursive-system-spinlock (*specializer-lock*) + (sb-thread::with-recursive-system-lock (*specializer-lock*) (call-next-method))) (defmethod remove-direct-method :around ((specializer specializer) method) ;; All the actions done under this lock are done in an order ;; that is safe to unwind at any point. - (sb-thread::with-recursive-system-spinlock (*specializer-lock*) + (sb-thread::with-recursive-system-lock (*specializer-lock*) (call-next-method))) (defmethod add-direct-method ((specializer class) (method method)) @@ -244,7 +244,7 @@ ;; we behave as if we got just first or just after -- it's just ;; for update that we need to lock. (or (cdr cell) - (sb-thread::with-spinlock (*specializer-lock*) + (sb-thread:with-mutex (*specializer-lock*) (setf (cdr cell) (let (collect) (dolist (m (car cell)) @@ -303,7 +303,7 @@ (entry (gethash object (specializer-method-table specializer)))) (when entry (or (cdr entry) - (sb-thread::with-spinlock (*specializer-lock*) + (sb-thread:with-mutex (*specializer-lock*) (setf (cdr entry) (let (collect) (dolist (m (car entry)) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 6a000b4..db9882c 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -55,11 +55,11 @@ ;;; used. (defvar *pv-tables* (make-hash-table :test 'equal)) -;;; ...and one lock to rule them. Spinlock because for certain (rare) +;;; ...and one lock to rule them. Lock because for certain (rare) ;;; cases this lock might be grabbed in the course of method dispatch ;;; -- and mostly this is already under the *world-lock* (defvar *pv-lock* - (sb-thread::make-spinlock :name "pv table index lock")) + (sb-thread:make-mutex :name "pv table index lock")) (defun intern-pv-table (&key slot-name-lists) (flet ((intern-slot-names (slot-names) @@ -77,7 +77,7 @@ :pv-size (* 2 (reduce #'+ snl :key (lambda (slots) (length (cdr slots)))))))))) - (sb-thread::with-spinlock (*pv-lock*) + (sb-thread:with-mutex (*pv-lock*) (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists))))) (defun use-standard-slot-access-p (class slot-name type) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 4e0b077..ab00e06 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -550,18 +550,12 @@ (gethash 5 *table*)) ;; This fails on threaded PPC because the hash-table implementation -;; uses recursive system spinlocks, which cons (see below for test -;; (:no-consing :spinlock), which also fails on threaded PPC). +;; uses recursive system locks, which cons (see below for test +;; (:no-consing :lock), which also fails on threaded PPC). (with-test (:name (:no-consing :hash-tables) :fails-on '(and :ppc :sb-thread)) (assert-no-consing (test-hash-table))) -;;; with-spinlock and with-mutex should use DX and not cons - -(defvar *slock* (sb-thread::make-spinlock :name "slocklock")) - -(defun test-spinlock () - (sb-thread::with-spinlock (*slock*) - (true *slock*))) +;;; with-mutex should use DX and not cons (defvar *mutex* (sb-thread::make-mutex :name "mutexlock")) @@ -571,10 +565,6 @@ (with-test (:name (:no-consing :mutex) :fails-on :ppc :skipped-on '(not :sb-thread)) (assert-no-consing (test-mutex))) - -(with-test (:name (:no-consing :spinlock) :fails-on :ppc :skipped-on '(not :sb-thread)) - (assert-no-consing (test-spinlock))) - ;;; Bugs found by Paul F. Dietz diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 9672f49..75bb628 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -37,10 +37,6 @@ (with-mutex (mutex) mutex))) -(with-test (:name (:with-spinlock :basics)) - (let ((spinlock (make-spinlock))) - (with-spinlock (spinlock)))) - (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose" void (where sb-alien:unsigned-long)) @@ -76,19 +72,19 @@ ;;;; Now the real tests... -(with-test (:name (:interrupt-thread :deferrables-unblocked-by-spinlock)) - (let ((spinlock (sb-thread::make-spinlock)) +(with-test (:name (:interrupt-thread :deferrables-unblocked-by-lock)) + (let ((lock (sb-thread::make-mutex)) (thread (sb-thread:make-thread (lambda () (loop (sleep 1)))))) - (sb-thread::get-spinlock spinlock) + (sb-thread::grab-mutex lock) (sb-thread:interrupt-thread thread (lambda () (check-deferrables-blocked-or-lose 0) - (sb-thread::get-spinlock spinlock) + (sb-thread::grab-mutex lock) (check-deferrables-unblocked-or-lose 0) (sb-ext:quit))) (sleep 1) - (sb-thread::release-spinlock spinlock))) + (sb-thread::release-mutex lock))) ;;; compare-and-swap @@ -229,38 +225,11 @@ (assert (ours-p (mutex-value l)) nil "5")) (assert (eql (mutex-value l) nil) nil "6")))) -(with-test (:name (:with-recursive-spinlock :basics)) - (labels ((ours-p (value) - (eq *current-thread* value))) - (let ((l (make-spinlock :name "rec"))) - (assert (eql (spinlock-value l) nil) nil "1") - (with-recursive-spinlock (l) - (assert (ours-p (spinlock-value l)) nil "3") - (with-recursive-spinlock (l) - (assert (ours-p (spinlock-value l)) nil "4")) - (assert (ours-p (spinlock-value l)) nil "5")) - (assert (eql (spinlock-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))))) -(with-test (:name (:spinlock :nesting-spinlock-and-recursive-spinlock)) - (let ((l (make-spinlock :name "a spinlock"))) - (with-spinlock (l) - (with-recursive-spinlock (l))))) - -(with-test (:name (:spinlock :more-basics)) - (let ((l (make-spinlock :name "spinlock"))) - (assert (eql (spinlock-value l) nil) ((spinlock-value l)) - "spinlock not free (1)") - (with-spinlock (l) - (assert (eql (spinlock-value l) *current-thread*) ((spinlock-value l)) - "spinlock not taken")) - (assert (eql (spinlock-value l) nil) ((spinlock-value l)) - "spinlock not free (2)"))) - ;; test that SLEEP actually sleeps for at least the given time, even ;; if interrupted by another thread exiting/a gc/anything (with-test (:name (:sleep :continue-sleeping-after-interrupt)) diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index c9db294..3d6d119 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -29,15 +29,6 @@ (release-mutex mutex)) (assert (not (mutex-value mutex))))) -(with-test (:name spinlock-owner) - ;; Make sure basics are sane on unithreaded ports as well - (let ((spinlock (sb-thread::make-spinlock))) - (sb-thread::get-spinlock spinlock) - (assert (eq *current-thread* (sb-thread::spinlock-value spinlock))) - (handler-bind ((warning #'error)) - (sb-thread::release-spinlock spinlock)) - (assert (not (sb-thread::spinlock-value spinlock))))) - ;;; Terminating a thread that's waiting for the terminal. #+sb-thread @@ -389,98 +380,6 @@ :deadlock)))) (assert (eq :ok (join-thread t1))))) -(with-test (:name deadlock-detection.4 :skipped-on '(not :sb-thread)) - (loop - repeat 1000 - do (flet ((test (ma mb sa sb) - (lambda () - (handler-case - (sb-thread::with-spinlock (ma) - (sb-thread:signal-semaphore sa) - (sb-thread:wait-on-semaphore sb) - (sb-thread::with-spinlock (mb) - :ok)) - (sb-thread:thread-deadlock (e) - (princ e) - :deadlock))))) - (let* ((m1 (sb-thread::make-spinlock :name "M1")) - (m2 (sb-thread::make-spinlock :name "M2")) - (s1 (sb-thread:make-semaphore :name "S1")) - (s2 (sb-thread:make-semaphore :name "S2")) - (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1")) - (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2"))) - ;; One will deadlock, and the other will then complete normally - ;; ...except sometimes, when we get unlucky, and both will do - ;; the deadlock detection in parallel and both signal. - (let ((res (list (sb-thread:join-thread t1) - (sb-thread:join-thread t2)))) - (assert (or (equal '(:deadlock :ok) res) - (equal '(:ok :deadlock) res) - (equal '(:deadlock :deadlock) res)))))))) - -(with-test (:name deadlock-detection.5 :skipped-on '(not :sb-thread)) - (let* ((m1 (sb-thread::make-spinlock :name "M1")) - (m2 (sb-thread::make-spinlock :name "M2")) - (s1 (sb-thread:make-semaphore :name "S1")) - (s2 (sb-thread:make-semaphore :name "S2")) - (t1 (sb-thread:make-thread - (lambda () - (sb-thread::with-spinlock (m1) - (sb-thread:signal-semaphore s1) - (sb-thread:wait-on-semaphore s2) - (sb-thread::with-spinlock (m2) - :ok))) - :name "T1"))) - (prog (err) - :retry - (handler-bind ((sb-thread:thread-deadlock - (lambda (e) - (unless err - ;; Make sure we can print the condition - ;; while it's active - (let ((*print-circle* nil)) - (setf err (princ-to-string e))) - (go :retry))))) - (when err - (sleep 1)) - (assert (eq :ok (sb-thread::with-spinlock (m2) - (unless err - (sb-thread:signal-semaphore s2) - (sb-thread:wait-on-semaphore s1) - (sleep 1)) - (sb-thread::with-spinlock (m1) - :ok))))) - (assert (stringp err))) - (assert (eq :ok (sb-thread:join-thread t1))))) - -(with-test (:name deadlock-detection.7 :skipped-on '(not :sb-thread)) - (let* ((m1 (sb-thread::make-spinlock :name "M1")) - (m2 (sb-thread::make-spinlock :name "M2")) - (s1 (sb-thread:make-semaphore :name "S1")) - (s2 (sb-thread:make-semaphore :name "S2")) - (t1 (sb-thread:make-thread - (lambda () - (sb-thread::with-spinlock (m1) - (sb-thread:signal-semaphore s1) - (sb-thread:wait-on-semaphore s2) - (sb-thread::with-spinlock (m2) - :ok))) - :name "T1"))) - (assert (eq :deadlock - (handler-case - (sb-thread::with-spinlock (m2) - (sb-thread:signal-semaphore s2) - (sb-thread:wait-on-semaphore s1) - (sleep 1) - (sb-sys:with-deadline (:seconds 0.1) - (sb-thread::with-spinlock (m1) - :ok))) - (sb-sys:deadline-timeout () - :deadline) - (sb-thread:thread-deadlock () - :deadlock)))) - (assert (eq :ok (join-thread t1))))) - #+sb-thread (with-test (:name :pass-arguments-to-thread) (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2)))))) -- 1.7.10.4