Subject: Re: bug#76969: kill-buffer fails silently when a thread exists where it's current

From: Dmitry Gutov <[email-masked]>
Date: Fri, 1 Aug 2025 03:01:11 +0300

On 31/07/2025 08:24, Eli Zaretskii wrote:
>> Okay. Do I just copy the argument's description twice? Alternatively,
>> could add references to 'make-thread'.
> Either of these is fine.
> 
>>> Also, these two new primitives should be documented in the ELisp
>>> manual.
>> Are they important enough for the manual? Since 'make-thread' gets the
>> new argument, I'd imagine most users would go through it, or at least
>> learn about "thread disposition" due to that.
> It just takes a sentence or two (and index entries) to mention these.
> You don't have to use the full-fledged @defun thingy.
> 
>> If you're sure, no problem - it's just the section that I'm looking at
>> is called "Basic Thread Functions".
> Right after make-thread, IMO.

Great, updated.

Also added main_thread_p check in thread-set-buffer-disposition.

diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi
index 3d9ebf08073..b458ad8ae36 100644
--- a/doc/lispref/threads.texi
+++ b/doc/lispref/threads.texi
@@ -55,7 +55,7 @@ Basic Thread Functions
 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,22 @@ Basic Thread Functions
 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}, it's not
+allowed.  Any other value, including 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/src/buffer.c b/src/buffer.c
index a465153279d..e44b6daf587 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -2050,6 +2050,13 @@ DEFUN ("kill-buffer", Fkill_buffer, Skill_buffer, 0, 1, "bKill buffer: ",
 	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/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 @@ DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
 #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 @@ DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
   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..320a3e31df4 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -143,6 +143,9 @@ #define lisp_eval_depth (current_thread->m_lisp_eval_depth)
   struct buffer *m_current_buffer;
 #define current_buffer (current_thread->m_current_buffer)
 
+  /* Decides whether the thread's current buffer can be killed.  */
+  Lisp_Object buffer_disposition;
+
   /* Every call to re_search, etc., must pass &search_regs as the regs
      argument unless you can show it is unnecessary (i.e., if re_search
      is certainly going to be called again before region-around-match
@@ -338,6 +341,8 @@ XCONDVAR (Lisp_Object a)
 
 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 @@ threads-test-bug33073
   (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 ()