X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=773fe9c9d38c74325b31918eb0c0113ec6a9b3bf;hb=c712f88b26cd7547ee984b90e18c134401335bc3;hp=82ce8270531d37a351f272450aa351eeb3f77f9f;hpb=90eeb9ca5bff9292afafe82a6d2139964e24f691;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 82ce827..773fe9c 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. @@ -342,6 +350,10 @@ See also: RETURN-FROM-THREAD and SB-EXT:EXIT." (os-thread #!-alpha unsigned-long #!+alpha unsigned-int) (signal int)) +(define-alien-routine "wake_thread" + integer + (os-thread #!-alpha unsigned-long #!+alpha unsigned-int)) + #!+sb-thread (progn ;; FIXME it would be good to define what a thread id is or isn't @@ -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) @@ -1338,7 +1349,7 @@ have the foreground next." ;;;; The beef -(defun make-thread (function &key name arguments) +(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 @@ -1349,7 +1360,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)))) @@ -1357,10 +1368,9 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." "Argument passed to ~S, ~S, is an improper list." 'make-thread arguments) #!+sb-thread - (tagbody + (let ((thread (%make-thread :name name :%ephemeral-p ephemeral))) (with-mutex (*make-thread-lock*) - (let* ((thread (%make-thread :name name)) - (setup-sem (make-semaphore :name "Thread setup semaphore")) + (let* ((setup-sem (make-semaphore :name "Thread setup semaphore")) (real-function (coerce function 'function)) (arguments (if (listp arguments) arguments @@ -1418,13 +1428,16 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." (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))))))) + (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) @@ -1434,6 +1447,8 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." ;; 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 @@ -1445,15 +1460,11 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." ;; 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."))) + (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 @@ -1501,7 +1512,7 @@ subject to change." ,@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*))))) @@ -1514,6 +1525,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. @@ -1568,12 +1605,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)) @@ -1588,7 +1625,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)