X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=402fe683d03cd139b93ae6f3a2b4139da07e0759;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=8948d3d85bcaca2ba3ac892dc89d8dbf190c5050;hpb=fb6f41008e8e7d22008d4b97d9aea364d688d2ae;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 8948d3d..402fe68 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -220,7 +220,7 @@ potentially stale even before the function returns, as the thread may exit at any time." (thread-%alive-p thread)) -(defun thread-emphemeral-p (thread) +(defun thread-ephemeral-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 @@ -1022,7 +1022,7 @@ is initially NIL.") (defun semaphore-notification-status (semaphore-notification) #!+sb-doc "Returns T if a WAIT-ON-SEMAPHORE or TRY-SEMAPHORE using -SEMAPHORE-NOTICATION has succeeded since the notification object was created +SEMAPHORE-NOTIFICATION has succeeded since the notification object was created or cleared." (barrier (:read)) (semaphore-notification-%status semaphore-notification)) @@ -1349,6 +1349,85 @@ have the foreground next." ;;;; The beef +#!+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)) + (*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 @@ -1356,7 +1435,7 @@ list designator provided (defaults to no argument). Thread exits when the function returns. The return values of FUNCTION are kept around and can be retrieved by JOIN-THREAD. -Invoking the initial ABORT restart estabilished by MAKE-THREAD +Invoking the initial ABORT restart established by MAKE-THREAD terminates the thread. See also: RETURN-FROM-THREAD, ABORT-THREAD." @@ -1369,102 +1448,38 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." 'make-thread arguments) #!+sb-thread (let ((thread (%make-thread :name name :%ephemeral-p ephemeral))) - (with-mutex (*make-thread-lock*) - (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 () - ;; 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) - (prog1 - (cons t - (multiple-value-list - (unwind-protect - (catch '%return-from-thread - (apply real-function arguments)) - (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)))) - ;; 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) - (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.")))) + (let* ((setup-sem (make-semaphore :name "Thread setup semaphore")) + (real-function (coerce function 'function)) + (arguments (if (listp arguments) + arguments + (list arguments))) + #!+win32 + (fp-modes (dpb 0 sb!vm::float-sticky-bits ;; clear accrued bits + (sb!vm:floating-point-modes))) + (initial-function + (named-lambda initial-thread-function () + ;; Win32 doesn't inherit parent thread's FP modes, + ;; while it seems to happen everywhere else + #!+win32 + (setf (sb!vm:floating-point-modes) fp-modes) + ;; 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 @@ -1478,7 +1493,7 @@ Trying to join the main thread will cause JOIN-THREAD to block until TIMEOUT occurs or the process exits: when main thread exits, the entire process exits. -NOTE: Return convention in case of a timeout is exprimental and +NOTE: Return convention in case of a timeout is experimental and subject to change." (let ((lock (thread-result-lock thread)) (got-it nil) @@ -1507,6 +1522,12 @@ 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)) @@ -1588,16 +1609,16 @@ With those caveats in mind, what you need to know when using it: given that asynch-unwind-safety does not compose: a function calling only asynch-unwind-safe function isn't automatically asynch-unwind-safe. - This means that in order for an asych unwind to be safe, the entire + This means that in order for an asynch unwind to be safe, the entire callstack at the point of interruption needs to be asynch-unwind-safe. * In addition to asynch-unwind-safety you must consider the issue of - re-entrancy. INTERRUPT-THREAD can cause function that are never normally + reentrancy. INTERRUPT-THREAD can cause function that are never normally called recursively to be re-entered during their dynamic contour, which may cause them to misbehave. (Consider binding of special variables, values of global variables, etc.) -Take togather, these two restrict the \"safe\" things to do using +Take together, these two restrict the \"safe\" things to do using INTERRUPT-THREAD to a fairly minimal set. One useful one -- exclusively for interactive development use is using it to force entry to debugger to inspect the state of a thread: