diff options
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 10 | ||||
| -rw-r--r-- | proto.h | 7 | ||||
| -rw-r--r-- | sv.c | 61 | ||||
| -rw-r--r-- | t/op/threads.t | 14 |
5 files changed, 53 insertions, 42 deletions
@@ -2360,6 +2360,9 @@ xpoM |struct refcounted_he *|store_cop_label \ xpo |int |keyword_plugin_standard|NN char* keyword_ptr|STRLEN keyword_len|NN OP** op_ptr #if defined(USE_ITHREADS) +# if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +s |void |unreferenced_to_tmp_stack|NN AV *const unreferenced +# endif Aanop |CLONE_PARAMS *|clone_params_new|NN PerlInterpreter *const from \ |NN PerlInterpreter *const to Anop |void |clone_params_del|NN CLONE_PARAMS *param @@ -2049,6 +2049,11 @@ #define boot_core_mro Perl_boot_core_mro #endif #if defined(USE_ITHREADS) +# if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define unreferenced_to_tmp_stack S_unreferenced_to_tmp_stack +#endif +# endif #endif #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop @@ -4491,6 +4496,11 @@ #ifdef PERL_CORE #endif #if defined(USE_ITHREADS) +# if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define unreferenced_to_tmp_stack(a) S_unreferenced_to_tmp_stack(aTHX_ a) +#endif +# endif #endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) @@ -6888,6 +6888,13 @@ PERL_CALLCONV int Perl_keyword_plugin_standard(pTHX_ char* keyword_ptr, STRLEN k #if defined(USE_ITHREADS) +# if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +STATIC void S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK \ + assert(unreferenced) + +# endif PERL_CALLCONV CLONE_PARAMS * Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) __attribute__malloc__ __attribute__warn_unused_result__ @@ -12634,37 +12634,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } if (!(flags & CLONEf_COPY_STACKS)) { - /* although we're not duplicating the tmps stack, we should still - * add entries for any SVs on the tmps stack that got cloned by a - * non-refcount means (eg a temp in @_); otherwise they will be - * orphaned. - * - * This actualy expands to all SVs which are pointed to, without a - * reference being owned by that pointer, such as @_ and weak - * references. Owners of these references include the tmps stack, the - * save stack, and (effectively) the magic backreference structure. - */ - if (AvFILLp(param->unreferenced) > -1) { - SV **svp = AvARRAY(param->unreferenced); - SV **const last = svp + AvFILLp(param->unreferenced); - SSize_t count = 0; - - do { - if (!SvREFCNT(*svp)) - ++count; - } while (++svp <= last); - - EXTEND_MORTAL(count); - - svp = AvARRAY(param->unreferenced); - - do { - if (!SvREFCNT(*svp)) - PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(*svp); - } while (++svp <= last); - } - - SvREFCNT_dec(param->unreferenced); + unreferenced_to_tmp_stack(param->unreferenced); } SvREFCNT_dec(param->stashes); @@ -12678,6 +12648,32 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, return my_perl; } +static void +S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced) +{ + PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK; + + if (AvFILLp(unreferenced) > -1) { + SV **svp = AvARRAY(unreferenced); + SV **const last = svp + AvFILLp(unreferenced); + SSize_t count = 0; + + do { + if (!SvREFCNT(*svp)) + ++count; + } while (++svp <= last); + + EXTEND_MORTAL(count); + svp = AvARRAY(unreferenced); + + do { + if (!SvREFCNT(*svp)) + PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(*svp); + } while (++svp <= last); + } + SvREFCNT_dec(unreferenced); +} + void Perl_clone_params_del(CLONE_PARAMS *param) { @@ -12692,7 +12688,8 @@ Perl_clone_params_del(CLONE_PARAMS *param) } SvREFCNT_dec(param->stashes); - SvREFCNT_dec(param->unreferenced); + if (param->unreferenced) + unreferenced_to_tmp_stack(param->unreferenced); Safefree(param); diff --git a/t/op/threads.t b/t/op/threads.t index 364045d995..95f5776bd3 100644 --- a/t/op/threads.t +++ b/t/op/threads.t @@ -116,10 +116,6 @@ print do 'op/threads_create.pl' || die $@; EOI -TODO: { - no strict 'vars'; # Accessing $TODO from test.pl - local $TODO = 'refcount issues with threads'; - # Scalars leaked: 1 foreach my $BLOCK (qw(CHECK INIT)) { fresh_perl_is(<<EOI, 'ok', { }, "threads in $BLOCK block"); @@ -129,8 +125,6 @@ foreach my $BLOCK (qw(CHECK INIT)) { EOI } -} # TODO - # Scalars leaked: 1 fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138'); use threads; @@ -206,8 +200,8 @@ print "ok"; EOI # Another, more reliable test for the same del_backref bug: -fresh_perl_like( - <<' EOJ', qr/ok/, {}, 'No del_backref panic [perl #70748] (2)' +fresh_perl_is( + <<' EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)' use threads; push @bar, threads->create(sub{sub{}})->join() for 1...10; print "ok"; @@ -216,10 +210,10 @@ fresh_perl_like( # Simple closure-returning test: At least this case works (though it # leaks), and we don't want to break it. -fresh_perl_like(<<'EOJ', qr/^foo\n/, {}, 'returning a closure'); +fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure'); use threads; print create threads sub { - my $x = "foo\n"; + my $x = 'foo'; sub{sub{$x}} }=>->join->()() //"undef" |