X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=c9e6f9e0571a04b7a19f681c4413ad5c4a88d0d1;hb=152cfc22ea64162b6b4093260b262aa0e28a0dce;hp=044c8bd051e2755197749305fe385c64ba68abdf;hpb=842c41230043ce99d4bf7b2c79aed85ce2908e89;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 044c8bd..c9e6f9e 100644 --- a/sv.c +++ b/sv.c @@ -10491,18 +10491,17 @@ ptr_table_* functions. that currently av_dup, gv_dup and hv_dup are the same as sv_dup. If this changes, please unmerge ss_dup. Likewise, sv_dup_inc_multiple() relies on this fact. */ -#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) -#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t)) +#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t)) #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t)) -#define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t)) #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t)) -#define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t)) #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t)) -#define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t)) #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t)) -#define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t)) #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t)) -#define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t)) #define SAVEPV(p) ((p) ? savepv(p) : NULL) #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) @@ -11006,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(); @@ -11246,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) { @@ -11334,7 +11326,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) * duped GV may never be freed. A bit of a hack! DAPM */ CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ? NULL : gv_dup(CvGV(dstr), param) ; - PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); + CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param); CvOUTSIDE(dstr) = CvWEAKOUTSIDE(sstr) ? cv_dup( CvOUTSIDE(dstr), param) @@ -11352,6 +11344,41 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) return dstr; } +SV * +Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) +{ + PERL_ARGS_ASSERT_SV_DUP_INC; + 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. + We need to do this by holding an actual reference to it in this array. + If we attempt to cheat, turn AvREAL_off(), and store only pointers + (akin to the stashes hash, and the perl stack), we come unstuck if + a weak reference (or other SV legitimately SvREFCNT() == 0 for this + thread) is manipulated in a CLONE method, because CLONE runs before the + unreferenced array is walked to find SVs still with SvREFCNT() == 0 + (and fix things up by giving each a reference via the temps stack). + Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and + then SvREFCNT_dec(), it will be cleaned up (and added to the free list) + before the walk of unreferenced happens and a reference to that is SV + added to the temps stack. At which point we have the same SV considered + to be in use, and free to be re-used. Not good. + */ + if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) { + assert(param->unreferenced); + av_push(param->unreferenced, SvREFCNT_inc(dstr)); + } + + return dstr; +} + /* duplicate a context */ PERL_CONTEXT * @@ -12006,7 +12033,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif /* PERL_IMPLICIT_SYS */ param->flags = flags; + /* Nothing in the core code uses this, but we make it available to + extensions (using mg_dup). */ param->proto_perl = proto_perl; + /* 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); @@ -12108,6 +12141,10 @@ 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(); + } + /* Set tainting stuff before PerlIO_debug can possibly get called */ PL_tainting = proto_perl->Itainting; PL_taint_warn = proto_perl->Itaint_warn; @@ -12414,6 +12451,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_unlockhook = proto_perl->Iunlockhook; PL_threadhook = proto_perl->Ithreadhook; PL_destroyhook = proto_perl->Idestroyhook; + PL_signalhook = proto_perl->Isignalhook; #ifdef THREADS_HAVE_PIDS PL_ppid = proto_perl->Ippid; @@ -12502,19 +12540,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 */ @@ -12621,6 +12646,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_ptr_table = NULL; } + if (!(flags & CLONEf_COPY_STACKS)) { + unreferenced_to_tmp_stack(param->unreferenced); + } SvREFCNT_dec(param->stashes); @@ -12633,6 +12661,106 @@ 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) == 1) + ++count; + } while (++svp <= last); + + EXTEND_MORTAL(count); + svp = AvARRAY(unreferenced); + + do { + if (SvREFCNT(*svp) == 1) { + /* Our reference is the only one to this SV. This means that + in this thread, the scalar effectively has a 0 reference. + That doesn't work (cleanup never happens), so donate our + reference to it onto the save stack. */ + PL_tmps_stack[++PL_tmps_ix] = *svp; + } else { + /* As an optimisation, because we are already walking the + entire array, instead of above doing either + SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead + release our reference to the scalar, so that at the end of + the array owns zero references to the scalars it happens to + point to. We are effectively converting the array from + AvREAL() on to AvREAL() off. This saves the av_clear() + (triggered by the SvREFCNT_dec(unreferenced) below) from + walking the array a second time. */ + SvREFCNT_dec(*svp); + } + + } while (++svp <= last); + AvREAL_off(unreferenced); + } + SvREFCNT_dec(unreferenced); +} + +void +Perl_clone_params_del(CLONE_PARAMS *param) +{ + PerlInterpreter *const was = PERL_GET_THX; + PerlInterpreter *const to = param->new_perl; + dTHXa(to); + + PERL_ARGS_ASSERT_CLONE_PARAMS_DEL; + + if (was != to) { + PERL_SET_THX(to); + } + + SvREFCNT_dec(param->stashes); + if (param->unreferenced) + unreferenced_to_tmp_stack(param->unreferenced); + + Safefree(param); + + if (was != to) { + PERL_SET_THX(was); + } +} + +CLONE_PARAMS * +Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) +{ + /* Need to play this game, as newAV() can call safesysmalloc(), and that + does a dTHX; to get the context from thread local storage. + FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to + a version that passes in my_perl. */ + PerlInterpreter *const was = PERL_GET_THX; + CLONE_PARAMS *param; + + PERL_ARGS_ASSERT_CLONE_PARAMS_NEW; + + if (was != to) { + PERL_SET_THX(to); + } + + /* Given that we've set the context, we can do this unshared. */ + Newx(param, 1, CLONE_PARAMS); + + param->flags = 0; + param->proto_perl = from; + 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); + + if (was != to) { + PERL_SET_THX(was); + } + return param; +} + #endif /* USE_ITHREADS */ /*