From d08d57ef17162c52e2024a3ba6755f778acbc697 Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Wed, 24 Feb 2010 17:15:41 +0000 Subject: [PATCH] Better ithreads cloning - add all SVs with a 0 refcnt to the temps stack. Track all SVs created by sv_dup() that have a 0 reference count. If they still have a 0 reference count at the end of cloning, assign a reference to each to the temps stack. As the temps stack is cleared at thread exit, SVs book keeping will be correct and consistent before perl_destruct() makes its check for leaked scalars. Remove special case code for checking each @_ and the parent's temp stack. --- embed.fnc | 4 +++ embed.h | 10 +++++++ proto.h | 9 +++++++ sv.c | 85 +++++++++++++++++++++++++++++++++++++++++----------------- sv.h | 1 + t/op/threads.t | 12 ++++++++- 6 files changed, 96 insertions(+), 25 deletions(-) diff --git a/embed.fnc b/embed.fnc index b35ad7e..882ea8b 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1421,6 +1421,10 @@ ApR |MAGIC* |mg_dup |NULLOK MAGIC *mg|NN CLONE_PARAMS *const param s |SV ** |sv_dup_inc_multiple|NN SV *const *source|NN SV **dest \ |SSize_t items|NN CLONE_PARAMS *const param #endif +#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +sR |SV* |sv_dup_common |NN const SV *const sstr \ + |NN CLONE_PARAMS *const param +#endif ApR |SV* |sv_dup |NULLOK const SV *const sstr|NN CLONE_PARAMS *const param ApR |SV* |sv_dup_inc |NULLOK const SV *const sstr \ |NN CLONE_PARAMS *const param diff --git a/embed.h b/embed.h index 819f76a..12b2087 100644 --- a/embed.h +++ b/embed.h @@ -1180,6 +1180,11 @@ #define sv_dup_inc_multiple S_sv_dup_inc_multiple #endif #endif +#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define sv_dup_common S_sv_dup_common +#endif +#endif #define sv_dup Perl_sv_dup #define sv_dup_inc Perl_sv_dup_inc #define rvpv_dup Perl_rvpv_dup @@ -3592,6 +3597,11 @@ #define sv_dup_inc_multiple(a,b,c,d) S_sv_dup_inc_multiple(aTHX_ a,b,c,d) #endif #endif +#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define sv_dup_common(a,b) S_sv_dup_common(aTHX_ a,b) +#endif +#endif #define sv_dup(a,b) Perl_sv_dup(aTHX_ a,b) #define sv_dup_inc(a,b) Perl_sv_dup_inc(aTHX_ a,b) #define rvpv_dup(a,b,c) Perl_rvpv_dup(aTHX_ a,b,c) diff --git a/proto.h b/proto.h index 4efc502..014ac97 100644 --- a/proto.h +++ b/proto.h @@ -4289,6 +4289,15 @@ STATIC SV ** S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, SSize_t i assert(source); assert(dest); assert(param) #endif +#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +STATIC SV* S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_SV_DUP_COMMON \ + assert(sstr); assert(param) + +#endif PERL_CALLCONV SV* Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); diff --git a/sv.c b/sv.c index d21c945..d559d6b 100644 --- a/sv.c +++ b/sv.c @@ -11005,16 +11005,14 @@ S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, /* duplicate an SV of any type (including AV, HV etc) */ -SV * -Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) +static SV * +S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) { dVAR; SV *dstr; - PERL_ARGS_ASSERT_SV_DUP; + PERL_ARGS_ASSERT_SV_DUP_COMMON; - if (!sstr) - return NULL; if (SvTYPE(sstr) == SVTYPEMASK) { #ifdef DEBUG_LEAKING_SCALARS_ABORT abort(); @@ -11245,11 +11243,6 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) else { while (items-- > 0) *dst_ary++ = sv_dup(*src_ary++, param); - if (!(param->flags & CLONEf_COPY_STACKS) - && AvREIFY(sstr)) - { - av_reify(MUTABLE_AV(dstr)); /* #41138 */ - } } items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr); while (items-- > 0) { @@ -11355,7 +11348,22 @@ SV * Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) { PERL_ARGS_ASSERT_SV_DUP_INC; - return SvREFCNT_inc(sv_dup(sstr,param)); + return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL; +} + +SV * +Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) +{ + SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL; + PERL_ARGS_ASSERT_SV_DUP; + + /* Track every SV that (at least initially) had a reference count of 0. */ + if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) { + assert(param->unreferenced); + av_push(param->unreferenced, dstr); + } + + return dstr; } /* duplicate a context */ @@ -12018,6 +12026,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* Likely nothing will use this, but it is initialised to be consistent with Perl_clone_params_new(). */ param->proto_perl = my_perl; + param->unreferenced = NULL; INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl); @@ -12119,6 +12128,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, &PL_sv_undef, and SvREFCNT_dec()ing those. */ AvREAL_off(param->stashes); + if (!(flags & CLONEf_COPY_STACKS)) { + param->unreferenced = newAV(); + AvREAL_off(param->unreferenced); + } + /* Set tainting stuff before PerlIO_debug can possibly get called */ PL_tainting = proto_perl->Itainting; PL_taint_warn = proto_perl->Itaint_warn; @@ -12513,19 +12527,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, else { init_stacks(); ENTER; /* perl_destruct() wants to LEAVE; */ - - /* 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 - */ - for (i = 0; i<= proto_perl->Itmps_ix; i++) { - SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, - proto_perl->Itmps_stack[i])); - if (nsv && !SvREFCNT(nsv)) { - PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv)); - } - } } PL_start_env = proto_perl->Istart_env; /* XXXXXX */ @@ -12632,6 +12633,39 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_ptr_table = NULL; } + 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); + } SvREFCNT_dec(param->stashes); @@ -12658,6 +12692,7 @@ Perl_clone_params_del(CLONE_PARAMS *param) } SvREFCNT_dec(param->stashes); + SvREFCNT_dec(param->unreferenced); Safefree(param); @@ -12690,6 +12725,8 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) param->new_perl = to; param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV); AvREAL_off(param->stashes); + param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV); + AvREAL_off(param->unreferenced); if (was != to) { PERL_SET_THX(was); diff --git a/sv.h b/sv.h index 744687a..3f31920 100644 --- a/sv.h +++ b/sv.h @@ -1940,6 +1940,7 @@ struct clone_params { UV flags; PerlInterpreter *proto_perl; PerlInterpreter *new_perl; + AV *unreferenced; }; /* diff --git a/t/op/threads.t b/t/op/threads.t index d9fed9b..364045d 100644 --- a/t/op/threads.t +++ b/t/op/threads.t @@ -16,7 +16,7 @@ BEGIN { exit 0; } - plan(19); + plan(20); } use strict; @@ -253,4 +253,14 @@ fresh_perl_like(<<'EOI', qr/\AThread 1 terminated abnormally: Not a CODE referen print "end"; EOI +fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt neither on tmps stack nor in @_'); + use threads; + my %h = (1, []); + use Scalar::Util 'weaken'; + my $a = $h{1}; + weaken($a); + delete $h{1} && threads->create(sub {}, shift)->join(); + print 'ok'; +EOI + # EOF -- 2.7.4