X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=015ebd1865a1c93e1146537225f85d29e8159eed;hb=bbbe40be1052fe7d46dacbfeb2e13041e5c9b293;hp=61ea1af1e7680405c26c5f54f06318d10546413b;hpb=6bce87e4926f16d6dc70a3163a8bbde4303ea61d;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 61ea1af..015ebd1 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -43,14 +43,16 @@ in future versions." (let* ((cookie (list thread)) (info (if (thread-alive-p thread) :running - (multiple-value-list (join-thread thread :default cookie)))) + (multiple-value-list + (join-thread thread :default cookie)))) (state (if (eq :running info) info (if (eq cookie (car info)) :aborted :finished))) (values (when (eq :finished state) info))) - (format stream "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]" + (format stream + "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]" (thread-name thread) (eq :finished state) state @@ -98,8 +100,9 @@ in future versions." ;; in case we are in reinit since saving core with multiple ;; threads doesn't work. (setq *all-threads* (list initial-thread)))) + -;;;; +;;;; Aliens, low level stuff #!+sb-thread (progn @@ -191,10 +194,13 @@ in future versions." (defun sb!vm::current-thread-offset-sap (n) (declare (type (unsigned-byte 27) n)) (sb!vm::current-thread-offset-sap n)) + + +;;;; Spinlocks (declaim (inline get-spinlock release-spinlock)) -;; Should always be called with interrupts disabled. +;;; Should always be called with interrupts disabled. (defun get-spinlock (spinlock) (declare (optimize (speed 3) (safety 0))) (let* ((new *current-thread*) @@ -204,11 +210,13 @@ in future versions." (error "Recursive lock attempt on ~S." spinlock)) #!+sb-thread (flet ((cas () - (unless (sb!ext:compare-and-swap (spinlock-value spinlock) nil new) - (return-from get-spinlock t)))) + (if (sb!ext:compare-and-swap (spinlock-value spinlock) nil new) + (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)) @@ -217,10 +225,21 @@ in future versions." (defun release-spinlock (spinlock) (declare (optimize (speed 3) (safety 0))) - (setf (spinlock-value spinlock) nil) - nil) - -;;;; mutexes + ;; 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 #!+sb-doc (setf (fdocumentation 'make-mutex 'function) @@ -239,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 @@ -265,8 +293,14 @@ directly." #!-sb-thread (ignore waitp)) (unless new-owner (setq new-owner *current-thread*)) - (when (eql new-owner (mutex-%owner mutex)) - (error "Recursive lock attempt ~S." mutex)) + (let ((old (mutex-%owner mutex))) + (when (eq new-owner old) + (error "Recursive lock attempt ~S." mutex)) + #!-sb-thread + (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 @@ -286,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+))) @@ -328,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. @@ -343,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+) @@ -351,8 +395,9 @@ mutex." (with-pinned-objects (mutex) (futex-wake (mutex-state-address mutex) 1)))) nil)) + -;;;; waitqueues/condition variables +;;;; Waitqueues/condition variables (defstruct (waitqueue (:constructor %make-waitqueue)) #!+sb-doc @@ -386,45 +431,60 @@ time we reacquire MUTEX and return to the caller." (assert mutex) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread - (let ((owner (mutex-%owner mutex))) + (let ((me *current-thread*)) + (assert (eq me (mutex-%owner mutex))) (/show0 "CONDITION-WAITing") #!+sb-lutex - (progn - ;; FIXME: This doesn't look interrupt safe! - (setf (mutex-%owner mutex) nil) - (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) - (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) - (%lutex-wait queue-lutex-address mutex-lutex-address))) - (setf (mutex-%owner mutex) owner)) + ;; Need to disable interrupts so that we don't miss setting the + ;; owner on our way out. (pthread_cond_wait handles the actual + ;; re-acquisition.) + (without-interrupts + (unwind-protect + (progn + (setf (mutex-%owner mutex) nil) + (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) + (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) + (with-local-interrupts + (%lutex-wait queue-lutex-address mutex-lutex-address))))) + (setf (mutex-%owner mutex) me))) #!-sb-lutex - (unwind-protect - (let ((me *current-thread*)) - ;; FIXME: should we do something to ensure that the result - ;; of this setf is visible to all CPUs? - (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) - (futex-wait (waitqueue-data-address queue) - (get-lisp-obj-address me) - (or to-sec -1) ;; our way if saying "no timeout" - (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 owner)))) + ;; 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))))) (defun condition-notify (queue &optional (n 1)) #!+sb-doc - "Notify N threads waiting on QUEUE." + "Notify N threads waiting on QUEUE. The same mutex that is used in +the correspoinding 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.") #!+sb-thread @@ -451,12 +511,13 @@ time we reacquire MUTEX and return to the caller." #!+sb-doc "Notify all threads waiting on QUEUE." (condition-notify queue - ;; On a 64-bit platform truncating M-P-F to an int results - ;; in -1, which wakes up only one thread. + ;; On a 64-bit platform truncating M-P-F to an int + ;; results in -1, which wakes up only one thread. (ldb (byte 29 0) most-positive-fixnum))) + -;;;; semaphores +;;;; Semaphores (defstruct (semaphore (:constructor %make-semaphore (name %count))) #!+sb-doc @@ -465,6 +526,7 @@ should be considered an implementation detail, and may change in the future." (name nil :type (or null simple-string)) (%count 0 :type (integer 0)) + (waitcount 0 :type (integer 0)) (mutex (make-mutex)) (queue (make-waitqueue))) @@ -485,23 +547,41 @@ future." #!+sb-doc "Decrement the count of SEMAPHORE if the count would not be negative. Else blocks until the semaphore can be decremented." - ;; a more direct implementation based directly on futexes should be - ;; possible - (with-mutex ((semaphore-mutex semaphore)) - (loop until (> (semaphore-%count semaphore) 0) - do (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore)) - finally (decf (semaphore-%count semaphore))))) + ;; A more direct implementation based directly on futexes should be + ;; possible. + ;; + ;; We need to disable interrupts so that we don't forget to + ;; decrement the waitcount (which would happen if an asynch + ;; interrupt should catch us on our way out from the loop.) + (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) + ;; Quick check: is it positive? If not, enter the wait loop. + (let ((count (semaphore-%count semaphore))) + (if (plusp count) + (setf (semaphore-%count semaphore) (1- count)) + (unwind-protect + (progn + (incf (semaphore-waitcount semaphore)) + (loop until (plusp (setf count (semaphore-%count semaphore))) + do (condition-wait (semaphore-queue semaphore) + (semaphore-mutex semaphore))) + (setf (semaphore-%count semaphore) (1- count))) + (decf (semaphore-waitcount semaphore))))))) (defun signal-semaphore (semaphore &optional (n 1)) #!+sb-doc "Increment the count of SEMAPHORE by N. If there are threads waiting on this semaphore, then N of them is woken up." (declare (type (integer 1) n)) - (with-mutex ((semaphore-mutex semaphore)) - (when (= n (incf (semaphore-%count semaphore) n)) - (condition-notify (semaphore-queue semaphore) n)))) + ;; Need to disable interrupts so that we don't lose a wakeup after + ;; we have incremented the count. + (with-system-mutex ((semaphore-mutex semaphore)) + (let ((waitcount (semaphore-waitcount semaphore)) + (count (incf (semaphore-%count semaphore) n))) + (when (plusp waitcount) + (condition-notify (semaphore-queue semaphore) (min waitcount count)))))) + -;;;; job control, independent listeners +;;;; Job control, independent listeners (defstruct session (lock (make-mutex :name "session lock")) @@ -514,15 +594,15 @@ on this semaphore, then N of them is woken up." ;;; The debugger itself tries to acquire the session lock, don't let ;;; funny situations (like getting a sigint while holding the session ;;; lock) occur. At the same time we need to allow interrupts while -;;; *waiting* for the session lock for things like GET-FOREGROUND -;;; to be interruptible. +;;; *waiting* for the session lock for things like GET-FOREGROUND to +;;; be interruptible. ;;; -;;; Take care: we sometimes need to obtain the session lock while holding -;;; on to *ALL-THREADS-LOCK*, so we must _never_ obtain it _after_ getting -;;; a session lock! (Deadlock risk.) +;;; Take care: we sometimes need to obtain the session lock while +;;; holding on to *ALL-THREADS-LOCK*, so we must _never_ obtain it +;;; _after_ getting a session lock! (Deadlock risk.) ;;; -;;; FIXME: It would be good to have ordered locks to ensure invariants like -;;; the above. +;;; FIXME: It would be good to have ordered locks to ensure invariants +;;; like the above. (defmacro with-session-lock ((session) &body body) `(with-system-mutex ((session-lock ,session) :allow-with-interrupts t) ,@body)) @@ -558,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) @@ -672,8 +749,9 @@ have the foreground next." (sb!impl::toplevel-repl nil) (sb!int:flush-standard-output-streams)))))) (make-thread #'thread-repl)))) + -;;;; the beef +;;;; The beef (defun make-thread (function &key name) #!+sb-doc @@ -700,9 +778,12 @@ 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* nil) + (*handler-clusters* (sb!kernel::initial-handler-clusters)) (*condition-restarts* nil) (sb!impl::*deadline* nil) (sb!impl::*step-out* nil) @@ -734,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)) @@ -775,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 @@ -804,24 +907,30 @@ 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 in C. (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*))))) + ;; 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. (defun interrupt-thread (thread function) #!+sb-doc "Interrupt the live THREAD and make it run FUNCTION. A moderate @@ -879,39 +988,48 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (defun %symbol-value-in-thread (symbol thread) (tagbody - ;; Prevent the dead from dying completely while we look for the TLS area... + ;; Prevent the dead from dying completely while we look for the + ;; TLS area... (with-all-threads-lock (if (thread-alive-p thread) - (let* ((offset (* sb!vm:n-word-bytes (sb!vm::symbol-tls-index symbol))) + (let* ((offset (* sb!vm:n-word-bytes + (sb!vm::symbol-tls-index symbol))) (tl-val (sap-ref-word (%thread-sap thread) offset))) (if (eql tl-val sb!vm::no-tls-value-marker-widetag) (go :unbound) - (return-from %symbol-value-in-thread (values (make-lisp-obj tl-val) t)))) + (return-from %symbol-value-in-thread + (values (make-lisp-obj tl-val) t)))) (return-from %symbol-value-in-thread (values nil nil)))) :unbound - (error "Cannot read thread-local symbol value: ~S unbound in ~S" symbol thread))) + (error "Cannot read thread-local symbol value: ~S unbound in ~S" + symbol thread))) (defun %set-symbol-value-in-thread (symbol thread value) (tagbody (with-pinned-objects (value) - ;; Prevent the dead from dying completely while we look for the TLS area... + ;; Prevent the dead from dying completely while we look for + ;; the TLS area... (with-all-threads-lock (if (thread-alive-p thread) - (let* ((offset (* sb!vm:n-word-bytes (sb!vm::symbol-tls-index symbol))) + (let* ((offset (* sb!vm:n-word-bytes + (sb!vm::symbol-tls-index symbol))) (sap (%thread-sap thread)) (tl-val (sap-ref-word sap offset))) (if (eql tl-val sb!vm::no-tls-value-marker-widetag) (go :unbound) - (setf (sap-ref-word sap offset) (get-lisp-obj-address value))) + (setf (sap-ref-word sap offset) + (get-lisp-obj-address value))) (return-from %set-symbol-value-in-thread (values value t))) (return-from %set-symbol-value-in-thread (values nil nil))))) :unbound - (error "Cannot set thread-local symbol value: ~S unbound in ~S" symbol thread)))) + (error "Cannot set thread-local symbol value: ~S unbound in ~S" + symbol thread)))) (defun sb!vm::locked-symbol-global-value-add (symbol-name delta) (sb!vm::locked-symbol-global-value-add symbol-name delta)) + -;;; Stepping +;;;; Stepping (defun thread-stepping () (make-lisp-obj