From b7929ab640fb12ed3a34f2fea180d19b341ac197 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 9 Jul 2025 10:49:53 +1000 Subject: [PATCH 1/3] update PL_main_thread on fork() 85e97066 modified the perl signal handler to forward signals to the main thread if it received a signal in a non-perl thread, which required saving the id of the main perl thread. Unfortunately I forgot to handle a possible change in the main thread id on a fork, this fixes that by re-saving the new main thread id immediately after a fork (via pthread_atfork()) On Linux it appears that the main thread id returned by pthread_seld() is constant between processes, but this may not be true on other platforms. Discussed at: https://github.com/Perl/perl5/issues/23326#issuecomment-3050481975 --- embed.fnc | 1 + embed.h | 1 + .../lib/ExtUtils/Miniperl.pm | 4 ++-- ext/XS-APItest/t/thread.t | 24 +++++++++++++++++++ miniperlmain.c | 2 +- proto.h | 4 ++++ util.c | 12 ++++++++++ 7 files changed, 45 insertions(+), 3 deletions(-) diff --git a/embed.fnc b/embed.fnc index 5ddab55acec8..d0a478e98aa4 100644 --- a/embed.fnc +++ b/embed.fnc @@ -678,6 +678,7 @@ Apx |void |apply_attrs_string \ Adp |OP * |apply_builtin_cv_attributes \ |NN CV *cv \ |NULLOK OP *attrlist +CTp |void |atfork_child CTp |void |atfork_lock CTp |void |atfork_unlock Cop |SV ** |av_arylen_p |NN AV *av diff --git a/embed.h b/embed.h index 9c5c2a8acf04..13aaf21b90fd 100644 --- a/embed.h +++ b/embed.h @@ -130,6 +130,7 @@ # define amagic_deref_call(a,b) Perl_amagic_deref_call(aTHX_ a,b) # define apply_attrs_string(a,b,c,d) Perl_apply_attrs_string(aTHX_ a,b,c,d) # define apply_builtin_cv_attributes(a,b) Perl_apply_builtin_cv_attributes(aTHX_ a,b) +# define atfork_child Perl_atfork_child # define atfork_lock Perl_atfork_lock # define atfork_unlock Perl_atfork_unlock # define av_clear(a) Perl_av_clear(aTHX_ a) diff --git a/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm b/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm index d7d4b714118c..c6117385bc05 100644 --- a/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm +++ b/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm @@ -5,7 +5,7 @@ use Exporter 'import'; use ExtUtils::Embed 1.31, qw(xsi_header xsi_protos xsi_body); our @EXPORT = qw(writemain); -our $VERSION = '1.14'; +our $VERSION = '1.15'; # blead will run this with miniperl, hence we can't use autodie or File::Temp my $temp; @@ -122,7 +122,7 @@ main(int argc, char **argv, char **env) * --GSAR 2001-07-20 */ PTHREAD_ATFORK(Perl_atfork_lock, Perl_atfork_unlock, - Perl_atfork_unlock); + Perl_atfork_child); #endif PERL_SYS_FPU_INIT; diff --git a/ext/XS-APItest/t/thread.t b/ext/XS-APItest/t/thread.t index fe5ac953ba34..00399a242762 100644 --- a/ext/XS-APItest/t/thread.t +++ b/ext/XS-APItest/t/thread.t @@ -1,6 +1,7 @@ #!perl use warnings; use strict; +use Test2::IPC; use Test2::Tools::Basic; use Config; @@ -14,4 +15,27 @@ use XS::APItest qw(thread_id_matches); ok(thread_id_matches(), "check main thread id saved and is current thread"); +# This test isn't too useful on Linux, it passes without the fix. +# +# thread ids are unique only within a process, so it's valid for Linux +# pthread_self() to return the same id for the main thread after a +# fork. +# +# This may be different on other POSIX-likes. +SKIP: +{ + $Config{d_fork} + or skip "Need fork", 1; + my $pid = fork; + defined $pid + or skip "Fork failed", 1; + if ($pid == 0) { + ok(thread_id_matches(), "check main thread id is updated by fork"); + exit; + } + else { + waitpid($pid, 0); + } +} + done_testing(); diff --git a/miniperlmain.c b/miniperlmain.c index 38951e002753..64ee56830f07 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -96,7 +96,7 @@ main(int argc, char **argv, char **env) * --GSAR 2001-07-20 */ PTHREAD_ATFORK(Perl_atfork_lock, Perl_atfork_unlock, - Perl_atfork_unlock); + Perl_atfork_child); #endif PERL_SYS_FPU_INIT; diff --git a/proto.h b/proto.h index a7e81e069149..38313d5e991a 100644 --- a/proto.h +++ b/proto.h @@ -210,6 +210,10 @@ Perl_apply_builtin_cv_attributes(pTHX_ CV *cv, OP *attrlist); #define PERL_ARGS_ASSERT_APPLY_BUILTIN_CV_ATTRIBUTES \ assert(cv); assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM) +PERL_CALLCONV void +Perl_atfork_child(void); +#define PERL_ARGS_ASSERT_ATFORK_CHILD + PERL_CALLCONV void Perl_atfork_lock(void); #define PERL_ARGS_ASSERT_ATFORK_LOCK diff --git a/util.c b/util.c index 7cf7a7629536..f7ce5884763b 100644 --- a/util.c +++ b/util.c @@ -2872,6 +2872,18 @@ Perl_atfork_unlock(void) #endif } +void +Perl_atfork_child(void) { +#ifdef USE_ITHREADS + /* so we can resend signals received in a non-perl thread to the + new main thread + */ + PTHREAD_INIT_SELF(PL_main_thread); +#endif + + Perl_atfork_unlock(); +} + /* =for apidoc_section $concurrency =for apidoc my_fork From bd91c49228b5abc719bf1a362c88521050c4baaf Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Thu, 10 Jul 2025 10:06:15 +1000 Subject: [PATCH 2/3] add direct tests for the bug reported in #22487 This was fixed by 85e97066 but the test only checked the sanity of the saved main thread thread id. Tested locally for failure by disarming the change in Perl_csighandler3. --- ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 26 ++++++++++++++++++++++++++ ext/XS-APItest/t/thread.t | 34 ++++++++++++++++++++++++++++++++-- ext/XS-APItest/typemap | 15 +++++++++++++++ 4 files changed, 74 insertions(+), 3 deletions(-) diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 9543147488f8..2ff6b1ecb7b3 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.43'; +our $VERSION = '1.44'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index f2d2774a655a..90caa7c2c410 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1601,6 +1601,17 @@ destruct_test(pTHX_ void *p) { warn("In destruct_test: %" SVf "\n", (SV*)p); } +#if defined(USE_ITHREADS) && !defined(WIN32) + +static void * +signal_thread_start(void *arg) { + PERL_UNUSED_ARG(arg); + raise(SIGUSR1); + return NULL; +} + +#endif + #ifdef PERL_USE_HWM # define hwm_checks_enabled() true #else @@ -4367,6 +4378,21 @@ CODE: OUTPUT: RETVAL +pthread_t +make_signal_thread() +CODE: + if (pthread_create(&RETVAL, NULL, signal_thread_start, NULL) != 0) + XSRETURN_EMPTY; +OUTPUT: + RETVAL + +int +join_signal_thread(pthread_t tid) +CODE: + RETVAL = pthread_join(tid, NULL); +OUTPUT: + RETVAL + # endif /* ifndef WIN32 */ #endif /* USE_ITHREADS */ diff --git a/ext/XS-APItest/t/thread.t b/ext/XS-APItest/t/thread.t index 00399a242762..d787c17d170d 100644 --- a/ext/XS-APItest/t/thread.t +++ b/ext/XS-APItest/t/thread.t @@ -2,7 +2,7 @@ use warnings; use strict; use Test2::IPC; -use Test2::Tools::Basic; +use Test2::V0; use Config; BEGIN { @@ -10,7 +10,7 @@ BEGIN { if !$Config{usethreads} || $^O eq "MSWin32"; } -use XS::APItest qw(thread_id_matches); +use XS::APItest qw(thread_id_matches make_signal_thread join_signal_thread); ok(thread_id_matches(), "check main thread id saved and is current thread"); @@ -38,4 +38,34 @@ SKIP: } } +{ + my $saw_signal; + local $SIG{USR1} = sub { ++$saw_signal }; + my $pid = make_signal_thread(); + join_signal_thread($pid); + ok($saw_signal, "saw signal sent to non-perl thread"); +} + +{ + $Config{d_fork} + or skip "Need fork", 1; + my $pid = fork; + defined $pid + or skip "Fork failed", 1; + if ($pid == 0) { + # ensure the main thread saved is valid after fork + my $saw_signal; + local $SIG{USR1} = sub { ++$saw_signal }; + my $pid = make_signal_thread(); + join_signal_thread($pid); + ok($saw_signal, "saw signal sent to non-perl thread in child"); + exit 0; + } + else { + is(waitpid($pid, 0), $pid, "wait child"); + # catches the child segfaulting for example + is($?, 0, "child success"); + } +} + done_testing(); diff --git a/ext/XS-APItest/typemap b/ext/XS-APItest/typemap index f4c401eba2c3..08840e090901 100644 --- a/ext/XS-APItest/typemap +++ b/ext/XS-APItest/typemap @@ -3,12 +3,27 @@ XS::APItest::PtrTable T_PTROBJ const WCHAR * WPV U8 * T_PV +pthread_t T_THREADID + INPUT WPV $var = ($type)SvPV_nolen($arg); +T_THREADID + { + STRLEN len; + const char *pv = SvPVbyte($arg, len); + if (len != sizeof(pthread_t)) + croak(\"Bad thread id for $arg\"); + Copy(pv, &$var, 1, pthread_t); + } + OUTPUT WPV sv_setpvn($arg, (const char *)($var), sizeof(WCHAR) * (1+wcslen($var))); + +T_THREADID + sv_setpvn($arg, (const char *)&($var), sizeof($var)); + SvUTF8_off($arg); From bcb1bff6f2f7b1dc3be268f9ae9ae6505eb2fadd Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 16 Jul 2025 10:36:58 +1000 Subject: [PATCH 3/3] foreign thread signal forwarding: swap tests to support OpenBSD On OpenBSD, With the tests in the original order, with the parent process setting a signal handler and accepting a foreign signal, the child process test would block busy waiting when the child process called exit. From looking at kdump the child process is busy waiting on sched_yield outside the perl process. Since this appears to be OpenBSD specific (other BSD, linux, MacOS work fine), and the sequence causing the problem seems unlikely outside a test scenario I'm not going to investigate further. --- ext/XS-APItest/t/thread.t | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/ext/XS-APItest/t/thread.t b/ext/XS-APItest/t/thread.t index d787c17d170d..4c4c88785f09 100644 --- a/ext/XS-APItest/t/thread.t +++ b/ext/XS-APItest/t/thread.t @@ -38,14 +38,6 @@ SKIP: } } -{ - my $saw_signal; - local $SIG{USR1} = sub { ++$saw_signal }; - my $pid = make_signal_thread(); - join_signal_thread($pid); - ok($saw_signal, "saw signal sent to non-perl thread"); -} - { $Config{d_fork} or skip "Need fork", 1; @@ -68,4 +60,13 @@ SKIP: } } +{ + my $saw_signal; + local $SIG{USR1} = sub { ++$saw_signal }; + my $pid = make_signal_thread(); + join_signal_thread($pid); + ok($saw_signal, "saw signal sent to non-perl thread"); +} + + done_testing();