Allow thread's buffer to be killed, by default

* src/thread.c (Fmake_thread): Add new argument (bug#76969).
(thread_set_error): New function, extracted from thread-signal.
(Fthread_buffer_disposition): Add getter.
(Fthread_set_buffer_disposition): And setter.
(thread_check_current_buffer): Check the values of threads'
buffer_disposition.
(thread_all_before_buffer_killed): New function.
(init_threads): Set buffer_disposition to nil for the main thread.
(syms_of_threads): Add new symbols and define the error.

* src/thread.h (thread_state): New field buffer_disposition.
(thread_all_before_buffer_killed): Declare.

* src/buffer.c (Fkill_buffer): Call thread_check_current_buffer
one more time after all hooks and after that call
thread_all_before_buffer_killed.

* src/comp.c (ABI_VERSION): Increase the value.

* test/src/thread-tests.el (thread-buffer-disposition-t)
(thread-buffer-disposition-nil)
(thread-buffer-disposition-silently)
(thread-set-buffer-disposition)
(thread-set-buffer-disposition-main-thread): New tests.

* doc/lispref/threads.texi (Basic Thread Functions): Document
buffer-disposition in make-thread and its getter and setter.

* etc/NEWS: Add entry.

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.

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
 

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);

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

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

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 */

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 ()