any time."
(thread-%alive-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
+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 #!-alpha unsigned-long #!+alpha unsigned-int))
+ (os-thread unsigned))
#!+sb-thread
(progn
;; 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 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))
;;;; 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))
+ (*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
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."
- #!-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
- (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 "~@<Abort thread (~A)~@:>" *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)
- (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
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)
"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))
#!+sb-thruption
(defun run-interruption ()
(in-interruption () ;the non-thruption code does this in the signal handler
- (loop
- (let ((interruption (with-interruptions-lock (*current-thread*)
- (pop (thread-interruptions *current-thread*)))))
- (unless interruption
- (return))
- (funcall interruption)))))
+ (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
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:
(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))
projects / sbcl.git / blobdiff