Skip to content

Commit

Permalink
Repurpose struct mro_meta to allow it to store cached linear ISA for …
Browse files Browse the repository at this point in the history 
…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.
  • Loading branch information
@nwc10
nwc10 committed Dec 27, 2008
1 parent 4e7245b commit fa60396
Show file tree
Hide file tree
Showing 6 changed files with 90 additions and 14 deletions.
5 changes: 5 additions & 0 deletions embed.fnc
View file
Expand Up @@ -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)
Expand Down
2 changes: 2 additions & 0 deletions global.sym
View file
Expand Up @@ -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
Expand Down
1 change: 0 additions & 1 deletion hv.c
View file
Expand Up @@ -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);
Expand Down
2 changes: 2 additions & 0 deletions hv.h
View file
Expand Up @@ -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 */
Expand Down
81 changes: 68 additions & 13 deletions mro.c
View file
Expand Up @@ -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;
Expand Down Expand Up @@ -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)));
Expand Down Expand Up @@ -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;
}

Expand Down Expand Up @@ -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)));
}

/*
Expand Down Expand Up @@ -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;
}

Expand Down Expand Up @@ -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;
}

Expand Down Expand Up @@ -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) {
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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++;
Expand Down
13 changes: 13 additions & 0 deletions proto.h
View file
Expand Up @@ -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 \
Expand Down

0 comments on commit fa60396

Please sign in to comment.