From f94d55d0cbc5eabf0f8cd951141b61fc99df69b5 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 6 Nov 2024 11:01:37 +1100
Subject: [PATCH] csighandler3: forward signals to the main thread if not a
 perl thread

This is only done for pthreads, Win32 already uses something like
my suggestion from #22530 and unlike POSIX doesn't have a way to
asynchronously interrupt a thread that I'm aware of.  It's also
complicated by pseudo-processes.

Fixes #22487
---
 MANIFEST                  |  1 +
 ext/XS-APItest/APItest.pm |  2 +-
 ext/XS-APItest/APItest.xs | 12 ++++++++++++
 ext/XS-APItest/t/thread.t | 17 +++++++++++++++++
 makedef.pl                |  4 ++++
 mg.c                      | 11 +++++++++++
 perl.c                    |  1 +
 perlvars.h                | 14 ++++++++++++++
 thread.h                  |  4 ++++
 win32/win32thread.h       |  2 ++
 10 files changed, 67 insertions(+), 1 deletion(-)
 create mode 100644 ext/XS-APItest/t/thread.t

diff --git a/MANIFEST b/MANIFEST
index cc59d64bbd2d..edc0d6e5bbb7 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5190,6 +5190,7 @@ ext/XS-APItest/t/swaptwostmts.t			test recursive descent statement parsing
 ext/XS-APItest/t/sym-hook.t			Test rv2cv hooks for bareword lookup
 ext/XS-APItest/t/synthetic_scope.t		Test block_start/block_end/intro_my
 ext/XS-APItest/t/temp_lv_sub.t			XS::APItest: tests for lvalue subs returning temps
+ext/XS-APItest/t/thread.t			Threads related tests
 ext/XS-APItest/t/underscore_length.t		Test find_rundefsv()
 ext/XS-APItest/t/utf16_to_utf8.t		Test behaviour of utf16_to_utf8{,reversed}
 ext/XS-APItest/t/utf8.t				Tests for code in utf8.c
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index d782d91f9ef2..05df69ef8c78 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.38';
+our $VERSION = '1.39';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 1676ded76c8d..6dcc02e8dbe7 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -4298,6 +4298,18 @@ CODE:
     exit(0);
 }
 
+#  ifndef WIN32
+
+bool
+thread_id_matches()
+CODE:
+    /* pthread_t might not be a scalar type */
+    RETVAL = pthread_equal(pthread_self(), PL_main_thread);
+OUTPUT:
+    RETVAL
+
+#  endif /* ifndef WIN32 */
+
 #endif /* USE_ITHREADS */
 
 SV*
diff --git a/ext/XS-APItest/t/thread.t b/ext/XS-APItest/t/thread.t
new file mode 100644
index 000000000000..fe5ac953ba34
--- /dev/null
+++ b/ext/XS-APItest/t/thread.t
@@ -0,0 +1,17 @@
+#!perl
+use warnings;
+use strict;
+use Test2::Tools::Basic;
+use Config;
+
+BEGIN {
+    skip_all "Not pthreads or is win32"
+      if !$Config{usethreads} || $^O eq "MSWin32";
+}
+
+use XS::APItest qw(thread_id_matches);
+
+ok(thread_id_matches(),
+   "check main thread id saved and is current thread");
+
+done_testing();
diff --git a/makedef.pl b/makedef.pl
index 3b6931508c50..538595086373 100644
--- a/makedef.pl
+++ b/makedef.pl
@@ -461,6 +461,10 @@ sub readvar {
     ++$skip{Perl_thread_locale_term};
 }
 
+if (!$define{USE_ITHREADS} || $define{WIN32}) {
+    ++$skip{PL_main_thread};
+}
+
 unless ($define{USE_POSIX_2008_LOCALE})
 {
     ++$skip{$_} foreach qw(
diff --git a/mg.c b/mg.c
index d972781ff1fe..ac90c81983ba 100644
--- a/mg.c
+++ b/mg.c
@@ -1564,6 +1564,17 @@ Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSE
     dTHX;
 #endif
 
+#if defined(USE_ITHREADS) && !defined(WIN32)
+    if (!aTHX) {
+        /* presumably ths signal is being delivered to a non-perl
+         * thread, presumably created by a library, redirect it to the
+         * main thread.
+         */
+        pthread_kill(PL_main_thread, sig);
+        return;
+    }
+#endif
+
 #ifdef PERL_USE_3ARG_SIGHANDLER
 #if defined(__cplusplus) && defined(__GNUC__)
     /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
diff --git a/perl.c b/perl.c
index 15127adc50fe..c10e10b495e5 100644
--- a/perl.c
+++ b/perl.c
@@ -90,6 +90,7 @@ S_init_tls_and_interp(PerlInterpreter *my_perl)
         ENV_INIT;
         MUTEX_INIT(&PL_dollarzero_mutex);
         MUTEX_INIT(&PL_my_ctx_mutex);
+        PTHREAD_INIT_SELF(PL_main_thread);
 #  endif
     }
 #if defined(USE_ITHREADS)
diff --git a/perlvars.h b/perlvars.h
index b5d70d926cf4..8d71b11760cd 100644
--- a/perlvars.h
+++ b/perlvars.h
@@ -43,6 +43,20 @@ PERLVARI(G, curinterp,	PerlInterpreter *, NULL)
                                          * useithreads) */
 #if defined(USE_ITHREADS)
 PERLVAR(G, thr_key,	perl_key)	/* key to retrieve per-thread struct */
+
+#  ifndef WIN32
+/* Used to re-send signals we receive on a non-perl thread to the main
+ * thread.  Windows uses window messages to do this so we don't need
+ * it there.
+ *
+ * If we do end up adding this for Windows it will need more complex
+ * management since we'd want to store a thread handle (a HANDLE)
+ * which needs clean up on exit.
+ */
+
+PERLVAR(G, main_thread, pthread_t)
+#  endif
+
 #endif
 
 /* XXX does anyone even use this? */
diff --git a/thread.h b/thread.h
index 474c2b43b660..f64e9bab8794 100644
--- a/thread.h
+++ b/thread.h
@@ -82,6 +82,10 @@
 #  endif
 #endif
 
+#ifndef PTHREAD_INIT_SELF
+#  define PTHREAD_INIT_SELF(var) (var = pthread_self())
+#endif
+
 #ifdef __VMS
   /* Default is 1024 on VAX, 8192 otherwise */
 #  ifdef __ia64
diff --git a/win32/win32thread.h b/win32/win32thread.h
index 9306157c1cda..da5f229b22e8 100644
--- a/win32/win32thread.h
+++ b/win32/win32thread.h
@@ -161,6 +161,8 @@ END_EXTERN_C
 
 #define PTHREAD_ATFORK(prepare,parent,child)	NOOP
 
+#define PTHREAD_INIT_SELF(var) NOOP
+
 #if defined(USE_RTL_THREAD_API) && !defined(_MSC_VER)
 #define JOIN(t, avp)							\
     STMT_START {							\