X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9349a6bbb9de151e5385038b962ceff7c7278b53..e24dfe9ca12550fe5f462e29569953bb5de194b7:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index 1550de5..ff9e594 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -47,7 +47,6 @@ PP(pp_const) PP(pp_nextstate) { 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; @@ -63,8 +62,6 @@ PP(pp_gvsv) PUSHs(save_scalar(cGVOP_gv)); else PUSHs(GvSVn(cGVOP_gv)); - if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)) - PL_sawalias = TRUE; RETURN; } @@ -76,7 +73,8 @@ PP(pp_null) 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) { PUSHMARK(PL_stack_sp); @@ -98,9 +96,6 @@ PP(pp_gv) { dSP; XPUSHs(MUTABLE_SV(cGVOP_gv)); - if (isGV(cGVOP_gv) - && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))) - PL_sawalias = TRUE; RETURN; } @@ -139,7 +134,8 @@ PP(pp_sassign) SV * const temp = left; left = right; right = temp; } - if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right)) + assert(TAINTING_get || !TAINT_get); + if (UNLIKELY(TAINT_get) && !SvTAINTED(right)) TAINT_NOT; if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) { /* *foo =\&bar */ @@ -213,7 +209,7 @@ PP(pp_sassign) assert(source); assert(CvFLAGS(source) & CVf_CONST); - SvREFCNT_inc_void(source); + SvREFCNT_inc_simple_void_NN(source); SvREFCNT_dec_NN(upgraded); SvRV_set(right, MUTABLE_SV(source)); } @@ -299,15 +295,10 @@ PP(pp_concat) } 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 { @@ -316,7 +307,6 @@ PP(pp_concat) sv_utf8_upgrade_nomg(right); rpv = SvPV_nomg_const(right, rlen); } - SPAGAIN; } sv_catpvn_nomg(TARG, rpv, rlen); @@ -449,6 +439,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(); @@ -471,25 +465,44 @@ PP(pp_eq) } -/* also used for: pp_i_predec() pp_i_preinc() pp_predec() */ +/* also used for: pp_i_preinc() */ PP(pp_preinc) { - dSP; - const bool inc = - PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC; - if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))) - Perl_croak_no_modify(); - if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) - && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN)) + SV *sv = *PL_stack_sp; + + if (LIKELY(((sv->sv_flags & + (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV| + SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK)) + == SVf_IOK)) + && SvIVX(sv) != IV_MAX) + { + SvIV_set(sv, SvIVX(sv) + 1); + } + else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */ + sv_inc(sv); + SvSETMAGIC(sv); + return NORMAL; +} + + +/* also used for: pp_i_predec() */ + +PP(pp_predec) +{ + SV *sv = *PL_stack_sp; + + if (LIKELY(((sv->sv_flags & + (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV| + SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK)) + == SVf_IOK)) + && SvIVX(sv) != IV_MIN) { - SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1)); - SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); + SvIV_set(sv, SvIVX(sv) - 1); } - else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ - if (inc) sv_inc(TOPs); - else sv_dec(TOPs); - SvSETMAGIC(TOPs); + else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */ + sv_dec(sv); + SvSETMAGIC(sv); return NORMAL; } @@ -570,15 +583,62 @@ PP(pp_defined) RETPUSHNO; } + + PP(pp_add) { dSP; dATARGET; bool useleft; SV *svl, *svr; + tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; - useleft = USE_LEFT(svl); #ifdef PERL_PRESERVE_IVUV + + /* special-case some simple common cases */ + if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) { + IV il, ir; + U32 flags = (svl->sv_flags & svr->sv_flags); + if (flags & SVf_IOK) { + /* both args are simple IVs */ + UV topl, topr; + il = SvIVX(svl); + ir = SvIVX(svr); + do_iv: + topl = ((UV)il) >> (UVSIZE * 8 - 2); + topr = ((UV)ir) >> (UVSIZE * 8 - 2); + + /* if both are in a range that can't under/overflow, do a + * simple integer add: if the top of both numbers + * are 00 or 11, then it's safe */ + if (!( ((topl+1) | (topr+1)) & 2)) { + SP--; + TARGi(il + ir, 0); /* args not GMG, so can't be tainted */ + SETs(TARG); + RETURN; + } + goto generic; + } + else if (flags & SVf_NOK) { + /* both args are NVs */ + NV nl = SvNVX(svl); + NV nr = SvNVX(svr); + + il = (IV)nl; + ir = (IV)nr; + if (nl == (NV)il && nr == (NV)ir) + /* nothing was lost by converting to IVs */ + goto do_iv; + SP--; + TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */ + SETs(TARG); + RETURN; + } + } + + generic: + + useleft = USE_LEFT(svl); /* We must see if we can perform the addition with integers if possible, as the integer code detects overflow while the NV code doesn't. If either argument hasn't had a numeric conversion yet attempt to get @@ -649,8 +709,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; @@ -670,7 +730,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. @@ -711,7 +771,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 ); @@ -721,7 +782,11 @@ PP(pp_add) } /* Overflow, drop through to NVs. */ } } + +#else + useleft = USE_LEFT(svl); #endif + { NV value = SvNV_nomg(svr); (void)POPs; @@ -1003,6 +1068,164 @@ S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) } } + +/* Do a mark and sweep with the SVf_BREAK flag to detect elements which + * are common to both the LHS and RHS of an aassign, and replace them + * with copies. All these copies are made before the actual list assign is + * done. + * + * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS + * element ($b) to the first LH element ($a), modifies $a; when the + * second assignment is done, the second RH element now has the wrong + * value. So we initially replace the RHS with ($b, mortalcopy($a)). + * Note that we don't need to make a mortal copy of $b. + * + * The algorithm below works by, for every RHS element, mark the + * corresponding LHS target element with SVf_BREAK. Then if the RHS + * element is found with SVf_BREAK set, it means it would have been + * modified, so make a copy. + * Note that by scanning both LHS and RHS in lockstep, we avoid + * unnecessary copies (like $b above) compared with a naive + * "mark all LHS; copy all marked RHS; unmark all LHS". + * + * If the LHS element is a 'my' declaration' and has a refcount of 1, then + * it can't be common and can be skipped. + * + * On DEBUGGING builds it takes an extra boolean, fake. If true, it means + * that we thought we didn't need to call S_aassign_copy_common(), but we + * have anyway for sanity checking. If we find we need to copy, then panic. + */ + +PERL_STATIC_INLINE void +S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem, + SV **firstrelem, SV **lastrelem +#ifdef DEBUGGING + , bool fake +#endif +) +{ + dVAR; + SV **relem; + SV **lelem; + SSize_t lcount = lastlelem - firstlelem + 1; + bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */ + bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1); + + assert(!PL_in_clean_all); /* SVf_BREAK not already in use */ + assert(firstlelem < lastlelem); /* at least 2 LH elements */ + assert(firstrelem < lastrelem); /* at least 2 RH elements */ + + + lelem = firstlelem; + /* we never have to copy the first RH element; it can't be corrupted + * by assigning something to the corresponding first LH element. + * So this scan does in a loop: mark LHS[N]; test RHS[N+1] + */ + relem = firstrelem + 1; + + for (; relem <= lastrelem; relem++) { + SV *svr; + + /* mark next LH element */ + + if (--lcount >= 0) { + SV *svl = *lelem++; + + if (UNLIKELY(!svl)) {/* skip AV alias marker */ + assert (lelem <= lastlelem); + svl = *lelem++; + lcount--; + } + + assert(svl); + if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) { + if (!marked) + return; + /* this LH element will consume all further args; + * no need to mark any further LH elements (if any). + * But we still need to scan any remaining RHS elements; + * set lcount negative to distinguish from lcount == 0, + * so the loop condition continues being true + */ + lcount = -1; + lelem--; /* no need to unmark this element */ + } + else if (!(do_rc1 && SvREFCNT(svl) == 1) && svl != &PL_sv_undef) { + assert(!SvIMMORTAL(svl)); + SvFLAGS(svl) |= SVf_BREAK; + marked = TRUE; + } + else if (!marked) { + /* don't check RH element if no SVf_BREAK flags set yet */ + if (!lcount) + break; + continue; + } + } + + /* see if corresponding RH element needs copying */ + + assert(marked); + svr = *relem; + assert(svr); + + if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK)) { + +#ifdef DEBUGGING + if (fake) { + /* op_dump(PL_op); */ + Perl_croak(aTHX_ + "panic: aassign skipped needed copy of common RH elem %" + UVuf, (UV)(relem - firstrelem)); + } +#endif + + 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 (UNLIKELY(SvIS_FREED(svr))) { + Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p", + (void*)svr); + } + /* avoid break flag while copying; otherwise COW etc + * disabled... */ + SvFLAGS(svr) &= ~SVf_BREAK; + /* Not newSVsv(), as it does not allow copy-on-write, + resulting in wasteful copies. + Also, we use SV_NOSTEAL in case the SV is used more than + once, e.g. (...) = (f())[0,0] + Where the same SV appears twice on the RHS without a ref + count bump. (Although I suspect that the SV won't be + stealable here anyway - DAPM). + */ + *relem = sv_mortalcopy_flags(svr, + SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL); + /* ... but restore afterwards in case it's needed again, + * e.g. ($a,$b,$c) = (1,$a,$a) + */ + SvFLAGS(svr) |= SVf_BREAK; + } + + if (!lcount) + break; + } + + if (!marked) + return; + + /*unmark LHS */ + + while (lelem > firstlelem) { + SV * const svl = *(--lelem); + if (svl) + SvFLAGS(svl) &= ~SVf_BREAK; + } +} + + + PP(pp_aassign) { dVAR; dSP; @@ -1021,49 +1244,60 @@ PP(pp_aassign) HV *hash; SSize_t i; int magic; - U32 lval = 0; + U32 lval; + /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we + * only need to save locally, not on the save stack */ + U16 old_delaymagic = PL_delaymagic; +#ifdef DEBUGGING + bool fake = 0; +#endif PL_delaymagic = DM_DELAY; /* catch simultaneous items */ - gimme = GIMME_V; - if (gimme == G_ARRAY) - lval = PL_op->op_flags & OPf_MOD || LVRET; /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't * clobber a value on the right that's used later in the list. - * Don't bother if LHS is just an empty hash or array. */ - if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias) - && ( - firstlelem != lastlelem - || ! ((sv = *firstlelem)) - || SvMAGICAL(sv) - || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV) - || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1) - || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0) - ) + if ( (PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1)) + /* at least 2 LH and RH elements, or commonality isn't an issue */ + && (firstlelem < lastlelem && firstrelem < lastrelem) ) { - EXTEND_MORTAL(lastrelem - firstrelem + 1); - for (relem = firstrelem; relem <= lastrelem; 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 (UNLIKELY(SvIS_FREED(sv))) { - Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p", - (void*)sv); - } - /* Not newSVsv(), as it does not allow copy-on-write, - resulting in wasteful copies. We need a second copy of - a temp here, hence the SV_NOSTEAL. */ - *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV - |SV_NOSTEAL); - } - } + if (PL_op->op_private & OPpASSIGN_COMMON_RC1) { + /* skip the scan if all scalars have a ref count of 1 */ + for (lelem = firstlelem; lelem <= lastlelem; lelem++) { + sv = *lelem; + if (!sv || SvREFCNT(sv) == 1) + continue; + if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV) + goto do_scan; + break; + } + } + else { + do_scan: + S_aassign_copy_common(aTHX_ + firstlelem, lastlelem, firstrelem, lastrelem +#ifdef DEBUGGING + , fake +#endif + ); + } } +#ifdef DEBUGGING + else { + /* on debugging builds, do the scan even if we've concluded we + * don't need to, then panic if we find commonality. Note that the + * scanner assumes at least 2 elements */ + if (firstlelem < lastlelem && firstrelem < lastrelem) { + fake = 1; + goto do_scan; + } + } +#endif + + gimme = GIMME_V; + lval = (gimme == G_ARRAY) ? (PL_op->op_flags & OPf_MOD || LVRET) : 0; relem = firstrelem; lelem = firstlelem; @@ -1080,36 +1314,79 @@ PP(pp_aassign) ASSUME(SvTYPE(sv) == SVt_PVAV); } switch (SvTYPE(sv)) { - case SVt_PVAV: + case SVt_PVAV: { + bool already_copied = FALSE; ary = MUTABLE_AV(sv); magic = SvMAGICAL(ary) != 0; ENTER; SAVEFREESV(SvREFCNT_inc_simple_NN(sv)); - av_clear(ary); - av_extend(ary, lastrelem - relem); + + /* We need to clear ary. The is a danger that if we do this, + * elements on the RHS may be prematurely freed, e.g. + * @a = ($a[0]); + * In the case of possible commonality, make a copy of each + * RHS SV *before* clearing the array, and add a reference + * from the tmps stack, so that it doesn't leak on death. + * Otherwise, make a copy of each RHS SV only as we're storing + * it into the array - that way we don't have to worry about + * it being leaked if we die, but don't incur the cost of + * mortalising everything. + */ + + if ( (PL_op->op_private & OPpASSIGN_COMMON_AGG) + && (relem <= lastrelem) + && (magic || AvFILL(ary) != -1)) + { + SV **svp; + EXTEND_MORTAL(lastrelem - relem + 1); + for (svp = relem; svp <= lastrelem; svp++) { + /* see comment in S_aassign_copy_common about SV_NOSTEAL */ + *svp = sv_mortalcopy_flags(*svp, + SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL); + TAINT_NOT; + } + already_copied = TRUE; + } + + av_clear(ary); + if (relem <= lastrelem) + av_extend(ary, lastrelem - relem); + i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ SV **didstore; - if (LIKELY(*relem)) - SvGETMAGIC(*relem); /* before newSV, in case it dies */ if (LIKELY(!alias)) { - sv = newSV(0); - sv_setsv_nomg(sv, *relem); - *relem = sv; + if (already_copied) + sv = *relem; + else { + if (LIKELY(*relem)) + /* before newSV, in case it dies */ + SvGETMAGIC(*relem); + sv = newSV(0); + /* see comment in S_aassign_copy_common about + * SV_NOSTEAL */ + sv_setsv_flags(sv, *relem, + (SV_DO_COW_SVSETSV|SV_NOSTEAL)); + *relem = sv; + } } else { + if (!already_copied) + SvGETMAGIC(*relem); 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) + if (lval && !already_copied) *relem = sv_mortalcopy(*relem); /* XXX else check for weak refs? */ - sv = SvREFCNT_inc_simple_NN(SvRV(*relem)); + sv = SvREFCNT_inc_NN(SvRV(*relem)); } relem++; + if (already_copied) + SvREFCNT_inc_simple_void_NN(sv); /* undo mortal free */ didstore = av_store(ary,i++,sv); if (magic) { if (!didstore) @@ -1123,12 +1400,15 @@ PP(pp_aassign) SvSETMAGIC(MUTABLE_SV(ary)); LEAVE; break; + } + case SVt_PVHV: { /* normal hash */ SV *tmpstr; int odd; int duplicates = 0; SV** topelem = relem; SV **firsthashrelem = relem; + bool already_copied = FALSE; hash = MUTABLE_HV(sv); magic = SvMAGICAL(hash) != 0; @@ -1143,7 +1423,31 @@ PP(pp_aassign) ENTER; SAVEFREESV(SvREFCNT_inc_simple_NN(sv)); + + /* We need to clear hash. The is a danger that if we do this, + * elements on the RHS may be prematurely freed, e.g. + * %h = (foo => $h{bar}); + * In the case of possible commonality, make a copy of each + * RHS SV *before* clearing the hash, and add a reference + * from the tmps stack, so that it doesn't leak on death. + */ + + if ( (PL_op->op_private & OPpASSIGN_COMMON_AGG) + && (relem <= lastrelem) + && (magic || HvUSEDKEYS(hash))) + { + SV **svp; + EXTEND_MORTAL(lastrelem - relem + 1); + for (svp = relem; svp <= lastrelem; svp++) { + *svp = sv_mortalcopy_flags(*svp, + SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL); + TAINT_NOT; + } + already_copied = TRUE; + } + hv_clear(hash); + while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */ HE *didstore; assert(*relem); @@ -1151,14 +1455,19 @@ PP(pp_aassign) to avoid having the next op modify our rhs. Copy it also if it is gmagical, lest it make the hv_store_ent call below croak, leaking the value. */ - sv = lval || SvGMAGICAL(*relem) + sv = (lval || SvGMAGICAL(*relem)) && !already_copied ? sv_mortalcopy(*relem) : *relem; relem++; assert(*relem); - SvGETMAGIC(*relem); - tmpstr = newSV(0); - sv_setsv_nomg(tmpstr,*relem++); /* value */ + if (already_copied) + tmpstr = *relem++; + else { + SvGETMAGIC(*relem); + tmpstr = newSV(0); + sv_setsv_nomg(tmpstr,*relem++); /* value */ + } + if (gimme == G_ARRAY) { if (hv_exists_ent(hash, sv, 0)) /* key overwrites an existing entry */ @@ -1171,6 +1480,8 @@ PP(pp_aassign) *topelem++ = tmpstr; } } + if (already_copied) + SvREFCNT_inc_simple_void_NN(tmpstr); /* undo mortal free */ didstore = hv_store_ent(hash,sv,tmpstr,0); if (magic) { if (!didstore) sv_2mortal(tmpstr); @@ -1308,7 +1619,7 @@ PP(pp_aassign) PERL_UNUSED_VAR(tmp_egid); #endif } - PL_delaymagic = 0; + PL_delaymagic = old_delaymagic; if (gimme == G_VOID) SP = firstrelem - 1; @@ -1386,7 +1697,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; @@ -1555,7 +1866,7 @@ PP(pp_match) } NOT_REACHED; /* NOTREACHED */ -nope: + nope: if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { if (!mg) mg = mg_find_mglob(TARG); @@ -1633,8 +1944,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; } @@ -1728,6 +2038,7 @@ Perl_do_readline(pTHX) XPUSHs(sv); if (type == OP_GLOB) { const char *t1; + Stat_t statbuf; if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { char * const tmps = SvEND(sv) - 1; @@ -1743,7 +2054,7 @@ Perl_do_readline(pTHX) if (strchr("$&*(){}[]'\";\\|?<>~`", *t1)) #endif break; - if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) { + if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) { (void)POPs; /* Unmatched wildcard? Chuck it... */ continue; } @@ -1790,7 +2101,8 @@ PP(pp_helem) const bool localizing = PL_op->op_private & OPpLVAL_INTRO; bool preeminent = TRUE; - assert(SvTYPE(hv) != SVt_PVHV); + if (SvTYPE(hv) != SVt_PVHV) + RETPUSHUNDEF; if (localizing) { MAGIC *mg; @@ -1818,7 +2130,7 @@ PP(pp_helem) LvTYPE(lv) = 'y'; sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0); SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */ - LvTARG(lv) = SvREFCNT_inc_simple(hv); + LvTARG(lv) = SvREFCNT_inc_simple_NN(hv); LvTARGLEN(lv) = 1; PUSHs(lv); RETURN; @@ -1856,6 +2168,442 @@ 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_NN(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) { dSP; @@ -2073,8 +2821,8 @@ PP(pp_subst) 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 */ @@ -2298,7 +3046,7 @@ PP(pp_subst) Move(s, d, i+1, char); /* include the NUL */ } SPAGAIN; - mPUSHi((I32)iters); + mPUSHi(iters); } } else { @@ -2378,7 +3126,8 @@ PP(pp_subst) } if (once) break; - } while (CALLREGEXEC(rx, s, strend, orig, s == m, + } while (CALLREGEXEC(rx, s, strend, orig, + s == m, /* Yields minend of 0 or 1 */ TARG, NULL, REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG)); @@ -2410,7 +3159,7 @@ PP(pp_subst) SvPV_set(dstr, NULL); SPAGAIN; - mPUSHi((I32)iters); + mPUSHi(iters); } } @@ -2466,15 +3215,8 @@ PP(pp_grepwhile) (void)POPMARK; /* pop dst */ SP = PL_stack_base + POPMARK; /* pop original mark */ if (gimme == G_SCALAR) { - if (PL_op->op_private & OPpGREP_LEX) { - SV* const sv = sv_newmortal(); - sv_setiv(sv, items); - PUSHs(sv); - } - else { dTARGET; XPUSHi(items); - } } else if (gimme == G_ARRAY) SP += items; @@ -2486,16 +3228,13 @@ PP(pp_grepwhile) ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); - src = PL_stack_base[*PL_markstack_ptr]; + src = PL_stack_base[TOPMARK]; if (SvPADTMP(src)) { - src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src); + src = PL_stack_base[TOPMARK] = sv_mortalcopy(src); PL_tmps_floor++; } SvTEMP_off(src); - if (PL_op->op_private & OPpGREP_LEX) - PAD_SVl(PL_op->op_targ) = src; - else - DEFSV_set(src); + DEFSV_set(src); RETURNOP(cLOGOP->op_other); } @@ -2511,8 +3250,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 */ @@ -2660,7 +3403,7 @@ PP(pp_entersub) } /* 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))) { @@ -2759,7 +3502,8 @@ try_autoload: SAVETMPS; if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && !CvLVALUE(cv))) - DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf, + SVfARG(cv_name(cv, NULL, 0))); /* warning must come *after* we fully set up the context * stuff so that __WARN__ handlers can safely dounwind() * if they want to @@ -2780,7 +3524,8 @@ try_autoload: & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub) ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && !CvLVALUE(cv))) - DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf, + SVfARG(cv_name(cv, NULL, 0))); if (UNLIKELY(!hasargs && GvAV(PL_defgv))) { /* Need to copy @_ to stack. Alternative may be to @@ -3175,11 +3920,5 @@ PP(pp_method_redir_super) } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */