This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[MERGE] faster arithmetic
authorDavid Mitchell <davem@iabyn.com>
Tue, 10 Nov 2015 13:50:51 +0000 (13:50 +0000)
committerDavid Mitchell <davem@iabyn.com>
Tue, 10 Nov 2015 13:52:34 +0000 (13:52 +0000)
14 files changed:
intrpvar.h
opcode.h
perl.h
pp.c
pp.h
pp_ctl.c
pp_hot.c
pp_proto.h
regcomp.c
regen/opcode.pl
sv.h
t/op/64bitint.t
t/op/taint.t
t/perf/benchmarks

index 1ab3351..7f9fa92 100644 (file)
@@ -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
index 2e03448..e711e65 100644 (file)
--- a/opcode.h
+++ b/opcode.h
 #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 b6c14b5..c11548d 100644 (file)
--- a/perl.h
+++ b/perl.h
 #   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 b084d49..35a5f26 100644 (file)
--- 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 5712b8e..945d1e5 100644 (file)
--- 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
index f9306e1..c006ce9 100644 (file)
--- 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);
     }
index d1e5562..ff9e594 100644 (file)
--- 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;
index 96934ff..f919313 100644 (file)
@@ -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);
index df60d1b..a37dc82 100644 (file)
--- 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)) {
index 50029bd..82454bb 100755 (executable)
@@ -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 e1797de..313bfb8 100644 (file)
--- 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
 
 /*
index fcf9949..b764f0e 100644 (file)
@@ -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();
index 08afc78..a3cb5b6 100644 (file)
@@ -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};
index 9456a6e..ce8f19e 100644 (file)
     },
 
 
+    '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
+
+    },
+
 ];