X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftarget-thread.lisp;h=a79774155218aaa0fd2ba4e66e0a8b035429d70b;hb=dacd3fc70cf2fc78677f9a8bbbb5c3b51883f1b7;hp=d5a333158a3dc5dd26591faa19e86a8b93cbf157;hpb=f0da2f63aa0b4e6d4dbf884854a4bf2dfdd01fc0;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index d5a3331..a797741 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -220,6 +220,14 @@ potentially stale even before the function returns, as the thread may exit at any time." (thread-%alive-p thread)) +(defun thread-emphemeral-p (thread) + #!+sb-doc + "Return T if THREAD is `ephemeral', which indicates that this thread is +used by SBCL for internal purposes, and specifically that it knows how to +to terminate this thread cleanly prior to core file saving without signalling +an error in that case." + (thread-%ephemeral-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 ;; all running threads. @@ -339,9 +347,13 @@ See also: RETURN-FROM-THREAD and SB-EXT:EXIT." (define-alien-routine "kill_safely" integer - (os-thread #!-alpha unsigned-long #!+alpha unsigned-int) + (os-thread #!-alpha unsigned #!+alpha unsigned-int) (signal int)) +(define-alien-routine "wake_thread" + integer + (os-thread unsigned)) + #!+sb-thread (progn ;; FIXME it would be good to define what a thread id is or isn't @@ -349,13 +361,13 @@ See also: RETURN-FROM-THREAD and SB-EXT:EXIT." ;; that on Linux it's a pid, but it might not be on posix thread ;; implementations. (define-alien-routine ("create_thread" %create-thread) - unsigned-long (lisp-fun-address unsigned-long)) + unsigned (lisp-fun-address unsigned)) (declaim (inline %block-deferrable-signals)) (define-alien-routine ("block_deferrable_signals" %block-deferrable-signals) void - (where sb!alien:unsigned-long) - (old sb!alien:unsigned-long)) + (where unsigned) + (old unsigned)) (defun block-deferrable-signals () (%block-deferrable-signals 0 0)) @@ -364,16 +376,16 @@ See also: RETURN-FROM-THREAD and SB-EXT:EXIT." (progn (declaim (inline futex-wait %futex-wait futex-wake)) - (define-alien-routine ("futex_wait" %futex-wait) - int (word unsigned-long) (old-value unsigned-long) - (to-sec long) (to-usec unsigned-long)) + (define-alien-routine ("futex_wait" %futex-wait) int + (word unsigned) (old-value unsigned) + (to-sec long) (to-usec unsigned-long)) (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)))) + int (word unsigned) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts #!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap)) @@ -611,9 +623,8 @@ HOLDING-MUTEX-P." (decode-timeout timeout)) (go :again))))))) -(defun get-mutex (mutex &optional new-owner (waitp t) (timeout nil)) - #!+sb-doc - "Deprecated in favor of GRAB-MUTEX." +(define-deprecated-function :early "1.0.37.33" get-mutex (grab-mutex) + (mutex &optional new-owner (waitp t) (timeout nil)) (declare (ignorable waitp timeout)) (let ((new-owner (or new-owner *current-thread*))) (or (%try-mutex mutex new-owner) @@ -1186,12 +1197,7 @@ on this semaphore, then N of them is woken up." (defun handle-thread-exit (thread) (/show0 "HANDLING THREAD EXIT") (when *exit-in-process* - (if (consp *exit-in-process*) - ;; This means we're the main thread, but someone else - ;; requested the exit and exiting with the right code is the - ;; only thing left to do. - (os-exit (car *exit-in-process*) :abort nil) - (%exit))) + (%exit)) ;; Lisp-side cleanup (with-all-threads-lock (setf (thread-%alive-p thread) nil) @@ -1208,10 +1214,11 @@ on this semaphore, then N of them is woken up." (grab-mutex *make-thread-lock*) (let ((timeout sb!ext:*exit-timeout*) (code *exit-in-process*) + (current *current-thread*) (joinees nil) (main nil)) (dolist (thread (list-all-threads)) - (cond ((eq thread *current-thread*)) + (cond ((eq thread current)) ((main-thread-p thread) (setf main thread)) (t @@ -1220,23 +1227,25 @@ on this semaphore, then N of them is woken up." (terminate-thread thread) (push thread joinees)) (interrupt-thread-error ()))))) - (dolist (thread (nreverse joinees)) - (join-thread thread :default t :timeout timeout)) - ;; Need to defer till others have joined, because when main - ;; thread exits, we're gone. Can't use TERMINATE-THREAD -- would - ;; get the exit code wrong. - (when main - (handler-case - (interrupt-thread - main - (lambda () - (setf *exit-in-process* (list code)) - (throw 'sb!impl::%end-of-the-world t))) - (interrupt-thread-error ())) - ;; Normally this never finishes, as once the main-thread - ;; unwinds we exit with the right code, but if times out - ;; before that happens, we will exit after returning. - (join-thread main :default t :timeout timeout))))) + (with-progressive-timeout (time-left :seconds timeout) + (dolist (thread joinees) + (join-thread thread :default t :timeout (time-left))) + ;; Need to defer till others have joined, because when main + ;; thread exits, we're gone. Can't use TERMINATE-THREAD -- would + ;; get the exit code wrong. + (when main + (handler-case + (interrupt-thread + main + (lambda () + (setf *exit-in-process* (list code)) + (throw 'sb!impl::%end-of-the-world t))) + (interrupt-thread-error ())) + ;; Normally this never finishes, as once the main-thread unwinds we + ;; exit with the right code, but if times out before that happens, + ;; we will exit after returning -- or rathe racing the main thread + ;; to calling OS-EXIT. + (join-thread main :default t :timeout (time-left))))))) (defun terminate-session () #!+sb-doc @@ -1340,7 +1349,87 @@ have the foreground next." ;;;; The beef -(defun make-thread (function &key name arguments) +#!+sb-thread +(defun initial-thread-function-trampoline + (thread setup-sem real-function arguments arg1 arg2 arg3) + ;; In time we'll move some of the binding presently done in C here + ;; too. + ;; + ;; KLUDGE: Here we have a magic list of variables that are not + ;; thread-safe for one reason or another. As people report problems + ;; with the thread safety of certain variables, (e.g. "*print-case* in + ;; multiple threads broken", sbcl-devel 2006-07-14), we add a few more + ;; bindings here. The Right Thing is probably some variant 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* (sb!kernel::initial-handler-clusters)) + (*condition-restarts* nil) + (*exit-in-process* nil) + (sb!impl::*deadline* nil) + (sb!impl::*deadline-seconds* nil) + (sb!impl::*step-out* nil) + ;; internal printer variables + (sb!impl::*previous-case* nil) + (sb!impl::*previous-readtable-case* nil) + (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*)) + (with-session-lock (*session*) + (push thread (session-threads *session*))) + (setf (thread-%alive-p thread) t) + (when setup-sem (signal-semaphore setup-sem)) + ;; Using handling-end-of-the-world would be a bit tricky + ;; due to other catches and interrupts, so we essentially + ;; re-implement it here. Once and only once more. + (catch 'sb!impl::toplevel-catcher + (catch 'sb!impl::%end-of-the-world + (catch '%abort-thread + (with-simple-restart + (abort "~@" *current-thread*) + (without-interrupts + (unwind-protect + (with-local-interrupts + (setf *gc-inhibit* nil) ;for foreign callbacks + (sb!unix::unblock-deferrable-signals) + (setf (thread-result thread) + (prog1 + (cons t + (multiple-value-list + (unwind-protect + (catch '%return-from-thread + (if (listp arguments) + (apply real-function arguments) + (funcall real-function arg1 arg2 arg3))) + (when *exit-in-process* + (sb!impl::call-exit-hooks))))) + #!+sb-safepoint + (sb!kernel::gc-safepoint)))) + ;; 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) + #!+sb-thruption + (setq *thruption-pending* nil) + (handle-thread-exit thread))))))))) + (values)) + +(defun make-thread (function &key name arguments ephemeral) #!+sb-doc "Create a new thread of NAME that runs FUNCTION with the argument list designator provided (defaults to no argument). Thread exits when @@ -1351,7 +1440,7 @@ Invoking the initial ABORT restart estabilished by MAKE-THREAD terminates the thread. See also: RETURN-FROM-THREAD, ABORT-THREAD." - #!-sb-thread (declare (ignore function name arguments)) + #!-sb-thread (declare (ignore function name arguments ephemeral)) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (assert (or (atom arguments) (null (cdr (last arguments)))) @@ -1359,103 +1448,32 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." "Argument passed to ~S, ~S, is an improper list." 'make-thread arguments) #!+sb-thread - (tagbody - (with-mutex (*make-thread-lock*) - (let* ((thread (%make-thread :name name)) - (setup-sem (make-semaphore :name "Thread setup semaphore")) - (real-function (coerce function 'function)) - (arguments (if (listp arguments) - arguments - (list arguments))) - (initial-function - (named-lambda initial-thread-function () - ;; In time we'll move some of the binding presently done in C - ;; here too. - ;; - ;; KLUDGE: Here we have a magic list of variables that are - ;; not thread-safe for one reason or another. As people - ;; report problems with the thread safety of certain - ;; variables, (e.g. "*print-case* in multiple threads - ;; broken", sbcl-devel 2006-07-14), we add a few more - ;; bindings here. The Right Thing is probably some variant - ;; 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* (sb!kernel::initial-handler-clusters)) - (*condition-restarts* nil) - (*exit-in-process* nil) - (sb!impl::*deadline* nil) - (sb!impl::*deadline-seconds* nil) - (sb!impl::*step-out* nil) - ;; internal printer variables - (sb!impl::*previous-case* nil) - (sb!impl::*previous-readtable-case* nil) - (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*)) - (with-session-lock (*session*) - (push thread (session-threads *session*))) - (setf (thread-%alive-p thread) t) - (signal-semaphore setup-sem) - ;; Using handling-end-of-the-world would be a bit tricky - ;; due to other catches and interrupts, so we essentially - ;; re-implement it here. Once and only once more. - (catch 'sb!impl::toplevel-catcher - (catch 'sb!impl::%end-of-the-world - (catch '%abort-thread - (with-simple-restart - (abort "~@" *current-thread*) - (without-interrupts - (unwind-protect - (with-local-interrupts - (sb!unix::unblock-deferrable-signals) - (setf (thread-result thread) - (cons t - (multiple-value-list - (unwind-protect - (catch '%return-from-thread - (apply real-function arguments)) - (when *exit-in-process* - (sb!impl::call-exit-hooks))))))) - ;; 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. 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) - (go :cant-spawn)) - (wait-on-semaphore setup-sem) - (return-from make-thread thread)))))) - :cant-spawn - (error "Could not create a new thread."))) + (let ((thread (%make-thread :name name :%ephemeral-p ephemeral))) + (let* ((setup-sem (make-semaphore :name "Thread setup semaphore")) + (real-function (coerce function 'function)) + (arguments (if (listp arguments) + arguments + (list arguments))) + (initial-function + (named-lambda initial-thread-function () + ;; As it is, this lambda must not cons until we are + ;; ready to run GC. Be very careful. + (initial-thread-function-trampoline + thread setup-sem real-function arguments nil nil nil)))) + ;; 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. Wrap the whole thing in + ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to + ;; another thread. + (with-system-mutex (*make-thread-lock*) + (with-pinned-objects (initial-function) + (if (zerop + (%create-thread (get-lisp-obj-address initial-function))) + (setf thread nil) + (wait-on-semaphore setup-sem))))) + (or thread (error "Could not create a new thread.")))) (defun join-thread (thread &key (default nil defaultp) timeout) #!+sb-doc @@ -1498,12 +1516,18 @@ subject to change." "Deprecated. Same as TERMINATE-THREAD." (terminate-thread thread)) +#!+sb-safepoint +(defun enter-foreign-callback (arg1 arg2 arg3) + (initial-thread-function-trampoline + (make-foreign-thread :name "foreign callback") + nil #'sb!alien::enter-alien-callback t arg1 arg2 arg3)) + (defmacro with-interruptions-lock ((thread) &body body) `(with-system-mutex ((thread-interruptions-lock ,thread)) ,@body)) ;;; Called from the signal handler. -#!-win32 +#!-(or sb-thruption win32) (defun run-interruption () (let ((interruption (with-interruptions-lock (*current-thread*) (pop (thread-interruptions *current-thread*))))) @@ -1516,6 +1540,32 @@ subject to change." (when interruption (funcall interruption)))) +#!+sb-thruption +(defun run-interruption () + (in-interruption () ;the non-thruption code does this in the signal handler + (let ((interruption (with-interruptions-lock (*current-thread*) + (pop (thread-interruptions *current-thread*))))) + (when interruption + (funcall interruption) + ;; I tried implementing this function as an explicit LOOP, because + ;; if we are currently processing the thruption queue, why not do + ;; all of them in one go instead of one-by-one? + ;; + ;; I still think LOOPing would be basically the right thing + ;; here. But suppose some interruption unblocked deferrables. + ;; Will the next one be happy with that? The answer is "no", at + ;; least in the sense that there are tests which check that + ;; deferrables are blocked at the beginning of a thruption, and + ;; races that make those tests fail. Whether the tests are + ;; misguided or not, it seems easier/cleaner to loop implicitly + ;; -- and it's also what AK had implemented in the first place. + ;; + ;; The implicit loop is achieved by returning to C, but having C + ;; call back to us immediately. The runtime will reset the sigmask + ;; in the mean time. + ;; -- DFL + (setf *thruption-pending* t))))) + (defun interrupt-thread (thread function) #!+sb-doc "Interrupt THREAD and make it run FUNCTION. @@ -1570,12 +1620,12 @@ the state of a thread: (interrupt-thread thread #'break) Short version: be careful out there." - #!+win32 + #!+(and (not sb-thread) win32) + #!+(and (not sb-thread) win32) (declare (ignore thread)) - #!+win32 (with-interrupt-bindings (with-interrupts (funcall function))) - #!-win32 + #!-(and (not sb-thread) win32) (let ((os-thread (thread-os-thread thread))) (cond ((not os-thread) (error 'interrupt-thread-error :thread thread)) @@ -1590,7 +1640,7 @@ Short version: be careful out there." (without-interrupts (allow-with-interrupts (funcall function)))))))) - (when (minusp (kill-safely os-thread sb!unix:sigpipe)) + (when (minusp (wake-thread os-thread)) (error 'interrupt-thread-error :thread thread)))))) (defun terminate-thread (thread) @@ -1663,20 +1713,19 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD." ;; Prevent the thread from dying completely while we look for the TLS ;; area... (with-all-threads-lock - (loop - (if (thread-alive-p thread) - (let* ((offset (sb!kernel:get-lisp-obj-address - (sb!vm::symbol-tls-index symbol))) - (obj (sap-ref-lispobj (%thread-sap thread) offset)) - (tl-val (sb!kernel:get-lisp-obj-address obj))) - (cond ((zerop offset) - (return (values nil :no-tls-value))) - ((or (eql tl-val sb!vm:no-tls-value-marker-widetag) - (eql tl-val sb!vm:unbound-marker-widetag)) - (return (values nil :unbound-in-thread))) - (t - (return (values obj :ok))))) - (return (values nil :thread-dead)))))) + (if (thread-alive-p thread) + (let* ((offset (sb!kernel:get-lisp-obj-address + (sb!vm::symbol-tls-index symbol))) + (obj (sap-ref-lispobj (%thread-sap thread) offset)) + (tl-val (sb!kernel:get-lisp-obj-address obj))) + (cond ((zerop offset) + (values nil :no-tls-value)) + ((or (eql tl-val sb!vm:no-tls-value-marker-widetag) + (eql tl-val sb!vm:unbound-marker-widetag)) + (values nil :unbound-in-thread)) + (t + (values obj :ok)))) + (values nil :thread-dead)))) (defun %set-symbol-value-in-thread (symbol thread value) (with-pinned-objects (value)