X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7554d34485b417b08875137130152d0168feefa8..32da1f0cbb3039b18da95a780824c723ee95d127:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index 39aef72..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. */ @@ -416,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 */ @@ -532,7 +533,7 @@ PP(pp_multiconcat) /* an undef value in the presence of warnings may trigger * side affects */ goto do_magical; - svpv_end->pv = (char*)""; + svpv_end->pv = ""; len = 0; } else @@ -639,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. @@ -686,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++) { @@ -1097,15 +1098,20 @@ PP(pp_multiconcat) SP = toparg - stack_adj + 1; - /* Assign result of all RHS concats (left) to LHS (targ). + /* 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) - SvTAINT(targ); - else { + if ( !is_append + && ( (PL_op->op_flags & OPf_STACKED) + || (PL_op->op_private & OPpTARGET_MY)) + ) { sv_setsv(targ, left); SvSETMAGIC(targ); } + else + targ = left; SETs(targ); RETURN; } @@ -1256,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; } @@ -1430,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); @@ -1521,7 +1527,9 @@ PP(pp_add) auv = aiv; auvok = 1; /* Now acting as a sign flag. */ } else { - auv = -(UV)aiv; + /* Using 0- here and later to silence bogus warning + * from MS VC */ + auv = (UV) (0 - (UV) aiv); } } a_valid = 1; @@ -1541,7 +1549,7 @@ PP(pp_add) buv = biv; buvok = 1; } else - buv = -(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. @@ -2070,7 +2078,6 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem, #endif ) { - dVAR; SV **relem; SV **lelem; SSize_t lcount = lastlelem - firstlelem + 1; @@ -2198,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; @@ -2736,8 +2743,8 @@ PP(pp_aassign) if (!SvIMMORTAL(lsv)) { sv_set_undef(lsv); SvSETMAGIC(lsv); - *relem++ = lsv; } + *relem++ = lsv; break; } /* switch */ } /* while */ @@ -2888,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; @@ -2943,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; } @@ -2965,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; } @@ -3129,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 */ @@ -3268,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) { @@ -3588,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. */ @@ -4612,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; @@ -5341,7 +5392,7 @@ PP(pp_aelem) 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)