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
{
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;
}
}
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)) {
} /* Overflow, drop through to NVs. */
}
}
+#else
+ useleft = USE_LEFT(svl);
#endif
{
NV value = SvNV_nomg(svr);
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
} /* Overflow, drop through to NVs. */
}
}
+
+#else
+ useleft = USE_LEFT(svl);
#endif
+
{
NV value = SvNV_nomg(svr);
(void)POPs;
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();
use strict;
use Config;
-plan tests => 801;
+plan tests => 807;
$| = 1;
'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};
},
+ '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',
+ },
+
];
https://perl5.git.perl.org / perl5.git / commitdiff