X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=3edfb7d5092f71df77df75dc60197b3718946364;hb=148ae852a476ec673020ecbf99be3bcb4a70eafc;hp=19e293a81bb9270d085285053136a0f062f56fc2;hpb=e20bf696a0722f349744152e3cac2600d3073d03;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 19e293a..3edfb7d 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -11,6 +11,11 @@ (in-package "SB!THREAD") +;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is +;;; necessary because threads are only supported with the conservative +;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS) +;;; are treated as references. + ;;; set the doc here because in early-thread FDOCUMENTATION is not ;;; available, yet #!+sb-doc @@ -22,7 +27,10 @@ "Thread type. Do not rely on threads being structs as it may change in future versions." name - %sap) + %alive-p + os-thread + interruptions + (interruptions-lock (make-mutex :name "thread interruptions lock"))) #!+sb-doc (setf (sb!kernel:fdocumentation 'thread-name 'function) @@ -38,22 +46,10 @@ in future versions." )) thread) -(defun thread-state (thread) - (let ((state - (sb!sys:sap-int - (sb!sys:sap-ref-sap (thread-%sap thread) - (* sb!vm::thread-state-slot - sb!vm::n-word-bytes))))) - (ecase state - (#.(sb!vm:fixnumize 0) :starting) - (#.(sb!vm:fixnumize 1) :running) - (#.(sb!vm:fixnumize 2) :suspended) - (#.(sb!vm:fixnumize 3) :dead)))) - (defun thread-alive-p (thread) #!+sb-doc "Check if THREAD is running." - (not (eq :dead (thread-state thread)))) + (thread-%alive-p thread)) ;; A thread is eligible for gc iff it has finished and there are no ;; more references to it. This list is supposed to keep a reference to @@ -73,12 +69,13 @@ in future versions." (declaim (inline current-thread-sap-id)) (defun current-thread-sap-id () - (sb!sys:sap-int + (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))) (defun init-initial-thread () (let ((initial-thread (%make-thread :name "initial thread" - :%sap (current-thread-sap)))) + :%alive-p t + :os-thread (current-thread-sap-id)))) (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 @@ -89,15 +86,18 @@ in future versions." #!+sb-thread (progn + ;; FIXME it would be good to define what a thread id is or isn't + ;; (our current assumption is that it's a fixnum). It so happens + ;; that on Linux it's a pid, but it might not be on posix thread + ;; implementations. (define-alien-routine ("create_thread" %create-thread) - system-area-pointer - (lisp-fun-address unsigned-long)) + unsigned-long (lisp-fun-address unsigned-long)) - (define-alien-routine "block_blockable_signals" - void) + (define-alien-routine "signal_interrupt_thread" + integer (os-thread unsigned-long)) - (define-alien-routine reap-dead-thread void - (thread-sap system-area-pointer)) + (define-alien-routine "block_blockable_signals" + void) (declaim (inline futex-wait futex-wake)) @@ -112,22 +112,16 @@ in future versions." #!-sb-thread (defun sb!vm::current-thread-offset-sap (n) (declare (type (unsigned-byte 27) n)) - (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) + (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) (* n sb!vm:n-word-bytes))) ;;;; spinlocks -(defstruct spinlock - #!+sb-doc - "Spinlock type." - (name nil :type (or null simple-string)) - (value 0)) - (declaim (inline get-spinlock release-spinlock)) ;;; The bare 2 here and below are offsets of the slots in the struct. ;;; There ought to be some better way to get these numbers -(defun get-spinlock (spinlock new-value) +(defun get-spinlock (spinlock) (declare (optimize (speed 3) (safety 0)) #!-sb-thread (ignore spinlock new-value)) @@ -135,7 +129,7 @@ in future versions." ;; store any value #!+sb-thread (loop until - (eql (sb!vm::%instance-set-conditional spinlock 2 0 new-value) 0))) + (eql (sb!vm::%instance-set-conditional spinlock 2 0 1) 0))) (defun release-spinlock (spinlock) (declare (optimize (speed 3) (safety 0)) @@ -150,19 +144,13 @@ in future versions." (defmacro with-spinlock ((spinlock) &body body) (sb!int:with-unique-names (lock) `(let ((,lock ,spinlock)) - (get-spinlock ,lock *current-thread*) + (get-spinlock ,lock) (unwind-protect (progn ,@body) (release-spinlock ,lock))))) ;;;; mutexes -(defstruct mutex - #!+sb-doc - "Mutex type." - (name nil :type (or null simple-string)) - (value nil)) - #!+sb-doc (setf (sb!kernel:fdocumentation 'make-mutex 'function) "Create a mutex." @@ -181,13 +169,14 @@ in future versions." (+ (sb!kernel:get-lisp-obj-address mutex) (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))) -(defun get-mutex (mutex &optional new-value (wait-p t)) +(defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t)) #!+sb-doc "Acquire MUTEX, setting it to NEW-VALUE or some suitable default value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep until it is available" (declare (type mutex mutex) (optimize (speed 3))) - (unless new-value (setf new-value *current-thread*)) + (unless new-value + (setq new-value *current-thread*)) #!-sb-thread (let ((old-value (mutex-value mutex))) (when (and old-value wait-p) @@ -208,8 +197,9 @@ until it is available" (setf old (sb!vm::%instance-set-conditional mutex 2 nil new-value)) (return t)) (unless wait-p (return nil)) - (futex-wait (mutex-value-address mutex) - (sb!kernel:get-lisp-obj-address old))))) + (with-pinned-objects (mutex old) + (futex-wait (mutex-value-address mutex) + (sb!kernel:get-lisp-obj-address old)))))) (defun release-mutex (mutex) #!+sb-doc @@ -268,8 +258,9 @@ time we reacquire MUTEX and return to the caller." ;; this comment, it will change queue->data, and so ;; futex-wait returns immediately instead of sleeping. ;; Ergo, no lost wakeup - (futex-wait (waitqueue-data-address queue) - (sb!kernel:get-lisp-obj-address me))) + (with-pinned-objects (queue me) + (futex-wait (waitqueue-data-address queue) + (sb!kernel:get-lisp-obj-address me)))) ;; 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 @@ -291,7 +282,8 @@ time we reacquire MUTEX and return to the caller." ;; XXX we should do something to ensure that the result of this setf ;; is visible to all CPUs (setf (waitqueue-data queue) me) - (futex-wake (waitqueue-data-address queue) n))) + (with-pinned-objects (queue) + (futex-wake (waitqueue-data-address queue) n)))) (defun condition-broadcast (queue) #!+sb-doc @@ -354,7 +346,7 @@ this semaphore, then N of them is woken up." #!-sb-thread `(locally ,@body) #!+sb-thread - `(sb!sys:without-interrupts + `(without-interrupts (with-mutex ((session-lock ,session)) ,@body))) @@ -470,16 +462,16 @@ have the foreground next." (labels ((thread-repl () (sb!unix::unix-setsid) (let* ((sb!impl::*stdin* - (sb!sys:make-fd-stream in :input t :buffering :line + (make-fd-stream in :input t :buffering :line :dual-channel-p t)) (sb!impl::*stdout* - (sb!sys:make-fd-stream out :output t :buffering :line + (make-fd-stream out :output t :buffering :line :dual-channel-p t)) (sb!impl::*stderr* - (sb!sys:make-fd-stream err :output t :buffering :line + (make-fd-stream err :output t :buffering :line :dual-channel-p t)) (sb!impl::*tty* - (sb!sys:make-fd-stream err :input t :output t + (make-fd-stream err :input t :output t :buffering :line :dual-channel-p t)) (sb!impl::*descriptor-handlers* nil)) @@ -501,57 +493,59 @@ returns the thread exits." (let* ((thread (%make-thread :name name)) (setup-sem (make-semaphore :name "Thread setup semaphore")) (real-function (coerce function 'function)) - (thread-sap - ;; don't let the child inherit *CURRENT-THREAD* because that - ;; can prevent gc'ing this thread while the child runs - (let ((*current-thread* nil)) - (%create-thread - (sb!kernel:get-lisp-obj-address - (lambda () - ;; in time we'll move some of the binding presently done in C - ;; here too - (let ((*current-thread* thread) - (sb!kernel::*restart-clusters* nil) - (sb!kernel::*handler-clusters* nil) - (sb!kernel::*condition-restarts* nil) - (sb!impl::*descriptor-handlers* nil)) ; serve-event - (wait-on-semaphore setup-sem) - ;; can't use handling-end-of-the-world, because that flushes - ;; output streams, and we don't necessarily have any (or we - ;; could be sharing them) - (unwind-protect - (catch 'sb!impl::toplevel-catcher - (catch 'sb!impl::%end-of-the-world - (with-simple-restart - (terminate-thread - (format nil - "~~@" - *current-thread*)) - ;; 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) - (unwind-protect - (funcall real-function) - ;; we're going down, can't handle - ;; interrupts sanely anymore - (let ((sb!impl::*gc-inhibit* t)) - (block-blockable-signals) - ;; and remove what can be the last - ;; reference to this thread - (handle-thread-exit thread)))))) - 0)) - (values))))))) - (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0)) - (error "Can't create a new thread")) - (setf (thread-%sap thread) thread-sap) - (with-mutex (*all-threads-lock*) - (push thread *all-threads*)) - (with-session-lock (*session*) - (push thread (session-threads *session*))) - (signal-semaphore setup-sem) - (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap))) - thread)) + (initial-function + (lambda () + ;; in time we'll move some of the binding presently done in C + ;; here too + (let ((*current-thread* thread) + (sb!kernel::*restart-clusters* nil) + (sb!kernel::*handler-clusters* nil) + (sb!kernel::*condition-restarts* nil) + (sb!impl::*descriptor-handlers* nil)) ; serve-event + (setf (thread-os-thread thread) (current-thread-sap-id)) + (with-mutex (*all-threads-lock*) + (push thread *all-threads*)) + (with-session-lock (*session*) + (push thread (session-threads *session*))) + (setf (thread-%alive-p thread) t) + (signal-semaphore setup-sem) + ;; can't use handling-end-of-the-world, because that flushes + ;; output streams, and we don't necessarily have any (or we + ;; could be sharing them) + (catch 'sb!impl::toplevel-catcher + (catch 'sb!impl::%end-of-the-world + (with-simple-restart + (terminate-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) + (funcall real-function)) + ;; we're going down, can't handle + ;; interrupts sanely anymore + (let ((sb!impl::*gc-inhibit* t)) + (block-blockable-signals) + (setf (thread-%alive-p thread) nil) + (setf (thread-os-thread thread) nil) + ;; and remove what can be the last + ;; reference to this thread + (handle-thread-exit thread))))))) + (values)))) + ;; Keep INITIAL-FUNCTION pinned until the child thread is + ;; initialized properly. + (with-pinned-objects (initial-function) + (let ((os-thread + (%create-thread + (sb!kernel:get-lisp-obj-address initial-function)))) + (when (zerop os-thread) + (error "Can't create a new thread")) + (wait-on-semaphore setup-sem) + thread)))) (defun destroy-thread (thread) #!+sb-doc @@ -559,26 +553,41 @@ returns the thread exits." (terminate-thread thread)) (define-condition interrupt-thread-error (error) - ((thread :reader interrupt-thread-error-thread :initarg :thread) - (errno :reader interrupt-thread-error-errno :initarg :errno)) + ((thread :reader interrupt-thread-error-thread :initarg :thread)) #!+sb-doc (:documentation "Interrupting thread failed.") (:report (lambda (c s) - (format s "interrupt thread ~A failed (~A: ~A)" - (interrupt-thread-error-thread c) - (interrupt-thread-error-errno c) - (strerror (interrupt-thread-error-errno c)))))) + (format s "Interrupt thread failed: thread ~A has exited." + (interrupt-thread-error-thread c))))) #!+sb-doc (setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function) - "The thread that was not interrupted." - (sb!kernel:fdocumentation 'interrupt-thread-error-errno 'function) - "The reason why the interruption failed.") - + "The thread that was not interrupted.") + +(defmacro with-interruptions-lock ((thread) &body body) + `(without-interrupts + (with-mutex ((thread-interruptions-lock ,thread)) + ,@body))) + +;; Called from the signal handler. +(defun run-interruption () + (in-interruption () + (let ((interruption (with-interruptions-lock (*current-thread*) + (pop (thread-interruptions *current-thread*))))) + (with-interrupts + (funcall interruption))))) + +;; 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 -degree of care is expected for use of interrupt-thread, due to its +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." @@ -590,18 +599,14 @@ won't like the effect." #!+sb-thread (if (eq thread *current-thread*) (funcall function) - (let ((function (coerce function 'function))) - (multiple-value-bind (res err) - ;; protect against gcing just when the ub32 address is - ;; just ready to be passed to C - (sb!sys::with-pinned-objects (function) - (sb!unix::syscall ("interrupt_thread" - system-area-pointer sb!alien:unsigned-long) - thread - (thread-%sap thread) - (sb!kernel:get-lisp-obj-address function))) - (unless res - (error 'interrupt-thread-error :thread thread :errno err)))))) + (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))))))) (defun terminate-thread (thread) #!+sb-doc @@ -614,11 +619,23 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" ;;; with an SBCL developer first, or are doing something that you ;;; should probably discuss with a professional psychiatrist first #!+sb-thread -(defun symbol-value-in-thread (symbol thread) - (let ((thread-sap (thread-%sap thread))) - (let* ((index (sb!vm::symbol-tls-index symbol)) - (tl-val (sb!sys: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) - (sb!kernel:make-lisp-obj tl-val))))) +(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) + (sb!kernel:make-lisp-obj tl-val))))