diff options
author | David Mitchell <davem@iabyn.com> | 2015-11-10 13:50:51 +0000 |
---|---|---|
committer | David Mitchell <davem@iabyn.com> | 2015-11-10 13:52:34 +0000 |
commit | 067cec4c785ab7f64d2974ec6622bb9f4fa53eac (patch) | |
tree | f30b419cd8f5a714a3479cc3fc13bf303549e955 | |
parent | fc9a9443cb9edf6f5607176e09aebe85d00da5fe (diff) | |
parent | 20e9643135b0912e2449f038a0ec1c0e84657f3f (diff) | |
download | perl-067cec4c785ab7f64d2974ec6622bb9f4fa53eac.tar.gz |
[MERGE] faster arithmetic
-rw-r--r-- | intrpvar.h | 2 | ||||
-rw-r--r-- | opcode.h | 14 | ||||
-rw-r--r-- | perl.h | 4 | ||||
-rw-r--r-- | pp.c | 199 | ||||
-rw-r--r-- | pp.h | 84 | ||||
-rw-r--r-- | pp_ctl.c | 3 | ||||
-rw-r--r-- | pp_hot.c | 103 | ||||
-rw-r--r-- | pp_proto.h | 2 | ||||
-rw-r--r-- | regcomp.c | 3 | ||||
-rwxr-xr-x | regen/opcode.pl | 6 | ||||
-rw-r--r-- | sv.h | 7 | ||||
-rw-r--r-- | t/op/64bitint.t | 96 | ||||
-rw-r--r-- | t/op/taint.t | 25 | ||||
-rw-r--r-- | t/perf/benchmarks | 115 |
14 files changed, 592 insertions, 71 deletions
diff --git a/intrpvar.h b/intrpvar.h index 1ab3351f46..7f9fa92123 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -75,7 +75,7 @@ PERLVAR(I, multideref_pc, UNOP_AUX_item *) PERLVAR(I, curpm, PMOP *) /* what to do \ interps in REs from */ PERLVAR(I, tainting, bool) /* doing taint checks */ -PERLVAR(I, tainted, bool) /* using variables controlled by $< */ +PERLVARI(I, tainted, bool, FALSE) /* using variables controlled by $< */ /* PL_delaymagic is currently used for two purposes: to assure simultaneous * updates in ($<,$>) = ..., and to assure atomic update in push/unshift @@ -22,11 +22,9 @@ #define Perl_pp_chomp Perl_pp_chop #define Perl_pp_schomp Perl_pp_schop #define Perl_pp_i_preinc Perl_pp_preinc -#define Perl_pp_predec Perl_pp_preinc -#define Perl_pp_i_predec Perl_pp_preinc +#define Perl_pp_i_predec Perl_pp_predec #define Perl_pp_i_postinc Perl_pp_postinc -#define Perl_pp_postdec Perl_pp_postinc -#define Perl_pp_i_postdec Perl_pp_postinc +#define Perl_pp_i_postdec Perl_pp_postdec #define Perl_pp_slt Perl_pp_sle #define Perl_pp_sgt Perl_pp_sle #define Perl_pp_sge Perl_pp_sle @@ -1013,12 +1011,12 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_pos, Perl_pp_preinc, Perl_pp_i_preinc, /* implemented by Perl_pp_preinc */ - Perl_pp_predec, /* implemented by Perl_pp_preinc */ - Perl_pp_i_predec, /* implemented by Perl_pp_preinc */ + Perl_pp_predec, + Perl_pp_i_predec, /* implemented by Perl_pp_predec */ Perl_pp_postinc, Perl_pp_i_postinc, /* implemented by Perl_pp_postinc */ - Perl_pp_postdec, /* implemented by Perl_pp_postinc */ - Perl_pp_i_postdec, /* implemented by Perl_pp_postinc */ + Perl_pp_postdec, + Perl_pp_i_postdec, /* implemented by Perl_pp_postdec */ Perl_pp_pow, Perl_pp_multiply, Perl_pp_i_multiply, @@ -597,9 +597,9 @@ # define TAINT_WARN_get 0 # define TAINT_WARN_set(s) NOOP #else -# define TAINT (PL_tainted = TRUE) +# define TAINT (PL_tainted = PL_tainting) # define TAINT_NOT (PL_tainted = FALSE) -# define TAINT_IF(c) if (UNLIKELY(c)) { PL_tainted = TRUE; } +# define TAINT_IF(c) if (UNLIKELY(c)) { PL_tainted = PL_tainting; } # define TAINT_ENV() if (UNLIKELY(PL_tainting)) { taint_env(); } # define TAINT_PROPER(s) if (UNLIKELY(PL_tainting)) { taint_proper(NULL, s); } # define TAINT_set(s) (PL_tainted = (s)) @@ -1072,28 +1072,23 @@ PP(pp_undef) } -/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */ +/* common "slow" code for pp_postinc and pp_postdec */ -PP(pp_postinc) +static OP * +S_postincdec_common(pTHX_ SV *sv, SV *targ) { - dSP; dTARGET; + dSP; const bool inc = PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC; - if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))) - Perl_croak_no_modify(); - if (SvROK(TOPs)) + + if (SvROK(sv)) TARG = sv_newmortal(); - sv_setsv(TARG, TOPs); - if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) - && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN)) - { - SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1)); - SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); - } - else if (inc) - sv_inc_nomg(TOPs); - else sv_dec_nomg(TOPs); - SvSETMAGIC(TOPs); + sv_setsv(TARG, sv); + if (inc) + sv_inc_nomg(sv); + else + sv_dec_nomg(sv); + SvSETMAGIC(sv); /* special case for undef: see thread at 2003-03/msg00536.html in archive */ if (inc && !SvOK(TARG)) sv_setiv(TARG, 0); @@ -1101,6 +1096,57 @@ PP(pp_postinc) return NORMAL; } + +/* also used for: pp_i_postinc() */ + +PP(pp_postinc) +{ + dSP; dTARGET; + SV *sv = TOPs; + + /* special-case sv being a simple integer */ + 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) + { + IV iv = SvIVX(sv); + SvIV_set(sv, iv + 1); + TARGi(iv, 0); /* arg not GMG, so can't be tainted */ + SETs(TARG); + return NORMAL; + } + + return S_postincdec_common(aTHX_ sv, TARG); +} + + +/* also used for: pp_i_postdec() */ + +PP(pp_postdec) +{ + dSP; dTARGET; + SV *sv = TOPs; + + /* special-case sv being a simple integer */ + 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) + { + IV iv = SvIVX(sv); + SvIV_set(sv, iv - 1); + TARGi(iv, 0); /* arg not GMG, so can't be tainted */ + SETs(TARG); + return NORMAL; + } + + return S_postincdec_common(aTHX_ sv, TARG); +} + + /* Ordinary operators. */ PP(pp_pow) @@ -1276,7 +1322,64 @@ PP(pp_multiply) tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; + #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 * 4 - 1); + topr = ((UV)ir) >> (UVSIZE * 4 - 1); + + /* if both are in a range that can't under/overflow, do a + * simple integer multiply: if the top halves(*) of both numbers + * are 00...00 or 11...11, then it's safe. + * (*) for 32-bits, the "top half" is the top 17 bits, + * for 64-bits, its 33 bits */ + if (!( + ((topl+1) | (topr+1)) + & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */ + )) { + 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); + NV result; + + il = (IV)nl; + ir = (IV)nr; + if (nl == (NV)il && nr == (NV)ir) + /* nothing was lost by converting to IVs */ + goto do_iv; + SP--; + result = nl * nr; +# if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN && NVSIZE == 16 + if (Perl_isinf(result)) { + Zero((U8*)&result + 8, 8, U8); + } +# endif + TARGn(result, 0); /* args not GMG, so can't be tainted */ + SETs(TARG); + RETURN; + } + } + + generic: + if (SvIV_please_nomg(svr)) { /* Unless the left argument is integer in range we are going to have to use NV maths. Hence only attempt to coerce the right argument if @@ -1393,18 +1496,15 @@ PP(pp_multiply) { NV right = SvNV_nomg(svr); NV left = SvNV_nomg(svl); + NV result = left * right; + (void)POPs; #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN && NVSIZE == 16 - { - NV result = left * right; - if (Perl_isinf(result)) { - Zero((U8*)&result + 8, 8, U8); - } - SETn( result ); + if (Perl_isinf(result)) { + Zero((U8*)&result + 8, 8, U8); } -#else - SETn( left * right ); #endif + SETn(result); RETURN; } } @@ -1804,8 +1904,53 @@ PP(pp_subtract) tryAMAGICbin_MG(subtr_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 subtract: 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); /* See comments in pp_add (in pp_hot.c) about Overflow, and how "bad things" happen if you rely on signed integers wrapping. */ if (SvIV_please_nomg(svr)) { @@ -1903,6 +2048,8 @@ PP(pp_subtract) } /* Overflow, drop through to NVs. */ } } +#else + useleft = USE_LEFT(svl); #endif { NV value = SvNV_nomg(svr); @@ -371,19 +371,85 @@ Does not use C<TARG>. See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>. } } STMT_END #endif +/* set TARG to the IV value i. If do_taint is false, + * assume that PL_tainted can never be true */ +#define TARGi(i, do_taint) \ + STMT_START { \ + IV TARGi_iv = i; \ + if (LIKELY( \ + ((SvFLAGS(TARG) & (SVTYPEMASK|SVf_THINKFIRST)) == SVt_IV) \ + & (do_taint ? !TAINT_get : 1))) \ + { \ + /* Cheap SvIOK_only(). \ + * Assert that flags which SvIOK_only() would test or \ + * clear can't be set, because we're SVt_IV */ \ + assert(!(SvFLAGS(TARG) & \ + (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK))))); \ + SvFLAGS(TARG) |= (SVf_IOK|SVp_IOK); \ + /* SvIV_set() where sv_any points to head */ \ + TARG->sv_u.svu_iv = TARGi_iv; \ + } \ + else \ + sv_setiv_mg(targ, TARGi_iv); \ + } STMT_END + +/* set TARG to the UV value u. If do_taint is false, + * assume that PL_tainted can never be true */ +#define TARGu(u, do_taint) \ + STMT_START { \ + UV TARGu_uv = u; \ + if (LIKELY( \ + ((SvFLAGS(TARG) & (SVTYPEMASK|SVf_THINKFIRST)) == SVt_IV) \ + & (do_taint ? !TAINT_get : 1) \ + & (TARGu_uv <= (UV)IV_MAX))) \ + { \ + /* Cheap SvIOK_only(). \ + * Assert that flags which SvIOK_only() would test or \ + * clear can't be set, because we're SVt_IV */ \ + assert(!(SvFLAGS(TARG) & \ + (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK))))); \ + SvFLAGS(TARG) |= (SVf_IOK|SVp_IOK); \ + /* SvIV_set() where sv_any points to head */ \ + TARG->sv_u.svu_iv = TARGu_uv; \ + } \ + else \ + sv_setuv_mg(targ, TARGu_uv); \ + } STMT_END + +/* set TARG to the NV value n. If do_taint is false, + * assume that PL_tainted can never be true */ +#define TARGn(n, do_taint) \ + STMT_START { \ + NV TARGn_nv = n; \ + if (LIKELY( \ + ((SvFLAGS(TARG) & (SVTYPEMASK|SVf_THINKFIRST)) == SVt_NV) \ + & (do_taint ? !TAINT_get : 1))) \ + { \ + /* Cheap SvNOK_only(). \ + * Assert that flags which SvNOK_only() would test or \ + * clear can't be set, because we're SVt_NV */ \ + assert(!(SvFLAGS(TARG) & \ + (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_NOK|SVp_NOK))))); \ + SvFLAGS(TARG) |= (SVf_NOK|SVp_NOK); \ + SvNV_set(TARG, TARGn_nv); \ + } \ + else \ + sv_setnv_mg(targ, TARGn_nv); \ + } STMT_END + #define PUSHs(s) (*++sp = (s)) #define PUSHTARG STMT_START { SvSETMAGIC(TARG); PUSHs(TARG); } STMT_END #define PUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); PUSHTARG; } STMT_END -#define PUSHn(n) STMT_START { sv_setnv(TARG, (NV)(n)); PUSHTARG; } STMT_END -#define PUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); PUSHTARG; } STMT_END -#define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#define PUSHn(n) STMT_START { TARGn(n,1); PUSHs(TARG); } STMT_END +#define PUSHi(i) STMT_START { TARGi(i,1); PUSHs(TARG); } STMT_END +#define PUSHu(u) STMT_START { TARGu(u,1); PUSHs(TARG); } STMT_END #define XPUSHs(s) STMT_START { EXTEND(sp,1); *++sp = (s); } STMT_END #define XPUSHTARG STMT_START { SvSETMAGIC(TARG); XPUSHs(TARG); } STMT_END #define XPUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } STMT_END -#define XPUSHn(n) STMT_START { sv_setnv(TARG, (NV)(n)); XPUSHTARG; } STMT_END -#define XPUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); XPUSHTARG; } STMT_END -#define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#define XPUSHn(n) STMT_START { TARGn(n,1); XPUSHs(TARG); } STMT_END +#define XPUSHi(i) STMT_START { TARGi(i,1); XPUSHs(TARG); } STMT_END +#define XPUSHu(u) STMT_START { TARGu(u,1); XPUSHs(TARG); } STMT_END #define XPUSHundef STMT_START { SvOK_off(TARG); XPUSHs(TARG); } STMT_END #define mPUSHs(s) PUSHs(sv_2mortal(s)) @@ -403,9 +469,9 @@ Does not use C<TARG>. See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>. #define SETs(s) (*sp = s) #define SETTARG STMT_START { SvSETMAGIC(TARG); SETs(TARG); } STMT_END #define SETp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); SETTARG; } STMT_END -#define SETn(n) STMT_START { sv_setnv(TARG, (NV)(n)); SETTARG; } STMT_END -#define SETi(i) STMT_START { sv_setiv(TARG, (IV)(i)); SETTARG; } STMT_END -#define SETu(u) STMT_START { sv_setuv(TARG, (UV)(u)); SETTARG; } STMT_END +#define SETn(n) STMT_START { TARGn(n,1); SETs(TARG); } STMT_END +#define SETi(i) STMT_START { TARGi(i,1); SETs(TARG); } STMT_END +#define SETu(u) STMT_START { TARGu(u,1); SETs(TARG); } STMT_END #define dTOPss SV *sv = TOPs #define dPOPss SV *sv = POPs @@ -165,7 +165,8 @@ PP(pp_regcomp) } - if (TAINTING_get && TAINT_get) { + assert(TAINTING_get || !TAINT_get); + if (TAINT_get) { SvTAINTED_on((SV*)new_re); RX_TAINT_on(new_re); } @@ -134,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 */ @@ -464,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; } @@ -563,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 @@ -715,7 +782,11 @@ PP(pp_add) } /* Overflow, drop through to NVs. */ } } + +#else + useleft = USE_LEFT(svl); #endif + { NV value = SvNV_nomg(svr); (void)POPs; diff --git a/pp_proto.h b/pp_proto.h index 96934ffc6f..f919313ed1 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -184,8 +184,10 @@ PERL_CALLCONV OP *Perl_pp_padrange(pTHX); PERL_CALLCONV OP *Perl_pp_padsv(pTHX); PERL_CALLCONV OP *Perl_pp_pipe_op(pTHX); PERL_CALLCONV OP *Perl_pp_pos(pTHX); +PERL_CALLCONV OP *Perl_pp_postdec(pTHX); PERL_CALLCONV OP *Perl_pp_postinc(pTHX); PERL_CALLCONV OP *Perl_pp_pow(pTHX); +PERL_CALLCONV OP *Perl_pp_predec(pTHX); PERL_CALLCONV OP *Perl_pp_preinc(pTHX); PERL_CALLCONV OP *Perl_pp_print(pTHX); PERL_CALLCONV OP *Perl_pp_prototype(pTHX); @@ -6679,7 +6679,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_pm_flags = pm_flags; if (runtime_code) { - if (TAINTING_get && TAINT_get) + assert(TAINTING_get || !TAINT_get); + if (TAINT_get) Perl_croak(aTHX_ "Eval-group in insecure regular expression"); if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) { diff --git a/regen/opcode.pl b/regen/opcode.pl index 50029bd1ae..82454bbb48 100755 --- a/regen/opcode.pl +++ b/regen/opcode.pl @@ -130,8 +130,10 @@ my @raw_alias = ( Perl_pp_chop => [qw(chop chomp)], Perl_pp_schop => [qw(schop schomp)], Perl_pp_bind => {connect => '#ifdef HAS_SOCKET'}, - Perl_pp_preinc => ['i_preinc', 'predec', 'i_predec'], - Perl_pp_postinc => ['i_postinc', 'postdec', 'i_postdec'], + Perl_pp_preinc => ['i_preinc'], + Perl_pp_predec => ['i_predec'], + Perl_pp_postinc => ['i_postinc'], + Perl_pp_postdec => ['i_postdec'], Perl_pp_ehostent => [qw(enetent eprotoent eservent spwent epwent sgrent egrent)], Perl_pp_shostent => [qw(snetent sprotoent sservent)], @@ -1473,10 +1473,9 @@ attention to precisely which outputs are influenced by which inputs. #define SvTAINT(sv) \ STMT_START { \ - if (UNLIKELY(TAINTING_get)) { \ - if (UNLIKELY(TAINT_get)) \ - SvTAINTED_on(sv); \ - } \ + assert(TAINTING_get || !TAINT_get); \ + if (UNLIKELY(TAINT_get)) \ + SvTAINTED_on(sv); \ } STMT_END /* diff --git a/t/op/64bitint.t b/t/op/64bitint.t index fcf9949700..b764f0ebb3 100644 --- a/t/op/64bitint.t +++ b/t/op/64bitint.t @@ -363,5 +363,101 @@ cmp_ok 0x8000000000000000 / -1, '==', -0x8000000000000000, '(IV_MAX+1) / -1'; cmp_ok 0 % -0x8000000000000000, '==', 0, '0 % IV_MIN'; cmp_ok -0x8000000000000000 % -0x8000000000000000, '==', 0, 'IV_MIN % IV_MIN'; +# check addition/subtraction with values 1 bit below max ranges +{ + my $a_3ff = 0x3fffffffffffffff; + my $a_400 = 0x4000000000000000; + my $a_7fe = 0x7ffffffffffffffe; + my $a_7ff = 0x7fffffffffffffff; + my $a_800 = 0x8000000000000000; + + my $m_3ff = -$a_3ff; + my $m_400 = -$a_400; + my $m_7fe = -$a_7fe; + my $m_7ff = -$a_7ff; + + cmp_ok $a_3ff, '==', 4611686018427387903, "1bit a_3ff"; + cmp_ok $m_3ff, '==', -4611686018427387903, "1bit -a_3ff"; + cmp_ok $a_400, '==', 4611686018427387904, "1bit a_400"; + cmp_ok $m_400, '==', -4611686018427387904, "1bit -a_400"; + cmp_ok $a_7fe, '==', 9223372036854775806, "1bit a_7fe"; + cmp_ok $m_7fe, '==', -9223372036854775806, "1bit -a_7fe"; + cmp_ok $a_7ff, '==', 9223372036854775807, "1bit a_7ff"; + cmp_ok $m_7ff, '==', -9223372036854775807, "1bit -a_7ff"; + cmp_ok $a_800, '==', 9223372036854775808, "1bit a_800"; + + cmp_ok $a_3ff + $a_3ff, '==', $a_7fe, "1bit a_3ff + a_3ff"; + cmp_ok $m_3ff + $a_3ff, '==', 0, "1bit -a_3ff + a_3ff"; + cmp_ok $a_3ff + $m_3ff, '==', 0, "1bit a_3ff + -a_3ff"; + cmp_ok $m_3ff + $m_3ff, '==', $m_7fe, "1bit -a_3ff + -a_3ff"; + + cmp_ok $a_3ff - $a_3ff, '==', 0, "1bit a_3ff - a_3ff"; + cmp_ok $m_3ff - $a_3ff, '==', $m_7fe, "1bit -a_3ff - a_3ff"; + cmp_ok $a_3ff - $m_3ff, '==', $a_7fe, "1bit a_3ff - -a_3ff"; + cmp_ok $m_3ff - $m_3ff, '==', 0, "1bit -a_3ff - -a_3ff"; + + cmp_ok $a_3ff + $a_400, '==', $a_7ff, "1bit a_3ff + a_400"; + cmp_ok $m_3ff + $a_400, '==', 1, "1bit -a_3ff + a_400"; + cmp_ok $a_3ff + $m_400, '==', -1, "1bit a_3ff + -a_400"; + cmp_ok $m_3ff + $m_400, '==', $m_7ff, "1bit -a_3ff + -a_400"; + + cmp_ok $a_3ff - $a_400, '==', -1, "1bit a_3ff - a_400"; + cmp_ok $m_3ff - $a_400, '==', $m_7ff, "1bit -a_3ff - a_400"; + cmp_ok $a_3ff - $m_400, '==', $a_7ff, "1bit a_3ff - -a_400"; + cmp_ok $m_3ff - $m_400, '==', 1, "1bit -a_3ff - -a_400"; + + cmp_ok $a_400 + $a_3ff, '==', $a_7ff, "1bit a_400 + a_3ff"; + cmp_ok $m_400 + $a_3ff, '==', -1, "1bit -a_400 + a_3ff"; + cmp_ok $a_400 + $m_3ff, '==', 1, "1bit a_400 + -a_3ff"; + cmp_ok $m_400 + $m_3ff, '==', $m_7ff, "1bit -a_400 + -a_3ff"; + + cmp_ok $a_400 - $a_3ff, '==', 1, "1bit a_400 - a_3ff"; + cmp_ok $m_400 - $a_3ff, '==', $m_7ff, "1bit -a_400 - a_3ff"; + cmp_ok $a_400 - $m_3ff, '==', $a_7ff, "1bit a_400 - -a_3ff"; + cmp_ok $m_400 - $m_3ff, '==', -1, "1bit -a_400 - -a_3ff"; +} + +# check multiplication with values using approx half the total bits +{ + my $a = 0xffffffff; + my $aa = 0xfffffffe00000001; + my $m = -$a; + my $mm = -$aa; + + cmp_ok $a, '==', 4294967295, "halfbits a"; + cmp_ok $m, '==', -4294967295, "halfbits -a"; + cmp_ok $aa, '==', 18446744065119617025, "halfbits aa"; + cmp_ok $mm, '==', -18446744065119617025, "halfbits -aa"; + cmp_ok $a * $a, '==', $aa, "halfbits a * a"; + cmp_ok $m * $a, '==', $mm, "halfbits -a * a"; + cmp_ok $a * $m, '==', $mm, "halfbits a * -a"; + cmp_ok $m * $m, '==', $aa, "halfbits -a * -a"; +} + +# check multiplication where the 2 args multiply to 2^62 .. 2^65 + +{ + my $exp62 = (2**62); + my $exp63 = (2**63); + my $exp64 = (2**64); + my $exp65 = (2**65); + cmp_ok $exp62, '==', 4611686018427387904, "2**62"; + cmp_ok $exp63, '==', 9223372036854775808, "2**63"; + cmp_ok $exp64, '==', 18446744073709551616, "2**64"; + cmp_ok $exp65, '==', 36893488147419103232, "2**65"; + + my @exp = ($exp62, $exp63, $exp64, $exp65); + for my $i (0..63) { + for my $x (0..3) { + my $j = 62 - $i + $x; + next if $j < 0 or $j > 63; + + my $a = (1 << $i); + my $b = (1 << $j); + my $c = $a * $b; + cmp_ok $c, '==', $exp[$x], "(1<<$i) * (1<<$j)"; + } + } +} done_testing(); diff --git a/t/op/taint.t b/t/op/taint.t index 08afc7858e..a3cb5b6d27 100644 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -17,7 +17,7 @@ BEGIN { use strict; use Config; -plan tests => 801; +plan tests => 807; $| = 1; @@ -2349,6 +2349,29 @@ is eval { eval $::x.1 }, 1, 'reset does not taint undef'; 'tainted constant as logop condition should not prevent "use"'; } +# optimised SETi etc need to handle tainting + +{ + my ($i1, $i2, $i3) = (1, 1, 1); + my ($n1, $n2, $n3) = (1.1, 1.1, 1.1); + my $tn = $TAINT0 + 1.1; + + $i1 = $TAINT0 + 2; + is_tainted $i1, "+ SETi"; + $i2 = $TAINT0 - 2; + is_tainted $i2, "- SETi"; + $i3 = $TAINT0 * 2; + is_tainted $i3, "* SETi"; + + $n1 = $tn + 2.2; + is_tainted $n1, "+ SETn"; + $n2 = $tn - 2.2; + is_tainted $n2, "- SETn"; + $n3 = $tn * 2.2; + is_tainted $n3, "* SETn"; +} + + # This may bomb out with the alarm signal so keep it last SKIP: { skip "No alarm()" unless $Config{d_alarm}; diff --git a/t/perf/benchmarks b/t/perf/benchmarks index 9456a6e7bb..ce8f19e6a0 100644 --- a/t/perf/benchmarks +++ b/t/perf/benchmarks @@ -715,4 +715,119 @@ }, + 'expr::arith::add_lex_ii' => { + desc => 'add two integers and assign to a lexical var', + setup => 'my ($x,$y,$z) = 1..3;', + code => '$z = $x + $y', + }, + 'expr::arith::add_pkg_ii' => { + desc => 'add two integers and assign to a package var', + setup => 'my ($x,$y) = 1..2; $z = 3;', + code => '$z = $x + $y', + }, + 'expr::arith::add_lex_nn' => { + desc => 'add two NVs and assign to a lexical var', + setup => 'my ($x,$y,$z) = (1.1, 2.2, 3.3);', + code => '$z = $x + $y', + }, + 'expr::arith::add_pkg_nn' => { + desc => 'add two NVs and assign to a package var', + setup => 'my ($x,$y); ($x,$y,$z) = (1.1, 2.2, 3.3);', + code => '$z = $x + $y', + }, + 'expr::arith::add_lex_ni' => { + desc => 'add an int and an NV and assign to a lexical var', + setup => 'my ($x,$y,$z) = (1, 2.2, 3.3);', + code => '$z = $x + $y', + }, + 'expr::arith::add_pkg_ni' => { + desc => 'add an int and an NV and assign to a package var', + setup => 'my ($x,$y); ($x,$y,$z) = (1, 2.2, 3.3);', + code => '$z = $x + $y', + }, + + 'expr::arith::sub_lex_ii' => { + desc => 'subtract two integers and assign to a lexical var', + setup => 'my ($x,$y,$z) = 1..3;', + code => '$z = $x - $y', + }, + 'expr::arith::sub_pkg_ii' => { + desc => 'subtract two integers and assign to a package var', + setup => 'my ($x,$y) = 1..2; $z = 3;', + code => '$z = $x - $y', + }, + 'expr::arith::sub_lex_nn' => { + desc => 'subtract two NVs and assign to a lexical var', + setup => 'my ($x,$y,$z) = (1.1, 2.2, 3.3);', + code => '$z = $x - $y', + }, + 'expr::arith::sub_pkg_nn' => { + desc => 'subtract two NVs and assign to a package var', + setup => 'my ($x,$y); ($x,$y,$z) = (1.1, 2.2, 3.3);', + code => '$z = $x - $y', + }, + 'expr::arith::sub_lex_ni' => { + desc => 'subtract an int and an NV and assign to a lexical var', + setup => 'my ($x,$y,$z) = (1, 2.2, 3.3);', + code => '$z = $x - $y', + }, + 'expr::arith::sub_pkg_ni' => { + desc => 'subtract an int and an NV and assign to a package var', + setup => 'my ($x,$y); ($x,$y,$z) = (1, 2.2, 3.3);', + code => '$z = $x - $y', + }, + + 'expr::arith::mult_lex_ii' => { + desc => 'multiply two integers and assign to a lexical var', + setup => 'my ($x,$y,$z) = 1..3;', + code => '$z = $x * $y', + }, + 'expr::arith::mult_pkg_ii' => { + desc => 'multiply two integers and assign to a package var', + setup => 'my ($x,$y) = 1..2; $z = 3;', + code => '$z = $x * $y', + }, + 'expr::arith::mult_lex_nn' => { + desc => 'multiply two NVs and assign to a lexical var', + setup => 'my ($x,$y,$z) = (1.1, 2.2, 3.3);', + code => '$z = $x * $y', + }, + 'expr::arith::mult_pkg_nn' => { + desc => 'multiply two NVs and assign to a package var', + setup => 'my ($x,$y); ($x,$y,$z) = (1.1, 2.2, 3.3);', + code => '$z = $x * $y', + }, + 'expr::arith::mult_lex_ni' => { + desc => 'multiply an int and an NV and assign to a lexical var', + setup => 'my ($x,$y,$z) = (1, 2.2, 3.3);', + code => '$z = $x * $y', + }, + 'expr::arith::mult_pkg_ni' => { + desc => 'multiply an int and an NV and assign to a package var', + setup => 'my ($x,$y); ($x,$y,$z) = (1, 2.2, 3.3);', + code => '$z = $x * $y', + }, + + 'expr::arith::preinc' => { + desc => '++$x', + setup => 'my $x = 1;', + code => '++$x', + }, + 'expr::arith::predec' => { + desc => '--$x', + setup => 'my $x = 1;', + code => '--$x', + }, + 'expr::arith::postinc' => { + desc => '$x++', + setup => 'my $x = 1; my $y', + code => '$y = $x++', # scalar context so not optimised to ++$x + }, + 'expr::arith::postdec' => { + desc => '$x--', + setup => 'my $x = 1; my $y', + code => '$y = $x--', # scalar context so not optimised to --$x + + }, + ]; |