X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=93184cf1d38d87d95c836fd45736ba67889656ea;hb=78b9063ba31cc2a48b78683b758601c04e4eb340;hp=0bcb7bde250c4810aa7070abf10f7c3e01c6e6b0;hpb=2d7268923bcf822410c0286f060732300ab91ea7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 0bcb7bd..93184cf 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,7 +1,7 @@ /* pp_hot.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -16,6 +16,19 @@ * Fire, Foes! Awake! */ +/* This file contains 'hot' pp ("push/pop") functions that + * execute the opcodes that make up a perl program. A typical pp function + * expects to find its arguments on the stack, and usually pushes its + * results onto the stack, hence the 'pp' terminology. Each OP structure + * contains a pointer to the relevant pp_foo() function. + * + * By 'hot', we mean common ops whose execution speed is critical. + * By gathering them together into a single file, we encourage + * CPU cache hits on hot code. Also it could be taken as a warning not to + * change any code in this file unless you're sure it won't affect + * performance. + */ + #include "EXTERN.h" #define PERL_IN_PP_HOT_C #include "perl.h" @@ -132,12 +145,11 @@ PP(pp_concat) dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; - STRLEN llen; - char* lpv; bool lbyte; STRLEN rlen; - char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */ - bool rbyte = !SvUTF8(right), rcopied = FALSE; + const char *rpv = SvPV(right, rlen); /* mg_get(right) happens here */ + const bool rbyte = !DO_UTF8(right); + bool rcopied = FALSE; if (TARG == right && right != left) { right = sv_2mortal(newSVpvn(rpv, rlen)); @@ -146,8 +158,9 @@ PP(pp_concat) } if (TARG != left) { - lpv = SvPV(left, llen); /* mg_get(left) may happen here */ - lbyte = !SvUTF8(left); + STRLEN llen; + const char* const lpv = SvPV(left, llen); /* mg_get(left) may happen here */ + lbyte = !DO_UTF8(left); sv_setpvn(TARG, lpv, llen); if (!lbyte) SvUTF8_on(TARG); @@ -155,24 +168,16 @@ PP(pp_concat) SvUTF8_off(TARG); } else { /* TARG == left */ + STRLEN llen; if (SvGMAGICAL(left)) mg_get(left); /* or mg_get(left) may happen here */ if (!SvOK(TARG)) - sv_setpv(left, ""); - lpv = SvPV_nomg(left, llen); - lbyte = !SvUTF8(left); - } - -#if defined(PERL_Y2KWARN) - if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) { - if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9' - && (llen == 2 || !isDIGIT(lpv[llen - 3]))) - { - Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s", - "about to append an integer to '19'"); - } + sv_setpvn(left, "", 0); + (void)SvPV_nomg(left, llen); /* Needed to set UTF8 flag */ + lbyte = !DO_UTF8(left); + if (IN_BYTES) + SvUTF8_off(TARG); } -#endif if (lbyte != rbyte) { if (lbyte) @@ -198,7 +203,7 @@ PP(pp_padsv) if (PL_op->op_flags & OPf_MOD) { if (PL_op->op_private & OPpLVAL_INTRO) SAVECLEARSV(PAD_SVl(PL_op->op_targ)); - else if (PL_op->op_private & OPpDEREF) { + if (PL_op->op_private & OPpDEREF) { PUTBACK; vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF); SPAGAIN; @@ -229,7 +234,7 @@ PP(pp_eq) { dSP; tryAMAGICbinSET(eq,0); #ifndef NV_PRESERVES_UV - if (SvROK(TOPs) && SvROK(TOPm1s)) { + if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s))); RETURN; @@ -295,12 +300,12 @@ PP(pp_eq) PP(pp_preinc) { dSP; - if (SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) DIE(aTHX_ PL_no_modify); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { - ++SvIVX(TOPs); + SvIV_set(TOPs, SvIVX(TOPs) + 1); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ @@ -324,9 +329,8 @@ PP(pp_dor) { /* Most of this is lifted straight from pp_defined */ dSP; - register SV* sv; + register SV* const sv = TOPs; - sv = TOPs; if (!sv || !SvANY(sv)) { --SP; RETURNOP(cLOGOP->op_other); @@ -429,7 +433,7 @@ PP(pp_add) if ((auvok = SvUOK(TOPm1s))) auv = SvUVX(TOPm1s); else { - register IV aiv = SvIVX(TOPm1s); + register const IV aiv = SvIVX(TOPm1s); if (aiv >= 0) { auv = aiv; auvok = 1; /* Now acting as a sign flag. */ @@ -449,7 +453,7 @@ PP(pp_add) if (buvok) buv = SvUVX(TOPs); else { - register IV biv = SvIVX(TOPs); + register const IV biv = SvIVX(TOPs); if (biv >= 0) { buv = biv; buvok = 1; @@ -521,8 +525,9 @@ PP(pp_add) PP(pp_aelemfast) { dSP; - AV *av = GvAV(cGVOP_gv); - U32 lval = PL_op->op_flags & OPf_MOD; + AV *av = PL_op->op_flags & OPf_SPECIAL ? + (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv); + const U32 lval = PL_op->op_flags & OPf_MOD; SV** svp = av_fetch(av, PL_op->op_private, lval); SV *sv = (svp ? *svp : &PL_sv_undef); EXTEND(SP, 1); @@ -565,7 +570,7 @@ PP(pp_pushre) PP(pp_print) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; GV *gv; IO *io; register PerlIO *fp; @@ -709,9 +714,6 @@ PP(pp_rv2av) GV *gv; if (SvTYPE(sv) != SVt_PVGV) { - char *sym; - STRLEN len; - if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) @@ -722,29 +724,28 @@ PP(pp_rv2av) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "an ARRAY"); if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); + report_uninit(sv); if (GIMME == G_ARRAY) { (void)POPs; RETURN; } RETSETUNDEF; } - sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { - gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV); + gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV); if (!gv - && (!is_gv_magical(sym,len,0) - || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV)))) + && (!is_gv_magical_sv(sv,0) + || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV)))) { RETSETUNDEF; } } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref, sym, "an ARRAY"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); + DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY"); + gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV); } } else { @@ -768,14 +769,17 @@ PP(pp_rv2av) } if (GIMME == G_ARRAY) { - I32 maxarg = AvFILL(av) + 1; + const I32 maxarg = AvFILL(av) + 1; (void)POPs; /* XXXX May be optimized away? */ EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { U32 i; for (i=0; i < (U32)maxarg; i++) { SV **svp = av_fetch(av, i, FALSE); - SP[i+1] = (svp) ? *svp : &PL_sv_undef; + /* See note in pp_helem, and bug id #27839 */ + SP[i+1] = svp + ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp + : &PL_sv_undef; } } else { @@ -785,7 +789,7 @@ PP(pp_rv2av) } else if (GIMME_V == G_SCALAR) { dTARGET; - I32 maxarg = AvFILL(av) + 1; + const I32 maxarg = AvFILL(av) + 1; SETi(maxarg); } RETURN; @@ -795,7 +799,8 @@ PP(pp_rv2hv) { dSP; dTOPss; HV *hv; - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; + static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context"; if (SvROK(sv)) { wasref: @@ -810,7 +815,7 @@ PP(pp_rv2hv) } else if (LVRET) { if (gimme != G_ARRAY) - Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); + Perl_croak(aTHX_ return_hash_to_lvalue_scalar ); SETs((SV*)hv); RETURN; } @@ -827,8 +832,7 @@ PP(pp_rv2hv) } else if (LVRET) { if (gimme != G_ARRAY) - Perl_croak(aTHX_ "Can't return hash to lvalue" - " scalar context"); + Perl_croak(aTHX_ return_hash_to_lvalue_scalar ); SETs((SV*)hv); RETURN; } @@ -837,9 +841,6 @@ PP(pp_rv2hv) GV *gv; if (SvTYPE(sv) != SVt_PVGV) { - char *sym; - STRLEN len; - if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) @@ -850,29 +851,28 @@ PP(pp_rv2hv) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a HASH"); if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); + report_uninit(sv); if (gimme == G_ARRAY) { SP--; RETURN; } RETSETUNDEF; } - sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { - gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV); + gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV); if (!gv - && (!is_gv_magical(sym,len,0) - || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV)))) + && (!is_gv_magical_sv(sv,0) + || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV)))) { RETSETUNDEF; } } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref, sym, "a HASH"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); + DIE(aTHX_ PL_no_symref_sv, sv, "a HASH"); + gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV); } } else { @@ -887,8 +887,7 @@ PP(pp_rv2hv) } else if (LVRET) { if (gimme != G_ARRAY) - Perl_croak(aTHX_ "Can't return hash to lvalue" - " scalar context"); + Perl_croak(aTHX_ return_hash_to_lvalue_scalar ); SETs((SV*)hv); RETURN; } @@ -901,15 +900,7 @@ PP(pp_rv2hv) } else if (gimme == G_SCALAR) { dTARGET; - if (SvRMAGICAL(hv) && mg_find((SV *)hv, PERL_MAGIC_tied)) - Perl_croak(aTHX_ "Can't provide tied hash usage; " - "use keys(%%hash) to test if empty"); - if (HvFILL(hv)) - Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf, - (IV)HvFILL(hv), (IV)HvMAX(hv) + 1); - else - sv_setiv(TARG, 0); - + TARG = Perl_hv_scalar(aTHX_ hv); SETTARG; } RETURN; @@ -923,17 +914,17 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) HE *didstore; if (ckWARN(WARN_MISC)) { + const char *err; if (relem == firstrelem && SvROK(*relem) && (SvTYPE(SvRV(*relem)) == SVt_PVAV || SvTYPE(SvRV(*relem)) == SVt_PVHV)) { - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Reference found where even-sized list expected"); + err = "Reference found where even-sized list expected"; } else - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Odd number of elements in hash assignment"); + err = "Odd number of elements in hash assignment"; + Perl_warner(aTHX_ packWARN(WARN_MISC), err); } tmpstr = NEWSV(29,0); @@ -950,7 +941,7 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) PP(pp_aassign) { - dSP; + dVAR; dSP; SV **lastlelem = PL_stack_sp; SV **lastrelem = PL_stack_base + POPMARK; SV **firstrelem = PL_stack_base + POPMARK + 1; @@ -967,7 +958,8 @@ PP(pp_aassign) I32 i; int magic; int duplicates = 0; - SV **firsthashrelem; + SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */ + PL_delaymagic = DM_DELAY; /* catch simultaneous items */ gimme = GIMME_V; @@ -1004,9 +996,8 @@ PP(pp_aassign) i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ SV **didstore; - sv = NEWSV(28,0); assert(*relem); - sv_setsv(sv,*relem); + sv = newSVsv(*relem); *(relem++) = sv; didstore = av_store(ary,i++,sv); if (magic) { @@ -1193,15 +1184,17 @@ PP(pp_match) char *truebase; /* Start of string */ register REGEXP *rx = PM_GETRE(pm); bool rxtainted; - I32 gimme = GIMME; + const I32 gimme = GIMME; STRLEN len; I32 minmatch = 0; - I32 oldsave = PL_savestack_ix; + const I32 oldsave = PL_savestack_ix; I32 update_minmatch = 1; I32 had_zerolen = 0; if (PL_op->op_flags & OPf_STACKED) TARG = POPs; + else if (PL_op->op_private & OPpTARGET_MY) + GETTARGET; else { TARG = DEFSV; EXTEND(SP,1); @@ -1260,11 +1253,6 @@ PP(pp_match) if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; - if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) { - SAVEINT(PL_multiline); - PL_multiline = pm->op_pmflags & PMf_MULTILINE; - } - play_it_again: if (global && rx->startp[0] != -1) { t = s = rx->endp[0] + truebase; @@ -1304,13 +1292,10 @@ play_it_again: RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { - I32 nparens, i, len; + const I32 nparens = rx->nparens; + I32 i = (global && !nparens) ? 1 : 0; + I32 len; - nparens = rx->nparens; - if (global && !nparens) - i = 1; - else - i = 0; SPAGAIN; /* EVAL blocks could move the stack. */ EXTEND(SP, nparens + i); EXTEND_MORTAL(nparens + i); @@ -1319,10 +1304,10 @@ play_it_again: /*SUPPRESS 560*/ if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { len = rx->endp[i] - rx->startp[i]; + s = rx->startp[i] + truebase; if (rx->endp[i] < 0 || rx->startp[i] < 0 || len < 0 || len > strend - s) DIE(aTHX_ "panic: pp_match start/end pointers"); - s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) SvUTF8_on(*SP); @@ -1454,14 +1439,14 @@ ret_no: OP * Perl_do_readline(pTHX) { - dSP; dTARGETSTACKED; + dVAR; dSP; dTARGETSTACKED; register SV *sv; STRLEN tmplen = 0; STRLEN offset; PerlIO *fp; - register IO *io = GvIO(PL_last_in_gv); - register I32 type = PL_op->op_type; - I32 gimme = GIMME_V; + register IO * const io = GvIO(PL_last_in_gv); + register const I32 type = PL_op->op_type; + const I32 gimme = GIMME_V; MAGIC *mg; if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { @@ -1523,7 +1508,7 @@ Perl_do_readline(pTHX) /* undef TARG, and push that undefined value */ if (type != OP_RCATLINE) { SV_CHECK_THINKFIRST_COW_DROP(TARG); - (void)SvOK_off(TARG); + SvOK_off(TARG); } PUSHTARG; } @@ -1589,7 +1574,7 @@ Perl_do_readline(pTHX) if (gimme == G_SCALAR) { if (type != OP_RCATLINE) { SV_CHECK_THINKFIRST_COW_DROP(TARG); - (void)SvOK_off(TARG); + SvOK_off(TARG); } SPAGAIN; PUSHTARG; @@ -1610,7 +1595,7 @@ Perl_do_readline(pTHX) tmps = SvEND(sv) - 1; if (*tmps == *SvPVX(PL_rs)) { *tmps = '\0'; - SvCUR(sv)--; + SvCUR_set(sv, SvCUR(sv) - 1); } } for (tmps = SvPVX(sv); *tmps; tmps++) @@ -1622,9 +1607,9 @@ Perl_do_readline(pTHX) continue; } } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ - U8 *s = (U8*)SvPVX(sv) + offset; - STRLEN len = SvCUR(sv) - offset; - U8 *f; + const U8 *s = (U8*)SvPVX(sv) + offset; + const STRLEN len = SvCUR(sv) - offset; + const U8 *f; if (ckWARN(WARN_UTF8) && !Perl_is_utf8_string_loc(aTHX_ s, len, &f)) @@ -1635,19 +1620,16 @@ Perl_do_readline(pTHX) } if (gimme == G_ARRAY) { if (SvLEN(sv) - SvCUR(sv) > 20) { - SvLEN_set(sv, SvCUR(sv)+1); - Renew(SvPVX(sv), SvLEN(sv), char); + SvPV_shrink_to_cur(sv); } sv = sv_2mortal(NEWSV(58, 80)); continue; } else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { /* try to reclaim a bit of scalar space (only on 1st alloc) */ - if (SvCUR(sv) < 60) - SvLEN_set(sv, 80); - else - SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */ - Renew(SvPVX(sv), SvLEN(sv), char); + const STRLEN new_len + = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */ + SvPV_renew(sv, new_len); } RETURN; } @@ -1655,7 +1637,7 @@ Perl_do_readline(pTHX) PP(pp_enter) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme = OP_GIMME(PL_op, -1); @@ -1681,13 +1663,13 @@ PP(pp_helem) SV **svp; SV *keysv = POPs; HV *hv = (HV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD || LVRET; - U32 defer = PL_op->op_private & OPpLVAL_DEFER; + const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; + const U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; #ifdef PERL_COPY_ON_WRITE - U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0; + const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0; #else - U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; + const U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; #endif I32 preeminent = 0; @@ -1722,8 +1704,7 @@ PP(pp_helem) SV* lv; SV* key2; if (!defer) { - STRLEN n_a; - DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); + DIE(aTHX_ PL_no_helem_sv, keysv); } lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); @@ -1741,7 +1722,7 @@ PP(pp_helem) else { if (!preeminent) { STRLEN keylen; - char *key = SvPV(keysv, keylen); + const char * const key = SvPV(keysv, keylen); SAVEDELETE(hv, savepvn(key,keylen), keylen); } else save_helem(hv, keysv, svp); @@ -1765,9 +1746,8 @@ PP(pp_helem) PP(pp_leave) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; - register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; @@ -1791,6 +1771,7 @@ PP(pp_leave) if (gimme == G_VOID) SP = newsp; else if (gimme == G_SCALAR) { + register SV **mark; MARK = newsp + 1; if (MARK <= SP) { if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) @@ -1805,6 +1786,7 @@ PP(pp_leave) } else if (gimme == G_ARRAY) { /* in case LEAVE wipes old return values */ + register SV **mark; for (mark = newsp + 1; mark <= SP; mark++) { if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { *mark = sv_mortalcopy(*mark); @@ -1823,7 +1805,7 @@ PP(pp_iter) { dSP; register PERL_CONTEXT *cx; - SV* sv; + SV *sv, *oldsv; AV* av; SV **itersvp; @@ -1839,8 +1821,8 @@ PP(pp_iter) if (cx->blk_loop.iterlval) { /* string increment */ register SV* cur = cx->blk_loop.iterlval; - STRLEN maxlen; - char *max = SvPV((SV*)av, maxlen); + STRLEN maxlen = 0; + const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : ""; if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ @@ -1851,8 +1833,9 @@ PP(pp_iter) /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as * they used to */ - SvREFCNT_dec(*itersvp); + oldsv = *itersvp; *itersvp = newSVsv(cur); + SvREFCNT_dec(oldsv); } if (strEQ(SvPVX(cur), max)) sv_setiv(cur, 0); /* terminate next time */ @@ -1876,28 +1859,47 @@ PP(pp_iter) /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as they * used to */ - SvREFCNT_dec(*itersvp); + oldsv = *itersvp; *itersvp = newSViv(cx->blk_loop.iterix++); + SvREFCNT_dec(oldsv); } RETPUSHYES; } /* iterate array */ - if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av))) - RETPUSHNO; - - SvREFCNT_dec(*itersvp); + if (PL_op->op_private & OPpITER_REVERSED) { + /* In reverse, use itermax as the min :-) */ + if (cx->blk_loop.iterix <= cx->blk_loop.itermax) + RETPUSHNO; - if (SvMAGICAL(av) || AvREIFY(av)) { - SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); - if (svp) - sv = *svp; - else - sv = Nullsv; + if (SvMAGICAL(av) || AvREIFY(av)) { + SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE); + if (svp) + sv = *svp; + else + sv = Nullsv; + } + else { + sv = AvARRAY(av)[cx->blk_loop.iterix--]; + } } else { - sv = AvARRAY(av)[++cx->blk_loop.iterix]; + if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : + AvFILL(av))) + RETPUSHNO; + + if (SvMAGICAL(av) || AvREIFY(av)) { + SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); + if (svp) + sv = *svp; + else + sv = Nullsv; + } + else { + sv = AvARRAY(av)[++cx->blk_loop.iterix]; + } } + if (sv && SvREFCNT(sv) == 0) { *itersvp = Nullsv; Perl_croak(aTHX_ "Use of freed value in iteration"); @@ -1927,7 +1929,10 @@ PP(pp_iter) sv = (SV*)lv; } + oldsv = *itersvp; *itersvp = SvREFCNT_inc(sv); + SvREFCNT_dec(oldsv); + RETPUSHYES; } @@ -1965,6 +1970,8 @@ PP(pp_subst) dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; if (PL_op->op_flags & OPf_STACKED) TARG = POPs; + else if (PL_op->op_private & OPpTARGET_MY) + GETTARGET; else { TARG = DEFSV; EXTEND(SP,1); @@ -1983,8 +1990,8 @@ PP(pp_subst) !is_cow && #endif (SvREADONLY(TARG) - || (SvTYPE(TARG) > SVt_PVLV - && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) + || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV) + && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) DIE(aTHX_ PL_no_modify); PUTBACK; @@ -2017,10 +2024,7 @@ PP(pp_subst) ? REXEC_COPY_STR : 0; if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; - if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) { - SAVEINT(PL_multiline); - PL_multiline = pm->op_pmflags & PMf_MULTILINE; - } + orig = m = s; if (rx->reganch & RE_USE_INTUIT) { PL_bostr = orig; @@ -2191,8 +2195,7 @@ PP(pp_subst) have_a_cow: #endif rxtainted |= RX_MATCH_TAINTED(rx); - dstr = NEWSV(25, len); - sv_setpvn(dstr, m, s-m); + dstr = newSVpvn(m, s-m); if (DO_UTF8(TARG)) SvUTF8_on(dstr); PL_curpm = pm; @@ -2243,15 +2246,13 @@ PP(pp_subst) } else #endif { - (void)SvOOK_off(TARG); - if (SvLEN(TARG)) - Safefree(SvPVX(TARG)); + SvPV_free(TARG); } - SvPVX(TARG) = SvPVX(dstr); + SvPV_set(TARG, SvPVX(dstr)); SvCUR_set(TARG, SvCUR(dstr)); SvLEN_set(TARG, SvLEN(dstr)); doutf8 |= DO_UTF8(dstr); - SvPVX(dstr) = 0; + SvPV_set(dstr, (char*)0); sv_free(dstr); TAINT_IF(rxtainted & 1); @@ -2279,7 +2280,7 @@ ret_no: PP(pp_grepwhile) { - dSP; + dVAR; dSP; if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; @@ -2297,8 +2298,15 @@ PP(pp_grepwhile) (void)POPMARK; /* pop dst */ SP = PL_stack_base + POPMARK; /* pop original mark */ if (gimme == G_SCALAR) { - dTARGET; - XPUSHi(items); + if (PL_op->op_private & OPpGREP_LEX) { + SV* sv = sv_newmortal(); + sv_setiv(sv, items); + PUSHs(sv); + } + else { + dTARGET; + XPUSHi(items); + } } else if (gimme == G_ARRAY) SP += items; @@ -2312,7 +2320,10 @@ PP(pp_grepwhile) src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); - DEFSV = src; + if (PL_op->op_private & OPpGREP_LEX) + PAD_SVl(PL_op->op_targ) = src; + else + DEFSV = src; RETURNOP(cLOGOP->op_other); } @@ -2320,7 +2331,7 @@ PP(pp_grepwhile) PP(pp_leavesub) { - dSP; + dVAR; dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2373,14 +2384,14 @@ PP(pp_leavesub) PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); - return pop_return(); + return cx->blk_sub.retop; } /* This duplicates the above code because the above code must not * get any slower by more conditions */ PP(pp_leavesublv) { - dSP; + dVAR; dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2531,7 +2542,7 @@ PP(pp_leavesublv) PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); - return pop_return(); + return cx->blk_sub.retop; } @@ -2540,10 +2551,10 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) { SV *dbsv = GvSV(PL_DBsub); + save_item(dbsv); if (!PERLDB_SUB_NN) { GV *gv = CvGV(cv); - save_item(dbsv); if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || strEQ(GvNAME(gv), "END") || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ @@ -2560,10 +2571,11 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) } } else { - (void)SvUPGRADE(dbsv, SVt_PVIV); + const int type = SvTYPE(dbsv); + if (type < SVt_PVIV && type != SVt_IV) + sv_upgrade(dbsv, SVt_PVIV); (void)SvIOK_on(dbsv); - SAVEIV(SvIVX(dbsv)); - SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */ + SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ } if (CvXSUB(cv)) @@ -2574,13 +2586,13 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) PP(pp_entersub) { - dSP; dPOPss; + dVAR; dSP; dPOPss; GV *gv; HV *stash; register CV *cv; register PERL_CONTEXT *cx; I32 gimme; - bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; + const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; if (!sv) DIE(aTHX_ "Not a CODE reference"); @@ -2597,9 +2609,7 @@ PP(pp_entersub) break; default: if (!SvROK(sv)) { - char *sym; - STRLEN n_a; - + const char *sym; if (sv == &PL_sv_yes) { /* unfound import, ignore */ if (hasargs) SP = PL_stack_base + POPMARK; @@ -2611,8 +2621,10 @@ PP(pp_entersub) goto got_rv; sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; } - else + else { + STRLEN n_a; sym = SvPV(sv, n_a); + } if (!sym) DIE(aTHX_ PL_no_usym, "a subroutine"); if (PL_op->op_private & HINT_STRICT_REFS) @@ -2652,8 +2664,8 @@ PP(pp_entersub) sv_setiv(PL_DBassertion, 1); cv = get_db_sub(&sv, cv); - if (!cv) - DIE(aTHX_ "No DBsub routine"); + if (!cv || (!CvXSUB(cv) && !CvSTART(cv))) + DIE(aTHX_ "No DB::sub routine defined"); } if (!(CvXSUB(cv))) { @@ -2661,20 +2673,18 @@ PP(pp_entersub) dMARK; register I32 items = SP - MARK; AV* padlist = CvPADLIST(cv); - push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_SUB, MARK); PUSHSUB(cx); + cx->blk_sub.retop = PL_op->op_next; CvDEPTH(cv)++; /* XXX This would be a natural place to set C so * that eval'' ops within this sub know the correct lexical space. * Owing the speed considerations, we choose instead to search for * the cv using find_runcv() when calling doeval(). */ - if (CvDEPTH(cv) < 2) - (void)SvREFCNT_inc(cv); - else { + if (CvDEPTH(cv) >= 2) { PERL_STACK_OVERFLOW_CHECK(); - pad_push(padlist, CvDEPTH(cv), 1); + pad_push(padlist, CvDEPTH(cv)); } PAD_SET_CUR(padlist, CvDEPTH(cv)); if (hasargs) @@ -2704,13 +2714,13 @@ PP(pp_entersub) ary = AvALLOC(av); if (AvARRAY(av) != ary) { AvMAX(av) += AvARRAY(av) - AvALLOC(av); - SvPVX(av) = (char*)ary; + SvPV_set(av, (char*)ary); } if (items > AvMAX(av) + 1) { AvMAX(av) = items - 1; Renew(ary,items,SV*); AvALLOC(av) = ary; - SvPVX(av) = (char*)ary; + SvPV_set(av, (char*)ary); } } Copy(MARK,AvARRAY(av),items,SV*); @@ -2764,10 +2774,8 @@ PP(pp_entersub) /* 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* av; - I32 items; - av = GvAV(PL_defgv); - items = AvFILLp(av) + 1; /* @_ is not tieable */ + AV * const av = GvAV(PL_defgv); + const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */ if (items) { /* Mark is at the end of the stack. */ @@ -2853,11 +2861,11 @@ PP(pp_aelem) { dSP; SV** svp; - SV* elemsv = POPs; + SV* const elemsv = POPs; IV elem = SvIV(elemsv); AV* av = (AV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD || LVRET; - U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); + 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; if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) @@ -2868,6 +2876,19 @@ PP(pp_aelem) RETPUSHUNDEF; svp = av_fetch(av, elem, lval && !defer); if (lval) { +#ifdef PERL_MALLOC_WRAP + if (SvUOK(elemsv)) { + const UV uv = SvUV(elemsv); + elem = uv > IV_MAX ? IV_MAX : uv; + } + else if (SvNOK(elemsv)) + elem = (IV)SvNV(elemsv); + if (elem > 0) { + static const char oom_array_extend[] = + "Out of memory during array extend"; /* Duplicated in av.c */ + MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend); + } +#endif if (!svp || *svp == &PL_sv_undef) { SV* lv; if (!defer) @@ -2905,19 +2926,19 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) if (SvTYPE(sv) < SVt_RV) sv_upgrade(sv, SVt_RV); else if (SvTYPE(sv) >= SVt_PV) { - (void)SvOOK_off(sv); - Safefree(SvPVX(sv)); - SvLEN(sv) = SvCUR(sv) = 0; + SvPV_free(sv); + SvLEN_set(sv, 0); + SvCUR_set(sv, 0); } switch (to_what) { case OPpDEREF_SV: - SvRV(sv) = NEWSV(355,0); + SvRV_set(sv, NEWSV(355,0)); break; case OPpDEREF_AV: - SvRV(sv) = (SV*)newAV(); + SvRV_set(sv, (SV*)newAV()); break; case OPpDEREF_HV: - SvRV(sv) = (SV*)newHV(); + SvRV_set(sv, (SV*)newHV()); break; } SvROK_on(sv); @@ -2959,13 +2980,12 @@ S_method_common(pTHX_ SV* meth, U32* hashp) SV* ob; GV* gv; HV* stash; - char* name; STRLEN namelen; - char* packname = 0; + const char* packname = 0; SV *packsv = Nullsv; STRLEN packlen; + const char *name = SvPV(meth, namelen); - name = SvPV(meth, namelen); sv = *(PL_stack_base + TOPMARK + 1); if (!sv) @@ -2992,7 +3012,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) if (!SvOK(sv) || !(packname) || - !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || + !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { /* this isn't the name of a filehandle either */ @@ -3056,9 +3076,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we don't want that. */ - char* leaf = name; - char* sep = Nullch; - char* p; + const char* leaf = name; + const char* sep = Nullch; + const char* p; for (p = name; *p; p++) { if (*p == '\'') @@ -3097,3 +3117,13 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */