faster add, subtract, multiply

In pp_add, pp_subtract and pp_multiply, special-case the following:

* both args IV, neither arg large enough to under/overflow
* both args NV.

Starting in 5.8.0, the implementation of the arithmetic pp functions
became a lot more complex (and famously, much slower), due to the need
to support 64-bit integers.

For example, formerly  pp_add just converted both its args to an NV and
returned an NV. On 64-bit systems, that could gave bad results if the
mantissa of an NV was < 64 bits; for example:

    $ perl561 -e'$x = 0x1000000000000000; printf "%x\n", $x+1'
    1000000000000000
    $ perl580 -e'$x = 0x1000000000000000; printf "%x\n", $x+1'
    1000000000000001

This led to a lot of complex code that covered all the possibilities
of overflow etc.

This commit adds some special casing to these three common arithmetic ops.
It does some quick checks (mainly involving fast boolean and bit ops)
to determine if both args are valid IVs (and not UVs), are not magic,
and aren't very big (+ve or -ve). In this case, the result is simply
SvIVX(svl) + SvIVX(svr) (or - or *) with no possibility of overflow.
Failing that, if both args are NV's and not magic, then if both NVs
can be converted to IVs without loss, handle as for the IV case; failing
that, just return SvNVX(svl) + SvNVX(svr);

For all other cases, such as mixed IV and NV or PV, fall back to the old
code.

On my platform (x86_64), it (along with the previous commit) reduces the
execution time of the nbody benchmark (lots of floating-point vector
arithmetic) by a third and in fact makes it 10% faster than 5.6.1.

5 files changed, 375 insertions, 11 deletions

diff --git a/pp.c b/pp.c
index b084d4949c..2305bbd72b 100644
--- a/pp.c
+++ b/pp.c
@@ -1276,7 +1276,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 +1450,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 +1858,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 +2002,8 @@ PP(pp_subtract)
 	    } /* Overflow, drop through to NVs.  */
 	}
     }
+#else
+    useleft = USE_LEFT(svl);
 #endif
     {
 	NV value = SvNV_nomg(svr);
diff --git a/pp_hot.c b/pp_hot.c
index 604b6ce053..bc12290a88 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -564,15 +564,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
@@ -716,7 +763,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/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..223c81f656 100644
--- a/t/perf/benchmarks
+++ b/t/perf/benchmarks
@@ -715,4 +715,97 @@
     },
 
 
+    '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',
+    },
+
 ];