(define-alien-routine ("create_thread" %create-thread)
unsigned-long (lisp-fun-address unsigned-long))
- (define-alien-routine "block_deferrable_signals"
- void)
+ (declaim (inline %block-deferrable-signals))
+ (define-alien-routine ("block_deferrable_signals" %block-deferrable-signals)
+ void
+ (where sb!alien:unsigned-long)
+ (old sb!alien:unsigned-long))
+
+ (defun block-deferrable-signals ()
+ (%block-deferrable-signals 0 0))
#!+sb-lutex
(progn
(setf (mutex-%owner mutex) new-owner)
t)
#!-sb-lutex
- ;; This is a direct tranlation of the Mutex 2 algorithm from
+ ;; 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+
(waitp
(bug "Failed to acquire lock with WAITP."))))))
-(defun release-mutex (mutex)
+(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.
-Signals a WARNING if current thread is not the current owner of the
-mutex."
+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)
- (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner)
- (setf (mutex-%owner mutex) nil)))
- #!+sb-thread
- (progn
- #!+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))
+ (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
;; Need to disable interrupts so that we don't miss grabbing the
;; mutex on our way out.
(without-interrupts
- (unwind-protect
- (let ((me *current-thread*))
- ;; This setf becomes visible to other CPUS due to the
- ;; usual memory barrier semantics of lock
- ;; acquire/release.
- (setf (waitqueue-data queue) me)
- (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 queue->data, and so
- ;; futex-wait returns immediately instead of sleeping.
- ;; Ergo, no lost wakeup. We may get spurious wakeups, but
- ;; that's ok.
- (loop
- (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
- (case (with-pinned-objects (queue me)
+ (let ((me nil))
+ ;; 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-data queue) me)
+ (loop
+ (multiple-value-bind (to-sec to-usec) (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 WAITQUEUE-DATA 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 queue->data, 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-data-address queue)
(get-lisp-obj-address me)
;; timeout":
(or to-sec -1)
(or to-usec 0))))
- ((1) (signal-deadline))
- ((2))
- (otherwise (return))))))
- ;; 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 mutex)))))
+ ;; 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
+ ((1) (signal-deadline))
+ ;; EINTR
+ ((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 correspoinding condition-wait must be held by this thread during
+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.")
,@body))
;;; Called from the signal handler.
+#!-win32
(defun run-interruption ()
(let ((interruption (with-interruptions-lock (*current-thread*)
(pop (thread-interruptions *current-thread*)))))
first thing to do is usually a WITH-INTERRUPTS or a
WITHOUT-INTERRUPTS. Within a thread interrupts are queued, they are
run in same the order they were sent."
+ #!+win32
+ (declare (ignore thread))
+ #!+win32
+ (with-interrupt-bindings
+ (with-interrupts (funcall function)))
+ #!-win32
(let ((os-thread (thread-os-thread thread)))
(cond ((not os-thread)
(error 'interrupt-thread-error :thread thread))
projects / sbcl.git / blobdiff