From: Nicholas Clark Date: Fri, 26 Dec 2008 16:38:58 +0000 (+0000) Subject: Repurpose struct mro_meta to allow it to store cached linear ISA for arbitary X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fa60396f123333e92849ecaecffb9252458d6678;p=p5sagit%2Fp5-mst-13.2.git Repurpose struct mro_meta to allow it to store cached linear ISA for arbitary method resolution orders. mro_linear_dfs becomes a hash holding the different MROs' private data. mro_linear_c3 becomes a shortcut pointer to the current MRO's private data. --- diff --git a/embed.fnc b/embed.fnc index cc3cf79..bb43543 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2184,6 +2184,11 @@ XEMop |void |emulate_cop_io |NN const COP *const c|NN SV *const sv : Used by SvRX and SvRXOK XEMop |REGEXP *|get_re_arg|NULLOK SV *sv +Aop |SV* |mro_get_private_data|NN struct mro_meta *const smeta \ + |NN const struct mro_alg *const which +Aop |SV* |mro_set_private_data|NN struct mro_meta *const smeta \ + |NN const struct mro_alg *const which \ + |NN SV *const data : Used in HvMROMETA() in gv.c, pp_hot.c, universal.c p |struct mro_meta* |mro_meta_init |NN HV* stash #if defined(USE_ITHREADS) diff --git a/global.sym b/global.sym index fe26578..af15270 100644 --- a/global.sym +++ b/global.sym @@ -769,6 +769,8 @@ Perl_my_strlcpy Perl_signbit Perl_emulate_cop_io Perl_get_re_arg +Perl_mro_get_private_data +Perl_mro_set_private_data Perl_mro_get_linear_isa Perl_mro_method_changed_in Perl_sys_init diff --git a/hv.c b/hv.c index adb5a4d..d41b978 100644 --- a/hv.c +++ b/hv.c @@ -1695,7 +1695,6 @@ S_hfreeentries(pTHX_ HV *hv) if((meta = iter->xhv_mro_meta)) { if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs); - if(meta->mro_linear_c3) SvREFCNT_dec(meta->mro_linear_c3); if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod); SvREFCNT_dec(meta->isa); Safefree(meta); diff --git a/hv.h b/hv.h index f92ce9e..66fb6f2 100644 --- a/hv.h +++ b/hv.h @@ -46,7 +46,9 @@ struct shared_he { struct mro_alg; struct mro_meta { + /* repurposed as a hash holding the different MROs private data. */ AV *mro_linear_dfs; /* cached dfs @ISA linearization */ + /* repurposed as a pointer directly to the current MROs private data. */ AV *mro_linear_c3; /* cached c3 @ISA linearization */ HV *mro_nextmethod; /* next::method caching */ U32 cache_gen; /* Bumping this invalidates our method cache */ diff --git a/mro.c b/mro.c index 36ad3ba..23070d9 100644 --- a/mro.c +++ b/mro.c @@ -28,18 +28,74 @@ These functions are related to the method resolution order of perl classes #include "perl.h" struct mro_alg { - const char *name; AV *(*resolve)(pTHX_ HV* stash, U32 level); + const char *name; + U16 length; + U16 kflags; /* For the hash API - set HVhek_UTF8 if name is UTF-8 */ + U32 hash; /* or 0 */ }; /* First one is the default */ static struct mro_alg mros[] = { - {"dfs", S_mro_get_linear_isa_dfs}, - {"c3", S_mro_get_linear_isa_c3} + {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0}, + {S_mro_get_linear_isa_c3, "c3", 2, 0, 0} }; #define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg)) +#define dfs_alg (&mros[0]) +#define c3_alg (&mros[1]) + +SV * +Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, + const struct mro_alg *const which) +{ + SV **data; + PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA; + + data = Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL, + which->name, which->length, which->kflags, + HV_FETCH_JUST_SV, NULL, which->hash); + if (!data) + return NULL; + + /* If we've been asked to look up the private data for the current MRO, then + cache it. */ + if (smeta->mro_which == which) + smeta->mro_linear_c3 = MUTABLE_AV(*data); + + return *data; +} + +SV * +Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta, + const struct mro_alg *const which, SV *const data) +{ + PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA; + + /* If we've been asked to look up the private data for the current MRO, then + cache it. */ + if (smeta->mro_which == which) + smeta->mro_linear_c3 = MUTABLE_AV(data); + + if (!smeta->mro_linear_dfs) { + HV *const hv = newHV(); + HvMAX(hv) = 0; /* Start with 1 bucket. It's unlikely we'll need more. + */ + smeta->mro_linear_dfs = MUTABLE_AV(hv); + } + + if (!Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL, + which->name, which->length, which->kflags, + HV_FETCH_ISSTORE, data, which->hash)) { + Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() " + "for '%.*s' %d", (int) which->length, which->name, + which->kflags); + } + + return data; +} + static const struct mro_alg * S_get_mro_from_name(pTHX_ const char *const name) { const struct mro_alg *algo = mros; @@ -85,9 +141,7 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) if (newmeta->mro_linear_dfs) newmeta->mro_linear_dfs = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_dfs, param))); - if (newmeta->mro_linear_c3) - newmeta->mro_linear_c3 - = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_c3, param))); + newmeta->mro_linear_c3 = NULL; if (newmeta->mro_nextmethod) newmeta->mro_nextmethod = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param))); @@ -177,7 +231,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) meta = HvMROMETA(stash); /* return cache if valid */ - if((retval = meta->mro_linear_dfs)) { + if((retval = MUTABLE_AV(Perl_mro_get_private_data(aTHX_ meta, dfs_alg)))) { return retval; } @@ -283,8 +337,8 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) and we do so by replacing it completely */ SvREADONLY_on(retval); - meta->mro_linear_dfs = retval; - return retval; + return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, dfs_alg, + MUTABLE_SV(retval))); } /* @@ -328,7 +382,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) meta = HvMROMETA(stash); /* return cache if valid */ - if((retval = meta->mro_linear_c3)) { + if((retval = MUTABLE_AV(Perl_mro_get_private_data(aTHX_ meta, c3_alg)))) { return retval; } @@ -501,7 +555,8 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) and we do so by replacing it completely */ SvREADONLY_on(retval); - meta->mro_linear_c3 = retval; + return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, c3_alg, + MUTABLE_SV(retval))); return retval; } @@ -569,7 +624,6 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) /* wipe out the cached linearizations for this stash */ meta = HvMROMETA(stash); SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs)); - SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3)); meta->mro_linear_dfs = NULL; meta->mro_linear_c3 = NULL; if (meta->isa) { @@ -612,7 +666,6 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) if(!revstash) continue; revmeta = HvMROMETA(revstash); SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs)); - SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3)); revmeta->mro_linear_dfs = NULL; revmeta->mro_linear_c3 = NULL; if(!is_universal) @@ -845,6 +898,8 @@ XS(XS_mro_set_mro) if(meta->mro_which != which) { meta->mro_which = which; + /* Scrub our cached pointer to the private data. */ + meta->mro_linear_c3 = NULL; /* Only affects local method cache, not even child classes */ meta->cache_gen++; diff --git a/proto.h b/proto.h index 62ddce4..f10ce56 100644 --- a/proto.h +++ b/proto.h @@ -6554,6 +6554,19 @@ PERL_CALLCONV void Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) PERL_CALLCONV REGEXP * Perl_get_re_arg(pTHX_ SV *sv); +PERL_CALLCONV SV* Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, const struct mro_alg *const which) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA \ + assert(smeta); assert(which) + +PERL_CALLCONV SV* Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta, const struct mro_alg *const which, SV *const data) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA \ + assert(smeta); assert(which); assert(data) + PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_META_INIT \