X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=2021cfb2cd586f25c4cc5f23b0fbfb89f069d4ff;hb=cf507f95509a855a752b6f1771aa06877b8a3b30;hp=5ac9a0b74b56514c47258ef01443e0c9c615f12f;hpb=6127c0b282bb6d7fa6d225ee91d0a601d9b82360;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 5ac9a0b..2021cfb 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -87,8 +87,10 @@ in future versions." (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") @@ -104,6 +106,11 @@ in future versions." ;;;; 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 @@ -113,11 +120,14 @@ in future versions." (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 @@ -214,25 +224,33 @@ in future versions." (thread-yield) (return-from get-spinlock t)))) (if (and (not *interrupts-enabled*) *allow-with-interrupts*) - ;; If interrupts are enabled, 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)) + ;; 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))) - ;; Simply setting SPINLOCK-VALUE to NIL is not enough as it does not - ;; propagate to other processors, plus without a memory barrier the - ;; CPU might reorder instructions allowing code from the critical - ;; section to leak out. Use COMPARE-AND-SWAP for the memory barrier - ;; effect and do some sanity checking while we are at it. - (unless (eq *current-thread* - (sb!ext:compare-and-swap (spinlock-value spinlock) - *current-thread* nil)) - (error "Only the owner can release the spinlock ~S." spinlock))) + ;; 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)) ;;;; Mutexes @@ -254,6 +272,15 @@ in future versions." (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)) + (defun get-mutex (mutex &optional (new-owner *current-thread*) (waitp t)) #!+sb-doc "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If @@ -284,9 +311,10 @@ directly." (when (eq new-owner old) (error "Recursive lock attempt ~S." mutex)) #!-sb-thread - (if old - (error "Strange deadlock on ~S in an unithreaded build?" mutex) - (setf (mutex-%owner mutex) new-owner))) + (when old + (error "Strange deadlock on ~S in an unithreaded build?" mutex))) + #!-sb-thread + (setf (mutex-%owner mutex) new-owner) #!+sb-thread (progn ;; FIXME: Lutexes do not currently support deadlines, as at least @@ -306,6 +334,8 @@ directly." (setf (mutex-%owner mutex) new-owner) 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+))) @@ -318,13 +348,16 @@ directly." +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+)) @@ -340,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. @@ -348,29 +381,43 @@ this mutex. RELEASE-MUTEX is not interrupt safe: interrupts should be disabled around calls to it. -Signals a WARNING is 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 - (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 @@ -427,39 +474,53 @@ 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. - (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.") @@ -614,9 +675,6 @@ on this semaphore, then N of them is woken up." #!+sb-thread (defun handle-thread-exit (thread) (/show0 "HANDLING THREAD EXIT") - ;; We're going down, can't handle interrupts sanely anymore. GC - ;; remains enabled. - (block-deferrable-signals) ;; Lisp-side cleanup (with-all-threads-lock (setf (thread-%alive-p thread) nil) @@ -757,6 +815,9 @@ around and can be retrieved by JOIN-THREAD." ;; of Allegro's *cl-default-special-bindings*, as that is at ;; least accessible to users to secure their own libraries. ;; --njf, 2006-07-15 + ;; + ;; As it is, this lambda must not cons until we are ready + ;; to run GC. Be very careful. (let* ((*current-thread* thread) (*restart-clusters* nil) (*handler-clusters* (sb!kernel::initial-handler-clusters)) @@ -791,28 +852,50 @@ around and can be retrieved by JOIN-THREAD." (format nil "~~@" *current-thread*)) - (unwind-protect - (progn - ;; now that most things have a chance to - ;; work properly without messing up other - ;; threads, it's time to enable signals - (sb!unix::reset-signal-mask) - (setf (thread-result thread) - (cons t - (multiple-value-list - (funcall real-function))))) - (handle-thread-exit thread))))))) + (without-interrupts + (unwind-protect + (with-local-interrupts + ;; Now that most things have a chance + ;; to work properly without messing up + ;; other threads, it's time to enable + ;; signals. + (sb!unix::unblock-deferrable-signals) + (setf (thread-result thread) + (cons t + (multiple-value-list + (funcall real-function)))) + ;; Try to block deferrables. An + ;; interrupt may unwind it, but for a + ;; normal exit it prevents interrupt + ;; loss. + (block-deferrable-signals)) + ;; We're going down, can't handle interrupts + ;; sanely anymore. GC remains enabled. + (block-deferrable-signals) + ;; We don't want to run interrupts in a dead + ;; thread when we leave WITHOUT-INTERRUPTS. + ;; This potentially causes important + ;; interupts to be lost: SIGINT comes to + ;; mind. + (setq *interrupt-pending* nil) + (handle-thread-exit thread)))))))) (values)))) + ;; If the starting thread is stopped for gc before it signals the + ;; semaphore then we'd be stuck. + (assert (not *gc-inhibit*)) ;; Keep INITIAL-FUNCTION pinned until the child thread is - ;; initialized properly. - (with-pinned-objects (initial-function) - (let ((os-thread - (%create-thread - (get-lisp-obj-address initial-function)))) - (when (zerop os-thread) - (error "Can't create a new thread")) - (wait-on-semaphore setup-sem) - thread)))) + ;; initialized properly. Wrap the whole thing in + ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another + ;; thread. + (without-interrupts + (with-pinned-objects (initial-function) + (let ((os-thread + (%create-thread + (get-lisp-obj-address initial-function)))) + (when (zerop os-thread) + (error "Can't create a new thread")) + (wait-on-semaphore setup-sem) + thread))))) (define-condition join-thread-error (error) ((thread :reader join-thread-error-thread :initarg :thread)) @@ -832,13 +915,13 @@ around and can be retrieved by JOIN-THREAD." "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 @@ -861,47 +944,54 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." `(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*))))) - (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