X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/16fe3f8a9e2ea46c1f8b8078916520fd6bf0a0b1..b30a5dee76d42a0c8e99b595031828d9df32ca4b:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index 5ed1792..0f5e417 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -34,6 +34,7 @@ #include "EXTERN.h" #define PERL_IN_PP_HOT_C #include "perl.h" +#include "regcomp.h" /* Hot code. */ @@ -361,8 +362,8 @@ In addition: sprintf "...%s...". Don't call '.' overloading: only use '""' overloading. - OPpMULTICONCAT_STRINGIFY: (for Deparse's benefit) the RHS was of the - form "...$a...$b..." rather than + OPpMULTICONCAT_STRINGIFY: the RHS was of the form + "...$a...$b..." rather than "..." . $a . "..." . $b . "..." An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are @@ -399,8 +400,7 @@ PP(pp_multiconcat) { dSP; SV *targ; /* The SV to be assigned or appended to */ - SV *dsv; /* the SV to concat args to (often == targ) */ - char *dsv_pv; /* where within SvPVX(dsv) we're writing to */ + char *targ_pv; /* where within SvPVX(targ) we're writing to */ STRLEN targ_len; /* SvCUR(targ) */ SV **toparg; /* the highest arg position on the stack */ UNOP_AUX_item *aux; /* PL_op->op_aux buffer */ @@ -408,7 +408,7 @@ PP(pp_multiconcat) const char *const_pv; /* the current segment of the const string buf */ SSize_t nargs; /* how many args were expected */ SSize_t stack_adj; /* how much to adjust SP on return */ - STRLEN grow; /* final size of destination string (dsv) */ + STRLEN grow; /* final size of destination string (targ) */ UV targ_count; /* how many times targ has appeared on the RHS */ bool is_append; /* OPpMULTICONCAT_APPEND flag is set */ bool slow_concat; /* args too complex for quick concat */ @@ -417,7 +417,7 @@ PP(pp_multiconcat) for ease of testing and setting) */ /* for each arg, holds the result of an SvPV() call */ struct multiconcat_svpv { - char *pv; + const char *pv; SSize_t len; } *targ_chain, /* chain of slots where targ has appeared on RHS */ @@ -456,10 +456,6 @@ PP(pp_multiconcat) toparg = SP; SP -= (nargs - 1); - dsv = targ; /* Set the destination for all concats. This is - initially targ; later on, dsv may be switched - to point to a TEMP SV if overloading is - encountered. */ grow = 1; /* allow for '\0' at minimum */ targ_count = 0; targ_chain = NULL; @@ -480,13 +476,13 @@ PP(pp_multiconcat) * Where an arg is actually targ, the stringification is deferred: * the length is set to 0, and the slot is added to targ_chain. * - * If an overloaded arg is found, the loop is abandoned at that point, - * and dsv is set to an SvTEMP SV where the results-so-far will be - * accumulated. + * If a magic, overloaded, or otherwise weird arg is found, which + * might have side effects when stringified, the loop is abandoned and + * we goto a code block where a more basic 'emulate calling + * pp_cpncat() on each arg in turn' is done. */ for (; SP <= toparg; SP++, svpv_end++) { - bool simple_flags; U32 utf8; STRLEN len; SV *sv; @@ -494,161 +490,54 @@ PP(pp_multiconcat) assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG); sv = *SP; - simple_flags = (SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK; /* this if/else chain is arranged so that common/simple cases * take few conditionals */ - if (LIKELY(simple_flags && (sv != targ))) { - /* common case: sv is a simple PV and not the targ */ - svpv_end->pv = SvPVX(sv); + if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) { + /* common case: sv is a simple non-magical PV */ + if (targ == sv) { + /* targ appears on RHS. + * Delay storing PV pointer; instead, add slot to targ_chain + * so it can be populated later, after targ has been grown and + * we know its final SvPVX() address. + */ + targ_on_rhs: + svpv_end->len = 0; /* zerojng here means we can skip + updating later if targ_len == 0 */ + svpv_end->pv = (char*)targ_chain; + targ_chain = svpv_end; + targ_count++; + continue; + } + len = SvCUR(sv); + svpv_end->pv = SvPVX(sv); } - else if (simple_flags) { - /* sv is targ (but can't be magic or overloaded). - * Delay storing PV pointer; instead, add slot to targ_chain - * so it can be populated later, after targ has been grown and - * we know its final SvPVX() address. + else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK))) + /* may have side effects: tie, overload etc. + * Abandon 'stringify everything first' and handle + * args in strict order. Note that already-stringified args + * will be reprocessed, which is safe because the each first + * stringification would have been idempotent. */ - targ_on_rhs: - svpv_end->len = 0; /* zerojng here means we can skip - updating later if targ_len == 0 */ - svpv_end->pv = (char*)targ_chain; - targ_chain = svpv_end; - targ_count++; - continue; - } - else { - if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK))) { - /* its got magic, is tied, and/or is overloaded */ - SvGETMAGIC(sv); - - if (UNLIKELY(SvAMAGIC(sv)) - && !(PL_op->op_private & OPpMULTICONCAT_FAKE)) - { - /* One of the RHS args is overloaded. Abandon stringifying - * the args at this point, then in the concat loop later - * on, concat the plain args stringified so far into a - * TEMP SV. At the end of this function the remaining - * args (including the current one) will be handled - * specially, using overload calls. - * FAKE implies an optimised sprintf which doesn't use - * concat overloading, only "" overloading. - */ - - if ( svpv_end == svpv_buf + 1 - /* no const string segments */ - && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize == -1 - && aux[PERL_MULTICONCAT_IX_LENGTHS + 1].ssize == -1 - ) { - /* special case: if the overloaded sv is the - * second arg in the concat chain, stop at the - * first arg rather than this, so that - * - * $arg1 . $arg2 - * - * invokes overloading as - * - * concat($arg2, $arg1, 1) - * - * rather than - * - * concat($arg2, "$arg1", 1) - * - * This means that if for example arg1 is a ref, - * it gets passed as-is to the concat method - * rather than a stringified copy. If it's not the - * first arg, it doesn't matter, as in $arg0 . - * $arg1 . $arg2, where the result of ($arg0 . - * $arg1) will already be a string. - * THis isn't perfect: we'll have already - * done SvPV($arg1) on the previous iteration; - * and are now throwing away that result and - * hoping arg1 hasn;t been affected. - */ - svpv_end--; - SP--; - } - - setup_overload: - dsv = newSVpvn_flags("", 0, SVs_TEMP); - - if (targ_chain) { - /* Get the string value of targ and populate any - * RHS slots which use it */ - char *pv = SvPV_nomg(targ, len); - dst_utf8 |= (SvFLAGS(targ) & SVf_UTF8); - grow += len * targ_count; - do { - struct multiconcat_svpv *p = targ_chain; - targ_chain = (struct multiconcat_svpv *)(p->pv); - p->pv = pv; - p->len = len; - } while (targ_chain); - } - else if (is_append) - SvGETMAGIC(targ); - - goto phase3; - } - - if (SvFLAGS(sv) & SVs_RMG) { - /* probably tied; copy it to guarantee separate values - * each time it's used, e.g. "-$tied-$tied-$tied-", - * since FETCH() isn't necessarily idempotent */ - SV *nsv = newSV(0); - sv_setsv_flags(nsv, sv, SV_NOSTEAL); - sv_2mortal(nsv); - if ( sv == targ - && is_append - && nargs == 1 - /* no const string segments */ - && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize == -1 - && aux[PERL_MULTICONCAT_IX_LENGTHS+1].ssize == -1) - { - /* special-case $tied .= $tied. - * - * For something like - * sub FETCH { $i++ } - * then - * $tied .= $tied . $tied . $tied; - * will STORE "4123" - * while - * $tied .= $tied - * will STORE "12" - * - * i.e. for a single mutator concat, the LHS is - * retrieved first; in all other cases it is - * retrieved last. Whether this is sane behaviour - * is open to debate; but for now, multiconcat (as - * it is an optimisation) tries to reproduce - * existing behaviour. - */ - sv_catsv(nsv, sv); - sv_setsv(sv,nsv); - SP++; - goto phase7; /* just return targ as-is */ - } - - sv = nsv; - } - } - - if (sv == targ) { - /* must warn for each RH usage of targ, except that - * we will later get one warning when doing - * SvPV_force(targ), *except* on '.=' */ - if ( !SvOK(sv) - && (targ_chain || is_append) - && ckWARN(WARN_UNINITIALIZED) - ) - report_uninit(sv); - goto targ_on_rhs; - } - - /* stringify general SV */ + goto do_magical; + else if (SvNIOK(sv)) { + if (targ == sv) + goto targ_on_rhs; + /* stringify general valid scalar */ svpv_end->pv = sv_2pv_flags(sv, &len, 0); } + else if (!SvOK(sv)) { + if (ckWARN(WARN_UNINITIALIZED)) + /* an undef value in the presence of warnings may trigger + * side affects */ + goto do_magical; + svpv_end->pv = ""; + len = 0; + } + else + goto do_magical; /* something weird */ utf8 = (SvFLAGS(sv) & SVf_UTF8); dst_utf8 |= utf8; @@ -667,31 +556,9 @@ PP(pp_multiconcat) */ if (is_append) { - if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK))) { - SvGETMAGIC(targ); /* must do before SvAMAGIC() check */ - if (UNLIKELY(SvAMAGIC(targ))) { - /* $overloaded .= ....; - * accumulate RHS in a temp SV rather than targ, - * then append tmp to targ at the end using overload - */ - assert(!targ_chain); - dsv = newSVpvn_flags("", 0, SVs_TEMP); - - if ( svpv_end == svpv_buf + 1 - /* no const string segments */ - && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize == -1 - ) { - /* special case $overloaded .= $arg1: - * avoid stringifying $arg1. - * Similar to the $arg1 . $arg2 case in phase1 - */ - svpv_end--; - SP--; - } - - goto phase3; - } - } + /* abandon quick route if using targ might have side effects */ + if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK))) + goto do_magical; if (SvOK(targ)) { U32 targ_utf8; @@ -709,6 +576,10 @@ PP(pp_multiconcat) grow += targ_len * (targ_count + is_append); goto phase3; } + else if (ckWARN(WARN_UNINITIALIZED)) + /* warning might have side effects */ + goto do_magical; + /* the undef targ will be silently SvPVCLEAR()ed below */ } else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) { /* Assigning to some weird LHS type. Don't force the LHS to be an @@ -720,28 +591,19 @@ PP(pp_multiconcat) * (which makes the 'F' typeglob an alias to the * '*main::F*main::F' typeglob). */ - goto setup_overload; + goto do_magical; } - else if (targ_chain) { + else if (targ_chain) /* targ was found on RHS. - * We don't need the SvGETMAGIC() call and SvAMAGIC() test as - * both were already done earlier in the SvPV() loop; other - * than that we can share the same code with the append - * branch below. - * Note that this goto jumps directly into the SvOK() branch - * even if targ isn't SvOK(), to force an 'uninitialised' - * warning; e.g. - * $undef .= .... targ only on LHS: don't warn - * $undef .= $undef .... targ on RHS too: warn + * Force stringify it, using the same code as the append branch + * above, except that we don't need the magic/overload/undef + * checks as these will already have been done in the phase 1 + * loop. */ - assert(!SvAMAGIC(targ)); goto stringify_targ; - } - /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0; * those will be done later. */ - assert(targ == dsv); SV_CHECK_THINKFIRST_COW_DROP(targ); SvUPGRADE(targ, SVt_PV); SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8); @@ -752,10 +614,10 @@ PP(pp_multiconcat) /* -------------------------------------------------------------- * Phase 3: * - * UTF-8 tweaks and grow dsv: + * UTF-8 tweaks and grow targ: * * Now that we know the length and utf8-ness of both the targ and - * args, grow dsv to the size needed to accumulate all the args, based + * args, grow targ to the size needed to accumulate all the args, based * on whether targ appears on the RHS, whether we're appending, and * whether any non-utf8 args expand in size if converted to utf8. * @@ -778,7 +640,7 @@ PP(pp_multiconcat) * one set of segment lengths. * * * If the string has different plain and utf8 representations - * (e.g. "\x80"), then then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]] + * (e.g. "\x80"), then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]] * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] * holds the utf8 rep, and there are 2 sets of segment lengths, * with the utf8 set following after the plain set. @@ -794,7 +656,7 @@ PP(pp_multiconcat) /* turn off utf8 handling if 'use bytes' is in scope */ if (UNLIKELY(dst_utf8 && IN_BYTES)) { dst_utf8 = 0; - SvUTF8_off(dsv); + SvUTF8_off(targ); /* undo all the negative lengths which flag utf8-ness */ for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) { SSize_t len = svpv_p->len; @@ -825,7 +687,7 @@ PP(pp_multiconcat) * calculate how much extra growth is needed for all the chars * which will expand to two utf8 bytes. * Also, if the growth is non-zero, negate the length to indicate - * that this this is a variant string. Conversely, un-negate the + * that this is a variant string. Conversely, un-negate the * length on utf8 args (which was only needed to flag non-utf8 * args in this loop */ for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) { @@ -852,16 +714,16 @@ PP(pp_multiconcat) /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should * already have been dropped */ - assert(!SvIsCOW(dsv)); - dsv_pv = (SvLEN(dsv) < (grow) ? sv_grow(dsv,grow) : SvPVX(dsv)); + assert(!SvIsCOW(targ)); + targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ)); /* -------------------------------------------------------------- * Phase 4: * - * Now that dsv (which is probably targ) has been grown, we know the - * final address of the targ PVX, if needed. Preserve / move targ - * contents if appending or if targ appears on RHS. + * Now that targ has been grown, we know the final address of the targ + * PVX, if needed. Preserve / move targ contents if appending or if + * targ appears on RHS. * * Also update svpv_buf slots in targ_chain. * @@ -884,7 +746,7 @@ PP(pp_multiconcat) * On exit, the targ contents will have been moved to the * earliest place they are needed (e.g. $x = "abc$x" will shift them * 3 bytes, while $x .= ... will leave them at the beginning); - * and dst_pv will point to the location within SvPVX(dsv) where the + * and dst_pv will point to the location within SvPVX(targ) where the * next arg should be copied. */ @@ -892,13 +754,12 @@ PP(pp_multiconcat) if (targ_len) { struct multiconcat_svpv *tc_stop; - char *targ_pv = dsv_pv; + char *targ_buf = targ_pv; /* ptr to original targ string */ - assert(targ == dsv); assert(is_append || targ_count); if (is_append) { - dsv_pv += targ_len; + targ_pv += targ_len; tc_stop = NULL; } else { @@ -939,8 +800,8 @@ PP(pp_multiconcat) } if (offset) { - targ_pv += offset; - Move(dsv_pv, targ_pv, targ_len, char); + targ_buf += offset; + Move(targ_pv, targ_buf, targ_len, char); /* a negative length implies don't Copy(), but do increment */ svpv_p->len = -((SSize_t)targ_len); slow_concat = TRUE; @@ -949,7 +810,7 @@ PP(pp_multiconcat) /* skip the first targ copy */ svpv_base++; const_lens++; - dsv_pv += targ_len; + targ_pv += targ_len; } /* Don't populate the first targ slot in the loop below; it's @@ -963,7 +824,7 @@ PP(pp_multiconcat) while (targ_chain != tc_stop) { struct multiconcat_svpv *p = targ_chain; targ_chain = (struct multiconcat_svpv *)(p->pv); - p->pv = targ_pv; + p->pv = targ_buf; p->len = (SSize_t)targ_len; } } @@ -972,7 +833,7 @@ PP(pp_multiconcat) /* -------------------------------------------------------------- * Phase 5: * - * Append all the args in svpv_buf, plus the const strings, to dsv. + * Append all the args in svpv_buf, plus the const strings, to targ. * * On entry to this section the (pv,len) pairs in svpv_buf have the * following meanings: @@ -980,7 +841,7 @@ PP(pp_multiconcat) * (pv, -(len+extra)) a plain string which will expand by 'extra' * bytes when converted to utf8 * (0, -len) left-most targ, whose content has already - * been copied. Just advance dsv_pv by len. + * been copied. Just advance targ_pv by len. */ /* If there are no constant strings and no special case args @@ -991,8 +852,8 @@ PP(pp_multiconcat) SSize_t len = svpv_p->len; if (!len) continue; - Copy(svpv_p->pv, dsv_pv, len, char); - dsv_pv += len; + Copy(svpv_p->pv, targ_pv, len, char); + targ_pv += len; } const_lens += (svpv_end - svpv_base + 1); } @@ -1007,8 +868,8 @@ PP(pp_multiconcat) /* append next const string segment */ if (len > 0) { - Copy(const_pv, dsv_pv, len, char); - dsv_pv += len; + Copy(const_pv, targ_pv, len, char); + targ_pv += len; const_pv += len; } @@ -1019,8 +880,8 @@ PP(pp_multiconcat) len = svpv_p->len; if (LIKELY(len > 0)) { - Copy(svpv_p->pv, dsv_pv, len, char); - dsv_pv += len; + Copy(svpv_p->pv, targ_pv, len, char); + targ_pv += len; } else if (UNLIKELY(len < 0)) { /* negative length indicates two special cases */ @@ -1028,141 +889,232 @@ PP(pp_multiconcat) len = -len; if (UNLIKELY(p)) { /* copy plain-but-variant pv to a utf8 targ */ - char * end_pv = dsv_pv + len; + char * end_pv = targ_pv + len; assert(dst_utf8); - while (dsv_pv < end_pv) { + while (targ_pv < end_pv) { U8 c = (U8) *p++; - append_utf8_from_native_byte(c, (U8**)&dsv_pv); + append_utf8_from_native_byte(c, (U8**)&targ_pv); } } else /* arg is already-copied targ */ - dsv_pv += len; + targ_pv += len; } } } - *dsv_pv = '\0'; - SvCUR_set(dsv, dsv_pv - SvPVX(dsv)); - assert(grow >= SvCUR(dsv) + 1); - assert(SvLEN(dsv) >= SvCUR(dsv) + 1); + *targ_pv = '\0'; + SvCUR_set(targ, targ_pv - SvPVX(targ)); + assert(grow >= SvCUR(targ) + 1); + assert(SvLEN(targ) >= SvCUR(targ) + 1); /* -------------------------------------------------------------- * Phase 6: * - * Handle overloading. If an overloaded arg or targ was detected - * earlier, dsv will have been set to a new mortal, and any args and - * consts to the left of the first overloaded arg will have been - * accumulated to it. This section completes any further concatenation - * steps with overloading handled. + * return result */ - if (UNLIKELY(dsv != targ)) { - SV *res; + SP -= stack_adj; + SvTAINT(targ); + SETTARG; + RETURN; - SvFLAGS(dsv) |= dst_utf8; + /* -------------------------------------------------------------- + * Phase 7: + * + * We only get here if any of the args (or targ too in the case of + * append) have something which might cause side effects, such + * as magic, overload, or an undef value in the presence of warnings. + * In that case, any earlier attempt to stringify the args will have + * been abandoned, and we come here instead. + * + * Here, we concat each arg in turn the old-fashioned way: essentially + * emulating pp_concat() in a loop. This means that all the weird edge + * cases will be handled correctly, if not necessarily speedily. + * + * Note that some args may already have been stringified - those are + * processed again, which is safe, since only args without side-effects + * were stringified earlier. + */ - if (SP <= toparg) { - /* Stringifying the RHS was abandoned because *SP - * is overloaded. dsv contains all the concatted strings - * before *SP. Apply the rest of the args using overloading. + do_magical: + { + SSize_t i, n; + SV *left = NULL; + SV *right; + SV* nexttarg; + bool nextappend; + U32 utf8 = 0; + SV **svp; + const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; + UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS; + Size_t arg_count = 0; /* how many args have been processed */ + + if (!cpv) { + cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; + utf8 = SVf_UTF8; + } + + svp = toparg - nargs + 1; + + /* iterate for: + * nargs arguments, + * plus possible nargs+1 consts, + * plus, if appending, a final targ in an extra last iteration + */ + + n = nargs *2 + 1; + for (i = 0; i <= n; i++) { + SSize_t len; + + /* if necessary, stringify the final RHS result in + * something like $targ .= "$a$b$c" - simulating + * pp_stringify */ - SV *left, *right, *res; - int i; - bool getmg = FALSE; - /* number of args already concatted */ - SSize_t n = (nargs - 1) - (toparg - SP); - /* current arg is either the first - * or second value to be concatted - * (including constant strings), so would - * form part of the first concat */ - bool first_concat = ( n == 0 - || (n == 1 && const_lens[-2].ssize < 0 - && const_lens[-1].ssize < 0)); - int f_assign = first_concat ? 0 : AMGf_assign; - - left = dsv; - - for (; n < nargs; n++) { - /* loop twice, first applying the arg, then the const segment */ - for (i = 0; i < 2; i++) { - if (i) { - /* append next const string segment */ - STRLEN len = (STRLEN)((const_lens++)->ssize); - /* a length of -1 implies no constant string - * rather than a zero-length one, e.g. - * ($a . $b) versus ($a . "" . $b) - */ - if ((SSize_t)len < 0) - continue; + if ( i == n + && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY) + && !(SvPOK(left)) + /* extra conditions for backwards compatibility: + * probably incorrect, but keep the existing behaviour + * for now. The rules are: + * $x = "$ov" single arg: stringify; + * $x = "$ov$y" multiple args: don't stringify, + * $lex = "$ov$y$z" except TARGMY with at least 2 concats + */ + && ( arg_count == 1 + || ( arg_count >= 3 + && !is_append + && (PL_op->op_private & OPpTARGET_MY) + && !(PL_op->op_private & OPpLVAL_INTRO) + ) + ) + ) + { + SV *tmp = sv_newmortal(); + sv_copypv(tmp, left); + SvSETMAGIC(tmp); + left = tmp; + } - /* set right to the next constant string segment */ - right = newSVpvn_flags(const_pv, len, - (dst_utf8 | SVs_TEMP)); - const_pv += len; - } - else { - /* append next arg */ - right = *SP++; - if (getmg) - SvGETMAGIC(right); - else - /* SvGETMAGIC already called on this SV just - * before we broke from the loop earlier */ - getmg = TRUE; - - if (first_concat && n == 0 && const_lens[-1].ssize < 0) { - /* nothing before the current arg; repeat the - * loop to get a second arg */ - left = right; - first_concat = FALSE; - continue; - } - } + /* do one extra iteration to handle $targ in $targ .= ... */ + if (i == n && !is_append) + break; - if ((SvAMAGIC(left) || SvAMAGIC(right)) - && (res = amagic_call(left, right, concat_amg, f_assign)) + /* get the next arg SV or regen the next const SV */ + len = lens[i >> 1].ssize; + if (i == n) { + /* handle the final targ .= (....) */ + right = left; + left = targ; + } + else if (i & 1) + right = svp[(i >> 1)]; + else if (len < 0) + continue; /* no const in this position */ + else { + right = newSVpvn_flags(cpv, len, (utf8 | SVs_TEMP)); + cpv += len; + } + + arg_count++; + + if (arg_count <= 1) { + left = right; + continue; /* need at least two SVs to concat together */ + } + + if (arg_count == 2 && i < n) { + /* for the first concat, create a mortal acting like the + * padtmp from OP_CONST. In later iterations this will + * be appended to */ + nexttarg = sv_newmortal(); + nextappend = FALSE; + } + else { + nexttarg = left; + nextappend = TRUE; + } + + /* Handle possible overloading. + * This is basically an unrolled + * tryAMAGICbin_MG(concat_amg, AMGf_assign); + * and + * Perl_try_amagic_bin() + * call, but using left and right rather than SP[-1], SP[0], + * and not relying on OPf_STACKED implying .= + */ + + if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) { + SvGETMAGIC(left); + if (left != right) + SvGETMAGIC(right); + + if ((SvAMAGIC(left) || SvAMAGIC(right)) + /* sprintf doesn't do concat overloading, + * but allow for $x .= sprintf(...) + */ + && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE) + || i == n) ) - left = res; - else { - if (left != dsv) { - sv_setsv(dsv, left); - left = dsv; + { + SV * const tmpsv = amagic_call(left, right, concat_amg, + (nextappend ? AMGf_assign: 0)); + if (tmpsv) { + /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test + * here, which isn't needed as any implicit + * assign done under OPpTARGET_MY is done after + * this loop */ + if (nextappend) { + sv_setsv(left, tmpsv); + SvSETMAGIC(left); } - sv_catsv_nomg(left, right); + else + left = tmpsv; + continue; } - f_assign = AMGf_assign; + } + + /* if both args are the same magical value, make one a copy */ + if (left == right && SvGMAGICAL(left)) { + left = sv_newmortal(); + /* Print the uninitialized warning now, so it includes the + * variable name. */ + if (!SvOK(right)) { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(right); + sv_setsv_flags(left, &PL_sv_no, 0); + } + else + sv_setsv_flags(left, right, 0); + SvGETMAGIC(right); } } - dsv = left; + + /* nexttarg = left . right */ + S_do_concat(aTHX_ left, right, nexttarg, 0); + left = nexttarg; } - /* assign/append RHS (dsv) to LHS (targ) */ - if (is_append) { - if ((SvAMAGIC(targ) || SvAMAGIC(dsv)) - && (res = amagic_call(targ, dsv, concat_amg, AMGf_assign)) - ) - sv_setsv(targ, res); - else - sv_catsv_nomg(targ, dsv); + SP = toparg - stack_adj + 1; + + /* Return the result of all RHS concats, unless this op includes + * an assign ($lex = x.y.z or expr = x.y.z), in which case copy + * to target (which will be $lex or expr). + * If we are appending, targ will already have been appended to in + * the loop */ + if ( !is_append + && ( (PL_op->op_flags & OPf_STACKED) + || (PL_op->op_private & OPpTARGET_MY)) + ) { + sv_setsv(targ, left); + SvSETMAGIC(targ); } else - sv_setsv(targ, dsv); + targ = left; + SETs(targ); + RETURN; } - - /* -------------------------------------------------------------- - * Phase 7: - * - * return result - */ - - phase7: - - SP -= stack_adj; - SvTAINT(targ); - SETTARG; - RETURN; } @@ -1310,14 +1262,20 @@ PP(pp_eq) { dSP; SV *left, *right; + U32 flags_and, flags_or; - tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric); + tryAMAGICbin_MG(eq_amg, AMGf_numeric); right = POPs; left = TOPs; + flags_and = SvFLAGS(left) & SvFLAGS(right); + flags_or = SvFLAGS(left) | SvFLAGS(right); + SETs(boolSV( - (SvIOK_notUV(left) && SvIOK_notUV(right)) - ? (SvIVX(left) == SvIVX(right)) - : ( do_ncmp(left, right) == 0) + ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) ) + ? (SvIVX(left) == SvIVX(right)) + : (flags_and & SVf_NOK) + ? (SvNVX(left) == SvNVX(right)) + : ( do_ncmp(left, right) == 0) )); RETURN; } @@ -1484,16 +1442,10 @@ PP(pp_add) NV nl = SvNVX(svl); NV nr = SvNVX(svr); - if ( -#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - !Perl_isnan(nl) && nl == (NV)(il = (IV)nl) - && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr) -#else - nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr) -#endif - ) + if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &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); @@ -1575,7 +1527,9 @@ PP(pp_add) auv = aiv; auvok = 1; /* Now acting as a sign flag. */ } else { - auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv); + /* Using 0- here and later to silence bogus warning + * from MS VC */ + auv = (UV) (0 - (UV) aiv); } } a_valid = 1; @@ -1595,7 +1549,7 @@ PP(pp_add) buv = biv; buvok = 1; } else - buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv); + buv = (UV) (0 - (UV) biv); } /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, else "IV" now, independent of how it came in. @@ -1876,7 +1830,6 @@ S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ) PUSHi(i); } else -#ifdef PERL_OP_PARENT if (is_keys) { /* parent op should be an unused OP_KEYS whose targ we can * use */ @@ -1890,7 +1843,6 @@ S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ) PUSHi(i); } else -#endif mPUSHi(i); } } @@ -2126,7 +2078,6 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem, #endif ) { - dVAR; SV **relem; SV **lelem; SSize_t lcount = lastlelem - firstlelem + 1; @@ -2254,7 +2205,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem, PP(pp_aassign) { - dVAR; dSP; + dSP; SV **lastlelem = PL_stack_sp; SV **lastrelem = PL_stack_base + POPMARK; SV **firstrelem = PL_stack_base + POPMARK + 1; @@ -2792,8 +2743,8 @@ PP(pp_aassign) if (!SvIMMORTAL(lsv)) { sv_set_undef(lsv); SvSETMAGIC(lsv); - *relem++ = lsv; } + *relem++ = lsv; break; } /* switch */ } /* while */ @@ -2944,6 +2895,47 @@ PP(pp_qr) RETURN; } +STATIC bool +S_are_we_in_Debug_EXECUTE_r(pTHX) +{ + /* Given a 'use re' is in effect, does it ask for outputting execution + * debug info? + * + * This is separated from the sole place it's called, an inline function, + * because it is the large-ish slow portion of the function */ + + DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX; + + return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK)); +} + +PERL_STATIC_INLINE bool +S_should_we_output_Debug_r(pTHX_ regexp *prog) +{ + PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R; + + /* pp_match can output regex debugging info. This function returns a + * boolean as to whether or not it should. + * + * Under -Dr, it should. Any reasonable compiler will optimize this bit of + * code away on non-debugging builds. */ + if (UNLIKELY(DEBUG_r_TEST)) { + return TRUE; + } + + /* If the regex engine is using the non-debugging execution routine, then + * no debugging should be output. Same if the field is NULL that pluggable + * engines are not supposed to fill. */ + if ( LIKELY(prog->engine->exec == &Perl_regexec_flags) + || UNLIKELY(prog->engine->op_comp == NULL)) + { + return FALSE; + } + + /* Otherwise have to check */ + return S_are_we_in_Debug_EXECUTE_r(aTHX); +} + PP(pp_match) { dSP; dTARG; @@ -2999,7 +2991,9 @@ PP(pp_match) pm->op_pmflags & PMf_USED #endif ) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once")); + if (UNLIKELY(should_we_output_Debug_r(prog))) { + PerlIO_printf(Perl_debug_log, "?? already matched once"); + } goto nope; } @@ -3021,9 +3015,11 @@ PP(pp_match) } if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%" - UVuf " < %" IVdf ")\n", - (UV)len, (IV)RXp_MINLEN(prog))); + if (UNLIKELY(should_we_output_Debug_r(prog))) { + PerlIO_printf(Perl_debug_log, + "String shorter than min possible regex match (%zd < %zd)\n", + len, RXp_MINLEN(prog)); + } goto nope; } @@ -3185,7 +3181,7 @@ Perl_do_readline(pTHX) if (IoFLAGS(io) & IOf_ARGV) { if (IoFLAGS(io) & IOf_START) { IoLINES(io) = 0; - if (av_tindex(GvAVn(PL_last_in_gv)) < 0) { + if (av_count(GvAVn(PL_last_in_gv)) == 0) { IoFLAGS(io) &= ~IOf_START; do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0); SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */ @@ -3324,9 +3320,9 @@ Perl_do_readline(pTHX) } for (t1 = SvPVX_const(sv); *t1; t1++) #ifdef __VMS - if (strchr("*%?", *t1)) + if (memCHRs("*%?", *t1)) #else - if (strchr("$&*(){}[]'\";\\|?<>~`", *t1)) + if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1)) #endif break; if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) { @@ -3644,7 +3640,7 @@ PP(pp_multideref) IV len; if (!defer) DIE(aTHX_ PL_no_aelem, elem); - len = av_tindex(av); + len = av_top_index(av); /* Resolve a negative index that falls within * the array. Leave it negative it if falls * outside the array. */ @@ -3986,7 +3982,7 @@ PP(pp_iter) case CXt_LOOP_LIST: /* for (1,2,3) */ assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */ - inc = 1 - (PL_op->op_private & OPpITER_REVERSED); + inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED); ix = (cx->blk_loop.state_u.stack.ix += inc); if (UNLIKELY(inc > 0 ? ix > cx->blk_oldsp @@ -4001,7 +3997,7 @@ PP(pp_iter) case CXt_LOOP_ARY: /* for (@ary) */ av = cx->blk_loop.state_u.ary.ary; - inc = 1 - (PL_op->op_private & OPpITER_REVERSED); + inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED); ix = (cx->blk_loop.state_u.ary.ix += inc); if (UNLIKELY(inc > 0 ? ix > AvFILL(av) @@ -4052,25 +4048,41 @@ PP(pp_iter) DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx)); } - /* Bypass pushing &PL_sv_yes and calling pp_and(); instead + /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead * jump straight to the AND op's op_other */ assert(PL_op->op_next->op_type == OP_AND); - assert(PL_op->op_next->op_ppaddr == Perl_pp_and); - return cLOGOPx(PL_op->op_next)->op_other; + if (PL_op->op_next->op_ppaddr == Perl_pp_and) { + return cLOGOPx(PL_op->op_next)->op_other; + } + else { + /* An XS module has replaced the op_ppaddr, so fall back to the slow, + * obvious way. */ + /* pp_enteriter should have pre-extended the stack */ + EXTEND_SKIP(PL_stack_sp, 1); + *++PL_stack_sp = &PL_sv_yes; + return PL_op->op_next; + } retno: - /* Bypass pushing &PL_sv_no and calling pp_and(); instead + /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead * jump straight to the AND op's op_next */ assert(PL_op->op_next->op_type == OP_AND); - assert(PL_op->op_next->op_ppaddr == Perl_pp_and); /* pp_enteriter should have pre-extended the stack */ EXTEND_SKIP(PL_stack_sp, 1); /* we only need this for the rare case where the OP_AND isn't * in void context, e.g. $x = do { for (..) {...} }; - * but its cheaper to just push it rather than testing first + * (or for when an XS module has replaced the op_ppaddr) + * but it's cheaper to just push it rather than testing first */ *++PL_stack_sp = &PL_sv_no; - return PL_op->op_next->op_next; + if (PL_op->op_next->op_ppaddr == Perl_pp_and) { + return PL_op->op_next->op_next; + } + else { + /* An XS module has replaced the op_ppaddr, so fall back to the slow, + * obvious way. */ + return PL_op->op_next; + } } @@ -4652,7 +4664,6 @@ PP(pp_grepwhile) void Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass) { - dVAR; dSP; SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */ SSize_t nargs; @@ -5374,16 +5385,14 @@ PP(pp_aelem) 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); + MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend"); } #endif if (!svp || !*svp) { IV len; if (!defer) DIE(aTHX_ PL_no_aelem, elem); - len = av_tindex(av); + len = av_top_index(av); /* Resolve a negative index that falls within the array. Leave it negative it if falls outside the array. */ if (elem < 0 && len + elem >= 0)