X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=2021cfb2cd586f25c4cc5f23b0fbfb89f069d4ff;hb=cf507f95509a855a752b6f1771aa06877b8a3b30;hp=2d0271311dff7f79795e22cfa91ee7600818207d;hpb=2b0c46508938b606e70cd6f2bb51506d44e45262;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 2d02713..2021cfb 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -120,8 +120,14 @@ in future versions." (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 @@ -328,7 +334,7 @@ directly." (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+ @@ -367,7 +373,7 @@ directly." (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. @@ -375,37 +381,43 @@ 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))) ;;;; Waitqueues/condition variables @@ -462,22 +474,28 @@ time we reacquire MUTEX and return to the caller." ;; 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) @@ -485,19 +503,24 @@ time we reacquire MUTEX and return to the caller." ;; 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.") @@ -922,6 +945,7 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." ,@body)) ;;; Called from the signal handler. +#!-win32 (defun run-interruption () (let ((interruption (with-interruptions-lock (*current-thread*) (pop (thread-interruptions *current-thread*))))) @@ -946,6 +970,12 @@ 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))) + #!-win32 (let ((os-thread (thread-os-thread thread))) (cond ((not os-thread) (error 'interrupt-thread-error :thread thread))