[Emacs-diffs] master 54b9213: Handle thread-signal towards the main thread (Bug#32502)

[Michael Albinus]

branch: master
commit 54b92132e1ec16565d59d6d9f8ff8910f38843b2
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>

    Handle thread-signal towards the main thread  (Bug#32502)
    
    * doc/lispref/threads.texi (Basic Thread Functions):
    * etc/NEWS: Document thread-signal towards the main thread.
    
    * lisp/emacs-lisp/thread.el: New package.
    
    * src/keyboard.c (read_char): Check for Qthread_event.
    (kbd_buffer_get_event, make_lispy_event): Handle THREAD_EVENT.
    (syms_of_keyboard): Declare Qthread_event.
    (keys_of_keyboard): Add thread-handle-event to special-event-map.
    
    * src/termhooks.h (enum event_kind): Add THREAD_EVENT.
    
    * src/thread.c: Include "keyboard.h".
    (poll_suppress_count) Don't declare extern.
    (Fthread_signal): Raise event if THREAD is the main thread.  (Bug#32502)
    
    * test/src/thread-tests.el (thread): Require it.
    (threads-signal-main-thread): New test.
---
 doc/lispref/threads.texi  | 10 ++--------
 etc/NEWS                  |  4 ++++
 lisp/emacs-lisp/thread.el | 42 ++++++++++++++++++++++++++++++++++++++++++
 src/keyboard.c            | 27 +++++++++++++++++++++++++--
 src/termhooks.h           |  4 ++++
 src/thread.c              | 33 +++++++++++++++++++++++++--------
 test/src/thread-tests.el  | 21 +++++++++++++++++++++
 7 files changed, 123 insertions(+), 18 deletions(-)

diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi
index 58a3a91..9830198 100644
--- a/doc/lispref/threads.texi
+++ b/doc/lispref/threads.texi
@@ -88,14 +88,8 @@ If @var{thread} was blocked by a call to @code{mutex-lock},
 @code{condition-wait}, or @code{thread-join}; @code{thread-signal}
 will unblock it.
 
-Since signal handlers in Emacs are located in the main thread, a
-signal must be propagated there in order to become visible.  The
-second @code{signal} call let the thread die:
-
address@hidden
-(thread-signal main-thread 'error data)
-(signal 'error data)
address@hidden example
+If @var{thread} is the main thread, the signal is not propagated
+there.  Instead, it is shown as message in the main thread.
 @end defun
 
 @defun thread-yield
diff --git a/etc/NEWS b/etc/NEWS
index 8a774d8..d536faa 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -726,6 +726,10 @@ to signal the main thread, e.g., when they encounter an 
error.
 +++
 *** 'thread-join' returns the result of the finished thread now.
 
++++
+*** 'thread-signal' does not propagate errors to the main thread.
+Instead, error messages are just printed in the main thread.
+
 ---
 ** thingatpt.el supports a new "thing" called 'uuid'.
 A symbol 'uuid' can be passed to thing-at-point and it returns the
diff --git a/lisp/emacs-lisp/thread.el b/lisp/emacs-lisp/thread.el
new file mode 100644
index 0000000..02cf9b9
--- /dev/null
+++ b/lisp/emacs-lisp/thread.el
@@ -0,0 +1,42 @@
+;;; thread.el --- List active threads in a buffer -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell <address@hidden>
+;; Maintainer: address@hidden
+;; Keywords: lisp, tools, maint
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+;;;###autoload
+(defun thread-handle-event (event)
+  "Handle thread events, propagated by `thread-signal'.
+An EVENT has the format
+  (thread-event THREAD ERROR-SYMBOL DATA)"
+  (interactive "e")
+  (if (and (consp event)
+           (eq (car event) 'thread-event)
+          (= (length event) 4))
+      (let ((thread (cadr event))
+            (err (cddr event)))
+        (message "Error %s: %S" thread err))))
+
+(provide 'thread)
+;;; thread.el ends here
diff --git a/src/keyboard.c b/src/keyboard.c
index 7fafb41..008d3b9 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -2828,6 +2828,9 @@ read_char (int commandflag, Lisp_Object map,
 #ifdef USE_FILE_NOTIFY
              || EQ (XCAR (c), Qfile_notify)
 #endif
+#ifdef THREADS_ENABLED
+             || EQ (XCAR (c), Qthread_event)
+#endif
              || EQ (XCAR (c), Qconfig_changed_event))
           && !end_time)
        /* We stopped being idle for this event; undo that.  This
@@ -3739,7 +3742,7 @@ kbd_buffer_get_event (KBOARD **kbp,
     }
 #endif /* subprocesses */
 
-#if !defined HAVE_DBUS && !defined USE_FILE_NOTIFY
+#if !defined HAVE_DBUS && !defined USE_FILE_NOTIFY && !defined THREADS_ENABLED
   if (noninteractive
       /* In case we are running as a daemon, only do this before
         detaching from the terminal.  */
@@ -3750,7 +3753,7 @@ kbd_buffer_get_event (KBOARD **kbp,
       *kbp = current_kboard;
       return obj;
     }
-#endif /* !defined HAVE_DBUS && !defined USE_FILE_NOTIFY  */
+#endif /* !defined HAVE_DBUS && !defined USE_FILE_NOTIFY && !defined 
THREADS_ENABLED  */
 
   /* Wait until there is input available.  */
   for (;;)
@@ -3900,6 +3903,9 @@ kbd_buffer_get_event (KBOARD **kbp,
 #ifdef HAVE_DBUS
       case DBUS_EVENT:
 #endif
+#ifdef THREADS_ENABLED
+      case THREAD_EVENT:
+#endif
 #ifdef HAVE_XWIDGETS
       case XWIDGET_EVENT:
 #endif
@@ -5983,6 +5989,13 @@ make_lispy_event (struct input_event *event)
       }
 #endif /* HAVE_DBUS */
 
+#ifdef THREADS_ENABLED
+    case THREAD_EVENT:
+      {
+       return Fcons (Qthread_event, event->arg);
+      }
+#endif /* THREADS_ENABLED */
+
 #ifdef HAVE_XWIDGETS
     case XWIDGET_EVENT:
       {
@@ -11078,6 +11091,10 @@ syms_of_keyboard (void)
   DEFSYM (Qdbus_event, "dbus-event");
 #endif
 
+#ifdef THREADS_ENABLED
+  DEFSYM (Qthread_event, "thread-event");
+#endif
+
 #ifdef HAVE_XWIDGETS
   DEFSYM (Qxwidget_event, "xwidget-event");
 #endif
@@ -11929,6 +11946,12 @@ keys_of_keyboard (void)
                            "dbus-handle-event");
 #endif
 
+#ifdef THREADS_ENABLED
+  /* Define a special event which is raised for thread signals.  */
+  initial_define_lispy_key (Vspecial_event_map, "thread-event",
+                           "thread-handle-event");
+#endif
+
 #ifdef USE_FILE_NOTIFY
   /* Define a special event which is raised for notification callback
      functions.  */
diff --git a/src/termhooks.h b/src/termhooks.h
index 160bd2f..8b5f648 100644
--- a/src/termhooks.h
+++ b/src/termhooks.h
@@ -222,6 +222,10 @@ enum event_kind
   , DBUS_EVENT
 #endif
 
+#ifdef THREADS_ENABLED
+  , THREAD_EVENT
+#endif
+
   , CONFIG_CHANGED_EVENT
 
 #ifdef HAVE_NTGUI
diff --git a/src/thread.c b/src/thread.c
index 1c73d93..78cb216 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -25,6 +25,7 @@ along with GNU Emacs.  If not, see 
<https://www.gnu.org/licenses/>.  */
 #include "process.h"
 #include "coding.h"
 #include "syssignal.h"
+#include "keyboard.h"
 
 static struct thread_state main_thread;
 
@@ -34,7 +35,6 @@ static struct thread_state *all_threads = &main_thread;
 
 static sys_mutex_t global_lock;
 
-extern int poll_suppress_count;
 extern volatile int interrupt_input_blocked;
 
 
@@ -863,7 +863,8 @@ DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 
3, 0,
 This acts like `signal', but arranges for the signal to be raised
 in THREAD.  If THREAD is the current thread, acts just like `signal'.
 This will interrupt a blocked call to `mutex-lock', `condition-wait',
-or `thread-join' in the target thread.  */)
+or `thread-join' in the target thread.
+If THREAD is the main thread, just the error message is shown.  */)
   (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
 {
   struct thread_state *tstate;
@@ -874,13 +875,29 @@ or `thread-join' in the target thread.  */)
   if (tstate == current_thread)
     Fsignal (error_symbol, data);
 
-  /* What to do if thread is already signaled?  */
-  /* What if error_symbol is Qnil?  */
-  tstate->error_symbol = error_symbol;
-  tstate->error_data = data;
+  if (main_thread_p (tstate))
+    {
+      /* Construct an event.  */
+      struct input_event event;
+      EVENT_INIT (event);
+      event.kind = THREAD_EVENT;
+      event.frame_or_window = Qnil;
+      event.arg = list3 (Fcurrent_thread (), error_symbol, data);
+
+      /* Store it into the input event queue.  */
+      kbd_buffer_store_event (&event);
+    }
+
+  else
+    {
+      /* What to do if thread is already signaled?  */
+      /* What if error_symbol is Qnil?  */
+      tstate->error_symbol = error_symbol;
+      tstate->error_data = data;
 
-  if (tstate->wait_condvar)
-    flush_stack_call_func (thread_signal_callback, tstate);
+      if (tstate->wait_condvar)
+       flush_stack_call_func (thread_signal_callback, tstate);
+    }
 
   return Qnil;
 }
diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el
index 364f6d6..cc1dff8 100644
--- a/test/src/thread-tests.el
+++ b/test/src/thread-tests.el
@@ -19,6 +19,8 @@
 
 ;;; Code:
 
+(require 'thread)
+
 ;; Declare the functions in case Emacs has been configured --without-threads.
 (declare-function all-threads "thread.c" ())
 (declare-function condition-mutex "thread.c" (cond))
@@ -320,6 +322,25 @@
     (should-not (thread-alive-p thread))
     (should (equal (thread-last-error) '(error)))))
 
+(ert-deftest threads-signal-main-thread ()
+  "Test signaling the main thread."
+  (skip-unless (featurep 'threads))
+  ;; We cannot use `ert-with-message-capture', because threads do not
+  ;; know let-bound variables.
+  (with-current-buffer "*Messages*"
+    (let (buffer-read-only)
+      (erase-buffer))
+    (let ((thread
+           (make-thread #'(lambda () (thread-signal main-thread 'error nil)))))
+      (while (thread-alive-p thread)
+        (thread-yield))
+      (read-event nil nil 0.1)
+      ;; No error has been raised, which is part of the test.
+      (should
+       (string-match
+        (format-message "Error %s: (error nil)" thread)
+        (buffer-string ))))))
+
 (defvar threads-condvar nil)
 
 (defun threads-test-condvar-wait ()