X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/feb38e3b9dba8f9f75fe6c737d7c4d99ff1aca46..aa38f4b16ec84f790a5473b0ff1ffe264bd93f5a:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index ee82673..9e6df2a 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -39,7 +39,6 @@ PP(pp_const) { - dVAR; dSP; XPUSHs(cSVOP_sv); RETURN; @@ -47,7 +46,6 @@ PP(pp_const) PP(pp_nextstate) { - dVAR; PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; @@ -58,10 +56,9 @@ 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)); @@ -70,21 +67,19 @@ PP(pp_gvsv) PP(pp_null) { - dVAR; return NORMAL; } /* This is sometimes called directly by pp_coreargs and pp_grepstart. */ 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 +90,13 @@ PP(pp_stringify) PP(pp_gv) { - dVAR; dSP; + dSP; XPUSHs(MUTABLE_SV(cGVOP_gv)); RETURN; } PP(pp_and) { - dVAR; PERL_ASYNC_CHECK(); { /* SP is not used to remove a variable that is saved across the @@ -123,7 +117,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 +127,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 +209,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 +222,7 @@ PP(pp_sassign) PP(pp_cond_expr) { - dVAR; dSP; + dSP; PERL_ASYNC_CHECK(); if (SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other); @@ -237,7 +232,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 +245,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,16 +272,18 @@ 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) { @@ -326,11 +322,11 @@ STATIC void S_pushav(pTHX_ AV* const av) { dSP; - const I32 maxarg = AvFILL(av) + 1; + const SSize_t maxarg = AvFILL(av) + 1; EXTEND(SP, maxarg); - if (SvRMAGICAL(av)) { - U32 i; - for (i=0; i < (U32)maxarg; i++) { + if (UNLIKELY(SvRMAGICAL(av))) { + PADOFFSET i; + for (i=0; i < (PADOFFSET)maxarg; i++) { SV ** const svp = av_fetch(av, i, FALSE); /* See note in pp_helem, and bug id #27839 */ SP[i+1] = svp @@ -339,7 +335,11 @@ S_pushav(pTHX_ AV* const av) } } else { - Copy(AvARRAY(av), SP+1, maxarg, SV*); + PADOFFSET i; + for (i=0; i < (PADOFFSET)maxarg; i++) { + SV * const sv = AvARRAY(av)[i]; + SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef; + } } SP += maxarg; PUTBACK; @@ -350,7 +350,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; @@ -391,7 +391,7 @@ PP(pp_padrange) PP(pp_padsv) { - dVAR; dSP; + dSP; EXTEND(SP, 1); { OP * const op = PL_op; @@ -421,7 +421,6 @@ PP(pp_padsv) PP(pp_readline) { - dVAR; dSP; if (TOPs) { SvGETMAGIC(TOPs); @@ -445,7 +444,7 @@ PP(pp_readline) PP(pp_eq) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric); @@ -461,12 +460,12 @@ PP(pp_eq) 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)); @@ -481,7 +480,7 @@ PP(pp_preinc) PP(pp_or) { - dVAR; dSP; + dSP; PERL_ASYNC_CHECK(); if (SvTRUE(TOPs)) RETURN; @@ -494,7 +493,7 @@ PP(pp_or) PP(pp_defined) { - dVAR; dSP; + dSP; SV* sv; bool defined; const int op_type = PL_op->op_type; @@ -503,7 +502,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); @@ -512,7 +511,7 @@ PP(pp_defined) else { /* OP_DEFINED */ sv = POPs; - if (!sv || !SvANY(sv)) + if (UNLIKELY(!sv || !SvANY(sv))) RETPUSHNO; } @@ -552,7 +551,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; @@ -717,12 +716,16 @@ PP(pp_add) 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); @@ -732,7 +735,7 @@ PP(pp_aelemfast) PP(pp_join) { - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; MARK++; do_join(TARG, *MARK, MARK, SP); SP = MARK; @@ -742,7 +745,7 @@ PP(pp_join) PP(pp_pushre) { - dVAR; dSP; + dSP; #ifdef DEBUGGING /* * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs @@ -763,7 +766,7 @@ PP(pp_pushre) PP(pp_print) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; PerlIO *fp; MAGIC *mg; GV * const gv @@ -857,7 +860,7 @@ PP(pp_print) 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"; @@ -866,18 +869,18 @@ PP(pp_rv2av) 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)) { @@ -897,7 +900,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) @@ -920,7 +923,7 @@ PP(pp_rv2av) } else if (gimme == G_SCALAR) { dTARGET; - const I32 maxarg = AvFILL(av) + 1; + const SSize_t maxarg = AvFILL(av) + 1; SETi(maxarg); } } else { @@ -935,9 +938,8 @@ PP(pp_rv2av) && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied))) SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0))); else if (gimme == G_SCALAR) { - dTARGET; + dTARG; TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv)); - SPAGAIN; SETTARG; } } @@ -952,8 +954,6 @@ PP(pp_rv2av) STATIC void S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) { - dVAR; - PERL_ARGS_ASSERT_DO_ODDBALL; if (*oddkey) { @@ -990,7 +990,7 @@ PP(pp_aassign) I32 gimme; HV *hash; - I32 i; + SSize_t i; int magic; U32 lval = 0; @@ -1017,13 +1017,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); } @@ -1041,7 +1041,7 @@ PP(pp_aassign) ary = NULL; hash = NULL; - while (lelem <= lastlelem) { + while (LIKELY(lelem <= lastlelem)) { TAINT_NOT; /* Each item stands on its own, taintwise. */ sv = *lelem++; switch (SvTYPE(sv)) { @@ -1055,8 +1055,8 @@ PP(pp_aassign) i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ SV **didstore; - assert(*relem); - SvGETMAGIC(*relem); /* before newSV, in case it dies */ + if (LIKELY(*relem)) + SvGETMAGIC(*relem); /* before newSV, in case it dies */ sv = newSV(0); sv_setsv_nomg(sv, *relem); *(relem++) = sv; @@ -1069,7 +1069,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; @@ -1084,7 +1084,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 */ @@ -1094,7 +1094,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, @@ -1154,10 +1154,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" @@ -1171,74 +1171,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(); } @@ -1277,7 +1285,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; @@ -1296,7 +1304,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); } @@ -1307,7 +1315,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)); } @@ -1317,12 +1325,12 @@ PP(pp_qr) PP(pp_match) { - dVAR; dSP; dTARG; + dSP; dTARG; PMOP *pm = cPMOP; PMOP *dynpm = pm; const char *s; const char *strend; - I32 curpos = 0; /* initial pos() or current $+[0] */ + SSize_t curpos = 0; /* initial pos() or current $+[0] */ I32 global; U8 r_flags = 0; const char *truebase; /* Start of string */ @@ -1332,6 +1340,7 @@ PP(pp_match) STRLEN len; const I32 oldsave = PL_savestack_ix; I32 had_zerolen = 0; + MAGIC *mg = NULL; if (PL_op->op_flags & OPf_STACKED) TARG = POPs; @@ -1378,16 +1387,18 @@ PP(pp_match) rx = PM_GETRE(pm); } - if (RX_MINLEN(rx) > (I32)len) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n")); + if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) { + DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%" + UVuf" < %"IVdf")\n", + (UV)len, (IV)RX_MINLEN(rx))); goto nope; } /* get pos() if //g */ if (global) { - MAGIC * const mg = mg_find_mglob(TARG); + mg = mg_find_mglob(TARG); if (mg && mg->mg_len >= 0) { - curpos = mg->mg_len; + curpos = MgBYTEPOS(mg, TARG, truebase, len); /* last time pos() was set, it was zero-length match */ if (mg->mg_flags & MGf_MINMATCH) had_zerolen = 1; @@ -1398,6 +1409,7 @@ PP(pp_match) if ( RX_NPARENS(rx) || PL_sawampersand || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) + || (dynpm->op_pmflags & PMf_KEEPCOPY) ) #endif { @@ -1409,26 +1421,29 @@ PP(pp_match) if (! (global && gimme == G_ARRAY)) r_flags |= REXEC_COPY_SKIP_POST; }; +#ifdef PERL_SAWAMPERSAND + if (dynpm->op_pmflags & PMf_KEEPCOPY) + /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */ + r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST); +#endif s = truebase; play_it_again: - if (global) { + if (global) s = truebase + curpos; - } if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, had_zerolen, TARG, NULL, r_flags)) goto nope; PL_curpm = pm; - if (dynpm->op_pmflags & PMf_ONCE) { + if (dynpm->op_pmflags & PMf_ONCE) #ifdef USE_ITHREADS SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); #else dynpm->op_pmflags |= PMf_USED; #endif - } if (rxtainted) RX_MATCH_TAINTED_on(rx); @@ -1437,18 +1452,13 @@ PP(pp_match) /* update pos */ if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) { - MAGIC *mg = mg_find_mglob(TARG); - if (!mg) { + if (!mg) mg = sv_magicext_mglob(TARG); - } - assert(RX_OFFS(rx)[0].start != -1); /* XXX get rid of next line? */ - if (RX_OFFS(rx)[0].start != -1) { - mg->mg_len = RX_OFFS(rx)[0].end; - if (RX_ZERO_LEN(rx)) - mg->mg_flags |= MGf_MINMATCH; - else - mg->mg_flags &= ~MGf_MINMATCH; - } + MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end); + if (RX_ZERO_LEN(rx)) + mg->mg_flags |= MGf_MINMATCH; + else + mg->mg_flags &= ~MGf_MINMATCH; } if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) { @@ -1467,11 +1477,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, @@ -1495,9 +1507,10 @@ PP(pp_match) nope: if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { - MAGIC* const mg = mg_find_mglob(TARG); - if (mg) - mg->mg_len = -1; + if (!mg) + mg = mg_find_mglob(TARG); + if (mg) + mg->mg_len = -1; } LEAVE_SCOPE(oldsave); if (gimme == G_ARRAY) @@ -1508,7 +1521,7 @@ nope: OP * Perl_do_readline(pTHX) { - dVAR; dSP; dTARGETSTACKED; + dSP; dTARGETSTACKED; SV *sv; STRLEN tmplen = 0; STRLEN offset; @@ -1536,9 +1549,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)); @@ -1562,14 +1575,10 @@ Perl_do_readline(pTHX) } if (!fp) { if ((!io || !(IoFLAGS(io) & IOf_START)) - && ckWARN2(WARN_GLOB, WARN_CLOSED)) + && ckWARN(WARN_CLOSED) + && type != OP_GLOB) { - if (type == OP_GLOB) - Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB), - "glob failed (can't start child: %s)", - Strerror(errno)); - else - report_evil_fh(PL_last_in_gv); + report_evil_fh(PL_last_in_gv); } if (gimme == G_SCALAR) { /* undef TARG, and push that undefined value */ @@ -1678,8 +1687,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... */ @@ -1717,7 +1729,7 @@ Perl_do_readline(pTHX) PP(pp_helem) { - dVAR; dSP; + dSP; HE* he; SV **svp; SV * const keysv = POPs; @@ -1797,7 +1809,7 @@ PP(pp_helem) PP(pp_iter) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; SV *oldsv; SV **itersvp; @@ -1816,11 +1828,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); } @@ -1842,12 +1854,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); } @@ -1860,7 +1872,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 @@ -1882,16 +1894,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; } @@ -1899,31 +1911,26 @@ PP(pp_iter) sv = AvARRAY(av)[ix]; } - if (sv) { - if (SvIS_FREED(sv)) { + 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)) { + assert(!IS_PADGV(sv)); sv = newSVsv(sv); + } else { SvTEMP_off(sv); SvREFCNT_inc_simple_void_NN(sv); } } + else if (!av_is_stack) { + sv = newSVavdefelem(av, ix, 0); + } else sv = &PL_sv_undef; - if (!av_is_stack && sv == &PL_sv_undef) { - SV *lv = newSV_type(SVt_PVLV); - LvTYPE(lv) = 'y'; - sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); - LvTARG(lv) = SvREFCNT_inc_simple(av); - LvTARGOFF(lv) = ix; - LvTARGLEN(lv) = (STRLEN)UV_MAX; - sv = lv; - } - oldsv = *itersvp; *itersvp = sv; SvREFCNT_dec(oldsv); @@ -1946,17 +1953,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, @@ -2009,7 +2013,7 @@ 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; @@ -2057,9 +2061,6 @@ PP(pp_subst) sv_force_normal_flags(TARG,0); #endif if (!(rpm->op_pmflags & PMf_NONDESTRUCT) -#ifdef PERL_ANY_COW - && !is_cow -#endif && (SvREADONLY(TARG) || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) || SvTYPE(TARG) > SVt_PVLV) @@ -2108,6 +2109,7 @@ PP(pp_subst) r_flags = ( RX_NPARENS(rx) || PL_sawampersand || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) + || (rpm->op_pmflags & PMf_KEEPCOPY) ) ? REXEC_COPY_STR : 0; @@ -2156,7 +2158,10 @@ PP(pp_subst) && !is_cow #endif && (I32)clen <= RX_MINLENRET(rx) - && (once || !(r_flags & REXEC_COPY_STR)) + && ( once + || !(r_flags & REXEC_COPY_STR) + || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN)) + ) && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST) && (!doutf8 || SvUTF8(TARG)) && !(rpm->op_pmflags & PMf_NONDESTRUCT)) @@ -2215,9 +2220,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)) { @@ -2230,10 +2235,10 @@ PP(pp_subst) d += clen; } s = RX_OFFS(rx)[0].end + orig; - } while (CALLREGEXEC(rx, s, strend, orig, s == m, + } while (CALLREGEXEC(rx, s, strend, orig, + s == m, /* don't match same null twice */ TARG, NULL, - /* don't match same null twice */ - REXEC_NOT_FIRST|REXEC_IGNOREPOS)); + REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); if (s != d) { I32 i = strend - s; SvCUR_set(TARG, d - SvPVX_const(TARG) + i); @@ -2285,9 +2290,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; @@ -2315,13 +2320,14 @@ PP(pp_subst) sv_catsv(dstr, nsv); } else sv_catsv(dstr, repl); - if (SvTAINTED(repl)) + if (UNLIKELY(SvTAINTED(repl))) rxtainted |= SUBST_TAINT_REPL; } if (once) break; } while (CALLREGEXEC(rx, s, strend, orig, s == m, - TARG, NULL, REXEC_NOT_FIRST|REXEC_IGNOREPOS)); + TARG, NULL, + REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG)); if (rpm->op_pmflags & PMf_NONDESTRUCT) { @@ -2388,7 +2394,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]; @@ -2397,7 +2403,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; @@ -2428,7 +2434,8 @@ PP(pp_grepwhile) SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; - if (SvPADTMP(src) && !IS_PADGV(src)) { + if (SvPADTMP(src)) { + assert(!IS_PADGV(src)); src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src); PL_tmps_floor++; } @@ -2444,7 +2451,7 @@ PP(pp_grepwhile) PP(pp_leavesub) { - dVAR; dSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2461,7 +2468,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)) { @@ -2501,8 +2508,8 @@ PP(pp_leavesub) PUTBACK; LEAVE; - cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ + cxstack_ix--; PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); @@ -2511,90 +2518,92 @@ 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))); + 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? */ @@ -2617,14 +2626,15 @@ 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; if (CvLVALUE(cv)) { /* check for lsub that handles lvalue subroutines */ - cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV))); + cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV)); /* if lsub not found then fall back to DB::sub */ if (!cv) cv = GvCV(PL_DBsub); } else { @@ -2635,37 +2645,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; - I32 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*); @@ -2673,62 +2689,90 @@ 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)) { + assert(!IS_PADGV(*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)); } else { - I32 markix = TOPMARK; + SSize_t markix = TOPMARK; 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) { + 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 */ AV * const av = GvAV(PL_defgv); - const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */ + const SSize_t items = AvFILL(av) + 1; if (items) { + SSize_t i = 0; + const bool m = cBOOL(SvRMAGICAL(av)); /* Mark is at the end of the stack. */ EXTEND(SP, items); - Copy(AvARRAY(av), SP + 1, items, SV*); + for (; i < items; ++i) + { + SV *sv; + if (m) { + SV ** const svp = av_fetch(av, i, 0); + sv = svp ? *svp : NULL; + } + else sv = AvARRAY(av)[i]; + if (sv) SP[i+1] = sv; + else { + SP[i+1] = newSVavdefelem(av, i, 1); + } + } SP += items; PUTBACK ; } } + else { + SV **mark = PL_stack_base + markix; + SSize_t items = SP - mark; + while (items--) { + mark++; + if (*mark && SvPADTMP(*mark)) { + assert(!IS_PADGV(*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; @@ -2740,12 +2784,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; @@ -2776,25 +2820,25 @@ Perl_sub_crush_depth(pTHX_ CV *cv) PP(pp_aelem) { - dVAR; dSP; + dSP; SV** svp; SV* const elemsv = POPs; IV elem = SvIV(elemsv); AV *const av = MUTABLE_AV(POPs); const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; - const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av)); + const U32 defer = PL_op->op_private & OPpLVAL_DEFER; const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 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; @@ -2821,21 +2865,20 @@ PP(pp_aelem) MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend); } #endif - if (!svp || *svp == &PL_sv_undef) { - SV* lv; + if (!svp || !*svp) { + IV len; if (!defer) DIE(aTHX_ PL_no_aelem, elem); - lv = sv_newmortal(); - sv_upgrade(lv, SVt_PVLV); - LvTYPE(lv) = 'y'; - sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); - LvTARG(lv) = SvREFCNT_inc_simple(av); - LvTARGOFF(lv) = elem; - LvTARGLEN(lv) = 1; - PUSHs(lv); + 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 + reporting in magic_setdefelem. */ + elem < 0 && len + elem >= 0 ? len + elem : elem, + 1)); RETURN; } - if (localizing) { + if (UNLIKELY(localizing)) { if (preeminent) save_aelem(av, elem, svp); else @@ -2890,7 +2933,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) PP(pp_method) { - dVAR; dSP; + dSP; SV* const sv = TOPs; if (SvROK(sv)) { @@ -2907,7 +2950,7 @@ PP(pp_method) PP(pp_method_named) { - dVAR; dSP; + dSP; SV* const sv = cSVOP_sv; U32 hash = SvSHARED_HASH(sv); @@ -2918,7 +2961,6 @@ PP(pp_method_named) STATIC SV * S_method_common(pTHX_ SV* meth, U32* hashp) { - dVAR; SV* ob; GV* gv; HV* stash; @@ -2931,7 +2973,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) PERL_ARGS_ASSERT_METHOD_COMMON; - if (!sv) + if (UNLIKELY(!sv)) undefined: Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value", SVfARG(meth)); @@ -2958,22 +3000,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) goto fetch; 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)))) { @@ -2985,16 +3017,8 @@ 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)); - } + stash = gv_stashpvn(packname, packlen, packname_utf8); + if (!stash) packsv = sv; goto fetch; } /* it _is_ a filehandle name -- replace with a reference */ @@ -3024,6 +3048,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp); if (he) { gv = MUTABLE_GV(HeVAL(he)); + assert(stash); if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) @@ -3031,9 +3056,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } } + assert(stash || packsv); gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv), - meth, GV_AUTOLOAD | GV_CROAK); - + meth, GV_AUTOLOAD | GV_CROAK); assert(gv); return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);