(declaim (inline current-thread-os-thread))
(defun current-thread-os-thread ()
- (sap-int
- (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
+ #!+sb-thread
+ (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))
+ #!-sb-thread
+ 0)
(defun init-initial-thread ()
(/show0 "Entering INIT-INITIAL-THREAD")
;;;; Aliens, low level stuff
+(define-alien-routine "kill_safely"
+ integer
+ (os-thread #!-alpha unsigned-long #!+alpha unsigned-int)
+ (signal int))
+
#!+sb-thread
(progn
;; FIXME it would be good to define what a thread id is or isn't
(define-alien-routine ("create_thread" %create-thread)
unsigned-long (lisp-fun-address unsigned-long))
- (define-alien-routine "signal_interrupt_thread"
- integer (os-thread unsigned-long))
+ (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))
- (define-alien-routine "block_deferrable_signals"
- void)
+ (defun block-deferrable-signals ()
+ (%block-deferrable-signals 0 0))
#!+sb-lutex
(progn
(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.
- (loop
- (loop repeat 128 do (cas)) ; 128 is arbitrary here
- (sb!unix::%check-interrupts))
+ ;; 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))
(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+
+lock-taken+
+lock-contested+))))
;; Wait on the contested lock.
- (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
- (when (= 1 (with-pinned-objects (mutex)
- (futex-wait (mutex-state-address mutex)
- (get-lisp-obj-address +lock-contested+)
- (or to-sec -1)
- (or to-usec 0))))
- (signal-deadline))))
+ (loop
+ (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
+ (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) (signal-deadline))
+ ((2))
+ (otherwise (return))))))
(setf old (sb!ext:compare-and-swap (mutex-state mutex)
+lock-free+
+lock-contested+))
(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.
- (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
- (when (= 1 (with-pinned-objects (queue me)
- (allow-with-interrupts
- (futex-wait (waitqueue-data-address queue)
- (get-lisp-obj-address me)
- ;; our way if saying "no
- ;; timeout":
- (or to-sec -1)
- (or to-usec 0)))))
- (signal-deadline))))
- ;; 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)))))
+ (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)
+ ;; our way if 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
+ ((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.")
"Suspend current thread until THREAD exits. Returns the result
values of the thread function. If the thread does not exit normally,
return DEFAULT if given or else signal JOIN-THREAD-ERROR."
- (with-mutex ((thread-result-lock thread))
+ (with-system-mutex ((thread-result-lock thread) :allow-with-interrupts t)
(cond ((car (thread-result thread))
- (values-list (cdr (thread-result thread))))
+ (return-from join-thread
+ (values-list (cdr (thread-result thread)))))
(defaultp
- default)
- (t
- (error 'join-thread-error :thread thread)))))
+ (return-from join-thread default))))
+ (error 'join-thread-error :thread thread))
(defun destroy-thread (thread)
#!+sb-doc
`(with-system-mutex ((thread-interruptions-lock ,thread))
,@body))
-;;; Called from the signal handler in C.
+;;; Called from the signal handler.
+#!-win32
(defun run-interruption ()
- (in-interruption ()
- (loop
- (let ((interruption (with-interruptions-lock (*current-thread*)
- (pop (thread-interruptions *current-thread*)))))
- ;; Resignalling after popping one works fine, because from the
- ;; OS's point of view we have returned from the signal handler
- ;; (thanks to arrange_return_to_lisp_function) so at least one
- ;; more signal will be delivered.
- (when (thread-interruptions *current-thread*)
- (signal-interrupt-thread (thread-os-thread *current-thread*)))
- (if interruption
- (with-interrupts
- (funcall interruption))
- (return))))))
-
-;;; The order of interrupt execution is peculiar. If thread A
-;;; interrupts thread B with I1, I2 and B for some reason receives I1
-;;; when FUN2 is already on the list, then it is FUN2 that gets to run
-;;; first. But when FUN2 is run SIG_INTERRUPT_THREAD is enabled again
-;;; and I2 hits pretty soon in FUN2 and run FUN1. This is of course
-;;; just one scenario, and the order of thread interrupt execution is
-;;; undefined.
+ (let ((interruption (with-interruptions-lock (*current-thread*)
+ (pop (thread-interruptions *current-thread*)))))
+ ;; If there is more to do, then resignal and let the normal
+ ;; interrupt deferral mechanism take care of the rest. From the
+ ;; OS's point of view the signal we are in the handler for is no
+ ;; longer pending, so the signal will not be lost.
+ (when (thread-interruptions *current-thread*)
+ (kill-safely (thread-os-thread *current-thread*) sb!unix:sigpipe))
+ (when interruption
+ (funcall interruption))))
+
(defun interrupt-thread (thread function)
#!+sb-doc
"Interrupt the live THREAD and make it run FUNCTION. A moderate
degree of care is expected for use of INTERRUPT-THREAD, due to its
nature: if you interrupt a thread that was holding important locks
then do something that turns out to need those locks, you probably
-won't like the effect."
- #!-sb-thread (declare (ignore thread))
- #!-sb-thread
+won't like the effect. FUNCTION runs with interrupts disabled, but
+WITH-INTERRUPTS is allowed in it. Keep in mind that many things may
+enable interrupts (GET-MUTEX when contended, for instance) so the
+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)))
- #!+sb-thread
- (if (eq thread *current-thread*)
- (with-interrupt-bindings
- (with-interrupts (funcall function)))
- (let ((os-thread (thread-os-thread thread)))
- (cond ((not os-thread)
- (error 'interrupt-thread-error :thread thread))
- (t
- (with-interruptions-lock (thread)
- (push function (thread-interruptions thread)))
- (when (minusp (signal-interrupt-thread os-thread))
- (error 'interrupt-thread-error :thread thread)))))))
+ #!-win32
+ (let ((os-thread (thread-os-thread thread)))
+ (cond ((not os-thread)
+ (error 'interrupt-thread-error :thread thread))
+ (t
+ (with-interruptions-lock (thread)
+ ;; Append to the end of the interruptions queue. It's
+ ;; O(N), but it does not hurt to slow interruptors down a
+ ;; bit when the queue gets long.
+ (setf (thread-interruptions thread)
+ (append (thread-interruptions thread)
+ (list (lambda ()
+ (without-interrupts
+ (allow-with-interrupts
+ (funcall function))))))))
+ (when (minusp (kill-safely os-thread sb!unix:sigpipe))
+ (error 'interrupt-thread-error :thread thread))))))
(defun terminate-thread (thread)
#!+sb-doc