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.
(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
(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)
;;;; 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
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))))
"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
(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)
;; 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
;; 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
,@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*)))))
(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.
(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))
(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)
projects / sbcl.git / blobdiff