X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=63e282d96f8d433135af6774ebee6bc6090a7032;hb=862c0325616a991a5bd7b50d79f7176d2115493b;hp=67ef209c7ab662ec63836ed3f47e6e9e712f48e2;hpb=ad3beba970fab6e451a461c9f9b14faf4ef17718;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 67ef209..63e282d 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -40,27 +40,16 @@ in future versions." (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))))) + (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." @@ -104,6 +93,9 @@ in future versions." system-area-pointer (lisp-fun-address unsigned-long)) + (define-alien-routine "block_blockable_signals" + void) + (define-alien-routine reap-dead-thread void (thread-sap system-area-pointer)) @@ -130,7 +122,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. @@ -418,13 +410,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 @@ -474,46 +467,47 @@ returns the thread exits." (setup-p nil) (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 - (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)))))) + ;; 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 () + ;; 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 + ;; 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) @@ -560,15 +554,20 @@ 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 ((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)))))) (defun terminate-thread (thread) #!+sb-doc @@ -586,6 +585,6 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (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) + (if (eql tl-val sb!vm::no-tls-value-marker-widetag) (sb!vm::symbol-global-value symbol) (sb!kernel:make-lisp-obj tl-val)))))