X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=015ebd1865a1c93e1146537225f85d29e8159eed;hb=bbbe40be1052fe7d46dacbfeb2e13041e5c9b293;hp=5ac9a0b74b56514c47258ef01443e0c9c615f12f;hpb=6127c0b282bb6d7fa6d225ee91d0a601d9b82360;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 5ac9a0b..015ebd1 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -214,8 +214,9 @@ 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. + ;; 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)) @@ -224,15 +225,18 @@ in future versions." (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 +258,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 +297,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 +320,8 @@ directly." (setf (mutex-%owner mutex) new-owner) t) #!-sb-lutex + ;; This is a direct tranlation 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+))) @@ -348,7 +364,7 @@ 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 +Signals a WARNING if current thread is not the current owner of the mutex." (declare (type mutex mutex)) ;; Order matters: set owner to NIL before releasing state. @@ -363,6 +379,14 @@ mutex." (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+) @@ -614,9 +638,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 +778,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 +815,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 +878,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 @@ -865,12 +911,18 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." (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)))))) + (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