X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/07b605e5ff63dcb6d539ba8bfcb5caf87078f032..6654d154224596cc22d201215ff167756a1c5030:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index 7ae8f3a..1094510 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -39,7 +39,6 @@ PP(pp_const) { - dVAR; dSP; XPUSHs(cSVOP_sv); RETURN; @@ -47,8 +46,8 @@ PP(pp_const) PP(pp_nextstate) { - dVAR; PL_curcop = (COP*)PL_op; + PL_sawalias = 0; TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; @@ -58,33 +57,36 @@ PP(pp_nextstate) PP(pp_gvsv) { - dVAR; dSP; EXTEND(SP,1); - if (PL_op->op_private & OPpLVAL_INTRO) + if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) PUSHs(save_scalar(cGVOP_gv)); else PUSHs(GvSVn(cGVOP_gv)); + if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)) + PL_sawalias = TRUE; RETURN; } + +/* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */ + PP(pp_null) { - dVAR; return NORMAL; } -/* This is sometimes called directly by pp_coreargs and pp_grepstart. */ +/* This is sometimes called directly by pp_coreargs, pp_grepstart and + amagic_call. */ PP(pp_pushmark) { - dVAR; PUSHMARK(PL_stack_sp); return NORMAL; } PP(pp_stringify) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const sv = TOPs; SETs(TARG); sv_copypv(TARG, sv); @@ -95,14 +97,19 @@ PP(pp_stringify) PP(pp_gv) { - dVAR; dSP; + dSP; XPUSHs(MUTABLE_SV(cGVOP_gv)); + if (isGV(cGVOP_gv) + && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))) + PL_sawalias = TRUE; RETURN; } + +/* also used for: pp_andassign() */ + PP(pp_and) { - dVAR; PERL_ASYNC_CHECK(); { /* SP is not used to remove a variable that is saved across the @@ -123,7 +130,7 @@ PP(pp_and) PP(pp_sassign) { - dVAR; dSP; + dSP; /* sassign keeps its args in the optree traditionally backwards. So we pop them differently. */ @@ -133,9 +140,10 @@ PP(pp_sassign) SV * const temp = left; left = right; right = temp; } - if (TAINTING_get && TAINT_get && !SvTAINTED(right)) + if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right)) TAINT_NOT; - if (PL_op->op_private & OPpASSIGN_CV_TO_GV) { + if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) { + /* *foo =\&bar */ SV * const cv = SvRV(right); const U32 cv_type = SvTYPE(cv); const bool is_gv = isGV_with_GP(left); @@ -214,7 +222,7 @@ PP(pp_sassign) } if ( - SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 && + UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 && (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC) ) Perl_warner(aTHX_ @@ -227,7 +235,7 @@ PP(pp_sassign) PP(pp_cond_expr) { - dVAR; dSP; + dSP; PERL_ASYNC_CHECK(); if (SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other); @@ -237,7 +245,6 @@ PP(pp_cond_expr) PP(pp_unstack) { - dVAR; PERL_ASYNC_CHECK(); TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; @@ -251,7 +258,7 @@ PP(pp_unstack) PP(pp_concat) { - dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign); + dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign); { dPOPTOPssrl; bool lbyte; @@ -278,28 +285,25 @@ PP(pp_concat) else SvUTF8_off(TARG); } - else { /* $l .= $r */ - if (!SvOK(TARG)) { + else { /* $l .= $r and left == TARG */ + if (!SvOK(left)) { if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */ report_uninit(right); sv_setpvs(left, ""); } - SvPV_force_nomg_nolen(left); + else { + SvPV_force_nomg_nolen(left); + } lbyte = !DO_UTF8(left); if (IN_BYTES) - SvUTF8_off(TARG); + SvUTF8_off(left); } if (!rcopied) { - if (left == right) - /* $r.$r: do magic twice: tied might return different 2nd time */ - SvGETMAGIC(right); rpv = SvPV_nomg_const(right, rlen); rbyte = !DO_UTF8(right); } if (lbyte != rbyte) { - /* sv_utf8_upgrade_nomg() may reallocate the stack */ - PUTBACK; if (lbyte) sv_utf8_upgrade_nomg(TARG); else { @@ -308,7 +312,6 @@ PP(pp_concat) sv_utf8_upgrade_nomg(right); rpv = SvPV_nomg_const(right, rlen); } - SPAGAIN; } sv_catpvn_nomg(TARG, rpv, rlen); @@ -328,7 +331,7 @@ S_pushav(pTHX_ AV* const av) dSP; const SSize_t maxarg = AvFILL(av) + 1; EXTEND(SP, maxarg); - if (SvRMAGICAL(av)) { + if (UNLIKELY(SvRMAGICAL(av))) { PADOFFSET i; for (i=0; i < (PADOFFSET)maxarg; i++) { SV ** const svp = av_fetch(av, i, FALSE); @@ -342,7 +345,7 @@ S_pushav(pTHX_ AV* const av) PADOFFSET i; for (i=0; i < (PADOFFSET)maxarg; i++) { SV * const sv = AvARRAY(av)[i]; - SP[i+1] = sv ? sv : &PL_sv_undef; + SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef; } } SP += maxarg; @@ -354,7 +357,7 @@ S_pushav(pTHX_ AV* const av) PP(pp_padrange) { - dVAR; dSP; + dSP; PADOFFSET base = PL_op->op_targ; int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK; int i; @@ -378,7 +381,7 @@ PP(pp_padrange) (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)) | (count << SAVE_TIGHT_SHIFT) | SAVEt_CLEARPADRANGE); - assert(OPpPADRANGE_COUNTMASK + 1 == (1 <> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base); { dSS_ADD; @@ -395,7 +398,7 @@ PP(pp_padrange) PP(pp_padsv) { - dVAR; dSP; + dSP; EXTEND(SP, 1); { OP * const op = PL_op; @@ -425,7 +428,6 @@ PP(pp_padsv) PP(pp_readline) { - dVAR; dSP; if (TOPs) { SvGETMAGIC(TOPs); @@ -442,6 +444,10 @@ PP(pp_readline) PUTBACK; Perl_pp_rv2gv(aTHX); PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + if (PL_last_in_gv == (GV *)&PL_sv_undef) + PL_last_in_gv = NULL; + else + assert(isGV_with_GP(PL_last_in_gv)); } } return do_readline(); @@ -449,7 +455,7 @@ PP(pp_readline) PP(pp_eq) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric); @@ -463,14 +469,17 @@ PP(pp_eq) RETURN; } + +/* also used for: pp_i_predec() pp_i_preinc() pp_predec() */ + PP(pp_preinc) { - dVAR; dSP; + dSP; const bool inc = PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC; - if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))) + if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))) Perl_croak_no_modify(); - if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) + if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN)) { SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1)); @@ -483,9 +492,12 @@ PP(pp_preinc) return NORMAL; } + +/* also used for: pp_orassign() */ + PP(pp_or) { - dVAR; dSP; + dSP; PERL_ASYNC_CHECK(); if (SvTRUE(TOPs)) RETURN; @@ -496,9 +508,12 @@ PP(pp_or) } } + +/* also used for: pp_dor() pp_dorassign() */ + PP(pp_defined) { - dVAR; dSP; + dSP; SV* sv; bool defined; const int op_type = PL_op->op_type; @@ -507,7 +522,7 @@ PP(pp_defined) if (is_dor) { PERL_ASYNC_CHECK(); sv = TOPs; - if (!sv || !SvANY(sv)) { + if (UNLIKELY(!sv || !SvANY(sv))) { if (op_type == OP_DOR) --SP; RETURNOP(cLOGOP->op_other); @@ -516,7 +531,7 @@ PP(pp_defined) else { /* OP_DEFINED */ sv = POPs; - if (!sv || !SvANY(sv)) + if (UNLIKELY(!sv || !SvANY(sv))) RETPUSHNO; } @@ -556,7 +571,7 @@ PP(pp_defined) PP(pp_add) { - dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr; + dSP; dATARGET; bool useleft; SV *svl, *svr; tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -633,8 +648,8 @@ PP(pp_add) if (aiv >= 0) { auv = aiv; auvok = 1; /* Now acting as a sign flag. */ - } else { /* 2s complement assumption for IV_MIN */ - auv = (UV)-aiv; + } else { + auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv); } } a_valid = 1; @@ -654,7 +669,7 @@ PP(pp_add) buv = biv; buvok = 1; } else - buv = (UV)-biv; + buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv); } /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, else "IV" now, independent of how it came in. @@ -695,7 +710,8 @@ PP(pp_add) else { /* Negate result */ if (result <= (UV)IV_MIN) - SETi( -(IV)result ); + SETi(result == (UV)IV_MIN + ? IV_MIN : -(IV)result); else { /* result valid, but out of range for IV. */ SETn( -(NV)result ); @@ -719,14 +735,21 @@ PP(pp_add) } } + +/* also used for: pp_aelemfast_lex() */ + PP(pp_aelemfast) { - dVAR; dSP; + dSP; AV * const av = PL_op->op_type == OP_AELEMFAST_LEX ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv); const U32 lval = PL_op->op_flags & OPf_MOD; - SV** const svp = av_fetch(av, PL_op->op_private, lval); + SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval); SV *sv = (svp ? *svp : &PL_sv_undef); + + if (UNLIKELY(!svp && lval)) + DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private); + EXTEND(SP, 1); if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */ mg_get(sv); @@ -736,7 +759,7 @@ PP(pp_aelemfast) PP(pp_join) { - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; MARK++; do_join(TARG, *MARK, MARK, SP); SP = MARK; @@ -746,7 +769,7 @@ PP(pp_join) PP(pp_pushre) { - dVAR; dSP; + dSP; #ifdef DEBUGGING /* * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs @@ -765,9 +788,11 @@ PP(pp_pushre) /* Oversized hot code. */ +/* also used for: pp_say() */ + PP(pp_print) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; PerlIO *fp; MAGIC *mg; GV * const gv @@ -859,29 +884,34 @@ PP(pp_print) RETURN; } + +/* also used for: pp_rv2hv() */ +/* also called directly by pp_lvavref */ + PP(pp_rv2av) { - dVAR; dSP; dTOPss; + dSP; dTOPss; const I32 gimme = GIMME_V; static const char an_array[] = "an ARRAY"; static const char a_hash[] = "a HASH"; - const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV; + const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV + || PL_op->op_type == OP_LVAVREF; const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV; SvGETMAGIC(sv); if (SvROK(sv)) { - if (SvAMAGIC(sv)) { + if (UNLIKELY(SvAMAGIC(sv))) { sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg); } sv = SvRV(sv); - if (SvTYPE(sv) != type) + if (UNLIKELY(SvTYPE(sv) != type)) /* diag_listed_as: Not an ARRAY reference */ DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash); - else if (PL_op->op_flags & OPf_MOD - && PL_op->op_private & OPpLVAL_INTRO) + else if (UNLIKELY(PL_op->op_flags & OPf_MOD + && PL_op->op_private & OPpLVAL_INTRO)) Perl_croak(aTHX_ "%s", PL_no_localize_ref); } - else if (SvTYPE(sv) != type) { + else if (UNLIKELY(SvTYPE(sv) != type)) { GV *gv; if (!isGV_with_GP(sv)) { @@ -901,7 +931,7 @@ PP(pp_rv2av) SETs(sv); RETURN; } - else if (PL_op->op_private & OPpMAYBE_LVSUB) { + else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { const I32 flags = is_lvalue_sub(); if (flags && !(flags & OPpENTERSUB_INARGS)) { if (gimme != G_ARRAY) @@ -913,9 +943,7 @@ PP(pp_rv2av) if (is_pp_rv2av) { AV *const av = MUTABLE_AV(sv); - /* The guts of pp_rv2av, with no intending change to preserve history - (until such time as we get tools that can do blame annotation across - whitespace changes. */ + /* The guts of pp_rv2av */ if (gimme == G_ARRAY) { SP--; PUTBACK; @@ -955,8 +983,6 @@ PP(pp_rv2av) STATIC void S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) { - dVAR; - PERL_ARGS_ASSERT_DO_ODDBALL; if (*oddkey) { @@ -1008,7 +1034,7 @@ PP(pp_aassign) * Don't bother if LHS is just an empty hash or array. */ - if ( (PL_op->op_private & OPpASSIGN_COMMON) + if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias) && ( firstlelem != lastlelem || ! ((sv = *firstlelem)) @@ -1020,13 +1046,13 @@ PP(pp_aassign) ) { EXTEND_MORTAL(lastrelem - firstrelem + 1); for (relem = firstrelem; relem <= lastrelem; relem++) { - if ((sv = *relem)) { + if (LIKELY((sv = *relem))) { TAINT_NOT; /* Each item is independent */ /* Dear TODO test in t/op/sort.t, I love you. (It's relying on a panic, not a "semi-panic" from newSVsv() and then an assertion failure below.) */ - if (SvIS_FREED(sv)) { + if (UNLIKELY(SvIS_FREED(sv))) { Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p", (void*)sv); } @@ -1044,9 +1070,15 @@ PP(pp_aassign) ary = NULL; hash = NULL; - while (lelem <= lastlelem) { + while (LIKELY(lelem <= lastlelem)) { + bool alias = FALSE; TAINT_NOT; /* Each item stands on its own, taintwise. */ sv = *lelem++; + if (UNLIKELY(!sv)) { + alias = TRUE; + sv = *lelem++; + ASSUME(SvTYPE(sv) == SVt_PVAV); + } switch (SvTYPE(sv)) { case SVt_PVAV: ary = MUTABLE_AV(sv); @@ -1058,11 +1090,26 @@ PP(pp_aassign) i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ SV **didstore; - if (*relem) + if (LIKELY(*relem)) SvGETMAGIC(*relem); /* before newSV, in case it dies */ - sv = newSV(0); - sv_setsv_nomg(sv, *relem); - *(relem++) = sv; + if (LIKELY(!alias)) { + sv = newSV(0); + sv_setsv_nomg(sv, *relem); + *relem = sv; + } + else { + if (!SvROK(*relem)) + DIE(aTHX_ "Assigned value is not a reference"); + if (SvTYPE(SvRV(*relem)) > SVt_PVLV) + /* diag_listed_as: Assigned value is not %s reference */ + DIE(aTHX_ + "Assigned value is not a SCALAR reference"); + if (lval) + *relem = sv_mortalcopy(*relem); + /* XXX else check for weak refs? */ + sv = SvREFCNT_inc_simple_NN(SvRV(*relem)); + } + relem++; didstore = av_store(ary,i++,sv); if (magic) { if (!didstore) @@ -1072,7 +1119,7 @@ PP(pp_aassign) } TAINT_NOT; } - if (PL_delaymagic & DM_ARRAY_ISA) + if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA)) SvSETMAGIC(MUTABLE_SV(ary)); LEAVE; break; @@ -1087,7 +1134,7 @@ PP(pp_aassign) magic = SvMAGICAL(hash) != 0; odd = ((lastrelem - firsthashrelem)&1)? 0 : 1; - if ( odd ) { + if (UNLIKELY(odd)) { do_oddball(lastrelem, firsthashrelem); /* we have firstlelem to reuse, it's not needed anymore */ @@ -1097,7 +1144,7 @@ PP(pp_aassign) ENTER; SAVEFREESV(SvREFCNT_inc_simple_NN(sv)); hv_clear(hash); - while (relem < lastrelem+odd) { /* gobble up all the rest */ + while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */ HE *didstore; assert(*relem); /* Copy the key if aassign is called in lvalue context, @@ -1157,10 +1204,10 @@ PP(pp_aassign) break; } if (relem <= lastrelem) { - if ( + if (UNLIKELY( SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 && (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC) - ) + )) Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless assignment to a temporary" @@ -1174,74 +1221,82 @@ PP(pp_aassign) break; } } - if (PL_delaymagic & ~DM_DELAY) { + if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) { /* Will be used to set PL_tainting below */ Uid_t tmp_uid = PerlProc_getuid(); Uid_t tmp_euid = PerlProc_geteuid(); Gid_t tmp_gid = PerlProc_getgid(); Gid_t tmp_egid = PerlProc_getegid(); + /* XXX $> et al currently silently ignore failures */ if (PL_delaymagic & DM_UID) { #ifdef HAS_SETRESUID - (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1, - (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1, - (Uid_t)-1); + PERL_UNUSED_RESULT( + setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1, + (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1, + (Uid_t)-1)); #else # ifdef HAS_SETREUID - (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1, - (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1); + PERL_UNUSED_RESULT( + setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1, + (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1)); # else # ifdef HAS_SETRUID if ((PL_delaymagic & DM_UID) == DM_RUID) { - (void)setruid(PL_delaymagic_uid); + PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid)); PL_delaymagic &= ~DM_RUID; } # endif /* HAS_SETRUID */ # ifdef HAS_SETEUID if ((PL_delaymagic & DM_UID) == DM_EUID) { - (void)seteuid(PL_delaymagic_euid); + PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid)); PL_delaymagic &= ~DM_EUID; } # endif /* HAS_SETEUID */ if (PL_delaymagic & DM_UID) { if (PL_delaymagic_uid != PL_delaymagic_euid) DIE(aTHX_ "No setreuid available"); - (void)PerlProc_setuid(PL_delaymagic_uid); + PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid)); } # endif /* HAS_SETREUID */ #endif /* HAS_SETRESUID */ + tmp_uid = PerlProc_getuid(); tmp_euid = PerlProc_geteuid(); } + /* XXX $> et al currently silently ignore failures */ if (PL_delaymagic & DM_GID) { #ifdef HAS_SETRESGID - (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1, - (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1, - (Gid_t)-1); + PERL_UNUSED_RESULT( + setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1, + (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1, + (Gid_t)-1)); #else # ifdef HAS_SETREGID - (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1, - (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1); + PERL_UNUSED_RESULT( + setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1, + (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1)); # else # ifdef HAS_SETRGID if ((PL_delaymagic & DM_GID) == DM_RGID) { - (void)setrgid(PL_delaymagic_gid); + PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid)); PL_delaymagic &= ~DM_RGID; } # endif /* HAS_SETRGID */ # ifdef HAS_SETEGID if ((PL_delaymagic & DM_GID) == DM_EGID) { - (void)setegid(PL_delaymagic_egid); + PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid)); PL_delaymagic &= ~DM_EGID; } # endif /* HAS_SETEGID */ if (PL_delaymagic & DM_GID) { if (PL_delaymagic_gid != PL_delaymagic_egid) DIE(aTHX_ "No setregid available"); - (void)PerlProc_setgid(PL_delaymagic_gid); + PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid)); } # endif /* HAS_SETREGID */ #endif /* HAS_SETRESGID */ + tmp_gid = PerlProc_getgid(); tmp_egid = PerlProc_getegid(); } @@ -1280,7 +1335,7 @@ PP(pp_aassign) PP(pp_qr) { - dVAR; dSP; + dSP; PMOP * const pm = cPMOP; REGEXP * rx = PM_GETRE(pm); SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL; @@ -1299,7 +1354,7 @@ PP(pp_qr) SvROK_on(rv); cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv); - if ((cv = *cvp) && CvCLONE(*cvp)) { + if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) { *cvp = cv_clone(cv); SvREFCNT_dec_NN(cv); } @@ -1310,7 +1365,7 @@ PP(pp_qr) (void)sv_bless(rv, stash); } - if (RX_ISTAINTED(rx)) { + if (UNLIKELY(RX_ISTAINTED(rx))) { SvTAINTED_on(rv); SvTAINTED_on(SvRV(rv)); } @@ -1320,7 +1375,7 @@ PP(pp_qr) PP(pp_match) { - dVAR; dSP; dTARG; + dSP; dTARG; PMOP *pm = cPMOP; PMOP *dynpm = pm; const char *s; @@ -1331,7 +1386,7 @@ PP(pp_match) const char *truebase; /* Start of string */ REGEXP *rx = PM_GETRE(pm); bool rxtainted; - const I32 gimme = GIMME; + const I32 gimme = GIMME_V; STRLEN len; const I32 oldsave = PL_savestack_ix; I32 had_zerolen = 0; @@ -1339,7 +1394,7 @@ PP(pp_match) if (PL_op->op_flags & OPf_STACKED) TARG = POPs; - else if (PL_op->op_private & OPpTARGET_MY) + else if (ARGTARG) GETTARGET; else { TARG = DEFSV; @@ -1472,11 +1527,13 @@ PP(pp_match) EXTEND_MORTAL(nparens + i); for (i = !i; i <= nparens; i++) { PUSHs(sv_newmortal()); - if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) { + if (LIKELY((RX_OFFS(rx)[i].start != -1) + && RX_OFFS(rx)[i].end != -1 )) + { const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start; const char * const s = RX_OFFS(rx)[i].start + truebase; - if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 || - len < 0 || len > strend - s) + if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 + || len < 0 || len > strend - s)) DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, " "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf, (long) i, (long) RX_OFFS(rx)[i].start, @@ -1496,9 +1553,9 @@ PP(pp_match) LEAVE_SCOPE(oldsave); RETURN; } - /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ -nope: + nope: if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { if (!mg) mg = mg_find_mglob(TARG); @@ -1514,7 +1571,7 @@ nope: OP * Perl_do_readline(pTHX) { - dVAR; dSP; dTARGETSTACKED; + dSP; dTARGETSTACKED; SV *sv; STRLEN tmplen = 0; STRLEN offset; @@ -1542,9 +1599,9 @@ Perl_do_readline(pTHX) if (IoFLAGS(io) & IOf_ARGV) { if (IoFLAGS(io) & IOf_START) { IoLINES(io) = 0; - if (av_len(GvAVn(PL_last_in_gv)) < 0) { + if (av_tindex(GvAVn(PL_last_in_gv)) < 0) { IoFLAGS(io) &= ~IOf_START; - do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL); + do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0); SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */ sv_setpvs(GvSVn(PL_last_in_gv), "-"); SvSETMAGIC(GvSV(PL_last_in_gv)); @@ -1552,7 +1609,7 @@ Perl_do_readline(pTHX) goto have_fp; } } - fp = nextargv(PL_last_in_gv); + fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); if (!fp) { /* Note: fp != IoIFP(io) */ (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ } @@ -1576,8 +1633,7 @@ Perl_do_readline(pTHX) if (gimme == G_SCALAR) { /* undef TARG, and push that undefined value */ if (type != OP_RCATLINE) { - SV_CHECK_THINKFIRST_COW_DROP(TARG); - SvOK_off(TARG); + sv_setsv(TARG,NULL); } PUSHTARG; } @@ -1639,7 +1695,7 @@ Perl_do_readline(pTHX) { PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { - fp = nextargv(PL_last_in_gv); + fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); if (fp) continue; (void)do_close(PL_last_in_gv, FALSE); @@ -1680,8 +1736,11 @@ Perl_do_readline(pTHX) } } for (t1 = SvPVX_const(sv); *t1; t1++) - if (!isALPHANUMERIC(*t1) && - strchr("$&*(){}[]'\";\\|?<>~`", *t1)) +#ifdef __VMS + if (strchr("*%?", *t1)) +#else + if (strchr("$&*(){}[]'\";\\|?<>~`", *t1)) +#endif break; if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) { (void)POPs; /* Unmatched wildcard? Chuck it... */ @@ -1719,7 +1778,7 @@ Perl_do_readline(pTHX) PP(pp_helem) { - dVAR; dSP; + dSP; HE* he; SV **svp; SV * const keysv = POPs; @@ -1797,9 +1856,445 @@ PP(pp_helem) RETURN; } + +/* a stripped-down version of Perl_softref2xv() for use by + * pp_multideref(), which doesn't use PL_op->op_flags */ + +GV * +S_softref2xv_lite(pTHX_ SV *const sv, const char *const what, + const svtype type) +{ + if (PL_op->op_private & HINT_STRICT_REFS) { + if (SvOK(sv)) + Perl_die(aTHX_ PL_no_symref_sv, sv, + (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); + else + Perl_die(aTHX_ PL_no_usym, what); + } + if (!SvOK(sv)) + Perl_die(aTHX_ PL_no_usym, what); + return gv_fetchsv_nomg(sv, GV_ADD, type); +} + + +/* Handle one or more aggregate derefs and array/hash indexings, e.g. + * $h->{foo} or $a[0]{$key}[$i] or f()->[1] + * + * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET. + * Each of these either contains a set of actions, or an argument, such as + * an IV to use as an array index, or a lexical var to retrieve. + * Several actions re stored per UV; we keep shifting new actions off the + * one UV, and only reload when it becomes zero. + */ + +PP(pp_multideref) +{ + SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */ + UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux; + UV actions = items->uv; + + assert(actions); + /* this tells find_uninit_var() where we're up to */ + PL_multideref_pc = items; + + while (1) { + /* there are three main classes of action; the first retrieve + * the initial AV or HV from a variable or the stack; the second + * does the equivalent of an unrolled (/DREFAV, rv2av, aelem), + * the third an unrolled (/DREFHV, rv2hv, helem). + */ + switch (actions & MDEREF_ACTION_MASK) { + + case MDEREF_reload: + actions = (++items)->uv; + continue; + + case MDEREF_AV_padav_aelem: /* $lex[...] */ + sv = PAD_SVl((++items)->pad_offset); + goto do_AV_aelem; + + case MDEREF_AV_gvav_aelem: /* $pkg[...] */ + sv = UNOP_AUX_item_sv(++items); + assert(isGV_with_GP(sv)); + sv = (SV*)GvAVn((GV*)sv); + goto do_AV_aelem; + + case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */ + { + dSP; + sv = POPs; + PUTBACK; + goto do_AV_rv2av_aelem; + } + + case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */ + sv = UNOP_AUX_item_sv(++items); + assert(isGV_with_GP(sv)); + sv = GvSVn((GV*)sv); + goto do_AV_vivify_rv2av_aelem; + + case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */ + sv = PAD_SVl((++items)->pad_offset); + /* FALLTHROUGH */ + + do_AV_vivify_rv2av_aelem: + case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */ + /* this is the OPpDEREF action normally found at the end of + * ops like aelem, helem, rv2sv */ + sv = vivify_ref(sv, OPpDEREF_AV); + /* FALLTHROUGH */ + + do_AV_rv2av_aelem: + /* this is basically a copy of pp_rv2av when it just has the + * sKR/1 flags */ + SvGETMAGIC(sv); + if (LIKELY(SvROK(sv))) { + if (UNLIKELY(SvAMAGIC(sv))) { + sv = amagic_deref_call(sv, to_av_amg); + } + sv = SvRV(sv); + if (UNLIKELY(SvTYPE(sv) != SVt_PVAV)) + DIE(aTHX_ "Not an ARRAY reference"); + } + else if (SvTYPE(sv) != SVt_PVAV) { + if (!isGV_with_GP(sv)) + sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV); + sv = MUTABLE_SV(GvAVn((GV*)sv)); + } + /* FALLTHROUGH */ + + do_AV_aelem: + { + /* retrieve the key; this may be either a lexical or package + * var (whose index/ptr is stored as an item) or a signed + * integer constant stored as an item. + */ + SV *elemsv; + IV elem = 0; /* to shut up stupid compiler warnings */ + + + assert(SvTYPE(sv) == SVt_PVAV); + + switch (actions & MDEREF_INDEX_MASK) { + case MDEREF_INDEX_none: + goto finish; + case MDEREF_INDEX_const: + elem = (++items)->iv; + break; + case MDEREF_INDEX_padsv: + elemsv = PAD_SVl((++items)->pad_offset); + goto check_elem; + case MDEREF_INDEX_gvsv: + elemsv = UNOP_AUX_item_sv(++items); + assert(isGV_with_GP(elemsv)); + elemsv = GvSVn((GV*)elemsv); + check_elem: + if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) + && ckWARN(WARN_MISC))) + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Use of reference \"%"SVf"\" as array index", + SVfARG(elemsv)); + /* the only time that S_find_uninit_var() needs this + * is to determine which index value triggered the + * undef warning. So just update it here. Note that + * since we don't save and restore this var (e.g. for + * tie or overload execution), its value will be + * meaningless apart from just here */ + PL_multideref_pc = items; + elem = SvIV(elemsv); + break; + } + + + /* this is basically a copy of pp_aelem with OPpDEREF skipped */ + + if (!(actions & MDEREF_FLAG_last)) { + SV** svp = av_fetch((AV*)sv, elem, 1); + if (!svp || ! (sv=*svp)) + DIE(aTHX_ PL_no_aelem, elem); + break; + } + + if (PL_op->op_private & + (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE)) + { + if (PL_op->op_private & OPpMULTIDEREF_EXISTS) { + sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no; + } + else { + I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0; + sv = av_delete((AV*)sv, elem, discard); + if (discard) + return NORMAL; + if (!sv) + sv = &PL_sv_undef; + } + } + else { + const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; + const U32 defer = PL_op->op_private & OPpLVAL_DEFER; + const bool localizing = PL_op->op_private & OPpLVAL_INTRO; + bool preeminent = TRUE; + AV *const av = (AV*)sv; + SV** svp; + + if (UNLIKELY(localizing)) { + MAGIC *mg; + HV *stash; + + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied array + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + if (SvCANEXISTDELETE(av)) + preeminent = av_exists(av, elem); + } + + svp = av_fetch(av, elem, lval && !defer); + + if (lval) { + if (!svp || !(sv = *svp)) { + IV len; + if (!defer) + DIE(aTHX_ PL_no_aelem, elem); + len = av_tindex(av); + sv = sv_2mortal(newSVavdefelem(av, + /* Resolve a negative index now, unless it points + * before the beginning of the array, in which + * case record it for error reporting in + * magic_setdefelem. */ + elem < 0 && len + elem >= 0 + ? len + elem : elem, 1)); + } + else { + if (UNLIKELY(localizing)) { + if (preeminent) { + save_aelem(av, elem, svp); + sv = *svp; /* may have changed */ + } + else + SAVEADELETE(av, elem); + } + } + } + else { + sv = (svp ? *svp : &PL_sv_undef); + /* see note in pp_helem() */ + if (SvRMAGICAL(av) && SvGMAGICAL(sv)) + mg_get(sv); + } + } + + } + finish: + { + dSP; + XPUSHs(sv); + RETURN; + } + /* NOTREACHED */ + + + + + case MDEREF_HV_padhv_helem: /* $lex{...} */ + sv = PAD_SVl((++items)->pad_offset); + goto do_HV_helem; + + case MDEREF_HV_gvhv_helem: /* $pkg{...} */ + sv = UNOP_AUX_item_sv(++items); + assert(isGV_with_GP(sv)); + sv = (SV*)GvHVn((GV*)sv); + goto do_HV_helem; + + case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */ + { + dSP; + sv = POPs; + PUTBACK; + goto do_HV_rv2hv_helem; + } + + case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */ + sv = UNOP_AUX_item_sv(++items); + assert(isGV_with_GP(sv)); + sv = GvSVn((GV*)sv); + goto do_HV_vivify_rv2hv_helem; + + case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */ + sv = PAD_SVl((++items)->pad_offset); + /* FALLTHROUGH */ + + do_HV_vivify_rv2hv_helem: + case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */ + /* this is the OPpDEREF action normally found at the end of + * ops like aelem, helem, rv2sv */ + sv = vivify_ref(sv, OPpDEREF_HV); + /* FALLTHROUGH */ + + do_HV_rv2hv_helem: + /* this is basically a copy of pp_rv2hv when it just has the + * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */ + + SvGETMAGIC(sv); + if (LIKELY(SvROK(sv))) { + if (UNLIKELY(SvAMAGIC(sv))) { + sv = amagic_deref_call(sv, to_hv_amg); + } + sv = SvRV(sv); + if (UNLIKELY(SvTYPE(sv) != SVt_PVHV)) + DIE(aTHX_ "Not a HASH reference"); + } + else if (SvTYPE(sv) != SVt_PVHV) { + if (!isGV_with_GP(sv)) + sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV); + sv = MUTABLE_SV(GvHVn((GV*)sv)); + } + /* FALLTHROUGH */ + + do_HV_helem: + { + /* retrieve the key; this may be either a lexical / package + * var or a string constant, whose index/ptr is stored as an + * item + */ + SV *keysv = NULL; /* to shut up stupid compiler warnings */ + + assert(SvTYPE(sv) == SVt_PVHV); + + switch (actions & MDEREF_INDEX_MASK) { + case MDEREF_INDEX_none: + goto finish; + + case MDEREF_INDEX_const: + keysv = UNOP_AUX_item_sv(++items); + break; + + case MDEREF_INDEX_padsv: + keysv = PAD_SVl((++items)->pad_offset); + break; + + case MDEREF_INDEX_gvsv: + keysv = UNOP_AUX_item_sv(++items); + keysv = GvSVn((GV*)keysv); + break; + } + + /* see comment above about setting this var */ + PL_multideref_pc = items; + + + /* ensure that candidate CONSTs have been HEKified */ + assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const) + || SvTYPE(keysv) >= SVt_PVMG + || !SvOK(keysv) + || SvROK(keysv) + || SvIsCOW_shared_hash(keysv)); + + /* this is basically a copy of pp_helem with OPpDEREF skipped */ + + if (!(actions & MDEREF_FLAG_last)) { + HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0); + if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef) + DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); + break; + } + + if (PL_op->op_private & + (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE)) + { + if (PL_op->op_private & OPpMULTIDEREF_EXISTS) { + sv = hv_exists_ent((HV*)sv, keysv, 0) + ? &PL_sv_yes : &PL_sv_no; + } + else { + I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0; + sv = hv_delete_ent((HV*)sv, keysv, discard, 0); + if (discard) + return NORMAL; + if (!sv) + sv = &PL_sv_undef; + } + } + else { + const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; + const U32 defer = PL_op->op_private & OPpLVAL_DEFER; + const bool localizing = PL_op->op_private & OPpLVAL_INTRO; + bool preeminent = TRUE; + SV **svp; + HV * const hv = (HV*)sv; + HE* he; + + if (UNLIKELY(localizing)) { + MAGIC *mg; + HV *stash; + + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied hash + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + if (SvCANEXISTDELETE(hv)) + preeminent = hv_exists_ent(hv, keysv, 0); + } + + he = hv_fetch_ent(hv, keysv, lval && !defer, 0); + svp = he ? &HeVAL(he) : NULL; + + + if (lval) { + if (!svp || !(sv = *svp) || sv == &PL_sv_undef) { + SV* lv; + SV* key2; + if (!defer) + DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); + lv = sv_newmortal(); + sv_upgrade(lv, SVt_PVLV); + LvTYPE(lv) = 'y'; + sv_magic(lv, key2 = newSVsv(keysv), + PERL_MAGIC_defelem, NULL, 0); + /* sv_magic() increments refcount */ + SvREFCNT_dec_NN(key2); + LvTARG(lv) = SvREFCNT_inc_simple(hv); + LvTARGLEN(lv) = 1; + sv = lv; + } + else { + if (localizing) { + if (HvNAME_get(hv) && isGV(sv)) + save_gp(MUTABLE_GV(sv), + !(PL_op->op_flags & OPf_SPECIAL)); + else if (preeminent) { + save_helem_flags(hv, keysv, svp, + (PL_op->op_flags & OPf_SPECIAL) + ? 0 : SAVEf_SETMAGIC); + sv = *svp; /* may have changed */ + } + else + SAVEHDELETE(hv, keysv); + } + } + } + else { + sv = (svp && *svp ? *svp : &PL_sv_undef); + /* see note in pp_helem() */ + if (SvRMAGICAL(hv) && SvGMAGICAL(sv)) + mg_get(sv); + } + } + goto finish; + } + + } /* switch */ + + actions >>= MDEREF_SHIFT; + } /* while */ + /* NOTREACHED */ +} + + PP(pp_iter) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; SV *oldsv; SV **itersvp; @@ -1818,11 +2313,11 @@ PP(pp_iter) It has SvPVX of "" and SvCUR of 0, which is what we want. */ STRLEN maxlen = 0; const char *max = SvPV_const(end, maxlen); - if (SvNIOK(cur) || SvCUR(cur) > maxlen) + if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen)) RETPUSHNO; oldsv = *itersvp; - if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) { + if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) { /* safe to reuse old SV */ sv_setsv(oldsv, cur); } @@ -1844,12 +2339,12 @@ PP(pp_iter) case CXt_LOOP_LAZYIV: /* integer increment */ { IV cur = cx->blk_loop.state_u.lazyiv.cur; - if (cur > cx->blk_loop.state_u.lazyiv.end) + if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) RETPUSHNO; oldsv = *itersvp; /* don't risk potential race */ - if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) { + if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) { /* safe to reuse old SV */ sv_setiv(oldsv, cur); } @@ -1862,7 +2357,7 @@ PP(pp_iter) SvREFCNT_dec_NN(oldsv); } - if (cur == IV_MAX) { + if (UNLIKELY(cur == IV_MAX)) { /* Handle end of range at IV_MAX */ cx->blk_loop.state_u.lazyiv.end = IV_MIN; } else @@ -1884,16 +2379,16 @@ PP(pp_iter) } if (PL_op->op_private & OPpITER_REVERSED) { ix = --cx->blk_loop.state_u.ary.ix; - if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)) + if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))) RETPUSHNO; } else { ix = ++cx->blk_loop.state_u.ary.ix; - if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))) + if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))) RETPUSHNO; } - if (SvMAGICAL(av) || AvREIFY(av)) { + if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) { SV * const * const svp = av_fetch(av, ix, FALSE); sv = svp ? *svp : NULL; } @@ -1901,13 +2396,19 @@ PP(pp_iter) sv = AvARRAY(av)[ix]; } - if (sv) { - if (SvIS_FREED(sv)) { + if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) { + SvSetMagicSV(*itersvp, sv); + break; + } + + if (LIKELY(sv)) { + if (UNLIKELY(SvIS_FREED(sv))) { *itersvp = NULL; Perl_croak(aTHX_ "Use of freed value in iteration"); } - if (SvPADTMP(sv) && !IS_PADGV(sv)) + if (SvPADTMP(sv)) { sv = newSVsv(sv); + } else { SvTEMP_off(sv); SvREFCNT_inc_simple_void_NN(sv); @@ -1941,17 +2442,14 @@ While the pattern is being assembled/concatenated and then compiled, PL_tainted will get set (via TAINT_set) if any component of the pattern is tainted, e.g. /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via -TAINT_get). +TAINT_get). It will also be set if any component of the pattern matches +based on locale-dependent behavior. When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to the pattern is marked as tainted. This means that subsequent usage, such as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED, on the new pattern too. -At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the -regex is cleared; during execution, locale-variant ops such as POSIXL may -set RXf_TAINTED_SEEN. - RXf_TAINTED_SEEN is used post-execution by the get magic code of $1 et al to indicate whether the returned value should be tainted. It is the responsibility of the caller of the pattern (i.e. pp_match, @@ -2004,15 +2502,15 @@ pp_match is just a simpler version of the above. PP(pp_subst) { - dVAR; dSP; dTARG; + dSP; dTARG; PMOP *pm = cPMOP; PMOP *rpm = pm; char *s; char *strend; const char *c; STRLEN clen; - I32 iters = 0; - I32 maxiters; + SSize_t iters = 0; + SSize_t maxiters; bool once; U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits. See "how taint works" above */ @@ -2035,7 +2533,7 @@ PP(pp_subst) if (PL_op->op_flags & OPf_STACKED) TARG = POPs; - else if (PL_op->op_private & OPpTARGET_MY) + else if (ARGTARG) GETTARGET; else { TARG = DEFSV; @@ -2123,8 +2621,8 @@ PP(pp_subst) if (DO_UTF8(TARG) && !doutf8) { nsv = sv_newmortal(); SvSetSV(nsv, dstr); - if (PL_encoding) - sv_recode_to_utf8(nsv, PL_encoding); + if (IN_ENCODING) + sv_recode_to_utf8(nsv, _get_encoding()); else sv_utf8_upgrade(nsv); c = SvPV_const(nsv, clen); @@ -2211,9 +2709,9 @@ PP(pp_subst) d = s = RX_OFFS(rx)[0].start + orig; do { I32 i; - if (iters++ > maxiters) + if (UNLIKELY(iters++ > maxiters)) DIE(aTHX_ "Substitution loop"); - if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */ rxtainted |= SUBST_TAINT_PAT; m = RX_OFFS(rx)[0].start + orig; if ((i = m - s)) { @@ -2236,7 +2734,7 @@ PP(pp_subst) Move(s, d, i+1, char); /* include the NUL */ } SPAGAIN; - mPUSHi((I32)iters); + mPUSHi(iters); } } else { @@ -2281,9 +2779,9 @@ PP(pp_subst) } first = TRUE; do { - if (iters++ > maxiters) + if (UNLIKELY(iters++ > maxiters)) DIE(aTHX_ "Substitution loop"); - if (RX_MATCH_TAINTED(rx)) + if (UNLIKELY(RX_MATCH_TAINTED(rx))) rxtainted |= SUBST_TAINT_PAT; if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { char *old_s = s; @@ -2304,14 +2802,14 @@ PP(pp_subst) first = FALSE; } else { - if (PL_encoding) { + if (IN_ENCODING) { if (!nsv) nsv = sv_newmortal(); sv_copypv(nsv, repl); - if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding); + if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding()); sv_catsv(dstr, nsv); } else sv_catsv(dstr, repl); - if (SvTAINTED(repl)) + if (UNLIKELY(SvTAINTED(repl))) rxtainted |= SUBST_TAINT_REPL; } if (once) @@ -2348,7 +2846,7 @@ PP(pp_subst) SvPV_set(dstr, NULL); SPAGAIN; - mPUSHi((I32)iters); + mPUSHi(iters); } } @@ -2385,7 +2883,7 @@ PP(pp_subst) PP(pp_grepwhile) { - dVAR; dSP; + dSP; if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; @@ -2394,7 +2892,7 @@ PP(pp_grepwhile) LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ - if (PL_stack_base + *PL_markstack_ptr > SP) { + if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) { I32 items; const I32 gimme = GIMME_V; @@ -2425,7 +2923,7 @@ PP(pp_grepwhile) SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; - if (SvPADTMP(src) && !IS_PADGV(src)) { + if (SvPADTMP(src)) { src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src); PL_tmps_floor++; } @@ -2441,7 +2939,7 @@ PP(pp_grepwhile) PP(pp_leavesub) { - dVAR; dSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2449,8 +2947,12 @@ PP(pp_leavesub) PERL_CONTEXT *cx; SV *sv; - if (CxMULTICALL(&cxstack[cxstack_ix])) + if (CxMULTICALL(&cxstack[cxstack_ix])) { + /* entry zero of a stack is always PL_sv_undef, which + * simplifies converting a '()' return into undef in scalar context */ + assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef); return 0; + } POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ @@ -2458,7 +2960,7 @@ PP(pp_leavesub) TAINT_NOT; if (gimme == G_SCALAR) { MARK = newsp + 1; - if (MARK <= SP) { + if (LIKELY(MARK <= SP)) { if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1 && !SvMAGICAL(TOPs)) { @@ -2508,95 +3010,97 @@ PP(pp_leavesub) PP(pp_entersub) { - dVAR; dSP; dPOPss; + dSP; dPOPss; GV *gv; CV *cv; PERL_CONTEXT *cx; I32 gimme; const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; - if (!sv) - DIE(aTHX_ "Not a CODE reference"); - switch (SvTYPE(sv)) { - /* This is overwhelming the most common case: */ - case SVt_PVGV: - we_have_a_glob: - if (!(cv = GvCVu((const GV *)sv))) { - HV *stash; - cv = sv_2cv(sv, &stash, &gv, 0); - } - if (!cv) { - ENTER; - SAVETMPS; - goto try_autoload; - } - break; - case SVt_PVLV: - if(isGV_with_GP(sv)) goto we_have_a_glob; - /*FALLTHROUGH*/ - default: - if (sv == &PL_sv_yes) { /* unfound import, ignore */ - if (hasargs) - SP = PL_stack_base + POPMARK; - else - (void)POPMARK; - RETURN; - } - SvGETMAGIC(sv); - if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - sv = amagic_deref_call(sv, to_cv_amg); - /* Don't SPAGAIN here. */ - } - } - else { - const char *sym; - STRLEN len; - if (!SvOK(sv)) - DIE(aTHX_ PL_no_usym, "a subroutine"); - sym = SvPV_nomg_const(sv, len); - if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : ""); - cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv)); - break; - } - cv = MUTABLE_CV(SvRV(sv)); - if (SvTYPE(cv) == SVt_PVCV) - break; - /* FALL THROUGH */ - case SVt_PVHV: - case SVt_PVAV: + if (UNLIKELY(!sv)) DIE(aTHX_ "Not a CODE reference"); - /* This is the second most common case: */ - case SVt_PVCV: - cv = MUTABLE_CV(sv); - break; + /* This is overwhelmingly the most common case: */ + if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) { + switch (SvTYPE(sv)) { + case SVt_PVGV: + we_have_a_glob: + if (!(cv = GvCVu((const GV *)sv))) { + HV *stash; + cv = sv_2cv(sv, &stash, &gv, 0); + } + if (!cv) { + ENTER; + SAVETMPS; + goto try_autoload; + } + break; + case SVt_PVLV: + if(isGV_with_GP(sv)) goto we_have_a_glob; + /* FALLTHROUGH */ + default: + if (sv == &PL_sv_yes) { /* unfound import, ignore */ + if (hasargs) + SP = PL_stack_base + POPMARK; + else + (void)POPMARK; + RETURN; + } + SvGETMAGIC(sv); + if (SvROK(sv)) { + if (SvAMAGIC(sv)) { + sv = amagic_deref_call(sv, to_cv_amg); + /* Don't SPAGAIN here. */ + } + } + else { + const char *sym; + STRLEN len; + if (!SvOK(sv)) + DIE(aTHX_ PL_no_usym, "a subroutine"); + sym = SvPV_nomg_const(sv, len); + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : ""); + cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv)); + break; + } + cv = MUTABLE_CV(SvRV(sv)); + if (SvTYPE(cv) == SVt_PVCV) + break; + /* FALLTHROUGH */ + case SVt_PVHV: + case SVt_PVAV: + DIE(aTHX_ "Not a CODE reference"); + /* This is the second most common case: */ + case SVt_PVCV: + cv = MUTABLE_CV(sv); + break; + } } ENTER; retry: - if (CvCLONE(cv) && ! CvCLONED(cv)) + if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv))) DIE(aTHX_ "Closure prototype called"); - if (!CvROOT(cv) && !CvXSUB(cv)) { + if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) { GV* autogv; SV* sub_name; /* anonymous or undef'd function leaves us no recourse */ - if (CvANON(cv) || !(gv = CvGV(cv))) { - if (CvNAMED(cv)) - DIE(aTHX_ "Undefined subroutine &%"HEKf" called", - HEKfARG(CvNAME_HEK(cv))); + if (CvLEXICAL(cv) && CvHASGV(cv)) + DIE(aTHX_ "Undefined subroutine &%"SVf" called", + SVfARG(cv_name(cv, NULL, 0))); + if (CvANON(cv) || !CvHASGV(cv)) { DIE(aTHX_ "Undefined subroutine called"); } /* autoloaded stub? */ - if (cv != GvCV(gv)) { + if (cv != GvCV(gv = CvGV(cv))) { cv = GvCV(gv); } /* should call AUTOLOAD now? */ else { -try_autoload: + try_autoload: if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), GvNAMEUTF8(gv) ? SVf_UTF8 : 0))) { @@ -2614,8 +3118,9 @@ try_autoload: goto retry; } - gimme = GIMME_V; - if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { + if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) + && !CvNODEBUG(cv))) + { Perl_get_db_sub(aTHX_ &sv, cv); if (CvISXSUB(cv)) PL_curcopdb = PL_curcop; @@ -2632,37 +3137,43 @@ try_autoload: DIE(aTHX_ "No DB::sub routine defined"); } + gimme = GIMME_V; + if (!(CvISXSUB(cv))) { /* This path taken at least 75% of the time */ dMARK; - SSize_t items = SP - MARK; PADLIST * const padlist = CvPADLIST(cv); + I32 depth; + PUSHBLOCK(cx, CXt_SUB, MARK); PUSHSUB(cx); cx->blk_sub.retop = PL_op->op_next; - CvDEPTH(cv)++; - if (CvDEPTH(cv) >= 2) { + if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) { PERL_STACK_OVERFLOW_CHECK(); - pad_push(padlist, CvDEPTH(cv)); + pad_push(padlist, depth); } SAVECOMPPAD(); - PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); - if (hasargs) { + PAD_SET_CUR_NOSAVE(padlist, depth); + if (LIKELY(hasargs)) { AV *const av = MUTABLE_AV(PAD_SVl(0)); - if (AvREAL(av)) { + SSize_t items; + AV **defavp; + + if (UNLIKELY(AvREAL(av))) { /* @_ is normally not REAL--this should only ever * happen when DB::sub() calls things that modify @_ */ av_clear(av); AvREAL_off(av); AvREIFY_on(av); } - cx->blk_sub.savearray = GvAV(PL_defgv); - GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av)); + defavp = &GvAV(PL_defgv); + cx->blk_sub.savearray = *defavp; + *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av)); CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; - ++MARK; + items = SP - MARK; - if (items - 1 > AvMAX(av)) { + if (UNLIKELY(items - 1 > AvMAX(av))) { SV **ary = AvALLOC(av); AvMAX(av) = items - 1; Renew(ary, items, SV*); @@ -2670,30 +3181,32 @@ try_autoload: AvARRAY(av) = ary; } - Copy(MARK,AvARRAY(av),items,SV*); + Copy(MARK+1,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; MARK = AvARRAY(av); while (items--) { if (*MARK) { - if (SvPADTMP(*MARK) && !IS_PADGV(*MARK)) + if (SvPADTMP(*MARK)) { *MARK = sv_mortalcopy(*MARK); + } SvTEMP_off(*MARK); } MARK++; } } SAVETMPS; - if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && - !CvLVALUE(cv)) + if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && + !CvLVALUE(cv))) DIE(aTHX_ "Can't modify non-lvalue subroutine call"); /* warning must come *after* we fully set up the context * stuff so that __WARN__ handlers can safely dounwind() * if they want to */ - if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION) - && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) + if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN + && ckWARN(WARN_RECURSION) + && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))) sub_crush_depth(cv); RETURNOP(CvSTART(cv)); } @@ -2703,13 +3216,13 @@ try_autoload: SAVETMPS; PUTBACK; - if (((PL_op->op_private + if (UNLIKELY(((PL_op->op_private & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub) ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && - !CvLVALUE(cv)) + !CvLVALUE(cv))) DIE(aTHX_ "Can't modify non-lvalue subroutine call"); - if (!hasargs && GvAV(PL_defgv)) { + if (UNLIKELY(!hasargs && GvAV(PL_defgv))) { /* Need to copy @_ to stack. Alternative may be to * switch stack to @_, and copy return values * back. This would allow popping @_ in XSUB, e.g.. XXXX */ @@ -2743,12 +3256,13 @@ try_autoload: SSize_t items = SP - mark; while (items--) { mark++; - if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark)) + if (*mark && SvPADTMP(*mark)) { *mark = sv_mortalcopy(*mark); + } } } /* We assume first XSUB in &DB::sub is the called one. */ - if (PL_curcopdb) { + if (UNLIKELY(PL_curcopdb)) { SAVEVPTR(PL_curcop); PL_curcop = PL_curcopdb; PL_curcopdb = NULL; @@ -2760,12 +3274,12 @@ try_autoload: CvXSUB(cv)(aTHX_ cv); /* Enforce some sanity in scalar context. */ - if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { - if (markix > PL_stack_sp - PL_stack_base) - *(PL_stack_base + markix) = &PL_sv_undef; - else - *(PL_stack_base + markix) = *PL_stack_sp; - PL_stack_sp = PL_stack_base + markix; + if (gimme == G_SCALAR) { + SV **svp = PL_stack_base + markix + 1; + if (svp != PL_stack_sp) { + *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp; + PL_stack_sp = svp; + } } LEAVE; return NORMAL; @@ -2780,23 +3294,14 @@ Perl_sub_crush_depth(pTHX_ CV *cv) if (CvANON(cv)) Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { - HEK *const hek = CvNAME_HEK(cv); - SV *tmpstr; - if (hek) { - tmpstr = sv_2mortal(newSVhek(hek)); - } - else { - tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, CvGV(cv), NULL); - } Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", - SVfARG(tmpstr)); + SVfARG(cv_name(cv,NULL,0))); } } PP(pp_aelem) { - dVAR; dSP; + dSP; SV** svp; SV* const elemsv = POPs; IV elem = SvIV(elemsv); @@ -2807,14 +3312,14 @@ PP(pp_aelem) bool preeminent = TRUE; SV *sv; - if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) + if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))) Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", SVfARG(elemsv)); - if (SvTYPE(av) != SVt_PVAV) + if (UNLIKELY(SvTYPE(av) != SVt_PVAV)) RETPUSHUNDEF; - if (localizing) { + if (UNLIKELY(localizing)) { MAGIC *mg; HV *stash; @@ -2845,7 +3350,7 @@ PP(pp_aelem) IV len; if (!defer) DIE(aTHX_ PL_no_aelem, elem); - len = av_len(av); + len = av_tindex(av); mPUSHs(newSVavdefelem(av, /* Resolve a negative index now, unless it points before the beginning of the array, in which case record it for error @@ -2854,7 +3359,7 @@ PP(pp_aelem) 1)); RETURN; } - if (localizing) { + if (UNLIKELY(localizing)) { if (preeminent) save_aelem(av, elem, svp); else @@ -2907,55 +3412,31 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) return sv; } -PP(pp_method) +PERL_STATIC_INLINE HV * +S_opmethod_stash(pTHX_ SV* meth) { - dVAR; dSP; - SV* const sv = TOPs; - - if (SvROK(sv)) { - SV* const rsv = SvRV(sv); - if (SvTYPE(rsv) == SVt_PVCV) { - SETs(rsv); - RETURN; - } - } - - SETs(method_common(sv, NULL)); - RETURN; -} - -PP(pp_method_named) -{ - dVAR; dSP; - SV* const sv = cSVOP_sv; - U32 hash = SvSHARED_HASH(sv); - - XPUSHs(method_common(sv, &hash)); - RETURN; -} - -STATIC SV * -S_method_common(pTHX_ SV* meth, U32* hashp) -{ - dVAR; SV* ob; - GV* gv; HV* stash; - SV *packsv = NULL; - SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp + + SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a " "package or object reference", SVfARG(meth)), (SV *)NULL) : *(PL_stack_base + TOPMARK + 1); - PERL_ARGS_ASSERT_METHOD_COMMON; + PERL_ARGS_ASSERT_OPMETHOD_STASH; - if (!sv) + if (UNLIKELY(!sv)) undefined: Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value", SVfARG(meth)); - SvGETMAGIC(sv); + if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv); + else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */ + stash = gv_stashsv(sv, GV_CACHE_ONLY); + if (stash) return stash; + } + if (SvROK(sv)) ob = MUTABLE_SV(SvRV(sv)); else if (!SvOK(sv)) goto undefined; @@ -2977,22 +3458,12 @@ S_method_common(pTHX_ SV* meth, U32* hashp) GV* iogv; STRLEN packlen; const char * const packname = SvPV_nomg_const(sv, packlen); - const bool packname_is_utf8 = !!SvUTF8(sv); - const HE* const he = - (const HE *)hv_common( - PL_stashcache, NULL, packname, packlen, - packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0 - ); - - if (he) { - stash = INT2PTR(HV*,SvIV(HeVAL(he))); - DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n", - stash, sv)); - goto fetch; - } + const U32 packname_utf8 = SvUTF8(sv); + stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY); + if (stash) return stash; if (!(iogv = gv_fetchpvn_flags( - packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO + packname, packlen, packname_utf8, SVt_PVIO )) || !(ob=MUTABLE_SV(GvIO(iogv)))) { @@ -3004,17 +3475,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) SVfARG(meth)); } /* assume it's a package name */ - stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0); - if (!stash) - packsv = sv; - else { - SV* const ref = newSViv(PTR2IV(stash)); - (void)hv_store(PL_stashcache, packname, - packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0); - DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n", - stash, sv)); - } - goto fetch; + stash = gv_stashpvn(packname, packlen, packname_utf8); + if (stash) return stash; + else return MUTABLE_HV(sv); } /* it _is_ a filehandle name -- replace with a reference */ *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv))); @@ -3032,38 +3495,125 @@ S_method_common(pTHX_ SV* meth, U32* hashp) : meth)); } - stash = SvSTASH(ob); + return SvSTASH(ob); +} - fetch: - /* NOTE: stash may be null, hope hv_fetch_ent and - gv_fetchmethod can cope (it seems they can) */ +PP(pp_method) +{ + dSP; + GV* gv; + HV* stash; + SV* const meth = TOPs; - /* shortcut for simple names */ - if (hashp) { - const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp); - if (he) { - gv = MUTABLE_GV(HeVAL(he)); - if (isGV(gv) && GvCV(gv) && - (!GvCVGEN(gv) || GvCVGEN(gv) - == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) - return MUTABLE_SV(GvCV(gv)); - } + if (SvROK(meth)) { + SV* const rmeth = SvRV(meth); + if (SvTYPE(rmeth) == SVt_PVCV) { + SETs(rmeth); + RETURN; + } } - gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv), - meth, GV_AUTOLOAD | GV_CROAK); + stash = opmethod_stash(meth); + gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK); assert(gv); - return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv); + SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); + RETURN; +} + +#define METHOD_CHECK_CACHE(stash,cache,meth) \ + const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \ + if (he) { \ + gv = MUTABLE_GV(HeVAL(he)); \ + if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \ + == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \ + { \ + XPUSHs(MUTABLE_SV(GvCV(gv))); \ + RETURN; \ + } \ + } \ + +PP(pp_method_named) +{ + dSP; + GV* gv; + SV* const meth = cMETHOPx_meth(PL_op); + HV* const stash = opmethod_stash(meth); + + if (LIKELY(SvTYPE(stash) == SVt_PVHV)) { + METHOD_CHECK_CACHE(stash, stash, meth); + } + + gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK); + assert(gv); + + XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); + RETURN; +} + +PP(pp_method_super) +{ + dSP; + GV* gv; + HV* cache; + SV* const meth = cMETHOPx_meth(PL_op); + HV* const stash = CopSTASH(PL_curcop); + /* Actually, SUPER doesn't need real object's (or class') stash at all, + * as it uses CopSTASH. However, we must ensure that object(class) is + * correct (this check is done by S_opmethod_stash) */ + opmethod_stash(meth); + + if ((cache = HvMROMETA(stash)->super)) { + METHOD_CHECK_CACHE(stash, cache, meth); + } + + gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER); + assert(gv); + + XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); + RETURN; +} + +PP(pp_method_redir) +{ + dSP; + GV* gv; + SV* const meth = cMETHOPx_meth(PL_op); + HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0); + opmethod_stash(meth); /* not used but needed for error checks */ + + if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); } + else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op)); + + gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK); + assert(gv); + + XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); + RETURN; +} + +PP(pp_method_redir_super) +{ + dSP; + GV* gv; + HV* cache; + SV* const meth = cMETHOPx_meth(PL_op); + HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0); + opmethod_stash(meth); /* not used but needed for error checks */ + + if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op)); + else if ((cache = HvMROMETA(stash)->super)) { + METHOD_CHECK_CACHE(stash, cache, meth); + } + + gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER); + assert(gv); + + XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); + RETURN; } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */