diff options
| -rw-r--r-- | ext/B/t/sv_stash.t | 1 | ||||
| -rw-r--r-- | hv.h | 1 | ||||
| -rw-r--r-- | mro_core.c | 14 | ||||
| -rw-r--r-- | sv.c | 34 |
4 files changed, 30 insertions, 20 deletions
diff --git a/ext/B/t/sv_stash.t b/ext/B/t/sv_stash.t index eaaabcf8fe..e9abf4d55d 100644 --- a/ext/B/t/sv_stash.t +++ b/ext/B/t/sv_stash.t @@ -14,7 +14,6 @@ plan 1; # RT #126410 = used to coredump when doing SvSTASH on %version:: TODO: { - local $TODO = 'Broken since c07f9fb2c7 - revert of a revert: slowed down detruction with no DESTROY'; fresh_perl_is( 'use B; version->new("v5.22.0"); $s = B::svref_2object(\%version::); $s->SvSTASH; print "ok\n"', "ok\n", { stderr => 1 }, 'RT #126410 - SvSTASH against %version::' @@ -82,6 +82,7 @@ struct mro_meta { const struct mro_alg *mro_which; /* which mro alg is in use? */ HV *isa; /* Everything this class @ISA */ HV *super; /* SUPER method cache */ + CV *destroy; /* DESTROY method if destroy_gen non-zero */ U32 destroy_gen; /* Generation number of DESTROY cache */ }; diff --git a/mro_core.c b/mro_core.c index c1e2da7cf1..d4ca7f2be1 100644 --- a/mro_core.c +++ b/mro_core.c @@ -191,6 +191,10 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) newmeta->super = NULL; + /* clear the destructor cache */ + newmeta->destroy = NULL; + newmeta->destroy_gen = 0; + return newmeta; } @@ -538,8 +542,8 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */ HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; - /* DESTROY can be cached in SvSTASH. */ - if (!SvOBJECT(stash)) SvSTASH(stash) = NULL; + /* DESTROY can be cached in meta. */ + meta->destroy_gen = 0; /* Iterate the isarev (classes that are our children), wiping out their linearization, method and isa caches @@ -1320,8 +1324,8 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) /* Inc the package generation, since a local method changed */ HvMROMETA(stash)->pkg_gen++; - /* DESTROY can be cached in SvSTASH. */ - if (!SvOBJECT(stash)) SvSTASH(stash) = NULL; + /* DESTROY can be cached in meta */ + HvMROMETA(stash)->destroy_gen = 0; /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ @@ -1346,7 +1350,7 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) mrometa->cache_gen++; if(mrometa->mro_nextmethod) hv_clear(mrometa->mro_nextmethod); - if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; + mrometa->destroy_gen = 0; } } @@ -6775,25 +6775,31 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) { assert(SvTYPE(stash) == SVt_PVHV); if (HvNAME(stash)) { CV* destructor = NULL; + struct mro_meta *meta; assert (SvOOK(stash)); - if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash); - if (!destructor || HvMROMETA(stash)->destroy_gen - != PL_sub_generation) - { + + DEBUG_o( Perl_deb(aTHX_ "Looking for DESTROY method for %s\n", + HvNAME(stash)) ); + + /* don't make this an initialization above the assert, since it needs + an AUX structure */ + meta = HvMROMETA(stash); + if (meta->destroy_gen && meta->destroy_gen == PL_sub_generation) { + destructor = meta->destroy; + DEBUG_o( Perl_deb(aTHX_ "Using cached DESTROY method %p for %s\n", + (void *)destructor, HvNAME(stash)) ); + } + else { GV * const gv = gv_fetchmeth_autoload(stash, "DESTROY", 7, 0); if (gv) destructor = GvCV(gv); - if (!SvOBJECT(stash)) - { - SvSTASH(stash) = - destructor ? (HV *)destructor : ((HV *)0)+1; - HvAUX(stash)->xhv_mro_meta->destroy_gen = - PL_sub_generation; - } + meta->destroy_gen = PL_sub_generation; + meta->destroy = destructor; + DEBUG_o( Perl_deb(aTHX_ "Set cached DESTROY method %p for %s\n", + (void *)destructor, HvNAME(stash)) ); } - assert(!destructor || destructor == ((CV *)0)+1 - || SvTYPE(destructor) == SVt_PVCV); - if (destructor && destructor != ((CV *)0)+1 + assert(!destructor || SvTYPE(destructor) == SVt_PVCV); + if (destructor /* A constant subroutine can have no side effects, so don't bother calling it. */ && !CvCONST(destructor) |