>From 6e9c04f4cd6b45aec319dad9e3dea4b9ec034c6b Mon Sep 17 00:00:00 2001
From: dickmao <none>
Date: Thu, 10 Jun 2021 16:19:16 -0400
Subject: [PATCH] Lift a 2012 "process locked to thread" restriction

Remove an unexplained error that forbade a thread from
accepting output from a process it didn't start.

* src/process.c (Faccept_process_output): remove the error
(wait_reading_process_output): remove eassert to the same effect
* test/src/thread-tests.el (threads-test-channel): add
(threads-test-channel-send): add
(threads-test-channel-recv): add
(threads-signal-early): add
(threads-test-bug33073): add
(threads-test-bug36609-signal): add
(threads-test-glib-lock): add
(threads-test-promiscuous-process): add
---
 src/process.c            |  29 +---------
 test/src/thread-tests.el | 112 ++++++++++++++++++++++++++++++++++++++-
 2 files changed, 112 insertions(+), 29 deletions(-)

diff --git a/src/process.c b/src/process.c
index c354f3a90d..df6c8e38a6 100644
--- a/src/process.c
+++ b/src/process.c
@@ -4728,27 +4728,6 @@ DEFUN ("accept-process-output", Faccept_process_output, Saccept_process_output,
   intmax_t secs;
   int nsecs;
 
-  if (! NILP (process))
-    {
-      CHECK_PROCESS (process);
-      struct Lisp_Process *proc = XPROCESS (process);
-
-      /* Can't wait for a process that is dedicated to a different
-	 thread.  */
-      if (!NILP (proc->thread) && !EQ (proc->thread, Fcurrent_thread ()))
-	{
-	  Lisp_Object proc_thread_name = XTHREAD (proc->thread)->name;
-
-	  error ("Attempt to accept output from process %s locked to thread %s",
-		 SDATA (proc->name),
-		 STRINGP (proc_thread_name)
-		 ? SDATA (proc_thread_name)
-		 : SDATA (Fprin1_to_string (proc->thread, Qt)));
-	}
-    }
-  else
-    just_this_one = Qnil;
-
   if (!NILP (millisec))
     { /* Obsolete calling convention using integers rather than floats.  */
       CHECK_FIXNUM (millisec);
@@ -4786,14 +4765,14 @@ DEFUN ("accept-process-output", Faccept_process_output, Saccept_process_output,
       else
 	wrong_type_argument (Qnumberp, seconds);
     }
-  else if (! NILP (process))
+  else if (!NILP (process))
     nsecs = 0;
 
   return
     ((wait_reading_process_output (secs, nsecs, 0, 0,
 				   Qnil,
 				   !NILP (process) ? XPROCESS (process) : NULL,
-				   (NILP (just_this_one) ? 0
+				   ((NILP (process) || NILP (just_this_one)) ? 0
 				    : !FIXNUMP (just_this_one) ? 1 : -1))
       <= 0)
      ? Qnil : Qt);
@@ -5156,10 +5135,6 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
   /* Close to the current time if known, an invalid timespec otherwise.  */
   struct timespec now = invalid_timespec ();
 
-  eassert (wait_proc == NULL
-	   || NILP (wait_proc->thread)
-	   || XTHREAD (wait_proc->thread) == current_thread);
-
   FD_ZERO (&Available);
   FD_ZERO (&Writeok);
 
diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el
index fc7bc7441b..6bafdb1d29 100644
--- a/test/src/thread-tests.el
+++ b/test/src/thread-tests.el
@@ -20,6 +20,8 @@
 ;;; Code:
 
 (require 'thread)
+(require 'eieio)
+(require 'ring)
 
 ;; Declare the functions in case Emacs has been configured --without-threads.
 (declare-function all-threads "thread.c" ())
@@ -42,6 +44,26 @@
 (declare-function thread-yield "thread.c" ())
 (defvar main-thread)
 
+(defclass threads-test-channel ()
+  ((condition :initarg :condition :type condition-variable)
+   (msg-queue :initarg :msg-queue :type ring)))
+
+(cl-defgeneric threads-test-channel-send ((channel threads-test-channel) message)
+  (with-slots (condition msg-queue) channel
+    (with-mutex (condition-mutex condition)
+      (while (<= (ring-size msg-queue) (ring-length msg-queue))
+        (condition-wait condition))
+      (ring-insert msg-queue message)
+      (condition-notify condition t))))
+
+(cl-defgeneric threads-test-channel-recv ((channel threads-test-channel))
+  (with-slots (condition msg-queue) channel
+    (with-mutex (condition-mutex condition)
+      (while (ring-empty-p msg-queue)
+        (condition-wait condition))
+      (prog1 (ring-remove msg-queue)
+        (condition-notify condition t)))))
+
 (ert-deftest threads-is-one ()
   "Test for existence of a thread."
   (skip-unless (featurep 'threads))
@@ -318,7 +340,7 @@ threads-signal-early
          (make-thread (lambda ()
                         (while t (thread-yield))))))
     (thread-signal thread 'error nil)
-    (sit-for 1)
+    (funcall (if noninteractive #'sit-for #'sleep-for) 1)
     (should-not (thread-live-p thread))
     (should (equal (thread-last-error) '(error)))))
 
@@ -389,7 +411,93 @@ threads-condvar-wait
     (should (equal (thread-last-error) '(error "Die, die, die!")))))
 
 (ert-deftest threads-test-bug33073 ()
+  (skip-unless (featurep 'threads))
   (let ((th (make-thread 'ignore)))
     (should-not (equal th main-thread))))
 
-;;; threads.el ends here
+(ert-deftest threads-test-bug36609-signal ()
+  "Would only fail under TEST_INTERACTIVE=yes, and not every time.
+The failure manifests only by being unable to exit the interactive emacs."
+  (skip-unless (featurep 'threads))
+  (let* ((cv (make-condition-variable (make-mutex) "CV"))
+       condition
+       (notify (lambda ()
+                 (sleep-for 1) ;; let wait() start spinning first
+                 (with-mutex (condition-mutex cv)
+                   (setq condition t)
+                   (condition-notify cv))))
+       (wait (lambda () (with-mutex (condition-mutex cv)
+                          (while (not condition)
+                            (condition-wait cv)))))
+       (herring (make-thread (apply-partially #'sleep-for 1000) "unrelated")))
+    ;; herring is a non-main thread that, if the bug is still present,
+    ;; could assume the glib context lock when the main thread executes wait()
+    (make-thread notify "notify")
+    (funcall wait)
+    (thread-signal herring 'quit nil)))
+
+(ert-deftest threads-test-glib-lock ()
+  "Would only fail under TEST_INTERACTIVE=yes, and not every time.
+The failure manifests only by being unable to exit the interactive emacs."
+  (skip-unless (featurep 'threads))
+  (cl-macrolet ((run-thread
+                 (name what)
+                 `(make-thread
+                   (lambda ()
+                     (sleep-for (1+ (random 3)))
+                     (funcall ,what))
+                   ,name)))
+    (let* ((n 3)
+           (capacity 1)
+           (channel (make-instance
+                     'threads-test-channel
+                     :condition (make-condition-variable (make-mutex) "channel")
+                     :msg-queue (make-ring capacity))))
+      (dotimes (i n)
+        (let ((send-name (format "send-%d" (1+ i)))
+	      (recv-name (format "recv-%d" (- n i))))
+          (run-thread send-name
+		      (lambda () (threads-test-channel-send channel 42)))
+          (run-thread recv-name
+		      (lambda () (threads-test-channel-recv channel))))))))
+
+(ert-deftest threads-test-promiscuous-process ()
+  "Can't we `accept-process-output' of a process started by another thread?
+For whatever reason, in 2012, tromey inserted an assertion forbidding this.
+We test flouting that edict here."
+  (skip-unless (featurep 'threads))
+  (thread-last-error t)
+  (let* ((thread-tests-main (get-buffer-create "thread-tests-main" t))
+         (buffers (list thread-tests-main))
+         (start-proc (lambda (n b)
+                       (apply #'start-process n b "cat" (split-string "/dev/urandom"))))
+         (n 3))
+    (funcall start-proc "threads-tests-main" (car buffers))
+    (dotimes (i (1- n))
+      (push (get-buffer-create (format "thread-tests-%d" i) t) buffers)
+      (make-thread (apply-partially start-proc
+                                    (format "thread-tests-%d" i)
+                                    (car buffers))))
+    (let ((procs (mapcar #'get-buffer-process buffers)))
+      (dotimes (i (1- n))
+        (make-thread
+         (lambda ()
+           (cl-loop repeat 5
+                    do (accept-process-output
+                        (nth (random (length procs)) procs)
+                        0.2
+                        nil
+                        t)))
+         (format "thread-tests-%d" i)))
+      (should (cl-loop repeat 20
+                       unless (cl-some
+                               (lambda (thr)
+                                 (cl-search "thread-tests-" (thread-name thr)))
+                               (all-threads))
+                       return t
+                       do (accept-process-output
+                           (nth (random (length procs)) procs) 1.0)
+                       finally return nil)))
+    (mapc (lambda (b) (kill-buffer b)) buffers))
+  (should-not (thread-last-error t)))
+;;; thread-tests.el ends here
-- 
2.26.2