X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mro.c;h=2d528058262ed46e75bd4e6731d1604fd57e6071;hb=bf8300decce77d53edc393ca2221fb591a778c59;hp=f3db7745aacfad338848ab5cdcf849c936dda9c7;hpb=84dccb35f7809a3cd00c6b11d0a9aa40b70e045f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mro.c b/mro.c index f3db774..2d52805 100644 --- a/mro.c +++ b/mro.c @@ -54,14 +54,14 @@ 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 = (void *) mros; + newmeta->mro_which = mros; return newmeta; } @@ -74,7 +74,7 @@ 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); @@ -117,19 +117,19 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) GV** gvp; GV* gv; AV* av; - const char* stashname; + const HEK* stashhek; struct mro_meta* meta; - 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); @@ -141,7 +141,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) /* not in cache, make a new one */ retval = (AV*)sv_2mortal((SV *)newAV()); - av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */ + av_push(retval, newSVhek(stashhek)); /* add ourselves at the top */ /* fetch our @ISA */ gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); @@ -231,21 +231,19 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) GV** gvp; GV* gv; AV* isa; - const char* stashname; - STRLEN stashname_len; + const HEK* stashhek; struct mro_meta* meta; - assert(stash); + PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3; assert(HvAUX(stash)); - stashname = HvNAME_get(stash); - stashname_len = HvNAMELEN_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); @@ -315,12 +313,13 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) 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) { - (void)hv_store_ent(tails, seqitem, newSViv(1), 0); - } - else { + /* LVALUE fetch will create a new undefined SV if necessary + */ + HE* const he = hv_fetch_ent(tails, seqitem, 1, 0); + if(he) { SV* const val = HeVAL(he); + /* This will increment undef to 1, which is what we + want for a newly created entry. */ sv_inc(val); } } @@ -329,7 +328,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) /* Initialize retval to build the return value in */ retval = newAV(); - av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */ + av_push(retval, newSVhek(stashhek)); /* us first */ /* This loop won't terminate until we either finish building the MRO, or get an exception. */ @@ -408,14 +407,14 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) Safefree(heads); Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': " - "merging failed on parent '%"SVf"'", stashname, SVfARG(cand)); + "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand)); } } } else { /* @ISA was undefined or empty */ /* build a retval containing only ourselves */ retval = newAV(); - av_push(retval, newSVpvn(stashname, stashname_len)); + av_push(retval, newSVhek(stashhek)); } /* we don't want anyone modifying the cache entry but us, @@ -448,7 +447,7 @@ Perl_mro_get_linear_isa(pTHX_ HV *stash) { struct mro_meta* meta; - assert(stash); + PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA; if(!SvOOK(stash)) Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); @@ -482,6 +481,8 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) 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"); @@ -519,8 +520,9 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) 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; @@ -551,12 +553,16 @@ 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); - } + 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 = (HV*)HeVAL(he); + SvUPGRADE((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 @@ -614,6 +620,8 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); HV * const isarev = svp ? (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"); @@ -635,8 +643,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; @@ -817,7 +826,7 @@ XS(XS_mro_get_isarev) while((iter = hv_iternext(isarev))) av_push(ret_array, newSVsv(hv_iterkeysv(iter))); } - XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array))); + mXPUSHs(newRV_noinc((SV*)ret_array)); PUTBACK; return; @@ -840,8 +849,7 @@ XS(XS_mro_is_universal) classname = ST(0); - classname_pv = SvPV_nolen(classname); - classname_len = strlen(classname_pv); + classname_pv = SvPV(classname,classname_len); he = hv_fetch_ent(PL_isarev, classname, 0, 0); isarev = he ? (HV*)HeVAL(he) : NULL; @@ -908,9 +916,7 @@ XS(XS_mro_get_pkg_gen) SP -= items; - XPUSHs(sv_2mortal(newSViv( - class_stash ? HvMROMETA(class_stash)->pkg_gen : 0 - ))); + mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0); PUTBACK; return; @@ -948,7 +954,7 @@ XS(XS_mro_nextcan) if(sv_isobject(self)) selfstash = SvSTASH(SvRV(self)); else - selfstash = gv_stashsv(self, 0); + selfstash = gv_stashsv(self, GV_ADD); assert(selfstash); @@ -1037,7 +1043,7 @@ XS(XS_mro_nextcan) Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); XSRETURN_EMPTY; } - XPUSHs(sv_2mortal(newRV_inc(val))); + mXPUSHs(newRV_inc(val)); XSRETURN(1); } } @@ -1045,7 +1051,7 @@ XS(XS_mro_nextcan) /* 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)); + stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP); linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */ @@ -1098,7 +1104,7 @@ XS(XS_mro_nextcan) if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { SvREFCNT_inc_simple_void_NN((SV*)cand_cv); (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0); - XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv))); + mXPUSHs(newRV_inc((SV*)cand_cv)); XSRETURN(1); } }