(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))
#!+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)
;; 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
;; 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))
(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)))))))
(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)))))))
(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)))
(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
(sb!vm::current-thread-offset-sap n))
\f
-;;;; 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)
;; 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)))
\f
-
;;;; Mutexes
#!+sb-doc
(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))
;; 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)
;; 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))))
'(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)
#'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
#'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)
#!-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))
(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))
(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)))
((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+)
: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.
;; 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)
;; 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))))))
\f
(defvar *dfun-count* nil)
(defvar *dfun-list* nil)
;; 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
;; 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)))
;;; 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))
;; 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))
(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))
;;; 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)
: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)))))
\f
(defun use-standard-slot-access-p (class slot-name type)
(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"))
(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)))
-
\f
;;; Bugs found by Paul F. Dietz
(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))
;;;; 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
(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))
(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
: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))))))
projects / sbcl.git / commitdiff