diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi index 3d9ebf08073..db6d0cf4d26 100644 --- a/doc/lispref/threads.texi +++ b/doc/lispref/threads.texi @@ -55,7 +55,7 @@ closure are shared by any threads invoking the closure. directly, but the current thread can be exited implicitly, and other threads can be signaled. -@defun make-thread function &optional name +@defun make-thread function &optional name buffer-disposition Create a new thread of execution which invokes @var{function}. When @var{function} returns, the thread exits. @@ -66,9 +66,23 @@ The new thread's current buffer is inherited from the current thread. used for debugging and informational purposes only; it has no meaning to Emacs. If @var{name} is provided, it must be a string. +@var{buffer-disposition} indicates what happens if the thread's current +buffer is about to be killed. If the value is @code{t}, killing the +buffer is not allowed. Any other value, including @code{nil} (which is +the default), means that the buffer is killed and the thread is assigned +another current buffer, and it's signaled the error +@code{thread-buffer-killed}. But if the value is the symbol +@code{silently}, the error is not signaled. + This function returns the new thread. @end defun +@findex thread-buffer-disposition +@findex thread-set-buffer-disposition +After a thread had been created, you can inspect or change its +buffer-disposition using functions @code{thread-buffer-disposition} and +@code{thread-set-buffer-disposition}. + @defun threadp object This function returns @code{t} if @var{object} represents an Emacs thread, @code{nil} otherwise. diff --git a/etc/NEWS b/etc/NEWS index d6bf37f3eb5..b29a3985b93 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2682,6 +2682,13 @@ by default and controlled by this variable; it can be set to non-nil to keep the old behavior. This change is to accomodate screen readers. ++++ +** A thread's current buffer can now be killed. +We introduce a new attribute for threads called buffer-disposition. +See the new argument in 'make-thread'. The default value allows the +thread's current buffer to be killed by another thread. This does not +apply to the main thread's buffer. + * Lisp Changes in Emacs 31.1 diff --git a/src/buffer.c b/src/buffer.c index a465153279d..e44b6daf587 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -2050,6 +2050,13 @@ cleaning up all windows currently displaying the buffer to be killed. */) return Qnil; } + /* Check all threads again, in case a hook changed something. */ + if (thread_check_current_buffer (b)) + return Qnil; + + /* Clean up references to the buffer in threads. */ + thread_all_before_buffer_killed (buffer); + /* If the buffer now current is shown in the minibuffer and our buffer is the sole other buffer give up. */ XSETBUFFER (tem, current_buffer); diff --git a/src/comp.c b/src/comp.c index bd5e637afe3..1e06f83dcbd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -468,7 +468,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "10" +#define ABI_VERSION "11" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 diff --git a/src/thread.c b/src/thread.c index 8fd713d0c81..3d29f6c591a 100644 --- a/src/thread.c +++ b/src/thread.c @@ -882,11 +882,18 @@ finalize_one_thread (struct thread_state *state) free_bc_thread (&state->bc); } -DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0, +DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 3, 0, doc: /* Start a new thread and run FUNCTION in it. When the function exits, the thread dies. -If NAME is given, it must be a string; it names the new thread. */) - (Lisp_Object function, Lisp_Object name) +If NAME is given, it must be a string; it names the new thread. + +BUFFER-DISPOSITION determines how attached the thread is to its current +buffer. If the value is t, that buffer can't be killed. Any other +value, including nil (the default), means that if its buffer is killed, +the thread is switched to another buffer and receives an error signal +`thread-buffer-killed'. But if the value is symbol `silently', no error +will be signaled. */) + (Lisp_Object function, Lisp_Object name, Lisp_Object buffer_disposition) { /* Can't start a thread in temacs. */ if (!initialized) @@ -934,6 +941,8 @@ If NAME is given, it must be a string; it names the new thread. */) #endif } + new_thread->buffer_disposition = buffer_disposition; + /* FIXME: race here where new thread might not be filled in? */ Lisp_Object result; XSETTHREAD (result, new_thread); @@ -972,6 +981,15 @@ thread_signal_callback (void *arg) post_acquire_global_lock (self); } +static void +thread_set_error (struct thread_state *tstate, Lisp_Object error_symbol, Lisp_Object data) +{ + /* What to do if thread is already signaled? */ + /* What if error_symbol is Qnil? */ + tstate->error_symbol = error_symbol; + tstate->error_data = data; +} + DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0, doc: /* Signal an error in a thread. This acts like `signal', but arranges for the signal to be raised @@ -1006,10 +1024,7 @@ If THREAD is the main thread, just the error message is shown. */) else #endif { - /* What to do if thread is already signaled? */ - /* What if error_symbol is Qnil? */ - tstate->error_symbol = error_symbol; - tstate->error_data = data; + thread_set_error (tstate, error_symbol, data); if (tstate->wait_condvar) flush_stack_call_func (thread_signal_callback, tstate); @@ -1030,6 +1045,41 @@ DEFUN ("thread-live-p", Fthread_live_p, Sthread_live_p, 1, 1, 0, return thread_live_p (tstate) ? Qt : Qnil; } +DEFUN ("thread-buffer-disposition", Fthread_buffer_disposition, Sthread_buffer_disposition, + 1, 1, 0, + doc: /* Return the value of THREAD's buffer disposition. +See `make-thread' for the description of possible values. */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + return tstate->buffer_disposition; +} + +DEFUN ("thread-set-buffer-disposition", Fthread_set_buffer_disposition, Sthread_set_buffer_disposition, + 2, 2, 0, + doc: /* Set THREAD's buffer disposition. +See `make-thread' for the description of possible values. + +Buffer disposition of the main thread cannot be modified. */) + (Lisp_Object thread, Lisp_Object value) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + if (main_thread_p (tstate)) + CHECK_TYPE (NILP (value), Qnull, value); + + tstate->buffer_disposition = value; + + return value; +} + DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0, doc: /* Return the object that THREAD is blocking on. If THREAD is blocked in `thread-join' on a second thread, return that @@ -1139,13 +1189,43 @@ thread_check_current_buffer (struct buffer *buffer) if (iter == current_thread) continue; - if (iter->m_current_buffer == buffer) + if (iter->m_current_buffer == buffer && EQ (iter->buffer_disposition, Qt)) return true; } return false; } +void +thread_all_before_buffer_killed (Lisp_Object current) +{ + struct thread_state *iter; + struct buffer * other = NULL; + struct buffer * b = XBUFFER (current); + struct thread_state *caller_thread = current_thread; + + for (iter = all_threads; iter; iter = iter->next_thread) + { + if (iter == caller_thread) + continue; + + if (iter->m_current_buffer == b) + { + Lisp_Object thread; + + XSETTHREAD (thread, iter); + + if (other == NULL) + other = XBUFFER (Fother_buffer (current, Qnil, Qnil)); + + if (!EQ (iter->buffer_disposition, Qsilently)) + thread_set_error (iter, Qthread_buffer_killed, Qnil); + + iter->m_current_buffer = other; + } + } +} + bool @@ -1174,6 +1254,7 @@ init_threads (void) #endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */ main_thread.s.thread_id = sys_thread_self (); + main_thread.s.buffer_disposition = Qnil; init_bc_thread (&main_thread.s.bc); } @@ -1203,6 +1284,8 @@ syms_of_threads (void) defsubr (&Scondition_mutex); defsubr (&Scondition_name); defsubr (&Sthread_last_error); + defsubr (&Sthread_buffer_disposition); + defsubr (&Sthread_set_buffer_disposition); staticpro (&last_thread_error); last_thread_error = Qnil; @@ -1214,6 +1297,13 @@ syms_of_threads (void) DEFSYM (Qmutexp, "mutexp"); DEFSYM (Qcondition_variable_p, "condition-variable-p"); + DEFSYM (Qthread_buffer_killed, "thread-buffer-killed"); + Fput (Qthread_buffer_killed, Qerror_conditions, + list (Qthread_buffer_killed, Qerror)); + Fput (Qthread_buffer_killed, Qerror_message, + build_string ("Thread's current buffer killed")); + DEFSYM (Qsilently, "silently"); + DEFVAR_LISP ("main-thread", Vmain_thread, doc: /* The main thread of Emacs. */); #ifdef THREADS_ENABLED diff --git a/src/thread.h b/src/thread.h index c496453b090..5a7f82319c9 100644 --- a/src/thread.h +++ b/src/thread.h @@ -85,6 +85,9 @@ struct thread_state Lisp_Object error_symbol; Lisp_Object error_data; + /* Decides whether the thread's current buffer can be killed. */ + Lisp_Object buffer_disposition; + /* If we are waiting for some event, this holds the object we are waiting on. */ Lisp_Object event_object; @@ -338,6 +341,8 @@ int thread_select (select_func *func, int max_fds, fd_set *rfds, bool thread_check_current_buffer (struct buffer *); +void thread_all_before_buffer_killed (Lisp_Object buffer); + INLINE_HEADER_END #endif /* THREAD_H */ diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index 9a065187b5e..0b9e8f96c09 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -398,6 +398,70 @@ (let ((th (make-thread 'ignore))) (should-not (equal th main-thread)))) +(ert-deftest thread-buffer-disposition-t () + "Test not being able to kill a bg thread's buffer." + (skip-unless (featurep 'threads)) + (let ((buf (get-buffer-create " *thread-buffer-killable-nil*")) + thread) + (with-current-buffer buf + (setq thread + (make-thread + (lambda () + (sleep-for 0.1)) + nil + t))) + (kill-buffer buf) + (should (buffer-live-p buf)) + ;; No error: + (thread-join thread))) + +(ert-deftest thread-buffer-disposition-nil () + "Test killing a bg thread's buffer." + (skip-unless (featurep 'threads)) + (let ((buf (get-buffer-create " *thread-buffer-killable-t*")) + thread) + (with-current-buffer buf + (setq thread + (make-thread + (lambda () + (sleep-for 0.1))))) + (kill-buffer buf) + (should-not (buffer-live-p buf)) + (should-error + (thread-join thread) + :type 'thread-buffer-killed))) + +(ert-deftest thread-buffer-disposition-silently () + "Test killing a bg thread's buffer silently." + (skip-unless (featurep 'threads)) + (let ((buf (get-buffer-create " *thread-buffer-killable-t*")) + thread) + (with-current-buffer buf + (setq thread + (make-thread + (lambda () + (sleep-for 0.1)) + nil + 'silently))) + (kill-buffer buf) + (should-not (buffer-live-p buf)) + (thread-join thread))) + +(ert-deftest thread-set-buffer-disposition () + "Test being able to modify a thread's buffer disposition." + (skip-unless (featurep 'threads)) + (let ((thread (make-thread #'ignore))) + (should (eq (thread-buffer-disposition thread) nil)) + (thread-set-buffer-disposition thread t) + (should (eq (thread-buffer-disposition thread) t)))) + +(ert-deftest thread-set-buffer-disposition-main-thread () + "Test not being able to modify main thread's buffer disposition." + (skip-unless (featurep 'threads)) + (should (null (thread-buffer-disposition main-thread))) + (should-error (thread-set-buffer-disposition main-thread t) + :type 'wrong-type-argument)) + (defvar threads-test--var 'global) (ert-deftest threads-test-bug48990 ()