From: Nicholas Clark Date: Thu, 25 Feb 2010 11:12:03 +0000 (+0000) Subject: When deleting CLONE_PARAMS, push any unreferenced SVs onto the temps stack. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e42956688f2e0df936f1a42811962946e4e185bf;p=p5sagit%2Fp5-mst-13.2.git When deleting CLONE_PARAMS, push any unreferenced SVs onto the temps stack. Effectively this leaves the cloned-into interpreter in a consistent state. In the cloned-from interpreter, the SV targets of non-reference owning pointers *are* referenced and managed by other pointers. SvREFCNT() == 0 SVs in the cloned-into interpreter result from the non-reference owning pointers being found and followed, but the reference owning and managing pointers not being part of the subsection of interpreter state cloned over. Hence, this change creates reference owning pointers to this SVs on the temps stack, which ensures that they are correctly cleaned up, and don't "leak" until interpreter destruction. (Which might be some time away, in a persistent process.) --- diff --git a/embed.fnc b/embed.fnc index 882ea8b..57dd568 100644 --- a/embed.fnc +++ b/embed.fnc @@ -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 diff --git a/embed.h b/embed.h index 12b2087..b328914 100644 --- a/embed.h +++ b/embed.h @@ -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) diff --git a/proto.h b/proto.h index 014ac97..0acb1c5 100644 --- a/proto.h +++ b/proto.h @@ -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__ diff --git a/sv.c b/sv.c index d559d6b..380f442 100644 --- a/sv.c +++ b/sv.c @@ -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 364045d..95f5776 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(<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"