-(defmacro with-spinlock ((queue) &body body)
- (with-unique-names (pid)
- `(let ((,pid (current-thread-id)))
- (unwind-protect
- (progn
- (get-spinlock ,queue 2 ,pid)
- ,@body)
- (release-spinlock ,queue 2 ,pid)))))
-
-
-;;;; the higher-level locking operations are based on waitqueues
-
-(declaim (inline waitqueue-data-address mutex-value-address))
-
-(defstruct waitqueue
- (name nil :type (or null simple-string))
- (lock 0)
- (data nil))
-
-;;; The bare 4 here and 5 below are offsets of the slots in the struct.
-;;; There ought to be some better way to get these numbers
-(defun waitqueue-data-address (lock)
- (declare (optimize (speed 3)))
- (sb!ext:truly-the
- (unsigned-byte 32)
- (+ (sb!kernel:get-lisp-obj-address lock)
- (- (* 4 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
-
-(defstruct (mutex (:include waitqueue))
- (value nil))
-
-(defun mutex-value-address (lock)
- (declare (optimize (speed 3)))
- (sb!ext:truly-the
- (unsigned-byte 32)
- (+ (sb!kernel:get-lisp-obj-address lock)
- (- (* 5 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
-
-(declaim (inline futex-wait futex-wake))
-(sb!alien:define-alien-routine
- "futex_wait" int (word unsigned-long) (old-value unsigned-long))
-(sb!alien:define-alien-routine
- "futex_wake" int (word unsigned-long) (n unsigned-long))
-
-
-;;;; mutex
-
-(defun get-mutex (lock &optional new-value (wait-p t))
- "Acquire LOCK, setting it to NEW-VALUE or some suitable default value
-if NIL. If WAIT-P is non-NIL and the lock is in use, sleep until it
-is available"
- (declare (type mutex lock) (optimize (speed 3)))
- (let ((pid (current-thread-id))
- old)
- (unless new-value (setf new-value pid))
- (when (eql new-value (mutex-value lock))
- (warn "recursive lock attempt ~S~%" lock))
- (loop
- (unless
- (setf old (sb!vm::%instance-set-conditional lock 4 nil new-value))
- (return t))
- (unless wait-p (return nil))
- (futex-wait (mutex-value-address lock)
- (sb!kernel:get-lisp-obj-address old)))))
-
-(defun release-mutex (lock)
- (declare (type mutex lock))
- (setf (mutex-value lock) nil)
- (futex-wake (mutex-value-address lock) 1))
-
-;;;; condition variables
-
-(defun condition-wait (queue lock)
- "Atomically release LOCK and enqueue ourselves on QUEUE. Another
-thread may subsequently notify us using CONDITION-NOTIFY, at which
-time we reacquire LOCK and return to the caller."
- (assert lock)
- (let ((value (mutex-value lock)))
- (unwind-protect
- (let ((me (current-thread-id)))
- ;; XXX we should do something to ensure that the result of this setf
- ;; is visible to all CPUs
- (setf (waitqueue-data queue) me)
- (release-mutex lock)
- ;; Now we go to sleep using futex-wait. If anyone else
- ;; manages to grab LOCK and call CONDITION-NOTIFY during
- ;; this comment, it will change queue->data, and so
- ;; futex-wait returns immediately instead of sleeping.
- ;; Ergo, no lost wakeup
- (futex-wait (waitqueue-data-address queue)
- (sb!kernel:get-lisp-obj-address me)))
- ;; If we are interrupted while waiting, we should do these things
- ;; before returning. Ideally, in the case of an unhandled signal,
- ;; we should do them before entering the debugger, but this is
- ;; better than nothing.
- (get-mutex lock value))))
-
-
-(defun condition-notify (queue)
- "Notify one of the processes waiting on QUEUE"
- (let ((me (current-thread-id)))
- ;; no problem if >1 thread notifies during the comment in
- ;; condition-wait: as long as the value in queue-data isn't the
- ;; waiting thread's id, it matters not what it is
+ ;; 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
+(setf (fdocumentation 'make-mutex 'function)
+ "Create a mutex."
+ (fdocumentation 'mutex-name 'function)
+ "The name of the mutex. Setfable.")
+
+#!+(and sb-thread (not sb-lutex))
+(progn
+ (define-structure-slot-addressor mutex-state-address
+ :structure mutex
+ :slot state)
+ ;; Important: current code assumes these are fixnums or other
+ ;; lisp objects that don't need pinning.
+ (defconstant +lock-free+ 0)
+ (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))
+
+;;; Signals an error if owner of LOCK is waiting on a lock whose release
+;;; depends on the current thread. Does not detect deadlocks from sempahores.
+(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))))
+ (detect-deadlock (lock)
+ (let ((other-thread (lock-owner lock)))
+ (cond ((not other-thread))
+ ((eq self other-thread)
+ (let* ((chain (deadlock-chain self origin))
+ (barf
+ (format nil
+ "~%WARNING: DEADLOCK CYCLE DETECTED:~%~@< ~@;~
+ ~{~:@_~S~:@_~}~:@>~
+ ~%END OF CYCLE~%"
+ (mapcar #'car chain))))
+ ;; Barf to stderr in case the system is too tied up
+ ;; to report the error properly -- to avoid cross-talk
+ ;; build the whole string up first.
+ (write-string barf sb!sys:*stderr*)
+ (finish-output sb!sys:*stderr*)
+ (error 'thread-deadlock
+ :thread *current-thread*
+ :cycle chain)))
+ (t
+ (let ((other-lock (thread-waiting-for other-thread)))
+ ;; 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 (and other-lock (not (consp other-lock)))
+ (detect-deadlock other-lock)))))))
+ (deadlock-chain (thread lock)
+ (let* ((other-thread (lock-owner lock))
+ (other-lock (when other-thread
+ (thread-waiting-for other-thread))))
+ (cond ((not other-thread)
+ ;; The deadlock is gone -- maybe someone unwound
+ ;; from the same deadlock already?
+ (return-from check-deadlock nil))
+ ((consp other-lock)
+ ;; There's a timeout -- no deadlock.
+ (return-from check-deadlock nil))
+ ((eq self other-thread)
+ ;; Done
+ (list (list thread lock)))
+ (t
+ (if other-lock
+ (cons (list thread lock)
+ (deadlock-chain other-thread other-lock))
+ ;; Again, the deadlock is gone?
+ (return-from check-deadlock nil)))))))
+ ;; Timeout means there is no deadlock
+ (unless (consp origin)
+ (detect-deadlock origin)
+ t))))
+
+(defun get-mutex (mutex &optional new-owner
+ (waitp t) (timeout nil))
+ #!+sb-doc
+ "Deprecated in favor of GRAB-MUTEX."
+ (declare (type mutex mutex) (optimize (speed 3))
+ #!-sb-thread (ignore waitp timeout))
+ (unless new-owner
+ (setq new-owner *current-thread*))
+ (barrier (:read))
+ (let ((old (mutex-%owner mutex)))
+ (when (eq new-owner old)
+ (error "Recursive lock attempt ~S." mutex))
+ #!-sb-thread
+ (when old
+ (error "Strange deadlock on ~S in an unithreaded build?" mutex)))
+ #!-sb-thread
+ (setf (mutex-%owner mutex) new-owner)
+ #!+sb-thread
+ (with-deadlocks (new-owner mutex timeout)
+ ;; FIXME: Lutexes do not currently support deadlines, as at least
+ ;; on Darwin pthread_foo_timedbar functions are not supported:
+ ;; this means that we probably need to use the Carbon multiprocessing
+ ;; functions on Darwin.
+ ;;
+ ;; FIXME: This is definitely not interrupt safe: what happens if
+ ;; we get hit (1) during the lutex calls (ok, they may be safe,
+ ;; but has that been checked?) (2) after the lutex call, but
+ ;; before setting the mutex owner.
+ #!+sb-lutex
+ (progn
+ (when timeout
+ (error "Mutex timeouts not supported on this platform."))
+ (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
+ (if waitp
+ (let ((once (%lutex-trylock lutex)))
+ (cond ((zerop once)
+ ;; No need to wait.
+ once)
+ (t
+ (with-interrupts
+ ;; Check for deadlocks before waiting
+ (check-deadlock)
+ (%lutex-lock lutex)))))
+ (%lutex-trylock lutex))))
+ ;; FIXME: If %LUTEX-LOCK unwinds due to a signal, we may actually
+ ;; be holding the lock already -- and but neglect to mark ourselves
+ ;; as the owner here. This is bad.
+ (setf (mutex-%owner mutex) new-owner)
+ (barrier (:write))
+ t))
+ #!-sb-lutex
+ ;; This is a direct translation 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+)))
+ (unless (or (eql +lock-free+ old) (not waitp))
+ (tagbody
+ :retry
+ (when (or (eql +lock-contested+ old)
+ (not (eql +lock-free+
+ (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-taken+
+ +lock-contested+))))
+ ;; Wait on the contested lock.
+ (with-interrupts
+ (check-deadlock)
+ (loop
+ (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
+ (decode-timeout timeout)
+ (declare (ignore stop-sec stop-usec))
+ (case (with-pinned-objects (mutex)
+ (futex-wait (mutex-state-address mutex)
+ (get-lisp-obj-address +lock-contested+)
+ (or to-sec -1)
+ (or to-usec 0)))
+ ((1) (if deadlinep
+ (signal-deadline)
+ (return-from get-mutex nil)))
+ ((2))
+ (otherwise (return)))))))
+ (setf old (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-free+
+ +lock-contested+))
+ ;; Did we get it?
+ (unless (eql +lock-free+ old)
+ (go :retry))))
+ (cond ((eql +lock-free+ old)
+ (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex)
+ nil new-owner)))
+ (when prev
+ (bug "Old owner in free mutex: ~S" prev))
+ t))
+ (waitp
+ (bug "Failed to acquire lock with WAITP."))))))
+
+(defun grab-mutex (mutex &key (waitp t) (timeout nil))
+ #!+sb-doc
+ "Acquire MUTEX for the current thread. If WAITP is true (the default) and
+the mutex is not immediately available, sleep until it is available.
+
+If TIMEOUT is given, it specifies a relative timeout, in seconds, on
+how long GRAB-MUTEX should try to acquire the lock in the contested
+case. Unsupported on :SB-LUTEX platforms (eg. Darwin), where a non-NIL
+TIMEOUT signals an error.
+
+If GRAB-MUTEX returns T, the lock acquisition was successful. In case
+of WAITP being NIL, or an expired TIMEOUT, GRAB-MUTEX may also return
+NIL which denotes that GRAB-MUTEX did -not- acquire the lock.
+
+Notes:
+
+ - GRAB-MUTEX is not interrupt safe. The correct way to call it is:
+
+ (WITHOUT-INTERRUPTS
+ ...
+ (ALLOW-WITH-INTERRUPTS (GRAB-MUTEX ...))
+ ...)
+
+ WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding
+ the call while the mutex is in an inconsistent state while
+ ALLOW-WITH-INTERRUPTS allows the call to be interrupted from
+ sleep.
+
+ - (GRAB-MUTEX <mutex> :timeout 0.0) differs from
+ (GRAB-MUTEX <mutex> :waitp nil) in that the former may signal a
+ DEADLINE-TIMEOUT if the global deadline was due already on
+ entering GRAB-MUTEX.
+
+ The exact interplay of GRAB-MUTEX and deadlines are reserved to
+ change in future versions.
+
+ - It is recommended that you use WITH-MUTEX instead of calling
+ GRAB-MUTEX directly.
+"
+ (get-mutex mutex nil waitp timeout))
+
+(defun release-mutex (mutex &key (if-not-owner :punt))
+ #!+sb-doc
+ "Release MUTEX by setting it to NIL. Wake up threads waiting for
+this mutex.
+
+RELEASE-MUTEX is not interrupt safe: interrupts should be disabled
+around calls to it.
+
+If the current thread is not the owner of the mutex then it silently
+returns without doing anything (if IF-NOT-OWNER is :PUNT), signals a
+WARNING (if IF-NOT-OWNER is :WARN), or releases the mutex anyway (if
+IF-NOT-OWNER is :FORCE)."
+ (declare (type mutex mutex))
+ ;; Order matters: set owner to NIL before releasing state.
+ (let* ((self *current-thread*)
+ (old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil)))
+ (unless (eql self old-owner)
+ (ecase if-not-owner
+ ((:punt) (return-from release-mutex nil))
+ ((:warn)
+ (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner))
+ ((:force))))
+ #!+sb-thread
+ (when old-owner
+ (setf (mutex-%owner mutex) nil)
+ #!+sb-lutex
+ (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+)
+ (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-contested+ +lock-free+)
+ (with-pinned-objects (mutex)
+ (futex-wake (mutex-state-address mutex) 1))))
+ nil)))
+\f
+
+;;;; Waitqueues/condition variables
+
+(defstruct (waitqueue (:constructor %make-waitqueue))
+ #!+sb-doc
+ "Waitqueue type."
+ (name nil :type (or null thread-name))
+ #!+(and sb-lutex sb-thread)
+ (lutex (make-lutex))
+ #!-sb-lutex
+ (token nil))
+
+(def!method print-object ((waitqueue waitqueue) stream)
+ (print-unreadable-object (waitqueue stream :type t :identity t)
+ (format stream "~@[~A~]" (waitqueue-name waitqueue))))
+
+(defun make-waitqueue (&key name)
+ #!+sb-doc
+ "Create a waitqueue."
+ (%make-waitqueue :name name))
+
+#!+sb-doc
+(setf (fdocumentation 'waitqueue-name 'function)
+ "The name of the waitqueue. Setfable.")
+
+#!+(and sb-thread (not sb-lutex))
+(define-structure-slot-addressor waitqueue-token-address
+ :structure waitqueue
+ :slot token)
+
+(defun condition-wait (queue mutex)
+ #!+sb-doc
+ "Atomically release MUTEX and enqueue ourselves on QUEUE. Another thread may
+subsequently notify us using CONDITION-NOTIFY, at which time we reacquire
+MUTEX and return to the caller.
+
+Important: CONDITION-WAIT may return without CONDITION-NOTIFY having occurred.
+The correct way to write code that uses CONDITION-WAIT is to loop around the
+call, checking the the associated data:
+
+ (defvar *data* nil)
+ (defvar *queue* (make-waitqueue))
+ (defvar *lock* (make-mutex))
+
+ ;; Consumer
+ (defun pop-data ()
+ (with-mutex (*lock*)
+ (loop until *data*
+ do (condition-wait *queue* *lock*))
+ (pop *data*)))
+
+ ;; Producer
+ (defun push-data (data)
+ (with-mutex (*lock*)
+ (push data *data*)
+ (condition-notify *queue*)))
+
+Also note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of
+returning normally, it may do so without holding the mutex."
+ #!-sb-thread (declare (ignore queue))
+ (assert mutex)
+ #!-sb-thread (error "Not supported in unithread builds.")
+ #!+sb-thread
+ (let ((me *current-thread*))
+ (barrier (:read))
+ (assert (eq me (mutex-%owner mutex)))
+ (/show0 "CONDITION-WAITing")
+ #!+sb-lutex
+ ;; Need to disable interrupts so that we don't miss setting the
+ ;; owner on our way out. (pthread_cond_wait handles the actual
+ ;; re-acquisition.)
+ (without-interrupts
+ (unwind-protect
+ (progn
+ (setf (mutex-%owner mutex) nil)
+ (with-lutex-address (queue-lutex-address (waitqueue-lutex queue))
+ (with-lutex-address (mutex-lutex-address (mutex-lutex mutex))
+ (with-local-interrupts
+ (%lutex-wait queue-lutex-address mutex-lutex-address)))))
+ (barrier (:write)
+ (setf (mutex-%owner mutex) me))))
+ #!-sb-lutex
+ ;; Need to disable interrupts so that we don't miss grabbing the
+ ;; mutex on our way out.
+ (without-interrupts
+ ;; This setf becomes visible to other CPUS due to the usual
+ ;; memory barrier semantics of lock acquire/release. This must
+ ;; not be moved into the loop else wakeups may be lost upon
+ ;; continuing after a deadline or EINTR.
+ (setf (waitqueue-token queue) me)
+ (loop
+ (multiple-value-bind (to-sec to-usec)
+ (allow-with-interrupts (decode-timeout nil))
+ (case (unwind-protect
+ (with-pinned-objects (queue me)
+ ;; RELEASE-MUTEX is purposefully as close to
+ ;; FUTEX-WAIT as possible to reduce the size of
+ ;; the window where the token may be set by a
+ ;; notifier.
+ (release-mutex mutex)
+ ;; Now we go to sleep using futex-wait. If
+ ;; anyone else manages to grab MUTEX and call
+ ;; CONDITION-NOTIFY during this comment, it
+ ;; will change the token, and so futex-wait
+ ;; returns immediately instead of sleeping.
+ ;; Ergo, no lost wakeup. We may get spurious
+ ;; wakeups, but that's ok.
+ (allow-with-interrupts
+ (futex-wait (waitqueue-token-address queue)
+ (get-lisp-obj-address me)
+ ;; our way of saying "no
+ ;; timeout":
+ (or to-sec -1)
+ (or to-usec 0))))
+ ;; If we are interrupted while waiting, we should
+ ;; do these things before returning. Ideally, in
+ ;; the case of an unhandled signal, we should do
+ ;; them before entering the debugger, but this is
+ ;; better than nothing.
+ (allow-with-interrupts (get-mutex mutex)))
+ ;; ETIMEDOUT; we know it was a timeout, yet we cannot
+ ;; signal a deadline unconditionally here because the
+ ;; call to GET-MUTEX may already have signaled it.
+ ((1))
+ ;; EINTR; we do not need to return to the caller because
+ ;; an interleaved wakeup would change the token causing an
+ ;; EWOULDBLOCK in the next iteration.
+ ((2))
+ ;; EWOULDBLOCK, -1 here, is the possible spurious wakeup
+ ;; case. 0 is the normal wakeup.
+ (otherwise (return))))))))
+
+(defun condition-notify (queue &optional (n 1))
+ #!+sb-doc
+ "Notify N threads waiting on QUEUE. The same mutex that is used in
+the corresponding CONDITION-WAIT must be held by this thread during
+this call."
+ #!-sb-thread (declare (ignore queue n))
+ #!-sb-thread (error "Not supported in unithread builds.")
+ #!+sb-thread
+ (declare (type (and fixnum (integer 1)) n))
+ (/show0 "Entering CONDITION-NOTIFY")
+ #!+sb-thread
+ (progn
+ #!+sb-lutex
+ (with-lutex-address (lutex (waitqueue-lutex queue))
+ (%lutex-wake lutex n))
+ ;; No problem if >1 thread notifies during the comment in condition-wait:
+ ;; as long as the value in queue-data isn't the waiting thread's id, it
+ ;; matters not what it is -- using the queue object itself is handy.
+ ;;