summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Mitchell <davem@iabyn.com>2015-11-10 13:50:51 +0000
committerDavid Mitchell <davem@iabyn.com>2015-11-10 13:52:34 +0000
commit067cec4c785ab7f64d2974ec6622bb9f4fa53eac (patch)
treef30b419cd8f5a714a3479cc3fc13bf303549e955
parentfc9a9443cb9edf6f5607176e09aebe85d00da5fe (diff)
parent20e9643135b0912e2449f038a0ec1c0e84657f3f (diff)
downloadperl-067cec4c785ab7f64d2974ec6622bb9f4fa53eac.tar.gz
[MERGE] faster arithmetic
-rw-r--r--intrpvar.h2
-rw-r--r--opcode.h14
-rw-r--r--perl.h4
-rw-r--r--pp.c199
-rw-r--r--pp.h84
-rw-r--r--pp_ctl.c3
-rw-r--r--pp_hot.c103
-rw-r--r--pp_proto.h2
-rw-r--r--regcomp.c3
-rwxr-xr-xregen/opcode.pl6
-rw-r--r--sv.h7
-rw-r--r--t/op/64bitint.t96
-rw-r--r--t/op/taint.t25
-rw-r--r--t/perf/benchmarks115
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
diff --git a/opcode.h b/opcode.h
index 2e03448be5..e711e65ac1 100644
--- a/opcode.h
+++ b/opcode.h
@@ -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,
diff --git a/perl.h b/perl.h
index b6c14b5d08..c11548db22 100644
--- a/perl.h
+++ b/perl.h
@@ -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))
diff --git a/pp.c b/pp.c
index b084d4949c..35a5f26552 100644
--- a/pp.c
+++ b/pp.c
@@ -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);
diff --git a/pp.h b/pp.h
index 5712b8eeeb..945d1e5aa3 100644
--- a/pp.h
+++ b/pp.h
@@ -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
diff --git a/pp_ctl.c b/pp_ctl.c
index f9306e1d0a..c006ce9a22 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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);
}
diff --git a/pp_hot.c b/pp_hot.c
index d1e55629dc..ff9e5944d4 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -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);
diff --git a/regcomp.c b/regcomp.c
index df60d1b789..a37dc82796 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -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)],
diff --git a/sv.h b/sv.h
index e1797de7d4..313bfb8517 100644
--- a/sv.h
+++ b/sv.h
@@ -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
+
+ },
+
];