In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/b98b62bccdcb420ec5430eb831023e3d91ab2fa0?hp=77ba44fbee37607ba9e35122619f1137d1d34dae>
- Log ----------------------------------------------------------------- commit b98b62bccdcb420ec5430eb831023e3d91ab2fa0 Author: David Mitchell <[email protected]> Date: Mon Oct 11 00:13:07 2010 +0100 make sv_clear() non-recursive on RVs The previous two commits made it non-recursive on AVs. With that machinery in place, it's now trivial to extend it to RVs too. This means that now any depth nesting of AVs and RVs will be freed in a single call to sv_clear(). M sv.c commit df90f6afd9a2814197a1dd002454410c69b7fed6 Author: David Mitchell <[email protected]> Date: Mon Oct 11 00:05:26 2010 +0100 re-indent sv_clear() The previous commit wrapped most of sv_clear in a big while loop, but didn't re-indent everything, to keep the change clear. So re-indent now, and wrap long lines. Only whitespace changes. M sv.c commit 5239d5c4bfde4ec02e1787e9dc9ada189ad868e5 Author: David Mitchell <[email protected]> Date: Fri Oct 8 16:22:42 2010 +0100 make sv_clear() iterate over AVs In sv_clear(), rather than calling av_undef(), iterate over the AV's elements. This is the first stage in making sv_clear() non-recursive, and thus non-stack-blowing when freeing deeply nested structures. Since we no longer have the stack to maintain the chain of AVs currently being iterated over, we instead store a pointer to the previous AV in the AvARRAY[AvMAX] slot of the currently-being-iterated AV. Since our first action is to pop the first SV, that slot is guaranteed to be free, and (in theory) nothing should be messing with the AV while we iterate over its elements, so that slot should remain undisturbed. M embed.fnc M proto.h M sv.c commit de61950ae56ef8b3703b4fd7a5fd7fea866f893c Author: David Mitchell <[email protected]> Date: Sun Oct 10 19:48:23 2010 +0100 stop DEBUG_LEAKING_SCALARS, er, leaking! When cloning an SV, new_SV() was setting sv_debug_file, then we immediately set it again without freeing the first one. M sv.c ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 +- proto.h | 4 +- sv.c | 489 ++++++++++++++++++++++++++++++++++++------------------------- 3 files changed, 294 insertions(+), 201 deletions(-) diff --git a/embed.fnc b/embed.fnc index fe70aa9..5741ef0 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1160,7 +1160,7 @@ Apd |void |sv_chop |NN SV *const sv|NULLOK const char *const ptr pd |I32 |sv_clean_all : Used only in perl.c pd |void |sv_clean_objs -Apd |void |sv_clear |NN SV *const sv +Apd |void |sv_clear |NN SV *const orig_sv Apd |I32 |sv_cmp |NULLOK SV *const sv1|NULLOK SV *const sv2 Apd |I32 |sv_cmp_flags |NULLOK SV *const sv1|NULLOK SV *const sv2|const I32 flags Apd |I32 |sv_cmp_locale |NULLOK SV *const sv1|NULLOK SV *const sv2 diff --git a/proto.h b/proto.h index aaa7c5c..bb89272 100644 --- a/proto.h +++ b/proto.h @@ -3897,10 +3897,10 @@ PERL_CALLCONV void Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr) PERL_CALLCONV I32 Perl_sv_clean_all(pTHX); PERL_CALLCONV void Perl_sv_clean_objs(pTHX); -PERL_CALLCONV void Perl_sv_clear(pTHX_ SV *const sv) +PERL_CALLCONV void Perl_sv_clear(pTHX_ SV *const orig_sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_CLEAR \ - assert(sv) + assert(orig_sv) PERL_CALLCONV I32 Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2); PERL_CALLCONV I32 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, const I32 flags); diff --git a/sv.c b/sv.c index abb4f32..1c8d6dd 100644 --- a/sv.c +++ b/sv.c @@ -5814,231 +5814,323 @@ instead. */ void -Perl_sv_clear(pTHX_ register SV *const sv) +Perl_sv_clear(pTHX_ SV *const orig_sv) { dVAR; - const U32 type = SvTYPE(sv); - const struct body_details *const sv_type_details - = bodies_by_type + type; HV *stash; + U32 type; + const struct body_details *sv_type_details; + SV* iter_sv = NULL; + SV* next_sv = NULL; + register SV *sv = orig_sv; PERL_ARGS_ASSERT_SV_CLEAR; - assert(SvREFCNT(sv) == 0); - assert(SvTYPE(sv) != SVTYPEMASK); - if (type <= SVt_IV) { - /* See the comment in sv.h about the collusion between this early - return and the overloading of the NULL slots in the size table. */ - if (SvROK(sv)) - goto free_rv; - SvFLAGS(sv) &= SVf_BREAK; - SvFLAGS(sv) |= SVTYPEMASK; - return; - } + /* within this loop, sv is the SV currently being freed, and + * iter_sv is the most recent AV or whatever that's being iterated + * over to provide more SVs */ - if (SvOBJECT(sv)) { - if (PL_defstash && /* Still have a symbol table? */ - SvDESTROYABLE(sv)) - { - dSP; - HV* stash; - do { - CV* destructor; - stash = SvSTASH(sv); - destructor = StashHANDLER(stash,DESTROY); - if (destructor + while (sv) { + + type = SvTYPE(sv); + + assert(SvREFCNT(sv) == 0); + assert(SvTYPE(sv) != SVTYPEMASK); + + if (type <= SVt_IV) { + /* See the comment in sv.h about the collusion between this + * early return and the overloading of the NULL slots in the + * size table. */ + if (SvROK(sv)) + goto free_rv; + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; + goto free_head; + } + + if (SvOBJECT(sv)) { + if (PL_defstash && /* Still have a symbol table? */ + SvDESTROYABLE(sv)) + { + dSP; + HV* stash; + do { + CV* destructor; + stash = SvSTASH(sv); + destructor = StashHANDLER(stash,DESTROY); + if (destructor /* A constant subroutine can have no side effects, so don't bother calling it. */ && !CvCONST(destructor) /* Don't bother calling an empty destructor */ && (CvISXSUB(destructor) || (CvSTART(destructor) - && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB)))) - { - SV* const tmpref = newRV(sv); - SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ - ENTER; - PUSHSTACKi(PERLSI_DESTROY); - EXTEND(SP, 2); - PUSHMARK(SP); - PUSHs(tmpref); - PUTBACK; - call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); - - - POPSTACK; - SPAGAIN; - LEAVE; - if(SvREFCNT(tmpref) < 2) { - /* tmpref is not kept alive! */ - SvREFCNT(sv)--; - SvRV_set(tmpref, NULL); - SvROK_off(tmpref); + && (CvSTART(destructor)->op_next->op_type + != OP_LEAVESUB)))) + { + SV* const tmpref = newRV(sv); + SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ + ENTER; + PUSHSTACKi(PERLSI_DESTROY); + EXTEND(SP, 2); + PUSHMARK(SP); + PUSHs(tmpref); + PUTBACK; + call_sv(MUTABLE_SV(destructor), + G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); + POPSTACK; + SPAGAIN; + LEAVE; + if(SvREFCNT(tmpref) < 2) { + /* tmpref is not kept alive! */ + SvREFCNT(sv)--; + SvRV_set(tmpref, NULL); + SvROK_off(tmpref); + } + SvREFCNT_dec(tmpref); } - SvREFCNT_dec(tmpref); - } - } while (SvOBJECT(sv) && SvSTASH(sv) != stash); + } while (SvOBJECT(sv) && SvSTASH(sv) != stash); - if (SvREFCNT(sv)) { - if (PL_in_clean_objs) - Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'", - HvNAME_get(stash)); - /* DESTROY gave object new lease on life */ - return; + if (SvREFCNT(sv)) { + if (PL_in_clean_objs) + Perl_croak(aTHX_ + "DESTROY created new reference to dead object '%s'", + HvNAME_get(stash)); + /* DESTROY gave object new lease on life */ + goto get_next_sv; + } } - } - if (SvOBJECT(sv)) { - SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ - SvOBJECT_off(sv); /* Curse the object. */ - if (type != SVt_PVIO) - --PL_sv_objcount; /* XXX Might want something more general */ - } - } - if (type >= SVt_PVMG) { - if (type == SVt_PVMG && SvPAD_OUR(sv)) { - SvREFCNT_dec(SvOURSTASH(sv)); - } else if (SvMAGIC(sv)) - mg_free(sv); - if (type == SVt_PVMG && SvPAD_TYPED(sv)) - SvREFCNT_dec(SvSTASH(sv)); - } - switch (type) { - /* case SVt_BIND: */ - case SVt_PVIO: - if (IoIFP(sv) && - IoIFP(sv) != PerlIO_stdin() && - IoIFP(sv) != PerlIO_stdout() && - IoIFP(sv) != PerlIO_stderr() && - !(IoFLAGS(sv) & IOf_FAKE_DIRP)) - { - io_close(MUTABLE_IO(sv), FALSE); - } - if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) - PerlDir_close(IoDIRP(sv)); - IoDIRP(sv) = (DIR*)NULL; - Safefree(IoTOP_NAME(sv)); - Safefree(IoFMT_NAME(sv)); - Safefree(IoBOTTOM_NAME(sv)); - goto freescalar; - case SVt_REGEXP: - /* FIXME for plugins */ - pregfree2((REGEXP*) sv); - goto freescalar; - case SVt_PVCV: - case SVt_PVFM: - cv_undef(MUTABLE_CV(sv)); - /* If we're in a stash, we don't own a reference to it. However it does - have a back reference to us, which needs to be cleared. */ - if ((stash = CvSTASH(sv))) - sv_del_backref(MUTABLE_SV(stash), sv); - goto freescalar; - case SVt_PVHV: - if (PL_last_swash_hv == (const HV *)sv) { - PL_last_swash_hv = NULL; - } - Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); - hv_undef(MUTABLE_HV(sv)); - break; - case SVt_PVAV: - if (PL_comppad == MUTABLE_AV(sv)) { - PL_comppad = NULL; - PL_curpad = NULL; + if (SvOBJECT(sv)) { + SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ + SvOBJECT_off(sv); /* Curse the object. */ + if (type != SVt_PVIO) + --PL_sv_objcount;/* XXX Might want something more general */ + } } - av_undef(MUTABLE_AV(sv)); - break; - case SVt_PVLV: - if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ - SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); - HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; - PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); + if (type >= SVt_PVMG) { + if (type == SVt_PVMG && SvPAD_OUR(sv)) { + SvREFCNT_dec(SvOURSTASH(sv)); + } else if (SvMAGIC(sv)) + mg_free(sv); + if (type == SVt_PVMG && SvPAD_TYPED(sv)) + SvREFCNT_dec(SvSTASH(sv)); } - else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ - SvREFCNT_dec(LvTARG(sv)); - case SVt_PVGV: - if (isGV_with_GP(sv)) { - if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) - && HvNAME_get(stash)) - mro_method_changed_in(stash); - gp_free(MUTABLE_GV(sv)); - if (GvNAME_HEK(sv)) - unshare_hek(GvNAME_HEK(sv)); - /* If we're in a stash, we don't own a reference to it. However it does - have a back reference to us, which needs to be cleared. */ - if (!SvVALID(sv) && (stash = GvSTASH(sv))) - sv_del_backref(MUTABLE_SV(stash), sv); - } - /* FIXME. There are probably more unreferenced pointers to SVs in the - interpreter struct that we should check and tidy in a similar - fashion to this: */ - if ((const GV *)sv == PL_last_in_gv) - PL_last_in_gv = NULL; - case SVt_PVMG: - case SVt_PVNV: - case SVt_PVIV: - case SVt_PV: - freescalar: - /* Don't bother with SvOOK_off(sv); as we're only going to free it. */ - if (SvOOK(sv)) { - STRLEN offset; - SvOOK_offset(sv, offset); - SvPV_set(sv, SvPVX_mutable(sv) - offset); - /* Don't even bother with turning off the OOK flag. */ - } - if (SvROK(sv)) { - free_rv: + switch (type) { + /* case SVt_BIND: */ + case SVt_PVIO: + if (IoIFP(sv) && + IoIFP(sv) != PerlIO_stdin() && + IoIFP(sv) != PerlIO_stdout() && + IoIFP(sv) != PerlIO_stderr() && + !(IoFLAGS(sv) & IOf_FAKE_DIRP)) { - SV * const target = SvRV(sv); - if (SvWEAKREF(sv)) - sv_del_backref(target, sv); - else - SvREFCNT_dec(target); + io_close(MUTABLE_IO(sv), FALSE); + } + if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) + PerlDir_close(IoDIRP(sv)); + IoDIRP(sv) = (DIR*)NULL; + Safefree(IoTOP_NAME(sv)); + Safefree(IoFMT_NAME(sv)); + Safefree(IoBOTTOM_NAME(sv)); + goto freescalar; + case SVt_REGEXP: + /* FIXME for plugins */ + pregfree2((REGEXP*) sv); + goto freescalar; + case SVt_PVCV: + case SVt_PVFM: + cv_undef(MUTABLE_CV(sv)); + /* If we're in a stash, we don't own a reference to it. + * However it does have a back reference to us, which needs to + * be cleared. */ + if ((stash = CvSTASH(sv))) + sv_del_backref(MUTABLE_SV(stash), sv); + goto freescalar; + case SVt_PVHV: + if (PL_last_swash_hv == (const HV *)sv) { + PL_last_swash_hv = NULL; + } + Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); + hv_undef(MUTABLE_HV(sv)); + break; + case SVt_PVAV: + { + AV* av = MUTABLE_AV(sv); + if (PL_comppad == av) { + PL_comppad = NULL; + PL_curpad = NULL; + } + if (AvREAL(av) && AvFILLp(av) > -1) { + next_sv = AvARRAY(av)[AvFILLp(av)--]; + /* save old iter_sv in top-most slot of AV, + * and pray that it doesn't get wiped in the meantime */ + AvARRAY(av)[AvMAX(av)] = iter_sv; + iter_sv = sv; + goto get_next_sv; /* process this new sv */ + } + Safefree(AvALLOC(av)); + } + + break; + case SVt_PVLV: + if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ + SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); + HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; + PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); + } + else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ + SvREFCNT_dec(LvTARG(sv)); + case SVt_PVGV: + if (isGV_with_GP(sv)) { + if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) + && HvNAME_get(stash)) + mro_method_changed_in(stash); + gp_free(MUTABLE_GV(sv)); + if (GvNAME_HEK(sv)) + unshare_hek(GvNAME_HEK(sv)); + /* If we're in a stash, we don't own a reference to it. + * However it does have a back reference to us, which + * needs to be cleared. */ + if (!SvVALID(sv) && (stash = GvSTASH(sv))) + sv_del_backref(MUTABLE_SV(stash), sv); + } + /* FIXME. There are probably more unreferenced pointers to SVs + * in the interpreter struct that we should check and tidy in + * a similar fashion to this: */ + if ((const GV *)sv == PL_last_in_gv) + PL_last_in_gv = NULL; + case SVt_PVMG: + case SVt_PVNV: + case SVt_PVIV: + case SVt_PV: + freescalar: + /* Don't bother with SvOOK_off(sv); as we're only going to + * free it. */ + if (SvOOK(sv)) { + STRLEN offset; + SvOOK_offset(sv, offset); + SvPV_set(sv, SvPVX_mutable(sv) - offset); + /* Don't even bother with turning off the OOK flag. */ + } + if (SvROK(sv)) { + free_rv: + { + SV * const target = SvRV(sv); + if (SvWEAKREF(sv)) + sv_del_backref(target, sv); + else + next_sv = target; + } } - } #ifdef PERL_OLD_COPY_ON_WRITE - else if (SvPVX_const(sv) - && !(SvTYPE(sv) == SVt_PVIO && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) { - if (SvIsCOW(sv)) { - if (DEBUG_C_TEST) { - PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); - sv_dump(sv); - } - if (SvLEN(sv)) { - sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv)); - } else { - unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + else if (SvPVX_const(sv) + && !(SvTYPE(sv) == SVt_PVIO + && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) + { + if (SvIsCOW(sv)) { + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); + sv_dump(sv); + } + if (SvLEN(sv)) { + sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv)); + } else { + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + } + + SvFAKE_off(sv); + } else if (SvLEN(sv)) { + Safefree(SvPVX_const(sv)); } + } +#else + else if (SvPVX_const(sv) && SvLEN(sv) + && !(SvTYPE(sv) == SVt_PVIO + && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) + Safefree(SvPVX_mutable(sv)); + else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) { + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + SvFAKE_off(sv); + } +#endif + break; + case SVt_NV: + break; + } - SvFAKE_off(sv); - } else if (SvLEN(sv)) { - Safefree(SvPVX_const(sv)); - } + free_body: + + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; + + sv_type_details = bodies_by_type + type; + if (sv_type_details->arena) { + del_body(((char *)SvANY(sv) + sv_type_details->offset), + &PL_body_roots[type]); } -#else - else if (SvPVX_const(sv) && SvLEN(sv) - && !(SvTYPE(sv) == SVt_PVIO && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) - Safefree(SvPVX_mutable(sv)); - else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) { - unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); - SvFAKE_off(sv); + else if (sv_type_details->body_size) { + safefree(SvANY(sv)); } -#endif - break; - case SVt_NV: - break; - } - SvFLAGS(sv) &= SVf_BREAK; - SvFLAGS(sv) |= SVTYPEMASK; + free_head: + /* caller is responsible for freeing the head of the original sv */ + if (sv != orig_sv && !SvREFCNT(sv)) + del_SV(sv); - if (sv_type_details->arena) { - del_body(((char *)SvANY(sv) + sv_type_details->offset), - &PL_body_roots[type]); - } - else if (sv_type_details->body_size) { - safefree(SvANY(sv)); - } + /* grab and free next sv, if any */ + get_next_sv: + while (1) { + sv = NULL; + if (next_sv) { + sv = next_sv; + next_sv = NULL; + } + else if (!iter_sv) { + break; + } else if (SvTYPE(iter_sv) == SVt_PVAV) { + AV *const av = (AV*)iter_sv; + if (AvFILLp(av) > -1) { + sv = AvARRAY(av)[AvFILLp(av)--]; + } + else { /* no more elements of current AV to free */ + sv = iter_sv; + type = SvTYPE(sv); + /* restore previous value, squirrelled away */ + iter_sv = AvARRAY(av)[AvMAX(av)]; + Safefree(AvALLOC(av)); + goto free_body; + } + } + + /* unrolled SvREFCNT_dec and sv_free2 follows: */ + + if (!sv) + continue; + if (!SvREFCNT(sv)) { + sv_free(sv); + continue; + } + if (--(SvREFCNT(sv))) + continue; +#ifdef DEBUGGING + if (SvTEMP(sv)) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), + "Attempt to free temp prematurely: SV 0x%"UVxf + pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); + continue; + } +#endif + if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = (~(U32)0)/2; + continue; + } + break; + } /* while 1 */ + + } /* while sv */ } /* @@ -11404,6 +11496,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) dstr->sv_debug_line = sstr->sv_debug_line; dstr->sv_debug_inpad = sstr->sv_debug_inpad; dstr->sv_debug_parent = (SV*)sstr; + FREE_SV_DEBUG_FILE(dstr); dstr->sv_debug_file = savepv(sstr->sv_debug_file); #endif -- Perl5 Master Repository
