From aa5e4ce039ffdf774322922ca7786251c8076535 Mon Sep 17 00:00:00 2001 From: bulk88 Date: Sun, 29 Jun 2025 05:53:50 -0400 Subject: [PATCH 1/2] add sv_refhek, sv_reftypehek functions for better ref() performance MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit -ref() PP keyword has extremely high usage. Greping my blead repo shows: Searched "ref(" 4347 hits in 605 files of 5879 searched -High level PP keyword ref(), aka C function Perl_pp_ref(), uses slow, inefficient, badly designed, backend public XS/C API called functions called Perl_sv_ref()/Perl_sv_reftype(). -This commit fixes all design problems with Perl_sv_ref()/Perl_sv_reftype(), and will speed up the very high usage PP keyword ref(), along with a very similar but very new and very little used PP keyword called "use builtin qw( reftype );" which is near identical to Perl_pp_ref(). -a crude benchmark, with the array ref in $aref holding 43000 SV*s, split 1/3rd SV* IOK, 1/3rd RV* to SV* IOK, and 1/3rd RV* to CV*, showed a %6 speed increase for this code sub benchme { foreach my $el (@{$aref}) { $cnt++ if ref($el) eq 'SCALAR';} } -The all UPPERCASE strings keyword ref() returns are part of the Perl 5 BNF grammer. Changing their spelling or lowercasing them is not for debate, or i18n-ing them dynamically realtime against glibc.so's current "OS global locale" with inotify()/kqueue() in the runloop to monitor a text file /etc or /var so this race condition works as designed in a unit test will never happen: $perl -E "dire('hello')" Routine indéfinie &cœur::dire aufgerufen bei -e Zeile 1 -sv_reftype() and sv_ref() have very badly designed prototypes, and the first time a new Perl in C dev reads their source code, they will think these 2 will cause infinite C stack recursion and a SEGV. Probably most automated C code analytic tools maybe will complain these 2 functions do infinite recursion. -The 2 functions don't return a string length, forcing all callers to execute a libc strlen() call on a string, that could be 8 bytes, or 80 MB. -All null term-ed strings that they return, are already sitting in virtual address space. Either const HW RO, or RCed HEK*s from the PL_strtab pool, that were found inside something similar to a GV*/HV*/HE*/CV*/AV*/GP*/OP*/SV* in a OP*(no threads) . -COW 255 buffers from Newx() under 9 chars can't COW currently by policy. CODE is 4, SCALAR is 6. HASH is 4. ARRAY is 5. But very short SV HEK* COWs will COW propagate without problems. ref() is also used to retrieve "Local::My::Class" strings, which have an extremely high chance to wind up getting passed to hv_common() through some high level PP keyword like bless or @ISA, and hv_common() extracts precalculated U32 hash values from SV* with HEK* buffers, speeding up hv_common(). So SV* POKs with COW 255 and COW SVs_STATIC buffers are bad choices compared to using SV* POK HEK* buffers for a new faster version of sv_reftype()/sv_ref(). -PP code "if(ref($self) eq 'HASH') {}" should never involve all 3-5 calls Newx()/Realloc()/strlen()/memcpy()/Safefree(), on each execution of the line. To improve the src code dev-friendlyness of the prototypes of, and speed inside of, and the speed of in all libperl callers of Perl_sv_ref()/Perl_sv_reftype(). Make HEK* variants of them. Initially the HEK* variants are private to libperl. Maybe after 1-3 years into the future, they can be made official public C API for CPAN XS authors. These 2 new functions are undocumented/private API until further notice. Using SV* holding RC-ed HEK* SvPVX() buffers removes all these libc C lang logical and/or Asm machine code steps from during execution of PP keyword ref(). The pre-allocated PAD TARG SV* just keeps getting a RC-- on the old HEK* inside SvPVX(), and a RC++ on the new HEK* written to SvPVX() of the PAD TARG SV*. Touching only 6 void*s/size_t adresses total, each one a single read/write CPU instruction pair. SvPVX, SvCUR, SvLEN, old_hek.shared_he.shared_he_he.he_valu.hent_refcount, new_hek.shared_he.shared_he_he.he_valu.hent_refcount, new_hek.shared_he.shared_he_hek.hek_len. This brings PP KW ref() closer to C++ style RTTI that just compares const read-only vtable pointers. Some design and optimization problems with the old and new pp_ref()/pp_reftype()/sv_ref()/sv_reftype()/sv_refhek()/sv_reftypehek() calls are intentionally not being fixed in this commit to keep this commit small. Check the associated PR of the commit for details. --- builtin.c | 36 +++++++++-- embed.fnc | 5 +- embed.h | 2 + pp.c | 4 +- proto.h | 11 ++++ sv.c | 176 +++++++++++++++++++++++++++++++++++++++++++++++++++++- sv.h | 18 +++++- 7 files changed, 241 insertions(+), 11 deletions(-) diff --git a/builtin.c b/builtin.c index 899445a7fb59..f90984beb86e 100644 --- a/builtin.c +++ b/builtin.c @@ -563,17 +563,43 @@ PP(pp_refaddr) PP(pp_reftype) { - dXSTARG; - SV *arg = *PL_stack_sp; + HEK *hek; + SV *rsv; + SV ** svp = PL_stack_sp; + SV *arg = *svp; SvGETMAGIC(arg); if(SvROK(arg)) - sv_setpv_mg(TARG, sv_reftype(SvRV(arg), FALSE)); + hek = sv_reftypehek(SvRV(arg), FALSE); else - sv_setsv(TARG, &PL_sv_undef); + hek = NULL; + + /* unrolled dXSTARG; avoid slower sv_setxv_mg(sv_newmortal(), ); */ + if (PL_op->op_private & OPpENTERSUB_HASTARG) { + rsv = PAD_SV(PL_op->op_targ); + if (hek) + sv_sethek(rsv, hek); + /* If a PAD TARG exists, returning &PL_sv_undef will force a slow trip + through sv_setsv() in next OP, so do the undef assignment here, + with the streamlined sv_set_undef() call, vs universal and complex + sv_setsv() call. Note, the prior code here, only fired SMG magic + on the sv_sethek()/sv_setpvs() branch, not on the sv_set_undef() + branch. */ + else + sv_set_undef(rsv); + SvSETMAGIC(rsv); + rpp_replace_1_1_NN(rsv); /* no RC_STK =, RC_STK RC++ = */ + } + else { + if (!hek) + rpp_replace_1_IMM_NN(&PL_sv_undef); + else { + rsv = newSVhek(hek); + rpp_replace_at_norc(svp, rsv); /* no RC_STK mortal =, RC_STK RC++ = */ + } + } - rpp_replace_1_1_NN(TARG); return NORMAL; } diff --git a/embed.fnc b/embed.fnc index 5ddab55acec8..c9064d68382a 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3366,9 +3366,12 @@ AMTdip |SV * |SvREFCNT_inc |NULLOK SV *sv AMTdip |SV * |SvREFCNT_inc_NN|NN SV *sv AMTdip |void |SvREFCNT_inc_void \ |NULLOK SV *sv +EXp |HEK * |sv_refhek |NN const SV * const sv \ + |const int ob ARdp |const char *|sv_reftype|NN const SV * const sv \ |const int ob - +ERXp |HEK * |sv_reftypehek |NN const SV * const sv \ + |const int ob Adp |void |sv_regex_global_pos_clear \ |NN SV *sv ARdp |bool |sv_regex_global_pos_get \ diff --git a/embed.h b/embed.h index 9c5c2a8acf04..07e3196896cb 100644 --- a/embed.h +++ b/embed.h @@ -1810,6 +1810,8 @@ # define skipspace_flags(a,b) Perl_skipspace_flags(aTHX_ a,b) # define sv_magicext_mglob(a) Perl_sv_magicext_mglob(aTHX_ a) # define sv_only_taint_gmagic Perl_sv_only_taint_gmagic +# define sv_refhek(a,b) Perl_sv_refhek(aTHX_ a,b) +# define sv_reftypehek(a,b) Perl_sv_reftypehek(aTHX_ a,b) # define utf16_to_utf8_base(a,b,c,d,e,f) Perl_utf16_to_utf8_base(aTHX_ a,b,c,d,e,f) # define utf8_to_utf16_base(a,b,c,d,e,f) Perl_utf8_to_utf16_base(aTHX_ a,b,c,d,e,f) # define validate_proto(a,b,c,d) Perl_validate_proto(aTHX_ a,b,c,d) diff --git a/pp.c b/pp.c index 5d174fd45829..04d11cbcd0df 100644 --- a/pp.c +++ b/pp.c @@ -573,13 +573,13 @@ PP(pp_ref) do_sv_ref: { + HEK* hek = sv_refhek(SvRV(sv), TRUE); dTARGET; - sv_ref(TARG, SvRV(sv), TRUE); + sv_sethek(TARG, hek); rpp_replace_1_1_NN(TARG); SvSETMAGIC(TARG); return NORMAL; } - } diff --git a/proto.h b/proto.h index a7e81e069149..8e8fefe63567 100644 --- a/proto.h +++ b/proto.h @@ -4758,12 +4758,23 @@ Perl_sv_ref(pTHX_ SV *dst, const SV * const sv, const int ob); #define PERL_ARGS_ASSERT_SV_REF \ assert(sv) +PERL_CALLCONV HEK * +Perl_sv_refhek(pTHX_ const SV * const sv, const int ob); +#define PERL_ARGS_ASSERT_SV_REFHEK \ + assert(sv) + PERL_CALLCONV const char * Perl_sv_reftype(pTHX_ const SV * const sv, const int ob) __attribute__warn_unused_result__; #define PERL_ARGS_ASSERT_SV_REFTYPE \ assert(sv) +PERL_CALLCONV HEK * +Perl_sv_reftypehek(pTHX_ const SV * const sv, const int ob) + __attribute__warn_unused_result__; +#define PERL_ARGS_ASSERT_SV_REFTYPEHEK \ + assert(sv) + PERL_CALLCONV void Perl_sv_regex_global_pos_clear(pTHX_ SV *sv); #define PERL_ARGS_ASSERT_SV_REGEX_GLOBAL_POS_CLEAR \ diff --git a/sv.c b/sv.c index 06d6a8421171..f22784fe6492 100644 --- a/sv.c +++ b/sv.c @@ -3000,8 +3000,9 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags) return RX_WRAPPED(re); } else { - const char *const typestring = sv_reftype(referent, 0); - const STRLEN typelen = strlen(typestring); + HEK * const typestring_hek = sv_reftypehek(referent, 0); + const char *const typestring = HEK_KEY(typestring_hek); + const I32 typelen = HEK_LEN(typestring_hek); UV addr = PTR2UV(referent); const char *stashname = NULL; STRLEN stashnamelen = 0; /* hush, gcc */ @@ -10634,6 +10635,150 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) } } +/* Experimental faster variant of sv_reftype(). Identical to sv_reftype() except + it returns a HEK* from PL_strtab. Does not bump the RC on the HEK*. + Caller must bump the RC of the HEK* if they want to preserve it for future + use. The easiest way to do the RC bump is with sv_sethek() or newSVhek(). + It is exported for private P5P experiments with Inline::C or EU::PXS, but + it is not a public API for CPAN authors and may change at any time. */ + +HEK* +Perl_sv_reftypehek(pTHX_ const SV *const sv, const int ob) +{ + PERL_ARGS_ASSERT_SV_REFTYPEHEK; + + if (ob && SvOBJECT(sv)) + return sv_refhek(sv, ob); + else { + SV* rsv; + /* The SV_CONST() macro can not be used here or else the switch table + below will have 17 unique callsites to exported libperl symbol + Perl_newSVpvn_share(). In the future, this switch statement can be + optimized to an array mapping U8 sv_type codes, to U8 or U16s indexes + pointing into array PL_sv_consts, with negative indexs being + if (){} else {} special cases needing extra checks.*/ + U32 idx; + /* WARNING - There is code, for instance in mg.c, that assumes that + * the only reason that sv_reftype(sv,0) would return a string starting + * with 'L' or 'S' is that it is a LVALUE or a SCALAR. + * Yes this a dodgy way to do type checking, but it saves practically reimplementing + * this routine inside other subs, and it saves time. + * Do not change this assumption without searching for "dodgy type check" in + * the code. + * - Yves */ + switch (SvTYPE(sv)) { + case SVt_NULL: + case SVt_IV: + case SVt_NV: + case SVt_PV: + case SVt_PVIV: + case SVt_PVNV: + case SVt_PVMG: + if (SvVOK(sv)) { + idx = SV_CONST_VSTRING; + break; + } + else if (SvROK(sv)) { + idx = SV_CONST_REF; + break; + } + else { + idx = SV_CONST_SCALAR; + break; + } + case SVt_PVLV: idx = (SvROK(sv) ? SV_CONST_REF + /* tied lvalues should appear to be + * scalars for backwards compatibility */ + : (isALPHA_FOLD_EQ(LvTYPE(sv), 't')) + ? SV_CONST_SCALAR : SV_CONST_LVALUE); break; + case SVt_PVAV: { idx = SV_CONST_ARRAY; break; } + case SVt_PVHV: { idx = SV_CONST_HASH; break; } + case SVt_PVCV: { idx = SV_CONST_CODE; break; } + case SVt_PVGV: { + idx = isGV_with_GP(sv) ? SV_CONST_GLOB : SV_CONST_SCALAR; + break; + } + case SVt_PVFM: { idx = SV_CONST_FORMAT; break; } + case SVt_PVIO: { idx = SV_CONST_IO; break; } + case SVt_INVLIST: { idx = SV_CONST_INVLIST; break; } + case SVt_REGEXP: { idx = SV_CONST_REGEXP; break; } + case SVt_PVOBJ: { idx = SV_CONST_OBJECT; break; } + default: { idx = SV_CONST_UNKNOWN; break; } + } + + rsv = PL_sv_consts[idx]; + if (!rsv) { + U8 len; + const char * pv; + switch(idx) { + case SV_CONST_ARRAY: + pv = "ARRAY"; + len = STRLENs("ARRAY"); + break; + case SV_CONST_CODE: + pv = "CODE"; + len = STRLENs("CODE"); + break; + case SV_CONST_FORMAT: + pv = "FORMAT"; + len = STRLENs("FORMAT"); + break; + case SV_CONST_GLOB: + pv = "GLOB"; + len = STRLENs("GLOB"); + break; + case SV_CONST_HASH: + pv = "HASH"; + len = STRLENs("HASH"); + break; + case SV_CONST_INVLIST: + pv = "INVLIST"; + len = STRLENs("INVLIST"); + break; + case SV_CONST_IO: + pv = "IO"; + len = STRLENs("IO"); + break; + case SV_CONST_LVALUE: + pv = "LVALUE"; + len = STRLENs("LVALUE"); + break; + case SV_CONST_OBJECT: + pv = "OBJECT"; + len = STRLENs("OBJECT"); + break; + case SV_CONST_REF: + pv = "REF"; + len = STRLENs("REF"); + break; + case SV_CONST_REGEXP: + pv = "REGEXP"; + len = STRLENs("REGEXP"); + break; + case SV_CONST_SCALAR: + pv = "SCALAR"; + len = STRLENs("SCALAR"); + break; + case SV_CONST_UNKNOWN: + pv = "UNKNOWN"; + len = STRLENs("UNKNOWN"); + break; + case SV_CONST_VSTRING: + pv = "VSTRING"; + len = STRLENs("VSTRING"); + break; + default: /* unreachable, don't make a verbose long string */ + croak_no_mem_ext(STR_WITH_LEN("sv_reftypehek")); + } + rsv = newSVpvn_share(pv, len, 0); + PL_sv_consts[idx] = rsv; + } /* Never return our secret PL_sv_consts[idx] SV*s to any caller for + any reason. We don't SvREADONLY_on(), and we don't trust PP code. + Example: my $klass = \ref($self); ${$klass} .= "::Base"; */ + return SvSHARED_HEK_FROM_PV(SvPVX_const(rsv)); + } +} + /* =for apidoc sv_ref @@ -10669,6 +10814,33 @@ Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob) return dst; } +/* Experimental faster variant of sv_ref(). Identical to sv_ref() except + it returns a HEK* from PL_strtab. Does not bump the RC on the HEK*. + Caller must bump the RC of the HEK* if they want to preserve it for future + use. The easiest way to do the RC bump is with sv_sethek() or newSVhek(). + It is exported for private P5P experiments with Inline::C or EU::PXS, but + it is not a public API for CPAN authors and may change at any time. */ + +HEK * +Perl_sv_refhek(pTHX_ const SV *const sv, const int ob) +{ + HEK * hek; + PERL_ARGS_ASSERT_SV_REFHEK; + + if (ob && SvOBJECT(sv)) { + HV* stash = SvSTASH(sv); + if (HvHasNAME(stash)) + hek = HvNAME_HEK(stash); + else { + SV * rsv = SV_CONST(__ANON__); + hek = SvSHARED_HEK_FROM_PV(SvPVX_const(rsv)); + } + } + else + hek = sv_reftypehek(sv, 0); + return hek; +} + /* =for apidoc sv_isobject diff --git a/sv.h b/sv.h index 449091e85375..4614c2d2746d 100644 --- a/sv.h +++ b/sv.h @@ -2695,9 +2695,25 @@ Create a new IO, setting the reference count to 1. # define SV_CONST_CLEAR 32 # define SV_CONST_UNTIE 33 # define SV_CONST_DESTROY 34 + +# define SV_CONST_ARRAY 35 +# define SV_CONST_CODE 36 +# define SV_CONST_FORMAT 37 +# define SV_CONST_GLOB 38 +# define SV_CONST_HASH 39 +# define SV_CONST_INVLIST 40 +# define SV_CONST_IO 41 +# define SV_CONST_LVALUE 42 +# define SV_CONST_OBJECT 43 +# define SV_CONST_REF 44 +# define SV_CONST_REGEXP 45 +/* "SCALAR" is above */ +# define SV_CONST_UNKNOWN 46 +# define SV_CONST_VSTRING 47 +# define SV_CONST___ANON__ 48 #endif -#define SV_CONSTS_COUNT 35 +#define SV_CONSTS_COUNT 49 /* * Bodyless IVs and NVs! From 2ad59edc87377bb2ee8ffb90951c614a20ac2186 Mon Sep 17 00:00:00 2001 From: bulk88 Date: Sun, 29 Jun 2025 21:35:03 -0400 Subject: [PATCH 2/2] mg.c pp.c pp_sys.c inline.h add more SV_CONST() SV* HEK* hash optimizations -faster method lookups, faster new SVPV creation (COWs), some of these locations were missed by the original branch/PRs/commits that added SV_CONST() macro/api. -I belive all "" C string literals that match a SV_CONST_UPPERCASE SV* HEK* cached constant have been replaced with their SV* POK HEK* COW buffer equivalents inside libperl with this commit, excluding some instances of "__ANON__" strings. Only PERL_CORE files qualify for the SV_CONST() optimization, because of design choices made previously about the SV_CONST() API. Changing the PERL_CORE-only design choice is out of scope of this patch. -in pp_dbmopen() add SV_CONST(TIEHASH) macros for faster lookup/U32 hash pre-calc, and change newSVpvs_flags("AnyDBM_File", SVs_TEMP) to newSVpvs_share("AnyDBM_File"), because this sv is used multiple times in this pp_*() function, and it is a package name, and it is guaranteed to get passed into hv_common() somewhere eventually in some child function call we are making. -some "__ANON__" locations were not changed from sv_*newSV*pvs("__ANON__"); to sv_*newSV*hek(SV_CONST(__ANON__)); because right after, there is a sv_catpvs(""); that will make the SVPV HEK* COW instantly de-COW which saved no CPU or memory resources in the end, and only wasted them. Or it didn't look "safe" for a SV* COW buffer to be on that line. -pp_tie() call_method() is an thin inefficient wrapper that makes a mortal SVPV around a C string, since the real backend API is call_sv(), so switch the call_method() in pp_tie() to the read backend function call_sv() and avoid making that mortal SVPV --- inline.h | 10 ++++++++-- mg.c | 3 +-- op.c | 2 +- pp.c | 8 ++++++-- pp_sys.c | 38 +++++++++++++++++++------------------- sv.h | 10 +++++++++- 6 files changed, 44 insertions(+), 27 deletions(-) diff --git a/inline.h b/inline.h index 44128c624d07..f282a5a13351 100644 --- a/inline.h +++ b/inline.h @@ -1176,6 +1176,11 @@ Perl_rpp_invoke_xs(pTHX_ CV *cv) CvXSUB(cv)(aTHX_ cv); } +/* SV_CONST() is limited to #ifdef PERL_CORE, so make a temporary macro. */ +#define x_SV_CONST(name) PL_sv_consts[SV_CONST_##name] \ + ? PL_sv_consts[SV_CONST_##name] \ + : (PL_sv_consts[SV_CONST_##name] = newSVpv_share(#name, 0)) + /* for SvCANEXISTDELETE() macro in pp.h */ PERL_STATIC_INLINE bool @@ -1188,10 +1193,11 @@ Perl_sv_can_existdelete(pTHX_ SV *sv) HV *stash = SvSTASH(SvRV(SvTIED_obj(sv, mg))); return stash && - gv_fetchmethod_autoload(stash, "EXISTS", TRUE) && - gv_fetchmethod_autoload(stash, "DELETE", TRUE); + gv_fetchmethod_sv_flags(stash, x_SV_CONST(EXISTS), GV_AUTOLOAD) && + gv_fetchmethod_sv_flags(stash, x_SV_CONST(DELETE), GV_AUTOLOAD); } +#undef x_SV_CONST /* ----------------------------- regexp.h ----------------------------- */ diff --git a/mg.c b/mg.c index 98da1f15910c..ee7c5fa8cb47 100644 --- a/mg.c +++ b/mg.c @@ -2306,8 +2306,7 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) HV * const pkg = SvSTASH((const SV *)SvRV(tied)); PERL_ARGS_ASSERT_MAGIC_SCALARPACK; - - if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) { + if (!gv_fetchmethod_sv_flags(pkg, SV_CONST(SCALAR), 0)) { SV *key; if (HvEITER_get(hv)) /* we are in an iteration so the hash cannot be empty */ diff --git a/op.c b/op.c index f616532c491c..0ca5236a6068 100644 --- a/op.c +++ b/op.c @@ -11080,7 +11080,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); has_name = TRUE; } else if (PL_curstash) { - gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); + gv = gv_fetchsv(SV_CONST(__ANON__), gv_fetch_flags, SVt_PVCV); has_name = FALSE; } else { gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); diff --git a/pp.c b/pp.c index 04d11cbcd0df..8ee94d77bedb 100644 --- a/pp.c +++ b/pp.c @@ -681,8 +681,12 @@ PP(pp_gelem) case 'P': if (memEQs(elem, len, "PACKAGE")) { const HV * const stash = GvSTASH(gv); - const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL; - sv = hek ? newSVhek(hek) : newSVpvs("__ANON__"); + const HEK * hek = stash ? HvNAME_HEK(stash) : NULL; + if (!hek) { + SV * sv_hek = SV_CONST(__ANON__); + hek = SvSHARED_HEK_FROM_PV(SvPVX_const(sv_hek)); + } + sv = newSVhek(hek); } break; case 'S': diff --git a/pp_sys.c b/pp_sys.c index 881fc7baa497..fdf0c21408a7 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1078,7 +1078,7 @@ PP_wrapped(pp_tie, 0, 1) GV *gv = NULL; SV *sv; const SSize_t markoff = MARK - PL_stack_base; - const char *methname; + SV* methname; int how = PERL_MAGIC_tied; SSize_t items; SV *varsv = *++MARK; @@ -1087,7 +1087,7 @@ PP_wrapped(pp_tie, 0, 1) case SVt_PVHV: { HE *entry; - methname = "TIEHASH"; + methname = SV_CONST(TIEHASH); if (HvLAZYDEL(varsv) && (entry = HvEITER_get((HV *)varsv))) { HvLAZYDEL_off(varsv); hv_free_ent(NULL, entry); @@ -1097,7 +1097,7 @@ PP_wrapped(pp_tie, 0, 1) break; } case SVt_PVAV: - methname = "TIEARRAY"; + methname = SV_CONST(TIEARRAY); if (!AvREAL(varsv)) { if (!AvREIFY(varsv)) croak("Cannot tie unreifiable array"); @@ -1109,7 +1109,7 @@ PP_wrapped(pp_tie, 0, 1) case SVt_PVGV: case SVt_PVLV: if (isGV_with_GP(varsv) && !SvFAKE(varsv)) { - methname = "TIEHANDLE"; + methname = SV_CONST(TIEHANDLE); how = PERL_MAGIC_tiedscalar; /* For tied filehandles, we apply tiedscalar magic to the IO slot of the GP rather than the GV itself. AMS 20010812 */ @@ -1124,7 +1124,7 @@ PP_wrapped(pp_tie, 0, 1) } /* FALLTHROUGH */ default: - methname = "TIESCALAR"; + methname = SV_CONST(TIESCALAR); how = PERL_MAGIC_tiedscalar; break; } @@ -1137,7 +1137,7 @@ PP_wrapped(pp_tie, 0, 1) while (items--) PUSHs(*MARK++); PUTBACK; - call_method(methname, G_SCALAR); + call_sv(methname, G_SCALAR | G_METHOD); } else { /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO" @@ -1148,37 +1148,37 @@ PP_wrapped(pp_tie, 0, 1) stash = gv_stashsv(*MARK, 0); if (!stash) { if (SvROK(*MARK)) - DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX + DIE(aTHX_ "Can't locate object method %" SVf_QUOTEDPREFIX " via package %" SVf_QUOTEDPREFIX, - methname, SVfARG(*MARK)); + SVfARG(methname), SVfARG(*MARK)); else if (isGV(*MARK)) { /* If the glob doesn't name an existing package, using * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So * generate the name for the error message explicitly. */ SV *stashname = sv_newmortal(); gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE); - DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX + DIE(aTHX_ "Can't locate object method %" SVf_QUOTEDPREFIX " via package %" SVf_QUOTEDPREFIX, - methname, SVfARG(stashname)); + SVfARG(methname), SVfARG(stashname)); } else { SV *stashname = !SvPOK(*MARK) ? &PL_sv_no : SvCUR(*MARK) ? *MARK : newSVpvs_flags("main", SVs_TEMP); - DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX + DIE(aTHX_ "Can't locate object method %" SVf_QUOTEDPREFIX " via package %" SVf_QUOTEDPREFIX " (perhaps you forgot to load %" SVf_QUOTEDPREFIX "?)", - methname, SVfARG(stashname), SVfARG(stashname)); + SVfARG(methname), SVfARG(stashname), SVfARG(stashname)); } } - else if (!(gv = gv_fetchmethod(stash, methname))) { + else if (!(gv = gv_fetchmethod_sv_flags(stash, methname, GV_AUTOLOAD))) { /* The effective name can only be NULL for stashes that have * been deleted from the symbol table, which this one can't * be, since we just looked it up by name. */ - DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX + DIE(aTHX_ "Can't locate object method %" SVf_QUOTEDPREFIX " via package %" HEKf_QUOTEDPREFIX , - methname, HvENAME_HEK_NN(stash)); + SVfARG(methname), HvENAME_HEK_NN(stash)); } ENTER_with_name("call_TIE"); PUSHSTACKi(PERLSI_MAGIC); @@ -1229,7 +1229,7 @@ PP_wrapped(pp_untie, 1, 0) if ((mg = SvTIED_mg(sv, how))) { SV * const obj = SvRV(SvTIED_obj(sv, mg)); if (obj && SvSTASH(obj)) { - GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE); + GV * const gv = gv_fetchmethod_sv_flags(SvSTASH(obj), SV_CONST(UNTIE), 0); CV *cv; if (gv && isGV(gv) && (cv = GvCV(gv))) { PUSHMARK(SP); @@ -1295,13 +1295,13 @@ PP_wrapped(pp_dbmopen, 3, 0) GV *gv = NULL; HV * const hv = MUTABLE_HV(POPs); - SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP); + SV * const sv = sv_2mortal(newSVpvs_share("AnyDBM_File")); stash = gv_stashsv(sv, 0); - if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) { + if (!stash || !(gv = gv_fetchmethod_sv_flags(stash, SV_CONST(TIEHASH), GV_AUTOLOAD))) { PUTBACK; require_pv("AnyDBM_File.pm"); SPAGAIN; - if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) + if (!stash || !(gv = gv_fetchmethod_sv_flags(stash, SV_CONST(TIEHASH), GV_AUTOLOAD))) DIE(aTHX_ "No dbm on this machine"); } diff --git a/sv.h b/sv.h index 4614c2d2746d..261cd17864c5 100644 --- a/sv.h +++ b/sv.h @@ -2664,8 +2664,12 @@ Create a new IO, setting the reference count to 1. # define SV_CONST_FETCHSIZE 5 # define SV_CONST_STORE 6 # define SV_CONST_STORESIZE 7 -# define SV_CONST_EXISTS 8 +#endif + +/* required by Perl_sv_can_existdelete() */ +#define SV_CONST_EXISTS 8 +#if defined(PERL_CORE) || defined(PERL_EXT) # define SV_CONST_PUSH 9 # define SV_CONST_POP 10 # define SV_CONST_SHIFT 11 @@ -2690,8 +2694,12 @@ Create a new IO, setting the reference count to 1. # define SV_CONST_BINMODE 28 # define SV_CONST_FILENO 29 # define SV_CONST_CLOSE 30 +#endif +/* required by Perl_sv_can_existdelete() */ # define SV_CONST_DELETE 31 + +#if defined(PERL_CORE) || defined(PERL_EXT) # define SV_CONST_CLEAR 32 # define SV_CONST_UNTIE 33 # define SV_CONST_DESTROY 34