From b0e6192f42b7db524847289efb1f15aac4ceed25 Mon Sep 17 00:00:00 2001 From: Daniel Dragan Date: Wed, 25 Jun 2025 18:58:12 -0400 Subject: [PATCH 1/6] mro.xs: switch Perl_croak(aTHX) to Perl_croak_nocontext() -less machine code on threaded perls for branches that will never execute in normal production code, each aTHX_, is a CPU's mov, push, load, or store machine code op (3-4 bytes typically, worst case 7 or 8 bytes). --- ext/mro/mro.pm | 2 +- ext/mro/mro.xs | 20 ++++++++++---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/ext/mro/mro.pm b/ext/mro/mro.pm index b86475cb7889..a38a4a9ddd6e 100644 --- a/ext/mro/mro.pm +++ b/ext/mro/mro.pm @@ -12,7 +12,7 @@ use warnings; # mro.pm versions < 1.00 reserved for MRO::Compat # for partial back-compat to 5.[68].x -our $VERSION = '1.29'; +our $VERSION = '1.30'; require XSLoader; XSLoader::load('mro'); diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs index 14cfa5ad887f..2b215cf409f6 100644 --- a/ext/mro/mro.xs +++ b/ext/mro/mro.xs @@ -43,10 +43,10 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) stashhek = HvENAME_HEK(stash); if (!stashhek) stashhek = HvNAME_HEK(stash); if (!stashhek) - Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); + Perl_croak_nocontext("Can't linearize anonymous symbol table"); if (level > 100) - Perl_croak(aTHX_ "Recursive inheritance detected in package '%" HEKf + Perl_croak_nocontext("Recursive inheritance detected in package '%" HEKf "'", HEKfARG(stashhek)); @@ -263,7 +263,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) SvREFCNT_dec(retval); Safefree(heads); - Perl_croak(aTHX_ "%" SVf, SVfARG(errmsg)); + Perl_croak_nocontext("%" SVf, SVfARG(errmsg)); } } } @@ -323,7 +323,7 @@ mro_get_linear_isa(...) else if(items > 1) { const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1)); if (!algo) - Perl_croak(aTHX_ "Invalid mro name: '%" SVf "'", ST(1)); + Perl_croak_nocontext("Invalid mro name: '%" SVf "'", ST(1)); RETVAL = algo->resolve(aTHX_ class_stash, 0); } else { @@ -346,7 +346,7 @@ mro_set_mro(...) classname = ST(0); class_stash = gv_stashsv(classname, GV_ADD); - if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%" SVf "'!", SVfARG(classname)); + if(!class_stash) Perl_croak_nocontext("Cannot create class: '%" SVf "'!", SVfARG(classname)); meta = HvMROMETA(class_stash); Perl_mro_set_mro(aTHX_ meta, ST(1)); @@ -496,7 +496,7 @@ mro__nextcan(...) hvname = HvNAME_get(selfstash); if (!hvname) - Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); + Perl_croak_nocontext("Can't use anonymous symbol table for method lookup"); /* This block finds the contextually-enclosing fully-qualified subname, much like looking at (caller($i))[3] until you find a real sub that @@ -509,7 +509,7 @@ mro__nextcan(...) /* 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"); + Perl_croak_nocontext("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); @@ -548,7 +548,7 @@ mro__nextcan(...) subname = strrchr(fq_subname, ':'); } if(!subname) - Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); + Perl_croak_nocontext("next::method/next::can/maybe::next::method cannot find enclosing method"); subname_utf8 = SvUTF8(sv) ? 1 : 0; subname++; @@ -576,7 +576,7 @@ mro__nextcan(...) SV* const val = HeVAL(cache_entry); if(val == &PL_sv_undef) { if(throw_nomethod) - Perl_croak(aTHX_ + Perl_croak_nocontext( "No next::method '%" SVf "' found for %" HEKf, SVfARG(newSVpvn_flags(subname, subname_len, SVs_TEMP | ( subname_utf8 ? SVf_UTF8 : 0 ) )), @@ -658,7 +658,7 @@ mro__nextcan(...) (void)hv_store_ent(nmcache, sv, &PL_sv_undef, 0); if(throw_nomethod) - Perl_croak(aTHX_ "No next::method '%" SVf "' found for %" HEKf, + Perl_croak_nocontext("No next::method '%" SVf "' found for %" HEKf, SVfARG(newSVpvn_flags(subname, subname_len, SVs_TEMP | ( subname_utf8 ? SVf_UTF8 : 0 ) )), HEKfARG( HvNAME_HEK(selfstash) )); From 8d32ca0ba3d735ced8ed33cb3607530577063fac Mon Sep 17 00:00:00 2001 From: bulk88 Date: Thu, 26 Jun 2025 01:53:21 -0400 Subject: [PATCH 2/6] mro_core.c mro.xs actually use static global field struct mro_alg->hash_U32 Perl_mro_register(aTHX_ &dfs_alg); will remember and store ptr &dfs_alg forever in a SVUV. So do not keep struct mro_alg'es in const RO memory, and fill in the U32 hash at perl proc start or shared lib attach time. Other parts of the interp will deref and pass struct member "struct mro_alg->hash" to hv_common(). PERL_HASH(hash, "c3", (sizeof("c3")-1)); was specially written instead of PERL_HASH(hash, c3_alg.name, c3_alg.length); because PERL_HASH() is inlineable, and I've seen MSVC 2022 -O1 do heavy inlining and heavy const folding of sbox32_hash_with_state(), if it knows the constant chars in a string, and the constant length of the string, ahead of time during CC .c->.obj phase. The machine code of a very heavy const fold of sbox32_hash_with_state(), superficially looks more like an inlined fixed length memcpy() or a struct to struct = assignment, than some kind of fancy "hash" or "cryptographic" or jpg/mpeg algorithm. I will assume "U32 hash = c3_alg.hash; if (hash == 0) {" and "c3_alg.hash = hash;" are atomic/multi-core safe. Aligned R/Ws to types U8/U16/U32 on all CPUs, and U64 on 64b, are supposed to be atomic safe on all CPUs. Aligned U32 R/Ws in C are never emulated with 4 separate U8 or 8 U4 R/W ops on any commercial CPU. --- ext/mro/mro.xs | 12 +++++++++++- mro_core.c | 12 +++++++++++- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs index 2b215cf409f6..503b6601f881 100644 --- a/ext/mro/mro.xs +++ b/ext/mro/mro.xs @@ -7,7 +7,7 @@ static AV* S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level); -static const struct mro_alg c3_alg = +static struct mro_alg c3_alg = {S_mro_get_linear_isa_c3, "c3", 2, 0, 0}; /* @@ -665,4 +665,14 @@ mro__nextcan(...) XSRETURN_EMPTY; BOOT: + { + U32 hash = c3_alg.hash; + if (hash == 0) { + assert(c3_alg.name == "c3" && c3_alg.length == (sizeof("c3")-1)); + /* Using "c3" will aggressively SBOX32 CC const fold. + But RW const char * c3_alg.name can not. */ + PERL_HASH(hash, "c3", (sizeof("c3")-1)); + c3_alg.hash = hash; + } + } Perl_mro_register(aTHX_ &c3_alg); diff --git a/mro_core.c b/mro_core.c index b4580f525a93..89ff920f8f22 100644 --- a/mro_core.c +++ b/mro_core.c @@ -31,7 +31,7 @@ Also see L. #define PERL_IN_MRO_CORE_C #include "perl.h" -static const struct mro_alg dfs_alg = +static struct mro_alg dfs_alg = {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0}; SV * @@ -1429,6 +1429,16 @@ Perl_boot_core_mro(pTHX) { static const char file[] = __FILE__; + { + U32 hash = dfs_alg.hash; + if (hash == 0) { + assert(dfs_alg.name == "dfs" && dfs_alg.length == STRLENs("dfs")); + /* Using "dfs" will aggressively SBOX32 CC const fold. + But RW const char * dfs_alg.name can not. */ + PERL_HASH(hash, "dfs", STRLENs("dfs")); + dfs_alg.hash = hash; + } + } Perl_mro_register(aTHX_ &dfs_alg); newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$"); From fdc661ee7ebb31392d155478dd5b9cd48e18aecf Mon Sep 17 00:00:00 2001 From: Daniel Dragan Date: Wed, 25 Jun 2025 22:05:16 -0400 Subject: [PATCH 3/6] mro.xs @_ stack cleanup, EXTEND rmvs, more HEK* COWs, U32 hash precalcs -HEK* cache str "UNIVERSAL" its heavily used inside the Perl VM, and take advantage of shared HEK* to HEK* comparison loop optimization inside hv_common -HEK* cache str "dfs", it is ineligible for COW 255 since its under 9 chars long -mro_get_mro() cleanup retval, PPCODE: moves SP back to 0, we push 1 elem then EUPXS does a PUTBACK for us, this removes alot of PL_stack_base derefs - av_push_simple(ret_array, newSVsv(hv_iterkeysv(iter))); is created 2 SV*s for no good reason, someone earlier never read the api docs for what hv_iterkeysv() does, or looked at its internals -mXPUSHs -> mPUSHs, X not needed, we bounds checked if (items != 1) and rewind with PPCODE earlier -switch to SvPV_const(), COW future proofing -hv_existss(isarev, "UNIVERSAL") switch to SVPV HEK* for faster lookups and precalced U32 hash -mro_get_pkg_gen() just use EU::PXS's built in IV retval logic instead of DIYing it, newer EU::PXSs use dXSTARG; and TARGi,(); optimization -mro_invalidate_all_method_caches() do @_ logic as early as possible croak_xs_usage() doesn't care if MARK was popped, or how much forwards or backwards the SV** inside PL_stack_sp is. Doing this allows the smallest machine code possible on any CPU arch, since the offset literals into my_perl, or unthreaded offsets into libperl.so.dll, that do the reads and writes are very close together (RISC CPUs might need a dedicated load const litteral integer to register op, to reach around inside my_perl or libperl.so.dll, they can't put a variable length 1-4 byte opcode + (U16 || U32) litteral into 1 RISC op. ARM's limit is U12 for example. --- ext/mro/mro.xs | 131 ++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 101 insertions(+), 30 deletions(-) diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs index 503b6601f881..c94637777fb4 100644 --- a/ext/mro/mro.xs +++ b/ext/mro/mro.xs @@ -10,6 +10,27 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level); static struct mro_alg c3_alg = {S_mro_get_linear_isa_c3, "c3", 2, 0, 0}; +#define MY_CXT_KEY "mro::_guts" + +typedef struct { + SV *sv_UNIVERSAL; + SV *sv_dfs; + SV *sv_ISA; +} my_cxt_t; + +START_MY_CXT + +static void +init_MY_CXT(pTHX_ pMY_CXT) +{ + MY_CXT.sv_UNIVERSAL = newSVpvs_share("UNIVERSAL"); + SvREADONLY_on(MY_CXT.sv_UNIVERSAL); + MY_CXT.sv_dfs = newSVpvs_share("dfs"); + SvREADONLY_on(MY_CXT.sv_dfs); + MY_CXT.sv_ISA = newSVpvs_share("ISA"); + SvREADONLY_on(MY_CXT.sv_ISA); +} + /* =for apidoc mro_get_linear_isa_c3 @@ -32,7 +53,6 @@ static AV* S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) { AV* retval; - GV** gvp; GV* gv; AV* isa; const HEK* stashhek; @@ -58,9 +78,9 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) } /* not in cache, make a new one */ - - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); - isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; + dMY_CXT; + HE* he = hv_fetch_ent(stash, MY_CXT.sv_ISA, FALSE, 0); + isa = (he && (gv = (GV*)HeVAL(he)) && 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: @@ -299,6 +319,41 @@ __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { MODULE = mro PACKAGE = mro PREFIX = mro_ +#ifdef MULTIPLICITY + +void CLONE (...) +CODE: +#undef memcpy +#define memcpy(a,b,c) NOOP + { + MY_CXT_CLONE; /* possible declaration */ + init_MY_CXT(aTHX_ aMY_CXT); + } +#undef memcpy + /* skip implicit PUTBACK, returning @_ to caller, more efficient */ + return; + +#endif + +void END(...) +PREINIT: + SV * sv; +PPCODE: + if (PL_perl_destruct_level) { + dMY_CXT; + sv = MY_CXT.sv_UNIVERSAL; + MY_CXT.sv_UNIVERSAL = NULL; + SvREFCNT_dec_NN(sv); + sv = MY_CXT.sv_dfs; + MY_CXT.sv_dfs = NULL; + SvREFCNT_dec_NN(sv); + sv = MY_CXT.sv_ISA; + MY_CXT.sv_ISA = NULL; + SvREFCNT_dec_NN(sv); + } + /* skip implicit PUTBACK, returning @_ to caller, more efficient*/ + return; + void mro_get_linear_isa(...) PROTOTYPE: $;$ @@ -359,6 +414,7 @@ mro_get_mro(...) PREINIT: SV* classname; HV* class_stash; + SV* retsv; PPCODE: if (items != 1) croak_xs_usage(cv, "classname"); @@ -368,13 +424,14 @@ mro_get_mro(...) if (class_stash) { const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which; - ST(0) = newSVpvn_flags(meta->name, meta->length, + retsv = newSVpvn_flags(meta->name, meta->length, SVs_TEMP | ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0)); } else { - ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP); + dMY_CXT; + retsv = newSVhek_mortal(SvSHARED_HEK_FROM_PV(SvPVX(MY_CXT.sv_dfs))); } - XSRETURN(1); + PUSHs(retsv); void mro_get_isarev(...) @@ -397,12 +454,13 @@ mro_get_isarev(...) if(isarev) { HE* iter; hv_iterinit(isarev); - while((iter = hv_iternext(isarev))) - av_push_simple(ret_array, newSVsv(hv_iterkeysv(iter))); + while((iter = hv_iternext(isarev))) { + assert(HeKLEN(iter) != HEf_SVKEY); + SV* ksv = newSVhek(HeKEY_hek(iter)); /* prev hv_iterkeysv(iter) */ + av_push_simple(ret_array, ksv); + } } - mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array))); - - PUTBACK; + mPUSHs(newRV_noinc(MUTABLE_SV(ret_array))); void mro_is_universal(...) @@ -410,37 +468,45 @@ mro_is_universal(...) PREINIT: SV* classname; HV* isarev; - char* classname_pv; - STRLEN classname_len; HE* he; + SV* rsv; PPCODE: if (items != 1) croak_xs_usage(cv, "classname"); classname = ST(0); - classname_pv = SvPV(classname,classname_len); - he = hv_fetch_ent(PL_isarev, classname, 0, 0); isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL; - if((memEQs(classname_pv, classname_len, "UNIVERSAL")) - || (isarev && hv_existss(isarev, "UNIVERSAL"))) - XSRETURN_YES; - else - XSRETURN_NO; + STRLEN classname_len; + const char* classname_pv = SvPV_const(classname, classname_len); + if(memEQs(classname_pv, classname_len, "UNIVERSAL")) + rsv = &PL_sv_yes; + else { + if (isarev) { + dMY_CXT; + if (hv_exists_ent(isarev, MY_CXT.sv_UNIVERSAL, 0)) + rsv = &PL_sv_yes; + else + rsv = &PL_sv_no; + } + else + rsv = &PL_sv_no; + } + PUSHs(rsv); void mro_invalidate_all_method_caches(...) PROTOTYPE: PPCODE: + SP = MARK; + PUTBACK; if (items != 0) croak_xs_usage(cv, ""); - PL_sub_generation++; - - XSRETURN_EMPTY; + return; void mro_get_pkg_gen(...) @@ -448,17 +514,18 @@ mro_get_pkg_gen(...) PREINIT: SV* classname; HV* class_stash; + IV RETVAL; + dXSTARG; /* CODE: + IV retval + prototypes seems to be broken in EU::PXS */ PPCODE: if(items != 1) croak_xs_usage(cv, "classname"); - classname = ST(0); - - class_stash = gv_stashsv(classname, 0); - - mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0); - + PUSHs(TARG); PUTBACK; + class_stash = gv_stashsv(classname, 0); + RETVAL = class_stash ? HvMROMETA(class_stash)->pkg_gen : 0; + TARGi(RETVAL,1); + return; void mro__nextcan(...) @@ -676,3 +743,7 @@ BOOT: } } Perl_mro_register(aTHX_ &c3_alg); + { + MY_CXT_INIT; + init_MY_CXT(aTHX_ aMY_CXT); + } From c6dfb67c1d9eba0ceb3cea27b7814e8b274e27c8 Mon Sep 17 00:00:00 2001 From: bulk88 Date: Thu, 26 Jun 2025 05:41:28 -0400 Subject: [PATCH 4/6] mro.xs add more SVPV HEK* opportunities - newSVsv()/newSVsv_flags() will not propagate a SVPV HEK* COW for us b/c we are not PERL_CORE, so manually detect SVPV HEK* COWs and send them to newSVhek(), probably faster too than the forest of logic trees inside sv_setsv_flags(). GMG test is paranoia. --- ext/mro/mro.xs | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs index c94637777fb4..41f3df9c1eac 100644 --- a/ext/mro/mro.xs +++ b/ext/mro/mro.xs @@ -31,6 +31,18 @@ init_MY_CXT(pTHX_ pMY_CXT) SvREADONLY_on(MY_CXT.sv_ISA); } +static SV* +S_mro_newSVsvhekok(pTHX_ SV* sv) +{ + char * pv = SvPVX(sv); + if ( ((SvFLAGS(sv) & (SVf_POK|SVs_GMG)) == SVf_POK) + && SvIsCOW_shared_hash(sv)) + return newSVhek(SvSHARED_HEK_FROM_PV(pv)); + else + return newSVsv(sv); +} +#define mro_newSVsvhekok(_sv) S_mro_newSVsvhekok(aTHX_ _sv) + /* =for apidoc mro_get_linear_isa_c3 @@ -110,7 +122,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) /* if no stash, make a temporary fake MRO containing just itself */ AV* const isa_lin = newAV_alloc_xz(4); - av_push_simple(isa_lin, newSVsv(isa_item)); + av_push_simple(isa_lin, mro_newSVsvhekok(isa_item)); av_push_simple(seqs, MUTABLE_SV(isa_lin)); } else { @@ -139,16 +151,17 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) /* First entry is this class. We happen to make a shared hash key scalar because it's the cheapest and fastest way to do it. */ - *svp++ = newSVhek(stashhek); + *svp++ = newSVhek(stashhek); /* Ex: Diamond_A */ while(subrv_items--) { /* These values are unlikely to be shared hash key scalars, so no point in adding code to optimising for a case that is unlikely to be true. (Or prove me wrong and do it.) */ - + /* Update: Example SVPV HEK*s seen on this line: + MRO_A MRO_B Diamond_A */ SV *const val = *subrv_p++; - *svp++ = newSVsv(val); + *svp++ = mro_newSVsvhekok(val); } SvREFCNT_inc(retval); @@ -223,7 +236,9 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) && (val = HeVAL(tail_entry)) && (SvIVX(val) > 0)) continue; - winner = newSVsv(cand); + /* Examples: SVPVHEK*s MRO_A HEK Diamond_B or a 0xd byte + unprintable string. Rarely a NewXed buffer like "Test::O" */ + winner = mro_newSVsvhekok(cand); av_push_simple(retval, winner); /* note however that even when we find a winner, we continue looping over @seqs to do housekeeping */ @@ -371,7 +386,7 @@ mro_get_linear_isa(...) if(!class_stash) { /* No stash exists yet, give them just the classname */ AV* isalin = newAV_alloc_xz(4); - av_push_simple(isalin, newSVsv(classname)); + av_push_simple(isalin, mro_newSVsvhekok(classname)); ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin))); XSRETURN(1); } From 9f52b0b7f29371e61f5fc22a8fc25f6d858cca87 Mon Sep 17 00:00:00 2001 From: Daniel Dragan Date: Fri, 27 Jun 2025 01:59:39 -0400 Subject: [PATCH 5/6] mro.xs more SVPV COW HEK * optimizations -S_mro_get_linear_isa_c3() dont call av_count() many times -the fn call mro_newSVsvhekok(), or any ISO C fn call located between static inlines newAV_alloc_xz() and av_push_simple() severely degrades or destroys any chance of anything const folding or any thing being removed by the CC for common sub exp elimination AV* isalin = newAV_alloc_xz(4); av_push_simple(isalin, mro_newSVsvhekok(classname)); Changing it to SV* nsv = mro_newSVsvhekok(classname); AV* isalin = newAV_alloc_xz(4); av_push_simple(isalin, nsv); fixes the problem. The CC is now allowed to fuse bottom half of newAV_alloc_xz() and top half of av_push_simple(). -"const I32 throw_nomethod = SvIVX(ST(1));" silence CC truncate warning --- ext/mro/mro.xs | 75 +++++++++++++++++++++++++++++++++++--------------- 1 file changed, 53 insertions(+), 22 deletions(-) diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs index 41f3df9c1eac..4222d68a8a7d 100644 --- a/ext/mro/mro.xs +++ b/ext/mro/mro.xs @@ -15,6 +15,7 @@ static struct mro_alg c3_alg = typedef struct { SV *sv_UNIVERSAL; SV *sv_dfs; + SV *sv_c3; SV *sv_ISA; } my_cxt_t; @@ -27,6 +28,8 @@ init_MY_CXT(pTHX_ pMY_CXT) SvREADONLY_on(MY_CXT.sv_UNIVERSAL); MY_CXT.sv_dfs = newSVpvs_share("dfs"); SvREADONLY_on(MY_CXT.sv_dfs); + MY_CXT.sv_c3 = newSVpvn_share("c3", sizeof("c3")-1, c3_alg.hash); + SvREADONLY_on(MY_CXT.sv_c3); MY_CXT.sv_ISA = newSVpvs_share("ISA"); SvREADONLY_on(MY_CXT.sv_ISA); } @@ -121,8 +124,9 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) if(!isa_item_stash) { /* if no stash, make a temporary fake MRO containing just itself */ + SV* nsv = mro_newSVsvhekok(isa_item); AV* const isa_lin = newAV_alloc_xz(4); - av_push_simple(isa_lin, mro_newSVsvhekok(isa_item)); + av_push_simple(isa_lin, nsv); av_push_simple(seqs, MUTABLE_SV(isa_lin)); } else { @@ -202,11 +206,12 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) } } } - + { /* Initialize retval to build the return value in */ - retval = newAV_alloc_xz(4); - av_push_simple(retval, newSVhek(stashhek)); /* us first */ - + SV* nsv = newSVhek(stashhek); + retval = newAV_alloc_xz(4); + av_push_simple(retval, nsv); /* us first */ + } /* This loop won't terminate until we either finish building the MRO, or get an exception. */ while(1) { @@ -280,14 +285,12 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) /* If we had candidates, but nobody won, then the @ISA hierarchy is not C3-incompatible */ if(!winner) { - SV *errmsg; - Size_t i; - - errmsg = newSVpvf( + SV *errmsg = newSVpvf( "Inconsistent hierarchy during C3 merge of class '%" HEKf "':\n\t" "current merge results [\n", HEKfARG(stashhek)); - for (i = 0; i < av_count(retval); i++) { + SSize_t count = av_count(retval); + for (SSize_t i = 0; i < count; i++) { SV **elem = av_fetch(retval, i, 0); sv_catpvf(errmsg, "\t\t%" SVf ",\n", SVfARG(*elem)); } @@ -303,9 +306,12 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) } } else { /* @ISA was undefined or empty */ +/* Do this 1st, the next 2 AV* API calls are likely to be inlined and + optimize away alot of AvFILL/memset/Renew logic if nothing is between them. */ + SV* nsv = newSVhek(stashhek); /* build a retval containing only ourselves */ retval = newAV_alloc_xz(4); - av_push_simple(retval, newSVhek(stashhek)); + av_push_simple(retval, nsv); } done: @@ -362,6 +368,9 @@ PPCODE: sv = MY_CXT.sv_dfs; MY_CXT.sv_dfs = NULL; SvREFCNT_dec_NN(sv); + sv = MY_CXT.sv_c3; + MY_CXT.sv_c3 = NULL; + SvREFCNT_dec_NN(sv); sv = MY_CXT.sv_ISA; MY_CXT.sv_ISA = NULL; SvREFCNT_dec_NN(sv); @@ -385,8 +394,9 @@ mro_get_linear_isa(...) if(!class_stash) { /* No stash exists yet, give them just the classname */ + SV* nsv = mro_newSVsvhekok(classname); AV* isalin = newAV_alloc_xz(4); - av_push_simple(isalin, mro_newSVsvhekok(classname)); + av_push_simple(isalin, nsv); ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin))); XSRETURN(1); } @@ -430,6 +440,7 @@ mro_get_mro(...) SV* classname; HV* class_stash; SV* retsv; + U32 which_my_cxt; /* rel offset MY_CXT, prevents 2 sep dMY_CXT deref lines */ PPCODE: if (items != 1) croak_xs_usage(cv, "classname"); @@ -439,12 +450,28 @@ mro_get_mro(...) if (class_stash) { const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which; - retsv = newSVpvn_flags(meta->name, meta->length, - SVs_TEMP - | ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0)); + if (memEQs(meta->name, meta->length, "dfs")) /* skipping meta->kflags & HVhek_UTF8 */ + goto ret_dfs; + /* "c3" shows up here running mro's .t'es */ + else if (memEQs(meta->name, meta->length, "c3")) { + which_my_cxt = STRUCT_OFFSET(my_cxt_t, sv_c3); + goto ret_my_cxt_hek; + } + else { /* pretty sure this string already exists inside PL_strtab by now */ + I32 i32len = meta->kflags & HVhek_UTF8 ? -(I32)meta->length : (I32)meta->length; + retsv = sv_2mortal(newSVpvn_share(meta->name, i32len, meta->hash)); + } } else { - dMY_CXT; - retsv = newSVhek_mortal(SvSHARED_HEK_FROM_PV(SvPVX(MY_CXT.sv_dfs))); + ret_dfs: + which_my_cxt = STRUCT_OFFSET(my_cxt_t, sv_dfs); + + ret_my_cxt_hek: + { + dMY_CXT; + SV** svp = NUM2PTR(SV**,(PTR2nat(&MY_CXT)+which_my_cxt)); + SV* svhek = *svp; + retsv = newSVhek_mortal(SvSHARED_HEK_FROM_PV(SvPVX(svhek))); + } } PUSHs(retsv); @@ -546,7 +573,7 @@ void mro__nextcan(...) PREINIT: SV* self = ST(0); - const I32 throw_nomethod = SvIVX(ST(1)); + const bool throw_nomethod = cBOOL(SvIVX(ST(1))); I32 cxix = cxstack_ix; const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; @@ -649,8 +676,10 @@ mro__nextcan(...) /* Initialize the next::method cache for this stash if necessary */ selfmeta = HvMROMETA(selfstash); - if(!(nmcache = selfmeta->mro_nextmethod)) { - nmcache = selfmeta->mro_nextmethod = newHV(); + nmcache = selfmeta->mro_nextmethod; + if (!nmcache) { + nmcache = newHV(); + selfmeta->mro_nextmethod = nmcache; } else { /* Use the cached coderef if it exists */ HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0); @@ -673,8 +702,10 @@ mro__nextcan(...) /* beyond here is just for cache misses, so perf isn't as critical */ stashname_len = subname - fq_subname - 2; - stashname = newSVpvn_flags(fq_subname, stashname_len, - SVs_TEMP | (subname_utf8 ? SVf_UTF8 : 0)); + { /* strs like "Qux::foo" "TTop::foo" show up here */ + I32 i32len = subname_utf8 ? -(I32)stashname_len : (I32)stashname_len; + stashname = sv_2mortal(newSVpvn_share(fq_subname, i32len, 0)); + } /* has ourselves at the top of the list */ linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0); From a8d2afddf64f157d7713e46847e270c6bdde8e53 Mon Sep 17 00:00:00 2001 From: bulk88 Date: Fri, 27 Jun 2025 02:01:42 -0400 Subject: [PATCH 6/6] mro.xs mro_set_mro() rmv duplicate PL_stack_base derefs, decrease liveness --- ext/mro/mro.xs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs index 4222d68a8a7d..c325718bbcbf 100644 --- a/ext/mro/mro.xs +++ b/ext/mro/mro.xs @@ -418,20 +418,21 @@ mro_set_mro(...) PROTOTYPE: $$ PREINIT: SV* classname; + SV* type; HV* class_stash; struct mro_meta* meta; - PPCODE: + CODE: if (items != 2) croak_xs_usage(cv, "classname, type"); - - classname = ST(0); + type = POPs; + classname = POPs; + PUTBACK; /* return empty list */ class_stash = gv_stashsv(classname, GV_ADD); if(!class_stash) Perl_croak_nocontext("Cannot create class: '%" SVf "'!", SVfARG(classname)); meta = HvMROMETA(class_stash); - Perl_mro_set_mro(aTHX_ meta, ST(1)); - - XSRETURN_EMPTY; + Perl_mro_set_mro(aTHX_ meta, type); + return; /* skip implied PUTBACK; */ void mro_get_mro(...)