X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=736c27e9787180b2c1944058eb0af23149e28a83;hb=9373c1691aee82e4e21379b85400c3ea363adf47;hp=995847e245f8a4a1370251189a7d969756df9d10;hpb=fe962ba01d267b92f638c8f0d19be41054219f04;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 995847e..736c27e 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -39,14 +39,24 @@ in future versions." "The name of the thread. Setfable.") (def!method print-object ((thread thread) stream) - (if (thread-name thread) - (print-unreadable-object (thread stream :type t :identity t) - (prin1 (thread-name thread) stream)) - (print-unreadable-object (thread stream :type t :identity t) - ;; body is empty => there is only one space between type and - ;; identity - )) - thread) + (print-unreadable-object (thread stream :type t :identity t) + (let* ((cookie (list thread)) + (info (if (thread-alive-p thread) + :running + (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~^, ~}~]~]" + (thread-name thread) + (eq :finished state) + state + values)))) (defun thread-alive-p (thread) #!+sb-doc @@ -59,13 +69,11 @@ in future versions." (defvar *all-threads* ()) (defvar *all-threads-lock* (make-mutex :name "all threads lock")) +(defvar *default-alloc-signal* nil) + (defmacro with-all-threads-lock (&body body) - #!-sb-thread - `(locally ,@body) - #!+sb-thread - `(without-interrupts - (with-mutex (*all-threads-lock*) - ,@body))) + `(with-system-mutex (*all-threads-lock*) + ,@body)) (defun list-all-threads () #!+sb-doc @@ -77,23 +85,31 @@ in future versions." (defun current-thread-sap () (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot)) -(declaim (inline current-thread-sap-id)) -(defun current-thread-sap-id () - (sap-int - (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))) +(declaim (inline current-thread-os-thread)) +(defun current-thread-os-thread () + #!+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") (let ((initial-thread (%make-thread :name "initial thread" :%alive-p t - :os-thread (current-thread-sap-id)))) + :os-thread (current-thread-os-thread)))) (setq *current-thread* initial-thread) ;; Either *all-threads* is empty or it contains exactly one thread ;; 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 + +(define-alien-routine "kill_safely" + integer + (os-thread #!-alpha unsigned-long #!+alpha unsigned-int) + (signal int)) #!+sb-thread (progn @@ -104,9 +120,6 @@ 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)) - (define-alien-routine "block_deferrable_signals" void) @@ -115,25 +128,25 @@ in future versions." (declaim (inline %lutex-init %lutex-wait %lutex-wake %lutex-lock %lutex-unlock)) - (sb!alien:define-alien-routine ("lutex_init" %lutex-init) + (define-alien-routine ("lutex_init" %lutex-init) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_wait" %lutex-wait) + (define-alien-routine ("lutex_wait" %lutex-wait) int (queue-lutex unsigned-long) (mutex-lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_wake" %lutex-wake) + (define-alien-routine ("lutex_wake" %lutex-wake) int (lutex unsigned-long) (n int)) - (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock) + (define-alien-routine ("lutex_lock" %lutex-lock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock) + (define-alien-routine ("lutex_trylock" %lutex-trylock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock) + (define-alien-routine ("lutex_unlock" %lutex-unlock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy) + (define-alien-routine ("lutex_destroy" %lutex-destroy) int (lutex unsigned-long)) ;; FIXME: Defining a whole bunch of alien-type machinery just for @@ -160,13 +173,17 @@ in future versions." #!-sb-lutex (progn - (declaim (inline futex-wait futex-wake)) + (declaim (inline futex-wait %futex-wait futex-wake)) - (sb!alien:define-alien-routine "futex_wait" + (define-alien-routine ("futex_wait" %futex-wait) int (word unsigned-long) (old-value unsigned-long) (to-sec long) (to-usec unsigned-long)) - (sb!alien:define-alien-routine "futex_wake" + (defun futex-wait (word old to-sec to-usec) + (with-interrupts + (%futex-wait word old to-sec to-usec))) + + (define-alien-routine "futex_wake" int (word unsigned-long) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts @@ -181,121 +198,217 @@ 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 -#!+sb-thread -(define-structure-slot-compare-and-swap - compare-and-swap-spinlock-value - :structure spinlock - :slot value) +;;;; Spinlocks (declaim (inline get-spinlock release-spinlock)) +;;; Should always be called with interrupts disabled. (defun get-spinlock (spinlock) - (declare (optimize (speed 3) (safety 0)) - #!-sb-thread - (ignore spinlock)) - ;; %instance-set-conditional can test for 0 (which is a fixnum) and - ;; store any value - #!+sb-thread - (loop until - (eql 0 (compare-and-swap-spinlock-value spinlock 0 1))) - t) + (declare (optimize (speed 3) (safety 0))) + (let* ((new *current-thread*) + (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new))) + (when old + (when (eq old new) + (error "Recursive lock attempt on ~S." spinlock)) + #!+sb-thread + (flet ((cas () + (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 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)) - #!-sb-thread (ignore spinlock)) - ;; %instance-set-conditional cannot compare arbitrary objects - ;; meaningfully, so (compare-and-swap-spinlock-value our-value 0) - ;; does not work for bignum thread ids. - #!+sb-thread - (setf (spinlock-value spinlock) 0) - nil) - -;;;; mutexes + (declare (optimize (speed 3) (safety 0))) + ;; 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) "Create a mutex." (fdocumentation 'mutex-name 'function) - "The name of the mutex. Setfable." - (fdocumentation 'mutex-value 'function) - "The value of the mutex. NIL if the mutex is free. Setfable.") + "The name of the mutex. Setfable.") #!+(and sb-thread (not sb-lutex)) (progn - (define-structure-slot-addressor mutex-value-address - :structure mutex - :slot value) - (define-structure-slot-compare-and-swap - compare-and-swap-mutex-value + (define-structure-slot-addressor mutex-state-address :structure mutex - :slot value)) - -(defun get-mutex (mutex &optional (new-value *current-thread*) (waitp t)) + :slot state) + ;; Important: current code assumes these are fixnums or other + ;; lisp objects that don't need pinning. + (defconstant +lock-free+ 0) + (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, setting it to NEW-VALUE or some suitable default -value if NIL. If WAITP is non-NIL and the mutex is in use, sleep -until it is available." - (declare (type mutex mutex) (optimize (speed 3))) - (/show0 "Entering GET-MUTEX") - (unless new-value - (setq new-value *current-thread*)) + "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If +NEW-OWNER is NIL, it defaults to the current thread. If WAITP is +non-NIL and the mutex is in use, sleep until it is available. + +Note: using GET-MUTEX to assign a MUTEX to another thread then the +current one is not recommended, and liable to be deprecated. + +GET-MUTEX is not interrupt safe. The correct way to call it is: + + (WITHOUT-INTERRUPTS + ... + (ALLOW-WITH-INTERRUPTS (GET-MUTEX ...)) + ...) + +WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding the +call while the mutex is in an inconsistent state while +ALLOW-WITH-INTERRUPTS allows the call to be interrupted from sleep. + +It is recommended that you use WITH-MUTEX instead of calling GET-MUTEX +directly." + (declare (type mutex mutex) (optimize (speed 3)) + #!-sb-thread (ignore waitp)) + (unless new-owner + (setq new-owner *current-thread*)) + (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 - (let ((old (mutex-value mutex))) - (when (and old waitp) - (error "In unithread mode, mutex ~S was requested with WAITP ~S and ~ - new-value ~S, but has already been acquired (with value ~S)." - mutex waitp new-value old)) - (setf (mutex-value mutex) new-value) - t) + (setf (mutex-%owner mutex) new-owner) #!+sb-thread - (when (eql new-value (mutex-value mutex)) - (warn "recursive lock attempt ~S~%" mutex) - (format *debug-io* "Thread: ~A~%" *current-thread*) - (sb!debug:backtrace most-positive-fixnum *debug-io*) - (force-output *debug-io*)) - ;; FIXME: Lutexes do not currently support deadlines, as at least - ;; on Darwin pthread_foo_timedbar functions are not supported: - ;; this means that we probably need to use the Carbon multiprocessing - ;; functions on Darwin. - #!+sb-lutex - (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) - (if waitp - (%lutex-lock lutex) - (%lutex-trylock lutex)))) - (setf (mutex-value mutex) new-value)) - #!-sb-lutex - (let (old) - (when (and (setf old (compare-and-exchange-mutex-value mutex nil new-value)) - waitp) - (loop while old - do (multiple-value-bind (to-sec to-usec) (decode-timeout nil) - (when (= 1 (with-pinned-objects (mutex old) - (futex-wait (mutex-value-address mutex) - (get-lisp-obj-address old) - (or to-sec -1) - (or to-usec 0)))) - (signal-deadline))) - (setf old (compare-and-exchange-mutex-value mutex nil new-value)))) - (not old))) + (progn + ;; FIXME: Lutexes do not currently support deadlines, as at least + ;; on Darwin pthread_foo_timedbar functions are not supported: + ;; this means that we probably need to use the Carbon multiprocessing + ;; functions on Darwin. + ;; + ;; FIXME: This is definitely not interrupt safe: what happens if + ;; we get hit (1) during the lutex calls (ok, they may be safe, + ;; but has that been checked?) (2) after the lutex call, but + ;; before setting the mutex owner. + #!+sb-lutex + (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) + (if waitp + (with-interrupts (%lutex-lock lutex)) + (%lutex-trylock lutex)))) + (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+))) + (unless (or (eql +lock-free+ old) (not waitp)) + (tagbody + :retry + (when (or (eql +lock-contested+ old) + (not (eql +lock-free+ + (sb!ext:compare-and-swap (mutex-state mutex) + +lock-taken+ + +lock-contested+)))) + ;; Wait on the contested lock. + (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+)) + ;; Did we get it? + (unless (eql +lock-free+ old) + (go :retry)))) + (cond ((eql +lock-free+ old) + (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex) + nil new-owner))) + (when prev + (bug "Old owner in free mutex: ~S" prev)) + t)) + (waitp + (bug "Failed to acquire lock with WAITP.")))))) (defun release-mutex (mutex) #!+sb-doc "Release MUTEX by setting it to NIL. Wake up threads waiting for -this mutex." +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." (declare (type mutex mutex)) - (/show0 "Entering RELEASE-MUTEX") - (setf (mutex-value mutex) nil) + ;; 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 - (futex-wake (mutex-value-address mutex) 1))) - -;;;; waitqueues/condition variables + ;; 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 (defstruct (waitqueue (:constructor %make-waitqueue)) #!+sb-doc @@ -329,44 +442,65 @@ time we reacquire MUTEX and return to the caller." (assert mutex) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread - (let ((value (mutex-value mutex))) + (let ((me *current-thread*)) + (assert (eq me (mutex-%owner mutex))) (/show0 "CONDITION-WAITing") #!+sb-lutex - (progn - (setf (mutex-value 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-value mutex) value)) + ;; 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*)) - ;; XXX we should 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) + ;; Need to disable interrupts so that we don't miss grabbing the + ;; mutex on our way out. + (without-interrupts + (unwind-protect + (let ((me nil)) + ;; 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) + (allow-with-interrupts (futex-wait (waitqueue-data-address queue) (get-lisp-obj-address me) - (or to-sec -1) ;; our way if saying "no timeout" + ;; 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 value)))) + ((1) (signal-deadline)) + ((2)) + ;; EWOULDBLOCK, -1 here, is the possible spurious + ;; wakeup case. 0 is the normal wakeup. + (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))))) (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 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.") #!+sb-thread @@ -393,50 +527,77 @@ 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)) +(defstruct (semaphore (:constructor %make-semaphore (name %count))) #!+sb-doc - "Semaphore type." + "Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT +should be considered an implementation detail, and may change in the +future." (name nil :type (or null simple-string)) - (count 0 :type (integer 0)) + (%count 0 :type (integer 0)) + (waitcount 0 :type (integer 0)) (mutex (make-mutex)) (queue (make-waitqueue))) +(setf (fdocumentation 'semaphore-name 'function) + "The name of the semaphore INSTANCE. Setfable.") + +(declaim (inline semaphore-count)) +(defun semaphore-count (instance) + "Returns the current count of the semaphore INSTANCE." + (semaphore-%count instance)) + (defun make-semaphore (&key name (count 0)) #!+sb-doc - "Create a semaphore with the supplied COUNT." - (%make-semaphore :name name :count count)) + "Create a semaphore with the supplied COUNT and NAME." + (%make-semaphore name count)) -(setf (fdocumentation 'semaphore-name 'function) - "The name of the semaphore. Setfable.") - -(defun wait-on-semaphore (sem) +(defun wait-on-semaphore (semaphore) #!+sb-doc - "Decrement the count of SEM if the count would not be negative. Else -block until the semaphore can be decremented." - ;; a more direct implementation based directly on futexes should be - ;; possible - (with-mutex ((semaphore-mutex sem)) - (loop until (> (semaphore-count sem) 0) - do (condition-wait (semaphore-queue sem) (semaphore-mutex sem)) - finally (decf (semaphore-count sem))))) - -(defun signal-semaphore (sem &optional (n 1)) + "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. + ;; + ;; 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 SEM by N. If there are threads waiting on -this semaphore, then N of them is woken up." - (declare (type (and fixnum (integer 1)) n)) - (with-mutex ((semaphore-mutex sem)) - (when (= n (incf (semaphore-count sem) n)) - (condition-notify (semaphore-queue sem) n)))) - -;;;; job control, independent listeners + "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)) + ;; 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 (defstruct session (lock (make-mutex :name "session lock")) @@ -446,17 +607,21 @@ this semaphore, then N of them is woken up." (defvar *session* nil) -;;; the debugger itself tries to acquire the session lock, don't let +;;; The debugger itself tries to acquire the session lock, don't let ;;; funny situations (like getting a sigint while holding the session -;;; lock) occur +;;; 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. +;;; +;;; 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. (defmacro with-session-lock ((session) &body body) - #!-sb-thread (declare (ignore session)) - #!-sb-thread - `(locally ,@body) - #!+sb-thread - `(without-interrupts - (with-mutex ((session-lock ,session)) - ,@body))) + `(with-system-mutex ((session-lock ,session) :allow-with-interrupts t) + ,@body)) (defun new-session () (make-session :threads (list *current-thread*) @@ -489,9 +654,6 @@ 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) @@ -603,8 +765,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 @@ -631,19 +794,26 @@ 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 - (let ((*current-thread* thread) - (*restart-clusters* nil) - (*handler-clusters* nil) - (*condition-restarts* nil) - (sb!impl::*step-out* nil) - ;; internal printer variables - (sb!impl::*previous-case* nil) - (sb!impl::*previous-readtable-case* nil) - (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small! - (sb!impl::*zap-array-data-temp* (vector)) ; - (sb!impl::*internal-symbol-output-fun* nil) - (sb!impl::*descriptor-handlers* nil)) ; serve-event - (setf (thread-os-thread thread) (current-thread-sap-id)) + ;; + ;; 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)) + (*condition-restarts* nil) + (sb!impl::*deadline* nil) + (sb!impl::*step-out* nil) + ;; internal printer variables + (sb!impl::*previous-case* nil) + (sb!impl::*previous-readtable-case* nil) + (empty (vector)) + (sb!impl::*merge-sort-temp-vector* empty) + (sb!impl::*zap-array-data-temp* empty) + (sb!impl::*internal-symbol-output-fun* nil) + (sb!impl::*descriptor-handlers* nil)) ; serve-event + ;; Binding from C + (setf sb!vm:*alloc-signal* *default-alloc-signal*) + (setf (thread-os-thread thread) (current-thread-os-thread)) (with-mutex ((thread-result-lock thread)) (with-all-threads-lock (push thread *all-threads*)) @@ -661,28 +831,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)) @@ -702,13 +894,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 @@ -728,51 +920,57 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." "The thread that was not interrupted.") (defmacro with-interruptions-lock ((thread) &body body) - `(without-interrupts - (with-mutex ((thread-interruptions-lock ,thread)) - ,@body))) + `(with-system-mutex ((thread-interruptions-lock ,thread)) + ,@body)) -;; Called from the signal handler. +;;; 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)) - ;; not quite perfect, because it does not take WITHOUT-INTERRUPTS - ;; into account - #!-sb-thread - (funcall function) - #!+sb-thread - (if (eq thread *current-thread*) - (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))))))) +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))) + #!-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 @@ -780,36 +978,75 @@ won't like the effect." SB-EXT:QUIT - the usual cleanup forms will be evaluated" (interrupt-thread thread 'sb!ext:quit)) -;;; internal use only. If you think you need to use this, either you +(define-alien-routine "thread_yield" int) + +#!+sb-doc +(setf (fdocumentation 'thread-yield 'function) + "Yield the processor to other threads.") + +;;; internal use only. If you think you need to use these, either you ;;; are an SBCL developer, are doing something that you should discuss ;;; with an SBCL developer first, or are doing something that you ;;; should probably discuss with a professional psychiatrist first #!+sb-thread -(defun thread-sap-for-id (id) - (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t))))) - (loop - (when (sap= thread-sap (int-sap 0)) (return nil)) - (let ((os-thread (sap-ref-word thread-sap - (* sb!vm:n-word-bytes - sb!vm::thread-os-thread-slot)))) - (when (= os-thread id) (return thread-sap)) - (setf thread-sap - (sap-ref-sap thread-sap (* sb!vm:n-word-bytes - sb!vm::thread-next-slot))))))) - -#!+sb-thread -(defun symbol-value-in-thread (symbol thread-sap) - (let* ((index (sb!vm::symbol-tls-index symbol)) - (tl-val (sap-ref-word thread-sap - (* sb!vm:n-word-bytes index)))) - (if (eql tl-val sb!vm::no-tls-value-marker-widetag) - (sb!vm::symbol-global-value symbol) - (make-lisp-obj tl-val)))) +(progn + (defun %thread-sap (thread) + (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t)))) + (target (thread-os-thread thread))) + (loop + (when (sap= thread-sap (int-sap 0)) (return nil)) + (let ((os-thread (sap-ref-word thread-sap + (* sb!vm:n-word-bytes + sb!vm::thread-os-thread-slot)))) + (when (= os-thread target) (return thread-sap)) + (setf thread-sap + (sap-ref-sap thread-sap (* sb!vm:n-word-bytes + sb!vm::thread-next-slot))))))) + + (defun %symbol-value-in-thread (symbol thread) + (tagbody + ;; 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))) + (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 nil nil)))) + :unbound + (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... + (with-all-threads-lock + (if (thread-alive-p thread) + (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))) + (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)))) (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