Skip to content

Update PL_main_thread on fork() and add more tests #23422

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 2 commits into
base: blead
Choose a base branch
from
Open

Update PL_main_thread on fork() and add more tests #23422

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
1c4a6db
update PL_main_thread on fork()
tonycoz Jul 9, 2025
71dcca6
add direct tests for the bug reported in #22487
tonycoz Jul 10, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions embed.fnc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions embed.h
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
4 changes: 2 additions & 2 deletions ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down Expand Up @@ -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;
Expand Down
2 changes: 1 addition & 1 deletion ext/XS-APItest/APItest.pm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ use strict;
use warnings;
use Carp;

our $VERSION = '1.43';
our $VERSION = '1.44';

require XSLoader;

Expand Down
26 changes: 26 additions & 0 deletions ext/XS-APItest/APItest.xs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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;
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why return empty list instead of &PL_sv_undef or &PL_sv_no or SvPV "" empty str or less perfect, SvIV -1 or SvIV 0? I know pp_entersub will cast empty list to 1 x &PL_sv_undef in G_SCALAR cxt, but why mk `pp_entersub do the cast?

OUTPUT:
RETVAL

int
join_signal_thread(pthread_t tid)
CODE:
RETVAL = pthread_join(tid, NULL);
OUTPUT:
RETVAL

# endif /* ifndef WIN32 */

#endif /* USE_ITHREADS */
Expand Down
58 changes: 56 additions & 2 deletions ext/XS-APItest/t/thread.t
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,17 +1,71 @@
#!perl
use warnings;
use strict;
use Test2::Tools::Basic;
use Test2::IPC;
use Test2::V0;
use Config;

BEGIN {
skip_all "Not pthreads or is win32"
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");

# 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);
}
}

{
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");
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

would test.pl/Test2:: sub is() corrupt PP mg var $? between waitpid() ret and sampling of $??

}
}

done_testing();
14 changes: 14 additions & 0 deletions ext/XS-APItest/typemap
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,12 +3,26 @@ 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));
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I see paranoia above with SvPVbyte(), so OUTPUT: also needs paranoia. sv_setpvn() doesn't clear the UTF8 flag if TARG already has UTF8 flag on. Also following paranoia guidelines, you forgot to call a _mg() SV* setter variant. Per rules, remember to clear UTF8 flag before the SMG setter method fires, not after. It should be sv_setpvn(); SvUTF8_off(); SvSETMAGIC(); or better yet SvUTF8_off(); sv_setpvn_mg();.

I am very aware this is code is inside XS-APItest, and not some high river CPAN XS module, so XS code "quality" is a very low priority here, but I saw paranoia INPUT: type entry so I'll keep the paranoia going.

2 changes: 1 addition & 1 deletion miniperlmain.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down
4 changes: 4 additions & 0 deletions proto.h
View file
Open in desktop

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

12 changes: 12 additions & 0 deletions util.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

More of a Win32 problem than a Posix Perl problem, but what happens to the entire Perl or 3P embedder process if the 1st Perl thread or 1st process startup thread, exits itself on Unix? Instant Process kill? If not, the TID or pthread_t obj stored in PL_main_thread now points to a zombie TID? Why would a child interp/my_perl on a 2nd pthread rethrow a signal to a gone/finished/dealloced root my_perl and dealloced or zombie TID??

static void
S_init_tls_and_interp(PerlInterpreter *my_perl)
{
    if (!PL_curinterp) {
        PERL_SET_INTERP(my_perl);
#if defined(USE_ITHREADS)
        INIT_THREADS;
        ALLOC_THREAD_KEY;
        PERL_SET_THX(my_perl);
        OP_REFCNT_INIT;
        OP_CHECK_MUTEX_INIT;
        KEYWORD_PLUGIN_MUTEX_INIT;
        HINTS_REFCNT_INIT;
        LOCALE_INIT;
        USER_PROP_MUTEX_INIT;
        ENV_INIT;
        MUTEX_INIT(&PL_dollarzero_mutex);
        MUTEX_INIT(&PL_my_ctx_mutex);
        PTHREAD_INIT_SELF(PL_main_thread);
#  endif
    }


Perl_atfork_unlock();
}

/*
=for apidoc_section $concurrency
=for apidoc my_fork
Expand Down
Loading