X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1e05feb346a08fdb97515cde9c4ec43c95989da5..1513219d7de1ec958bd1113b68580bd0437d8182:/mro.c diff --git a/mro.c b/mro.c index f7b3668..488e564 100644 --- a/mro.c +++ b/mro.c @@ -1,6 +1,7 @@ /* mro.c * * Copyright (c) 2007 Brandon L Black + * Copyright (c) 2007, 2008 Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -8,8 +9,10 @@ */ /* - * "Which order shall we go in?" said Frodo. "Eldest first, or quickest first? - * You'll be last either way, Master Peregrin." + * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first? + * You'll be last either way, Master Peregrin.' + * + * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"] */ /* @@ -21,19 +24,125 @@ These functions are related to the method resolution order of perl classes */ #include "EXTERN.h" +#define PERL_IN_MRO_C #include "perl.h" +static const struct mro_alg dfs_alg = + {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0}; + +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 = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, 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_current = *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 (!smeta->mro_linear_all) { + if (smeta->mro_which == which) { + /* If all we need to store is the current MRO's data, then don't use + memory on a hash with 1 element - store it direct, and signal + this by leaving the would-be-hash NULL. */ + smeta->mro_linear_current = data; + return data; + } else { + HV *const hv = newHV(); + /* Start with 2 buckets. It's unlikely we'll need more. */ + HvMAX(hv) = 1; + smeta->mro_linear_all = hv; + + if (smeta->mro_linear_current) { + /* If we were storing something directly, put it in the hash + before we lose it. */ + Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, + smeta->mro_linear_current); + } + } + } + + /* We get here if we're storing more than one linearisation for this stash, + or the linearisation we are storing is not that if its current MRO. */ + + if (smeta->mro_which == which) { + /* If we've been asked to store the private data for the current MRO, + then cache it. */ + smeta->mro_linear_current = data; + } + + if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, 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; +} + +const struct mro_alg * +Perl_mro_get_from_name(pTHX_ SV *name) { + SV **data; + + PERL_ARGS_ASSERT_MRO_GET_FROM_NAME; + + data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0, + HV_FETCH_JUST_SV, NULL, 0); + if (!data) + return NULL; + assert(SvTYPE(*data) == SVt_IV); + assert(SvIOK(*data)); + return INT2PTR(const struct mro_alg *, SvUVX(*data)); +} + +void +Perl_mro_register(pTHX_ const struct mro_alg *mro) { + SV *wrapper = newSVuv(PTR2UV(mro)); + + PERL_ARGS_ASSERT_MRO_REGISTER; + + + if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL, + mro->name, mro->length, mro->kflags, + HV_FETCH_ISSTORE, wrapper, mro->hash)) { + SvREFCNT_dec(wrapper); + Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() " + "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags); + } +} + struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash) { struct mro_meta* newmeta; - assert(stash); + PERL_ARGS_ASSERT_MRO_META_INIT; assert(HvAUX(stash)); assert(!(HvAUX(stash)->xhv_mro_meta)); Newxz(newmeta, 1, struct mro_meta); HvAUX(stash)->xhv_mro_meta = newmeta; newmeta->cache_gen = 1; + newmeta->pkg_gen = 1; + newmeta->mro_which = &dfs_alg; return newmeta; } @@ -46,20 +155,29 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) { struct mro_meta* newmeta; - assert(smeta); + PERL_ARGS_ASSERT_MRO_META_DUP; Newx(newmeta, 1, struct mro_meta); Copy(smeta, newmeta, 1, struct mro_meta); - if (newmeta->mro_linear_dfs) - newmeta->mro_linear_dfs - = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param)); - if (newmeta->mro_linear_c3) - newmeta->mro_linear_c3 - = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param)); + if (newmeta->mro_linear_all) { + newmeta->mro_linear_all + = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param)); + /* This is just acting as a shortcut pointer, and will be automatically + updated on the first get. */ + newmeta->mro_linear_current = NULL; + } else if (newmeta->mro_linear_current) { + /* Only the current MRO is stored, so this owns the data. */ + newmeta->mro_linear_current + = sv_dup_inc((const SV *)newmeta->mro_linear_current, param); + } + if (newmeta->mro_nextmethod) newmeta->mro_nextmethod - = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param)); + = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param)); + if (newmeta->isa) + newmeta->isa + = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param)); return newmeta; } @@ -82,51 +200,56 @@ invalidated). =cut */ -AV* -Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) +static AV* +S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) { AV* retval; GV** gvp; GV* gv; AV* av; - const char* stashname; + const HEK* stashhek; struct mro_meta* meta; + SV *our_name; + HV *stored = NULL; - assert(stash); + PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS; assert(HvAUX(stash)); - stashname = HvNAME_get(stash); - if (!stashname) + stashhek = HvNAME_HEK(stash); + if (!stashhek) Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - stashname); + HEK_KEY(stashhek)); meta = HvMROMETA(stash); /* return cache if valid */ - if((retval = meta->mro_linear_dfs)) { + if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) { return retval; } /* not in cache, make a new one */ - retval = newAV(); - av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */ + retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV()))); + /* We use this later in this function, but don't need a reference to it + beyond the end of this function, so reference count is fine. */ + our_name = newSVhek(stashhek); + av_push(retval, our_name); /* add ourselves at the top */ /* fetch our @ISA */ gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; - if(av && AvFILLp(av) >= 0) { + /* "stored" is used to keep track of all of the classnames we have added to + the MRO so far, so we can do a quick exists check and avoid adding + duplicate classnames to the MRO as we go. + It's then retained to be re-used as a fast lookup for ->isa(), by adding + our own name and "UNIVERSAL" to it. */ - /* "stored" is used to keep track of all of the classnames - we have added to the MRO so far, so we can do a quick - exists check and avoid adding duplicate classnames to - the MRO as we go. */ + if(av && AvFILLp(av) >= 0) { - HV* const stored = (HV*)sv_2mortal((SV*)newHV()); SV **svp = AvARRAY(av); I32 items = AvFILLp(av) + 1; @@ -145,244 +268,108 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) } else { /* otherwise, recurse into ourselves for the MRO - of this @ISA member, and append their MRO to ours */ + of this @ISA member, and append their MRO to ours. + The recursive call could throw an exception, which + has memory management implications here, hence the use of + the mortal. */ const AV *const subrv = mro_get_linear_isa_dfs(basestash, level + 1); subrv_p = AvARRAY(subrv); subrv_items = AvFILLp(subrv) + 1; } - while(subrv_items--) { - SV *const subsv = *subrv_p++; - if(!hv_exists_ent(stored, subsv, 0)) { - hv_store_ent(stored, subsv, &PL_sv_undef, 0); - av_push(retval, newSVsv(subsv)); + if (stored) { + while(subrv_items--) { + SV *const subsv = *subrv_p++; + /* LVALUE fetch will create a new undefined SV if necessary + */ + HE *const he = hv_fetch_ent(stored, subsv, 1, 0); + assert(he); + if(HeVAL(he) != &PL_sv_undef) { + /* It was newly created. Steal it for our new SV, and + replace it in the hash with the "real" thing. */ + SV *const val = HeVAL(he); + HEK *const key = HeKEY_hek(he); + + HeVAL(he) = &PL_sv_undef; + /* Save copying by making a shared hash key scalar. We + inline this here rather than calling + Perl_newSVpvn_share because we already have the + scalar, and we already have the hash key. */ + assert(SvTYPE(val) == SVt_NULL); + sv_upgrade(val, SVt_PV); + SvPV_set(val, HEK_KEY(share_hek_hek(key))); + SvCUR_set(val, HEK_LEN(key)); + SvREADONLY_on(val); + SvFAKE_on(val); + SvPOK_on(val); + if (HEK_UTF8(key)) + SvUTF8_on(val); + + av_push(retval, val); + } } - } + } else { + /* We are the first (or only) parent. We can short cut the + complexity above, because our @ISA is simply us prepended + to our parent's @ISA, and our ->isa cache is simply our + parent's, with our name added. */ + /* newSVsv() is slow. This code is only faster if we can avoid + it by ensuring that SVs in the arrays are shared hash key + scalar SVs, because we can "copy" them very efficiently. + Although to be fair, we can't *ensure* this, as a reference + to the internal array is returned by mro::get_linear_isa(), + so we'll have to be defensive just in case someone faffed + with it. */ + if (basestash) { + SV **svp; + stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa))); + av_extend(retval, subrv_items); + AvFILLp(retval) = subrv_items; + svp = AvARRAY(retval); + while(subrv_items--) { + SV *const val = *subrv_p++; + *++svp = SvIsCOW_shared_hash(val) + ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val))) + : newSVsv(val); + } + } else { + /* They have no stash. So create ourselves an ->isa cache + as if we'd copied it from what theirs should be. */ + stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); + (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0); + av_push(retval, + newSVhek(HeKEY_hek(hv_store_ent(stored, sv, + &PL_sv_undef, 0)))); + } + } } + } else { + /* We have no parents. */ + stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); + (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0); } - /* we don't want anyone modifying the cache entry but us, - and we do so by replacing it completely */ - SvREADONLY_on(retval); - - meta->mro_linear_dfs = retval; - return retval; -} - -/* -=for apidoc mro_get_linear_isa_c3 - -Returns the C3 linearization of @ISA -the given stash. The return value is a read-only AV*. -C should be 0 (it is used internally in this -function's recursion). - -You are responsible for C on the -return value if you plan to store it anywhere -semi-permanently (otherwise it might be deleted -out from under you the next time the cache is -invalidated). - -=cut -*/ - -AV* -Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) -{ - AV* retval; - GV** gvp; - GV* gv; - AV* isa; - const char* stashname; - STRLEN stashname_len; - struct mro_meta* meta; - - assert(stash); - assert(HvAUX(stash)); - - stashname = HvNAME_get(stash); - stashname_len = HvNAMELEN_get(stash); - if (!stashname) - Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); - - if (level > 100) - Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - stashname); - - meta = HvMROMETA(stash); - - /* return cache if valid */ - if((retval = meta->mro_linear_c3)) { - return retval; - } - - /* not in cache, make a new one */ - - retval = newAV(); - av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */ - - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); - isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; - - /* For a better idea how the rest of this works, see the much clearer - pure perl version in Algorithm::C3 0.01: - http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm - (later versions go about it differently than this code for speed reasons) - */ - - if(isa && AvFILLp(isa) >= 0) { - SV** seqs_ptr; - I32 seqs_items; - HV* const tails = (HV*)sv_2mortal((SV*)newHV()); - AV* const seqs = (AV*)sv_2mortal((SV*)newAV()); - I32* heads; - - /* This builds @seqs, which is an array of arrays. - The members of @seqs are the MROs of - the members of @ISA, followed by @ISA itself. - */ - I32 items = AvFILLp(isa) + 1; - SV** isa_ptr = AvARRAY(isa); - while(items--) { - AV* isa_lin; - SV* const isa_item = *isa_ptr++; - HV* const isa_item_stash = gv_stashsv(isa_item, 0); - if(!isa_item_stash) { - /* if no stash, make a temporary fake MRO - containing just itself */ - isa_lin = (AV*)sv_2mortal((SV*)newAV()); - av_push(isa_lin, newSVsv(isa_item)); - } - else { - isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */ - } - av_push(seqs, (SV*)isa_lin); - } - av_push(seqs, (SV*)isa); - - /* This builds "heads", which as an array of integer array - indices, one per seq, which point at the virtual "head" - of the seq (initially zero) */ - Newxz(heads, AvFILLp(seqs)+1, I32); - - /* This builds %tails, which has one key for every class - mentioned in the tail of any sequence in @seqs (tail meaning - everything after the first class, the "head"). The value - is how many times this key appears in the tails of @seqs. - */ - seqs_ptr = AvARRAY(seqs); - seqs_items = AvFILLp(seqs) + 1; - while(seqs_items--) { - AV* const seq = (AV*)*seqs_ptr++; - I32 seq_items = AvFILLp(seq); - if(seq_items > 0) { - SV** seq_ptr = AvARRAY(seq) + 1; - while(seq_items--) { - SV* const seqitem = *seq_ptr++; - HE* const he = hv_fetch_ent(tails, seqitem, 0, 0); - if(!he) { - hv_store_ent(tails, seqitem, newSViv(1), 0); - } - else { - SV* const val = HeVAL(he); - sv_inc(val); - } - } - } - } - - /* This loop won't terminate until we either finish building - the MRO, or get an exception. */ - while(1) { - SV* cand = NULL; - SV* winner = NULL; - int s; - - /* "foreach $seq (@seqs)" */ - SV** const avptr = AvARRAY(seqs); - for(s = 0; s <= AvFILLp(seqs); s++) { - SV** svp; - AV * const seq = (AV*)(avptr[s]); - SV* seqhead; - if(!seq) continue; /* skip empty seqs */ - svp = av_fetch(seq, heads[s], 0); - seqhead = *svp; /* seqhead = head of this seq */ - if(!winner) { - HE* tail_entry; - SV* val; - /* if we haven't found a winner for this round yet, - and this seqhead is not in tails (or the count - for it in tails has dropped to zero), then this - seqhead is our new winner, and is added to the - final MRO immediately */ - cand = seqhead; - if((tail_entry = hv_fetch_ent(tails, cand, 0, 0)) - && (val = HeVAL(tail_entry)) - && (SvIVX(val) > 0)) - continue; - winner = newSVsv(cand); - av_push(retval, winner); - /* note however that even when we find a winner, - we continue looping over @seqs to do housekeeping */ - } - if(!sv_cmp(seqhead, winner)) { - /* Once we have a winner (including the iteration - where we first found him), inc the head ptr - for any seq which had the winner as a head, - NULL out any seq which is now empty, - and adjust tails for consistency */ - - const int new_head = ++heads[s]; - if(new_head > AvFILLp(seq)) { - avptr[s] = NULL; - } - else { - HE* tail_entry; - SV* val; - /* Because we know this new seqhead used to be - a tail, we can assume it is in tails and has - a positive value, which we need to dec */ - svp = av_fetch(seq, new_head, 0); - seqhead = *svp; - tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); - val = HeVAL(tail_entry); - sv_dec(val); - } - } - } + (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0); - /* if we found no candidates, we are done building the MRO. - !cand means no seqs have any entries left to check */ - if(!cand) { - Safefree(heads); - break; - } + SvREFCNT_inc_simple_void_NN(stored); + SvTEMP_off(stored); + SvREADONLY_on(stored); - /* If we had candidates, but nobody won, then the @ISA - hierarchy is not C3-incompatible */ - if(!winner) { - /* we have to do some cleanup before we croak */ - SV** svp = AvARRAY(seqs); - items = AvFILLp(seqs) + 1; - while (items--) - *svp++ = NULL; + meta->isa = stored; - SvREFCNT_dec(retval); - Safefree(heads); - - Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': " - "merging failed on parent '%"SVf"'", stashname, SVfARG(cand)); - } - } - } + /* now that we're past the exception dangers, grab our own reference to + the AV we're about to use for the result. The reference owned by the + mortals' stack will be released soon, so everything will balance. */ + SvREFCNT_inc_simple_void_NN(retval); + SvTEMP_off(retval); /* we don't want anyone modifying the cache entry but us, and we do so by replacing it completely */ SvREADONLY_on(retval); - meta->mro_linear_c3 = retval; - return retval; + return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg, + MUTABLE_SV(retval))); } /* @@ -406,18 +393,15 @@ AV* Perl_mro_get_linear_isa(pTHX_ HV *stash) { struct mro_meta* meta; - assert(stash); - assert(HvAUX(stash)); + + PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA; + if(!SvOOK(stash)) + Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); meta = HvMROMETA(stash); - if(meta->mro_which == MRO_DFS) { - return mro_get_linear_isa_dfs(stash, 0); - } else if(meta->mro_which == MRO_C3) { - return mro_get_linear_isa_c3(stash, 0); - } else { + if (!meta->mro_which) Perl_croak(aTHX_ "panic: invalid MRO!"); - } - return NULL; /* NOT REACHED */ + return meta->mro_which->resolve(aTHX_ stash, 0); } /* @@ -439,22 +423,41 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) SV** svp; I32 items; bool is_universal; + struct mro_meta * meta; const char * const stashname = HvNAME_get(stash); const STRLEN stashname_len = HvNAMELEN_get(stash); + PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN; + + if(!stashname) + Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table"); + /* wipe out the cached linearizations for this stash */ - struct mro_meta * const meta = HvMROMETA(stash); - SvREFCNT_dec((SV*)meta->mro_linear_dfs); - SvREFCNT_dec((SV*)meta->mro_linear_c3); - meta->mro_linear_dfs = NULL; - meta->mro_linear_c3 = NULL; + meta = HvMROMETA(stash); + if (meta->mro_linear_all) { + SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all)); + meta->mro_linear_all = NULL; + /* This is just acting as a shortcut pointer. */ + meta->mro_linear_current = NULL; + } else if (meta->mro_linear_current) { + /* Only the current MRO is stored, so this owns the data. */ + SvREFCNT_dec(meta->mro_linear_current); + meta->mro_linear_current = NULL; + } + if (meta->isa) { + SvREFCNT_dec(meta->isa); + meta->isa = NULL; + } + + /* Inc the package generation, since our @ISA changed */ + meta->pkg_gen++; /* Wipe the global method cache if this package is UNIVERSAL or one of its parents */ svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); - isarev = svp ? (HV*)*svp : NULL; + isarev = svp ? MUTABLE_HV(*svp) : NULL; if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { @@ -470,24 +473,35 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); /* Iterate the isarev (classes that are our children), - wiping out their linearization and method caches */ + wiping out their linearization, method and isa caches */ if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { - SV* const revkey = hv_iterkeysv(iter); - HV* revstash = gv_stashsv(revkey, 0); + I32 len; + const char* const revkey = hv_iterkey(iter, &len); + HV* revstash = gv_stashpvn(revkey, len, 0); struct mro_meta* revmeta; if(!revstash) continue; revmeta = HvMROMETA(revstash); - SvREFCNT_dec((SV*)revmeta->mro_linear_dfs); - SvREFCNT_dec((SV*)revmeta->mro_linear_c3); - revmeta->mro_linear_dfs = NULL; - revmeta->mro_linear_c3 = NULL; + if (revmeta->mro_linear_all) { + SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all)); + revmeta->mro_linear_all = NULL; + /* This is just acting as a shortcut pointer. */ + revmeta->mro_linear_current = NULL; + } else if (revmeta->mro_linear_current) { + /* Only the current MRO is stored, so this owns the data. */ + SvREFCNT_dec(revmeta->mro_linear_current); + revmeta->mro_linear_current = NULL; + } if(!is_universal) revmeta->cache_gen++; if(revmeta->mro_nextmethod) hv_clear(revmeta->mro_nextmethod); + if (revmeta->isa) { + SvREFCNT_dec(revmeta->isa); + revmeta->isa = NULL; + } } } @@ -506,25 +520,29 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) SV* const sv = *svp++; HV* mroisarev; - HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0); - if(!he) { - he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0); - } - mroisarev = (HV*)HeVAL(he); + HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); + + /* That fetch should not fail. But if it had to create a new SV for + us, then will need to upgrade it to an HV (which sv_upgrade() can + now do for us. */ + + mroisarev = MUTABLE_HV(HeVAL(he)); + + SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); /* This hash only ever contains PL_sv_yes. Storing it over itself is almost as cheap as calling hv_exists, so on aggregate we expect to save time by not making two calls to the common HV code for the case where it doesn't exist. */ - hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0); + (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0); if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { I32 revkeylen; char* const revkey = hv_iterkey(iter, &revkeylen); - hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0); + (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0); } } } @@ -567,7 +585,15 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) const STRLEN stashname_len = HvNAMELEN_get(stash); SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); - HV * const isarev = svp ? (HV*)*svp : NULL; + HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; + + PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; + + if(!stashname) + Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table"); + + /* Inc the package generation, since a local method changed */ + HvMROMETA(stash)->pkg_gen++; /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ @@ -584,8 +610,9 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { - SV* const revkey = hv_iterkeysv(iter); - HV* const revstash = gv_stashsv(revkey, 0); + I32 len; + const char* const revkey = hv_iterkey(iter, &len); + HV* const revstash = gv_stashpvn(revkey, len, 0); struct mro_meta* mrometa; if(!revstash) continue; @@ -597,418 +624,47 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) } } -/* These two are static helpers for next::method and friends, - and re-implement a bunch of the code from pp_caller() in - a more efficient manner for this particular usage. -*/ - -STATIC I32 -__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { - I32 i; - for (i = startingblock; i >= 0; i--) { - if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i; - } - return i; -} - -STATIC SV* -__nextcan(pTHX_ SV* self, I32 throw_nomethod) -{ - register I32 cxix; - register const PERL_CONTEXT *ccstack = cxstack; - const PERL_SI *top_si = PL_curstackinfo; - HV* selfstash; - SV *stashname; - const char *fq_subname; - const char *subname; - STRLEN stashname_len; - STRLEN subname_len; - SV* sv; - GV** gvp; - AV* linear_av; - SV** linear_svp; - const char *hvname; - I32 items; - struct mro_meta* selfmeta; - HV* nmcache; - - if(sv_isobject(self)) - selfstash = SvSTASH(SvRV(self)); - else - selfstash = gv_stashsv(self, 0); - - assert(selfstash); - - hvname = HvNAME_get(selfstash); - if (!hvname) - Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); - - cxix = __dopoptosub_at(cxstack, cxstack_ix); - - /* This block finds the contextually-enclosing fully-qualified subname, - much like looking at (caller($i))[3] until you find a real sub that - isn't ANON, etc */ - for (;;) { - GV* cvgv; - STRLEN fq_subname_len; - - /* we may be in a higher stacklevel, so dig down deeper */ - while (cxix < 0) { - if(top_si->si_type == PERLSI_MAIN) - Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context"); - top_si = top_si->si_prev; - ccstack = top_si->si_cxstack; - cxix = __dopoptosub_at(ccstack, top_si->si_cxix); - } - - if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB - || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) { - cxix = __dopoptosub_at(ccstack, cxix - 1); - continue; - } - - { - const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); - if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { - if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) { - cxix = dbcxix; - continue; - } - } - } - - cvgv = CvGV(ccstack[cxix].blk_sub.cv); - - if(!isGV(cvgv)) { - cxix = __dopoptosub_at(ccstack, cxix - 1); - continue; - } - - /* we found a real sub here */ - sv = sv_2mortal(newSV(0)); - - gv_efullname3(sv, cvgv, NULL); - - fq_subname = SvPVX(sv); - fq_subname_len = SvCUR(sv); - - subname = strrchr(fq_subname, ':'); - if(!subname) - Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); - - subname++; - subname_len = fq_subname_len - (subname - fq_subname); - if(subname_len == 8 && strEQ(subname, "__ANON__")) { - cxix = __dopoptosub_at(ccstack, cxix - 1); - continue; - } - break; - } - - /* If we made it to here, we found our context */ - - /* Initialize the next::method cache for this stash - if necessary */ - selfmeta = HvMROMETA(selfstash); - if(!(nmcache = selfmeta->mro_nextmethod)) { - nmcache = selfmeta->mro_nextmethod = newHV(); - } - else { /* Use the cached coderef if it exists */ - HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0); - if (cache_entry) { - SV* const val = HeVAL(cache_entry); - if(val == &PL_sv_undef) { - if(throw_nomethod) - Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); - } - return val; - } - } - - /* beyond here is just for cache misses, so perf isn't as critical */ - - stashname_len = subname - fq_subname - 2; - stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len)); - - linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */ - - linear_svp = AvARRAY(linear_av); - items = AvFILLp(linear_av) + 1; - - /* Walk down our MRO, skipping everything up - to the contextually enclosing class */ - while (items--) { - SV * const linear_sv = *linear_svp++; - assert(linear_sv); - if(sv_eq(linear_sv, stashname)) - break; - } - - /* Now search the remainder of the MRO for the - same method name as the contextually enclosing - method */ - if(items > 0) { - while (items--) { - SV * const linear_sv = *linear_svp++; - HV* curstash; - GV* candidate; - CV* cand_cv; - - assert(linear_sv); - curstash = gv_stashsv(linear_sv, FALSE); - - if (!curstash) { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", - (void*)linear_sv, hvname); - continue; - } - - assert(curstash); - - gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0); - if (!gvp) continue; - - candidate = *gvp; - assert(candidate); - - if (SvTYPE(candidate) != SVt_PVGV) - gv_init(candidate, curstash, subname, subname_len, TRUE); - - /* Notably, we only look for real entries, not method cache - entries, because in C3 the method cache of a parent is not - valid for the child */ - if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { - SvREFCNT_inc_simple_void_NN((SV*)cand_cv); - hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0); - return (SV*)cand_cv; - } - } - } - - hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0); - if(throw_nomethod) - Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); - return &PL_sv_undef; -} - -#include "XSUB.h" - -XS(XS_mro_get_linear_isa); -XS(XS_mro_set_mro); -XS(XS_mro_get_mro); -XS(XS_mro_get_isarev); -XS(XS_mro_is_universal); -XS(XS_mro_invalidate_method_caches); -XS(XS_mro_method_changed_in); -XS(XS_next_can); -XS(XS_next_method); -XS(XS_maybe_next_method); - void -Perl_boot_core_mro(pTHX) +Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name) { - dVAR; - static const char file[] = __FILE__; + const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name); + + PERL_ARGS_ASSERT_MRO_SET_MRO; - newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$"); - newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$"); - newXSproto("mro::get_mro", XS_mro_get_mro, file, "$"); - newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$"); - newXSproto("mro::is_universal", XS_mro_is_universal, file, "$"); - newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, ""); - newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$"); - newXS("next::can", XS_next_can, file); - newXS("next::method", XS_next_method, file); - newXS("maybe::next::method", XS_maybe_next_method, file); -} - -XS(XS_mro_get_linear_isa) { - dVAR; - dXSARGS; - AV* RETVAL; - HV* class_stash; - SV* classname; - - PERL_UNUSED_ARG(cv); - - if(items < 1 || items > 2) - Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])"); - - classname = ST(0); - class_stash = gv_stashsv(classname, 0); - if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - - if(items > 1) { - const char* const which = SvPV_nolen(ST(1)); - if(strEQ(which, "dfs")) - RETVAL = mro_get_linear_isa_dfs(class_stash, 0); - else if(strEQ(which, "c3")) - RETVAL = mro_get_linear_isa_c3(class_stash, 0); - else - Perl_croak(aTHX_ "Invalid mro name: '%s'", which); - } - else { - RETVAL = mro_get_linear_isa(class_stash); - } - - ST(0) = newRV_inc((SV*)RETVAL); - sv_2mortal(ST(0)); - XSRETURN(1); -} - -XS(XS_mro_set_mro) -{ - dVAR; - dXSARGS; - SV* classname; - char* whichstr; - mro_alg which; - HV* class_stash; - struct mro_meta* meta; - - PERL_UNUSED_ARG(cv); - - if (items != 2) - Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)"); - - classname = ST(0); - whichstr = SvPV_nolen(ST(1)); - class_stash = gv_stashsv(classname, GV_ADD); - if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname)); - meta = HvMROMETA(class_stash); - - if(strEQ(whichstr, "dfs")) - which = MRO_DFS; - else if(strEQ(whichstr, "c3")) - which = MRO_C3; - else - Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr); + if (!which) + Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name); if(meta->mro_which != which) { - meta->mro_which = which; + if (meta->mro_linear_current && !meta->mro_linear_all) { + /* If we were storing something directly, put it in the hash before + we lose it. */ + Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, + MUTABLE_SV(meta->mro_linear_current)); + } + meta->mro_which = which; + /* Scrub our cached pointer to the private data. */ + meta->mro_linear_current = NULL; /* Only affects local method cache, not even child classes */ meta->cache_gen++; if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); } - - XSRETURN_EMPTY; -} - - -XS(XS_mro_get_mro) -{ - dVAR; - dXSARGS; - SV* classname; - HV* class_stash; - struct mro_meta* meta; - - PERL_UNUSED_ARG(cv); - - if (items != 1) - Perl_croak(aTHX_ "Usage: mro::get_mro(classname)"); - - classname = ST(0); - class_stash = gv_stashsv(classname, 0); - if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - meta = HvMROMETA(class_stash); - - if(meta->mro_which == MRO_DFS) - ST(0) = sv_2mortal(newSVpvn("dfs", 3)); - else - ST(0) = sv_2mortal(newSVpvn("c3", 2)); - - XSRETURN(1); -} - -XS(XS_mro_get_isarev) -{ - dVAR; - dXSARGS; - SV* classname; - HV* class_stash; - SV** svp; - HV* isarev; - char* stashname; - STRLEN stashname_len; - - PERL_UNUSED_ARG(cv); - - if (items != 1) - Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)"); - - classname = ST(0); - - class_stash = gv_stashsv(classname, 0); - if(!class_stash) - Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - - SP -= items; - - stashname = HvNAME_get(class_stash); - stashname_len = HvNAMELEN_get(class_stash); - svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); - isarev = svp ? (HV*)*svp : NULL; - if(isarev) { - HE* iter; - hv_iterinit(isarev); - while((iter = hv_iternext(isarev))) - XPUSHs(hv_iterkeysv(iter)); - } - - PUTBACK; - return; } -XS(XS_mro_is_universal) -{ - dVAR; - dXSARGS; - SV* classname; - HV* class_stash; - HV* isarev; - char* stashname; - STRLEN stashname_len; - SV** svp; - - PERL_UNUSED_ARG(cv); - - if (items != 1) - Perl_croak(aTHX_ "Usage: mro::is_universal(classname)"); - - classname = ST(0); - class_stash = gv_stashsv(classname, 0); - if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - - stashname = HvNAME_get(class_stash); - stashname_len = HvNAMELEN_get(class_stash); - - svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); - isarev = svp ? (HV*)*svp : NULL; +#include "XSUB.h" - if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) - || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) - XSRETURN_YES; - else - XSRETURN_NO; -} +XS(XS_mro_method_changed_in); -XS(XS_mro_invalidate_method_caches) +void +Perl_boot_core_mro(pTHX) { dVAR; - dXSARGS; - - PERL_UNUSED_ARG(cv); - - if (items != 0) - Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()"); + static const char file[] = __FILE__; - PL_sub_generation++; + Perl_mro_register(aTHX_ &dfs_alg); - XSRETURN_EMPTY; + newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$"); } XS(XS_mro_method_changed_in) @@ -1018,10 +674,8 @@ XS(XS_mro_method_changed_in) SV* classname; HV* class_stash; - PERL_UNUSED_ARG(cv); - if(items != 1) - Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)"); + croak_xs_usage(cv, "classname"); classname = ST(0); @@ -1033,57 +687,6 @@ XS(XS_mro_method_changed_in) XSRETURN_EMPTY; } -XS(XS_next_can) -{ - dVAR; - dXSARGS; - SV* const self = ST(0); - SV* const methcv = __nextcan(aTHX_ self, 0); - - PERL_UNUSED_ARG(cv); - PERL_UNUSED_VAR(items); - - if(methcv == &PL_sv_undef) { - ST(0) = &PL_sv_undef; - } - else { - ST(0) = sv_2mortal(newRV_inc(methcv)); - } - - XSRETURN(1); -} - -XS(XS_next_method) -{ - dMARK; - dAX; - SV* const self = ST(0); - SV* const methcv = __nextcan(aTHX_ self, 1); - - PERL_UNUSED_ARG(cv); - - PL_markstack_ptr++; - call_sv(methcv, GIMME_V); -} - -XS(XS_maybe_next_method) -{ - dMARK; - dAX; - SV* const self = ST(0); - SV* const methcv = __nextcan(aTHX_ self, 0); - - PERL_UNUSED_ARG(cv); - - if(methcv == &PL_sv_undef) { - ST(0) = &PL_sv_undef; - XSRETURN(1); - } - - PL_markstack_ptr++; - call_sv(methcv, GIMME_V); -} - /* * Local variables: * c-indentation-style: bsd