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.
(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
;; 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))
(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))
(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)
(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)
(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
(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
;;;; 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 "~@<Abort thread (~A)~@:>" *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
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
(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 "~@<Abort thread (~A)~@:>" *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))))
+ (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*))
;; 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
"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*)))))
(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)
;; 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)
projects / sbcl.git / blobdiff