X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=18832b4b6923658e19b0d72c04df60565b31c5f5;hb=64d420902d31cb87ea752f09b314e4767816a9c9;hp=67ef209c7ab662ec63836ed3f47e6e9e712f48e2;hpb=ad3beba970fab6e451a461c9f9b14faf4ef17718;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 67ef209..18832b4 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -22,7 +22,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,33 +41,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 %set-thread-state (thread state) - (setf (sb!sys:sap-ref-sap (thread-%sap thread) - (* sb!vm::thread-state-slot - sb!vm::n-word-bytes)) - (sb!sys:int-sap - (ecase state - (:starting #.(sb!vm:fixnumize 0)) - (:running #.(sb!vm:fixnumize 1)) - (:suspended #.(sb!vm:fixnumize 2)) - (:dead #.(sb!vm:fixnumize 3)))))) - (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 @@ -84,12 +64,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 @@ -100,12 +81,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 "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)) @@ -120,7 +107,7 @@ 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 @@ -130,7 +117,7 @@ in future versions." "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. @@ -284,12 +271,14 @@ time we reacquire MUTEX and return to the caller." ;; better than nothing. (get-mutex mutex value)))) -(defun condition-notify (queue) +(defun condition-notify (queue &optional (n 1)) #!+sb-doc - "Notify one of the threads waiting on QUEUE." - #!-sb-thread (declare (ignore queue)) + "Notify N threads waiting on QUEUE." + #!-sb-thread (declare (ignore queue n)) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread + (declare (type (and fixnum (integer 1)) n)) + #!+sb-thread (let ((me *current-thread*)) ;; no problem if >1 thread notifies during the comment in ;; condition-wait: as long as the value in queue-data isn't the @@ -297,17 +286,50 @@ 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) 1))) + (futex-wake (waitqueue-data-address queue) n))) (defun condition-broadcast (queue) #!+sb-doc "Notify all threads waiting on QUEUE." - #!-sb-thread (declare (ignore queue)) - #!-sb-thread (error "Not supported in unithread builds.") - #!+sb-thread - (let ((me *current-thread*)) - (setf (waitqueue-data queue) me) - (futex-wake (waitqueue-data-address queue) (ash 1 30)))) + (condition-notify queue most-positive-fixnum)) + +;;;; semaphores + +(defstruct (semaphore (:constructor %make-semaphore)) + #!+sb-doc + "Semaphore type." + (name nil :type (or null simple-string)) + (count 0 :type (integer 0)) + (mutex (make-mutex)) + (queue (make-waitqueue))) + +(defun make-semaphore (&key name (count 0)) + #!+sb-doc + "Create a semaphore with the supplied COUNT." + (%make-semaphore :name name :count count)) + +(setf (sb!kernel:fdocumentation 'semaphore-name 'function) + "The name of the semaphore. Setfable.") + +(defun wait-on-semaphore (sem) + #!+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)) + #!+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 @@ -327,7 +349,7 @@ time we reacquire MUTEX and return to the caller." #!-sb-thread `(locally ,@body) #!+sb-thread - `(sb!sys:without-interrupts + `(without-interrupts (with-mutex ((session-lock ,session)) ,@body))) @@ -418,13 +440,14 @@ interactive." (defun release-foreground (&optional next) #!+sb-doc "Background this thread. If NEXT is supplied, arrange for it to -have the foreground next" +have the foreground next." #!-sb-thread (declare (ignore next)) #!-sb-thread nil #!+sb-thread (with-session-lock (*session*) - (setf (session-interactive-threads *session*) - (delete *current-thread* (session-interactive-threads *session*))) + (when (rest (session-interactive-threads *session*)) + (setf (session-interactive-threads *session*) + (delete *current-thread* (session-interactive-threads *session*)))) (when next (setf (session-interactive-threads *session*) (list* next @@ -442,16 +465,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)) @@ -471,59 +494,62 @@ returns the thread exits." #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (let* ((thread (%make-thread :name name)) - (setup-p nil) + (setup-sem (make-semaphore :name "Thread setup semaphore")) (real-function (coerce function 'function)) - (thread-sap - (%create-thread - (sb!kernel:get-lisp-obj-address - (lambda () - ;; FIXME: use semaphores? - (loop until setup-p) - ;; 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 - (sb!impl::*available-buffers* nil)) ;for fd-stream - ;; 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 + (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) - (unwind-protect - (funcall real-function) - ;; we're going down, can't handle - ;; interrupts sanely anymore - (sb!unix::block-blockable-signals))))) - ;; mark the thread dead, so that the gc does not - ;; wait for it to handle sig-stop-for-gc - (%set-thread-state thread :dead) - ;; and remove what can be the last reference to - ;; the thread object - (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*))) - (setq setup-p t) - (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap))) - thread)) + (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)))) + (with-pinned-objects (initial-function) + (let ((os-thread + ;; 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 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 @@ -531,26 +557,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." @@ -560,15 +601,16 @@ won't like the effect." #!-sb-thread (funcall function) #!+sb-thread - (let ((function (coerce function 'function))) - (multiple-value-bind (res err) - (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))))) + (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))))))) (defun terminate-thread (thread) #!+sb-doc @@ -581,11 +623,24 @@ 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::unbound-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)))) + (print os-thread) + (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))))