X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=24af67eb63e5b42221ac9dec0594876d5e5c9fcd;hb=06c0cc96ebd866767a6d107ed78967600f7e0395;hp=508840393b86e31e2f4a6dbf42aee255d5a5a11d;hpb=d526390560c1ae208a087ad4d648b08895f79f8f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 5088403..24af67e 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -58,7 +58,7 @@ PP(pp_gvsv) if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(save_scalar(cGVOP_gv)); else - PUSHs(GvSV(cGVOP_gv)); + PUSHs(GvSVn(cGVOP_gv)); RETURN; } @@ -100,7 +100,8 @@ PP(pp_and) if (!SvTRUE(TOPs)) RETURN; else { - --SP; + if (PL_op->op_type == OP_AND) + --SP; RETURNOP(cLOGOP->op_other); } } @@ -153,7 +154,7 @@ PP(pp_concat) if (TARG == right && right != left) { right = sv_2mortal(newSVpvn(rpv, rlen)); - rpv = SvPV(right, rlen); /* no point setting UTF-8 here */ + rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */ rcopied = TRUE; } @@ -169,8 +170,7 @@ PP(pp_concat) } else { /* TARG == left */ STRLEN llen; - if (SvGMAGICAL(left)) - mg_get(left); /* or mg_get(left) may happen here */ + SvGETMAGIC(left); /* or mg_get(left) may happen here */ if (!SvOK(TARG)) sv_setpvn(left, "", 0); (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */ @@ -186,7 +186,7 @@ PP(pp_concat) if (!rcopied) right = sv_2mortal(newSVpvn(rpv, rlen)); sv_utf8_upgrade_nomg(right); - rpv = SvPV(right, rlen); + rpv = SvPV_const(right, rlen); } } sv_catpvn_nomg(TARG, rpv, rlen); @@ -320,44 +320,63 @@ PP(pp_or) if (SvTRUE(TOPs)) RETURN; else { - --SP; + if (PL_op->op_type == OP_OR) + --SP; RETURNOP(cLOGOP->op_other); } } -PP(pp_dor) +PP(pp_defined) { - /* Most of this is lifted straight from pp_defined */ dSP; - register SV* const sv = TOPs; + register SV* sv = NULL; + bool defined = FALSE; + const int op_type = PL_op->op_type; + + if(op_type == OP_DOR || op_type == OP_DORASSIGN) { + sv = TOPs; + if (!sv || !SvANY(sv)) { + if (op_type == OP_DOR) + --SP; + RETURNOP(cLOGOP->op_other); + } + } else if (op_type == OP_DEFINED) { + sv = POPs; + if (!sv || !SvANY(sv)) + RETPUSHNO; + } else + DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op)); - if (!sv || !SvANY(sv)) { - --SP; - RETURNOP(cLOGOP->op_other); - } - switch (SvTYPE(sv)) { case SVt_PVAV: if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - RETURN; + defined = TRUE; break; case SVt_PVHV: if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - RETURN; + defined = TRUE; break; case SVt_PVCV: if (CvROOT(sv) || CvXSUB(sv)) - RETURN; + defined = TRUE; break; default: - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvOK(sv)) - RETURN; + defined = TRUE; } - --SP; - RETURNOP(cLOGOP->op_other); + if(op_type == OP_DOR || op_type == OP_DORASSIGN) { + if(defined) + RETURN; + if(op_type == OP_DOR) + --SP; + RETURNOP(cLOGOP->op_other); + } + /* assuming OP_DEFINED */ + if(defined) + RETPUSHYES; + RETPUSHNO; } PP(pp_add) @@ -555,7 +574,7 @@ PP(pp_pushre) * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs * will be enough to hold an OP*. */ - SV* sv = sv_newmortal(); + SV* const sv = sv_newmortal(); sv_upgrade(sv, SVt_PVLV); LvTYPE(sv) = '/'; Copy(&PL_op, &LvTARGOFF(sv), 1, OP*); @@ -660,12 +679,12 @@ PP(pp_print) } } SP = ORIGMARK; - PUSHs(&PL_sv_yes); + XPUSHs(&PL_sv_yes); RETURN; just_say_no: SP = ORIGMARK; - PUSHs(&PL_sv_undef); + XPUSHs(&PL_sv_undef); RETURN; } @@ -775,7 +794,7 @@ PP(pp_rv2av) if (SvRMAGICAL(av)) { U32 i; for (i=0; i < (U32)maxarg; i++) { - SV **svp = av_fetch(av, i, FALSE); + SV ** const svp = av_fetch(av, i, FALSE); /* See note in pp_helem, and bug id #27839 */ SP[i+1] = svp ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp @@ -971,7 +990,6 @@ PP(pp_aassign) if (PL_op->op_private & (OPpASSIGN_COMMON)) { EXTEND_MORTAL(lastrelem - firstrelem + 1); for (relem = firstrelem; relem <= lastrelem; relem++) { - /*SUPPRESS 560*/ if ((sv = *relem)) { TAINT_NOT; /* Each item is independent */ *relem = sv_mortalcopy(sv); @@ -1162,9 +1180,9 @@ PP(pp_aassign) PP(pp_qr) { dSP; - register PMOP *pm = cPMOP; - SV *rv = sv_newmortal(); - SV *sv = newSVrv(rv, "Regexp"); + register PMOP * const pm = cPMOP; + SV * const rv = sv_newmortal(); + SV * const sv = newSVrv(rv, "Regexp"); if (pm->op_pmdynflags & PMdf_TAINTED) SvTAINTED_on(rv); sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0); @@ -1176,8 +1194,8 @@ PP(pp_match) dSP; dTARG; register PMOP *pm = cPMOP; PMOP *dynpm = pm; - const register char *t; - const register char *s; + register const char *t; + register const char *s; const char *strend; I32 global; I32 r_flags = REXEC_CHECKED; @@ -1202,9 +1220,9 @@ PP(pp_match) PUTBACK; /* EVAL blocks need stack_sp. */ s = SvPV_const(TARG, len); - strend = s + len; if (!s) DIE(aTHX_ "panic: pp_match"); + strend = s + len; rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; @@ -1301,7 +1319,6 @@ play_it_again: EXTEND_MORTAL(nparens + i); for (i = !i; i <= nparens; i++) { PUSHs(sv_newmortal()); - /*SUPPRESS 560*/ if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { const I32 len = rx->endp[i] - rx->startp[i]; s = rx->startp[i] + truebase; @@ -1378,7 +1395,7 @@ yup: /* Confirmed by INTUIT */ rx->subbeg = (char *) truebase; rx->startp[0] = s - truebase; if (RX_MATCH_UTF8(rx)) { - char *t = (char*)utf8_hop((U8*)s, rx->minlen); + char * const t = (char*)utf8_hop((U8*)s, rx->minlen); rx->endp[0] = t - truebase; } else { @@ -1475,7 +1492,7 @@ Perl_do_readline(pTHX) if (av_len(GvAVn(PL_last_in_gv)) < 0) { IoFLAGS(io) &= ~IOf_START; do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp); - sv_setpvn(GvSV(PL_last_in_gv), "-", 1); + sv_setpvn(GvSVn(PL_last_in_gv), "-", 1); SvSETMAGIC(GvSV(PL_last_in_gv)); fp = IoIFP(io); goto have_fp; @@ -1496,8 +1513,9 @@ Perl_do_readline(pTHX) } } if (!fp) { - if (ckWARN2(WARN_GLOB, WARN_CLOSED) - && (!io || !(IoFLAGS(io) & IOf_START))) { + if ((!io || !(IoFLAGS(io) & IOf_START)) + && ckWARN2(WARN_GLOB, WARN_CLOSED)) + { if (type == OP_GLOB) Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)", @@ -1590,6 +1608,7 @@ Perl_do_readline(pTHX) XPUSHs(sv); if (type == OP_GLOB) { char *tmps; + const char *t1; if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { tmps = SvEND(sv) - 1; @@ -1598,21 +1617,21 @@ Perl_do_readline(pTHX) SvCUR_set(sv, SvCUR(sv) - 1); } } - for (tmps = SvPVX(sv); *tmps; tmps++) - if (!isALPHA(*tmps) && !isDIGIT(*tmps) && - strchr("$&*(){}[]'\";\\|?<>~`", *tmps)) + for (t1 = SvPVX_const(sv); *t1; t1++) + if (!isALPHA(*t1) && !isDIGIT(*t1) && + strchr("$&*(){}[]'\";\\|?<>~`", *t1)) break; - if (*tmps && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) { + if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) { (void)POPs; /* Unmatched wildcard? Chuck it... */ continue; } } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ - const U8 *s = (U8*)SvPVX(sv) + offset; + const U8 *s = (const U8*)SvPVX_const(sv) + offset; const STRLEN len = SvCUR(sv) - offset; const U8 *f; if (ckWARN(WARN_UTF8) && - !Perl_is_utf8_string_loc(aTHX_ s, len, &f)) + !is_utf8_string_loc(s, len, &f)) /* Emulate :encoding(utf8) warning in the same case. */ Perl_warner(aTHX_ packWARN(WARN_UTF8), "utf8 \"\\x%02X\" does not map to Unicode", @@ -1869,11 +1888,8 @@ PP(pp_iter) RETPUSHNO; if (SvMAGICAL(av) || AvREIFY(av)) { - SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE); - if (svp) - sv = *svp; - else - sv = Nullsv; + SV ** const svp = av_fetch(av, cx->blk_loop.iterix--, FALSE); + sv = svp ? *svp : Nullsv; } else { sv = AvARRAY(av)[cx->blk_loop.iterix--]; @@ -1885,11 +1901,8 @@ PP(pp_iter) RETPUSHNO; if (SvMAGICAL(av) || AvREIFY(av)) { - SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); - if (svp) - sv = *svp; - else - sv = Nullsv; + SV ** const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); + sv = svp ? *svp : Nullsv; } else { sv = AvARRAY(av)[++cx->blk_loop.iterix]; @@ -1954,7 +1967,7 @@ PP(pp_subst) register REGEXP *rx = PM_GETRE(pm); STRLEN len; int force_on_match = 0; - I32 oldsave = PL_savestack_ix; + const I32 oldsave = PL_savestack_ix; STRLEN slen; bool doutf8 = FALSE; #ifdef PERL_OLD_COPY_ON_WRITE @@ -2112,7 +2125,6 @@ PP(pp_subst) *m = '\0'; SvCUR_set(TARG, m - s); } - /*SUPPRESS 560*/ else if ((i = m - s)) { /* faster from front */ d -= clen; m = d; @@ -2141,7 +2153,6 @@ PP(pp_subst) DIE(aTHX_ "Substitution loop"); rxtainted |= RX_MATCH_TAINTED(rx); m = rx->startp[0] + orig; - /*SUPPRESS 560*/ if ((i = m - s)) { if (s != d) Move(s, d, i, char); @@ -2198,7 +2209,7 @@ PP(pp_subst) if (!c) { register PERL_CONTEXT *cx; SPAGAIN; - ReREFCNT_inc(rx); + (void)ReREFCNT_inc(rx); PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } @@ -2286,7 +2297,7 @@ PP(pp_grepwhile) /* All done yet? */ if (PL_stack_base + *PL_markstack_ptr > SP) { I32 items; - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; LEAVE; /* exit outer scope */ (void)POPMARK; /* pop src */ @@ -2295,7 +2306,7 @@ PP(pp_grepwhile) SP = PL_stack_base + POPMARK; /* pop original mark */ if (gimme == G_SCALAR) { if (PL_op->op_private & OPpGREP_LEX) { - SV* sv = sv_newmortal(); + SV* const sv = sv_newmortal(); sv_setiv(sv, items); PUSHs(sv); } @@ -2335,6 +2346,9 @@ PP(pp_leavesub) register PERL_CONTEXT *cx; SV *sv; + if (CxMULTICALL(&cxstack[cxstack_ix])) + return 0; + POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ @@ -2395,6 +2409,9 @@ PP(pp_leavesublv) register PERL_CONTEXT *cx; SV *sv; + if (CxMULTICALL(&cxstack[cxstack_ix])) + return 0; + POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ @@ -2443,7 +2460,10 @@ PP(pp_leavesublv) MARK = newsp + 1; EXTEND_MORTAL(1); if (MARK == SP) { - if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { + /* Temporaries are bad unless they happen to be elements + * of a tied hash or array */ + if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) && + !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) { LEAVE; cxstack_ix--; POPSUB(cx,sv); @@ -2545,7 +2565,7 @@ PP(pp_leavesublv) STATIC CV * S_get_db_sub(pTHX_ SV **svp, CV *cv) { - SV *dbsv = GvSV(PL_DBsub); + SV * const dbsv = GvSVn(PL_DBsub); save_item(dbsv); if (!PERLDB_SUB_NN) { @@ -2558,7 +2578,7 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) && (gv = (GV*)*svp) ))) { /* Use GV from the stack as a fallback. */ /* GV is potentially non-unique, or contain different CV. */ - SV *tmp = newRV((SV*)cv); + SV * const tmp = newRV((SV*)cv); sv_setsv(dbsv, tmp); SvREFCNT_dec(tmp); } @@ -2629,7 +2649,7 @@ PP(pp_entersub) } got_rv: { - SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); } cv = (CV*)SvRV(sv); @@ -2667,7 +2687,7 @@ PP(pp_entersub) /* This path taken at least 75% of the time */ dMARK; register I32 items = SP - MARK; - AV* padlist = CvPADLIST(cv); + AV* const padlist = CvPADLIST(cv); PUSHBLOCK(cx, CXt_SUB, MARK); PUSHSUB(cx); cx->blk_sub.retop = PL_op->op_next; @@ -2681,15 +2701,11 @@ PP(pp_entersub) PERL_STACK_OVERFLOW_CHECK(); pad_push(padlist, CvDEPTH(cv)); } - PAD_SET_CUR(padlist, CvDEPTH(cv)); + SAVECOMPPAD(); + PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); if (hasargs) { - AV* av; -#if 0 - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p entersub preparing @_\n", thr)); -#endif - av = (AV*)PAD_SVl(0); + AV* const av = (AV*)PAD_SVl(0); if (AvREAL(av)) { /* @_ is normally not REAL--this should only ever * happen when DB::sub() calls things that modify @_ */ @@ -2800,6 +2816,7 @@ PP(pp_entersub) return NORMAL; } + /*NOTREACHED*/ assert (0); /* Cannot get here. */ /* This is deliberately moved here as spaghetti code to keep it out of the hot path. */ @@ -2843,7 +2860,7 @@ Perl_sub_crush_depth(pTHX_ CV *cv) if (CvANON(cv)) Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { - SV* tmpstr = sv_newmortal(); + SV* const tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", tmpstr); @@ -2856,7 +2873,7 @@ PP(pp_aelem) SV** svp; SV* const elemsv = POPs; IV elem = SvIV(elemsv); - AV* av = (AV*)POPs; + AV* const av = (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)); SV *sv; @@ -2911,8 +2928,7 @@ PP(pp_aelem) void Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) { - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (!SvOK(sv)) { if (SvREADONLY(sv)) Perl_croak(aTHX_ PL_no_modify); @@ -2942,10 +2958,10 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) PP(pp_method) { dSP; - SV* sv = TOPs; + SV* const sv = TOPs; if (SvROK(sv)) { - SV* rsv = SvRV(sv); + SV* const rsv = SvRV(sv); if (SvTYPE(rsv) == SVt_PVCV) { SETs(rsv); RETURN; @@ -2959,7 +2975,7 @@ PP(pp_method) PP(pp_method_named) { dSP; - SV* sv = cSVOP_sv; + SV* const sv = cSVOP_sv; U32 hash = SvSHARED_HASH(sv); XPUSHs(method_common(sv, &hash)); @@ -2969,31 +2985,26 @@ PP(pp_method_named) STATIC SV * S_method_common(pTHX_ SV* meth, U32* hashp) { - SV* sv; SV* ob; GV* gv; HV* stash; STRLEN namelen; - const char* packname = 0; + const char* packname = Nullch; SV *packsv = Nullsv; STRLEN packlen; - const char *name = SvPV_const(meth, namelen); - - sv = *(PL_stack_base + TOPMARK + 1); + const char * const name = SvPV_const(meth, namelen); + SV * const sv = *(PL_stack_base + TOPMARK + 1); if (!sv) Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name); - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvROK(sv)) ob = (SV*)SvRV(sv); else { GV* iogv; /* this isn't a reference */ - packname = Nullch; - if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) { const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0); if (he) { @@ -3085,7 +3096,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) packname = CopSTASHPV(PL_curcop); } else if (stash) { - HEK *packhek = HvNAME_HEK(stash); + HEK * const packhek = HvNAME_HEK(stash); if (packhek) { packname = HEK_KEY(packhek); packlen = HEK_LEN(packhek);