diff --git a/Configure b/Configure index 6bebe1845c1..840432bb92f 100755 --- a/Configure +++ b/Configure @@ -1424,6 +1424,7 @@ CONFIG='' usecperl='' fake_signatures='' usenamedanoncv='' +useexactarith='' : Detect odd OSs define='define' @@ -7584,6 +7585,32 @@ $define) ;; esac +case "$useexactarith" in +$define|true|[yY]*) dflt='y' ;; +*) dflt='n' ;; +esac +cat <&4 + ;; +esac + case "$usecperl" in $define) usecperl='define' echo "cperl variant selected." >&4 @@ -25924,6 +25951,7 @@ usecrosscompile='$usecrosscompile' usedevel='$usedevel' usedl='$usedl' usedtrace='$usedtrace' +useexactarith='$useexactarith' usefaststdio='$usefaststdio' useffi='$useffi' useithreads='$useithreads' diff --git a/MANIFEST b/MANIFEST index 9ff4d6a41d0..cfafa85ae01 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5689,6 +5689,8 @@ lib/dumpvar.pl A variable dumper lib/dumpvar.t A variable dumper tester lib/English.pm Readable aliases for short variables lib/English.t See if English works +lib/exact_arith.pm Pragma to set exact arithmetic as in perl6 +lib/exact_arith.t See if use exact_arith works lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs lib/ExtUtils/t/Embed.t See if ExtUtils::Embed and embedding works lib/ExtUtils/typemap Extension interface types diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 8f5e7a98eb6..ba4e6c1b3f8 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1732,6 +1732,7 @@ package Maintainers; lib/DBM_Filter/ lib/DirHandle.{pm,t} lib/English.{pm,t} + lib/exact_arith.{pm,t} lib/ExtUtils/Embed.pm lib/ExtUtils/XSSymSet.pm lib/ExtUtils/t/Embed.t diff --git a/config_h.SH b/config_h.SH index 59b0c6dc673..031f763994b 100755 --- a/config_h.SH +++ b/config_h.SH @@ -5488,6 +5488,14 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$usesafehashiter USE_SAFE_HASHITER /**/ #endif +/* USE_EXACT_ARITH: + * This symbol, if defined, indicates that Perl uses exact_arith as default. + */ +#define PERL_EXACT_ARITH +#ifndef USE_EXACT_ARITH +#$useexactarith USE_EXACT_ARITH /**/ +#endif + /* PERL_HASH_FUNC_*: * This symbol defines the used perl hash function variant. * It is set in Configure or via -Dhash_func=, but can be left blank. diff --git a/embed.fnc b/embed.fnc index 8a097f3e538..883628a50dd 100644 --- a/embed.fnc +++ b/embed.fnc @@ -528,6 +528,7 @@ pR |int |PerlSock_accept_cloexec|int listenfd \ pR |int |PerlSock_socketpair_cloexec|int domain|int type|int protocol \ |NN int *pairfd #endif +AMp |void |bigint_arith |NN const char *op|NN SV *const left|NN SV *const right #if defined(PERL_IN_DOIO_C) s |IO * |openn_setup |NN GV *gv|NN char *mode|NN PerlIO **saveifp \ |NN PerlIO **saveofp|NN int *savefd \ diff --git a/embed.h b/embed.h index f5031a2a6cf..79cca5cb4b3 100644 --- a/embed.h +++ b/embed.h @@ -67,6 +67,7 @@ #define av_top_index(a) S_av_top_index(aTHX_ a) #define av_undef(a) Perl_av_undef(aTHX_ a) #define av_unshift(a,b) Perl_av_unshift(aTHX_ a,b) +#define bigint_arith(a,b,c) Perl_bigint_arith(aTHX_ a,b,c) #define block_end(a,b) Perl_block_end(aTHX_ a,b) #define block_gimme() Perl_block_gimme(aTHX) #define block_start(a) Perl_block_start(aTHX_ a) diff --git a/ext/Config/Config_xs.in b/ext/Config/Config_xs.in index f8804fbb181..f62b7169948 100644 --- a/ext/Config/Config_xs.in +++ b/ext/Config/Config_xs.in @@ -1503,6 +1503,7 @@ usecrosscompile, T_INV,0,ALN64I"@@usecrosscompile@@" usedevel, T_INV,0,ALN64I"@@usedevel@@" usedl, T_INV,0,ALN64I"@@usedl@@" usedtrace, T_INV,0,ALN64I"@@usedtrace@@" +useexactarith, T_INV,0,ALN64I"@@useexactarith@@" usefaststdio, T_INV,0,ALN64I"@@usefaststdio@@" useffi, T_INV,0,ALN64I"@@useffi@@" useithreads, T_INV,0,ALN64I"@@useithreads@@" diff --git a/lib/exact_arith.pm b/lib/exact_arith.pm new file mode 100644 index 00000000000..353f6d22530 --- /dev/null +++ b/lib/exact_arith.pm @@ -0,0 +1,41 @@ +package exact_arith; +our $VERSION = '0.01'; +my $HINT_EXACT_ARITH = 0x0000010; # see perl.h + +sub import { + use Math::BigInt try => 'GMP'; + #$^H{exact_arith} = 1; + $^H |= $HINT_EXACT_ARITH; +} +sub unimport { + #delete $^H{exact_arith}; + $^H &= ~$HINT_EXACT_ARITH; +} + +1; +__END__ + +=head1 NAME + +exact_arith - promote on overflow to bigint/num + +=head1 SYNOPSIS + + use exact_arith; + print 18446744073709551614 * 2; # => 36893488147419103228, a Math::BigInt object + + { no exact_arith; + print 18446744073709551614 * 2; # => 3.68934881474191e+19 + } + +=head1 DESCRIPTION + +This is a new lexical user-pragma since cperl 5.32 to use exact +arithmetic, without loosing precision on all builtin arithmetic ops. +As in perl6. + +It is of course a bit slower than without, but it's much faster than +perl6, since it only does use bigint on IV/UV overflows which do +happen very seldom. + +=cut diff --git a/lib/exact_arith.t b/lib/exact_arith.t new file mode 100644 index 00000000000..b9bf24bcdce --- /dev/null +++ b/lib/exact_arith.t @@ -0,0 +1,64 @@ +#!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*- + +BEGIN { + chdir 't' if -d 't'; + @INC = ( '.', '../lib' ); +} + +use strict; +require '../t/test.pl'; +plan(8); + +$|=1; +my $a = 18446744073709551614; + +# test it at compile-time in constant folding +use exact_arith; +my $n = 18446744073709551614 * 2; # => 36893488147419103228, Math::BigInt or *::GMP +like(ref $n, qr/^Math::BigInt/, '* type (c)'); +ok($n eq '36893488147419103228', '* val (c)') or + is($n, '36893488147419103228'); + +{ + no exact_arith; + my $m = 18446744073709551614 * 2; + is(ref $m, '', '* no type (c)'); + is($m, 3.68934881474191e+19, '* no val (c)'); +} + +my $two = 2; +$n = 18446744073709551614 * $two; # run-time +like(ref $n, qr/^Math::BigInt/, '* type (r)'); +ok($n eq '36893488147419103228', '* val (r)') or + is($n, '36893488147419103228'); + +{ + no exact_arith; + my $m = 18446744073709551614 * $two; + is(ref $m, '', '* no type (r)'); + is($m, 3.68934881474191e+19, '* no val (r)'); +} + +my $c = 18446744073709551614 + 10000; +like(ref $c, qr/^Math::BigInt/, '+ type (c)'); +my $r = $a + 10000; +like(ref $r, qr/^Math::BigInt/, '+ type (r)'); + +$c = 18446744073709551624 - 2; +like(ref $c, qr/^Math::BigInt/, '- type (c)'); +$r = $c - 1; +like(ref $r, qr/^Math::BigInt/, '- type (r)'); + +$c = 1844674407370955162400 / 0.3; +like(ref $c, qr/^Math::BigInt/, '/ type (c)'); +$r = 1844674407370955162400 / 0.3; +like(ref $r, qr/^Math::BigInt/, '/ type (r)'); + +$c = 18446744073709551614 ** 2; +like(ref $c, qr/^Math::BigInt/, '** type (c)'); +$r = $a ** 2; +like(ref $r, qr/^Math::BigInt/, '** type (r)'); + +$r = $a++; +like(ref $r, qr/^Math::BigInt/, '++ type (r)'); + diff --git a/perl.c b/perl.c index 297f17a8462..7639e1d92f4 100644 --- a/perl.c +++ b/perl.c @@ -1932,6 +1932,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_DONT_CREATE_GVSV " PERL_DONT_CREATE_GVSV" # endif +# ifdef PERL_EXACT_ARITH + " PERL_EXACT_ARITH" +# endif # ifdef PERL_EXTERNAL_GLOB " PERL_EXTERNAL_GLOB" # endif @@ -2034,6 +2037,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef USE_CPERL " USE_CPERL" # endif +# ifdef USE_EXACT_ARITH + " USE_EXACT_ARITH" +# endif # ifdef USE_FAST_STDIO " USE_FAST_STDIO" # endif diff --git a/perl.h b/perl.h index fd9ac9b8dd1..1a38ec1239e 100644 --- a/perl.h +++ b/perl.h @@ -317,9 +317,12 @@ RX_ENGINE(rx_sv)->dupe(aTHX_ (rx_sv),(param)) #endif - - - +#ifdef PERL_EXACT_ARITH +#define IS_EXACT_ARITH PL_curcop->cop_hints & HINT_EXACT_ARITH +/*#define IS_EXACT_ARITH cop_hints_fetch_pvs(PL_curcop, "exact_arith", REFCOUNTED_HE_EXISTS)*/ +#else +#define IS_EXACT_ARITH 0 +#endif /* * Because of backward compatibility reasons the PERL_UNUSED_DECL @@ -5442,7 +5445,6 @@ END_EXTERN_C #define HINT_UTF8 0x00800000 /* utf8 pragma */ #define HINT_NO_AMAGIC 0x01000000 /* overloading pragma */ - #define HINT_RE_FLAGS 0x02000000 /* re '/xism' pragma */ #define HINT_FEATURE_MASK 0x1c000000 /* 3 bits (4,8,10) for feature bundles */ diff --git a/pod/perlcdelta.pod b/pod/perlcdelta.pod index e247056074c..035402b19de 100644 --- a/pod/perlcdelta.pod +++ b/pod/perlcdelta.pod @@ -559,6 +559,12 @@ release manager will have to investigate the situation carefully.) =over 4 +=item L 0.01 + +Promote on overflow to bigint/bignum as in perl6, do not loose precision +with all builtin arithmetic operators. +L<[cperl #21]|https://github.com/perl11/cperl/issues/21> + =item L 0.01c ffi helpers and ffi types. diff --git a/pp.c b/pp.c index 50b3e8df022..b793b051130 100644 --- a/pp.c +++ b/pp.c @@ -1448,6 +1448,13 @@ PP(pp_pow) if (iv >= 0) { power = iv; } else { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bpow", svl, svr); + return NORMAL; + } else +#endif goto float_pow; /* Can't do negative powers this way. */ } } @@ -1488,8 +1495,19 @@ PP(pp_pow) result *= base; } SP--; - SETn( result ); - SvIV_please_void_nomg(svr); + if (result < UV_MAX_P1) { + SETn( result ); + SvIV_please_void_nomg(svr); + } +#ifdef PERL_EXACT_ARITH + else if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bpow", svl, svr); + return NORMAL; + } +#endif + else + SETn( result ); RETURN; } else { unsigned int highbit = 8 * sizeof(UV); @@ -1524,10 +1542,24 @@ PP(pp_pow) /* 2's complement assumption: special case IV_MIN */ SETi( IV_MIN ); else - /* answer negative, doesn't fit */ - SETn( -(NV)result ); +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bpow", svl, svr); + return NORMAL; + } else +#endif + /* answer negative, doesn't fit */ + SETn( -(NV)result ); RETURN; - } + } +#ifdef PERL_EXACT_ARITH + else if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bpow", svl, svr); + return NORMAL; + } +#endif } } float_pow: @@ -1645,8 +1677,15 @@ PP(pp_multiply) /* nothing was lost by converting to IVs */ goto do_iv; SP--; - /* TODO: check exact arith pragma and nv overflow/precision loss + /* check exact arith pragma and nv overflow/precision loss and promote to bignum */ +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bmul", svl, svr); + return NORMAL; + } +#endif 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)) { @@ -1683,6 +1722,13 @@ PP(pp_multiply) const UV auv = both_neg ? (UV)(-aiv) : (UV)aiv; const UV buv = both_neg ? (UV)(-biv) : (UV)biv; if (BUILTIN_UMUL_OVERFLOW(auv, buv, &result)) { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bmul", svl, svr); + return NORMAL; + } else +#endif SETn( (NV)auv * (NV)buv ); } else { if ((auvok & buvok) || result > IV_MAX) @@ -1695,6 +1741,13 @@ PP(pp_multiply) } else { IV value; if (BUILTIN_SMUL_OVERFLOW(aiv, biv, &value)) { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bmul", svl, svr); + return NORMAL; + } else +#endif SETn( (NV)aiv * (NV)biv ); } else { SETi( value ); @@ -1803,9 +1856,30 @@ PP(pp_multiply) ? IV_MIN : -(IV)product_low); RETURN; } /* else drop to NVs below. */ +# ifdef PERL_EXACT_ARITH + else if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bmul", svl, svr); + return NORMAL; + } +# endif } +#ifdef PERL_EXACT_ARITH + else if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bmul", svl, svr); + return NORMAL; + } +#endif } /* product_middle too large */ - } /* ahigh && bhigh */ +# ifdef PERL_EXACT_ARITH + else if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bmul", svl, svr); + return NORMAL; + } +# endif + } /* else ahigh && bhigh */ #endif } /* SvIOK(svl) */ } /* SvIOK(svr) */ @@ -1829,6 +1903,77 @@ PP(pp_multiply) } } +/* +=for apidoc AMp|void|bigint_arith + +Does a binary arithmetic op via Math::BigInt and string eval +when requested via use exact_arith. +Can do a unary negation with &PL_sv_undef as 2nd arg. + +Slow but exact. But only called on arithmetic overflow, so still +much faster than perl6, which doesn't check overflows, only does type +and range analysis. + +=cut +*/ + +void +Perl_bigint_arith(pTHX_ const char *op, SV* const left, SV* const right) +{ +#ifdef PERL_EXACT_ARITH + SV* sv; + PERL_ARGS_ASSERT_BIGINT_ARITH; + + ENTER; + DEBUG_kv(PerlIO_printf(Perl_debug_log, "bigint_arith: base %p sp %p mark %p %d\n", + PL_stack_base, PL_stack_sp, PL_markstack_ptr, (int)TOPMARK)); + /* otherwise it's already loaded. avoids the $INC{} check */ +#if 0 && !defined(USE_EXACT_ARITH) + /*require_pv("Math::BigInt");*/ + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvs("Math::BigInt"), NULL + op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, newSVpvs("try")), + newSVOP(OP_CONST, 0, newSVpvs("GMP")))); + PUSHSTACKi(PERLSI_REQUIRE); +#endif + sv = Perl_newSVpvf(aTHX_ "Math::BigInt->%s(", op); + if (SvIOK(left)) { + if (SvUOK(left)) + Perl_sv_catpvf(aTHX_ sv, "%"UVuf"", SvUVX(left)); + else + Perl_sv_catpvf(aTHX_ sv, "%"IVdf"", SvIVX(left)); + } else { + STORE_LC_NUMERIC_SET_STANDARD(); + /* full precision, not just %g. TODO long double */ + Perl_sv_catpvf(aTHX_ sv, "%.15g, ", SvNVX(left)); + RESTORE_LC_NUMERIC(); + } + if (SvIOK(right)) { + PL_stack_sp--; + if (SvUOK(right)) + Perl_sv_catpvf(aTHX_ sv, ", %"UVuf")", SvUVX(right)); + else + Perl_sv_catpvf(aTHX_ sv, ", %"IVdf")", SvIVX(right)); + } else if (SvNOK(right)) { + STORE_LC_NUMERIC_SET_STANDARD(); + PL_stack_sp--; + Perl_sv_catpvf(aTHX_ sv, ", %.15g)", SvNVX(right)); + RESTORE_LC_NUMERIC(); + } else { + Perl_sv_catpvf(aTHX_ sv, ")"); + } + + (void)eval_sv(sv, G_SCALAR|G_KEEPERR); + + DEBUG_kv(PerlIO_printf(Perl_debug_log, "bigint_arith: base %p sp %p mark %p %d\n", + PL_stack_base, PL_stack_sp, PL_markstack_ptr, (int)TOPMARK)); + SvREFCNT_dec(sv); + if (SvTRUE_NN(ERRSV)) + Perl_croak_nocontext("%s", SvPV_nolen_const(ERRSV)); + LEAVE; +#endif +} + PP(pp_divide) { dSP; dATARGET; SV *svl, *svr; @@ -1937,12 +2082,33 @@ PP(pp_divide) if (result <= (UV)IV_MIN) SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result); else { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bdiv", svl, svr); + return NORMAL; + } else +#endif /* It's exact but too negative for IV. */ SETn( -(NV)result ); } RETURN; } /* tried integer divide but it was not an integer result */ +#ifdef PERL_EXACT_ARITH + else if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bdiv", svl, svr); + return NORMAL; + } +#endif } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */ +#ifdef PERL_EXACT_ARITH + else if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bdiv", svl, svr); + return NORMAL; + } +#endif } /* one operand wasn't SvIOK */ #endif /* PERL_TRY_UV_DIVIDE */ { @@ -2389,12 +2555,26 @@ PP(pp_subtract) SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result); else { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bsub", svl, svr); + return NORMAL; + } else +#endif /* result valid, but out of range for IV. */ SETn( -(NV)result ); } } RETURN; } /* Overflow, drop through to NVs. */ +#ifdef PERL_EXACT_ARITH + else if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bsub", svl, svr); + return NORMAL; + } +#endif } } #else @@ -3584,14 +3764,28 @@ PPt(pp_int, "(:Numeric):Int") if (value < (NV)UV_MAX + 0.5) { SETu(U_V(value)); } else { - SETn(Perl_floor(value)); +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bfloor", sv, &PL_sv_undef); + return NORMAL; + } else +#endif + SETn(Perl_floor(value)); } } else { if (value > (NV)IV_MIN - 0.5) { SETi(I_V(value)); } else { - SETn(Perl_ceil(value)); +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("bceil", sv, &PL_sv_undef); + return NORMAL; + } else +#endif + SETn(Perl_ceil(value)); } } } @@ -3604,37 +3798,37 @@ PPt(pp_abs, "(:Numeric):Numeric") dSP; dTARGET; tryAMAGICun_MG(abs_amg, AMGf_numeric); { - SV * const sv = TOPs; - /* This will cache the NV value if string isn't actually integer */ - const IV iv = SvIV_nomg(sv); + SV * const sv = TOPs; + /* This will cache the NV value if string isn't actually integer */ + const IV iv = SvIV_nomg(sv); - if (!SvOK(sv)) { - SETu(0); - } - else if (SvIOK(sv)) { - /* IVX is precise */ - if (SvIsUV(sv)) { - SETu(SvUV_nomg(sv)); /* force it to be numeric only */ - } else { - if (iv >= 0) { - SETi(iv); - } else { - if (iv != IV_MIN) { - SETi(-iv); - } else { - /* 2s complement assumption. Also, not really needed as - IV_MIN and -IV_MIN should both be %100...00 and NV-able */ - SETu((UV)IV_MIN); - } - } - } - } else{ - const NV value = SvNV_nomg(sv); - if (value < 0.0) - SETn(-value); - else - SETn(value); - } + if (!SvOK(sv)) { + SETu(0); + } + else if (SvIOK(sv)) { + /* IVX is precise */ + if (SvIsUV(sv)) { + SETu(SvUV_nomg(sv)); /* force it to be numeric only */ + } else { + if (iv >= 0) { + SETi(iv); + } else { + if (iv != IV_MIN) { + SETi(-iv); + } else { + /* 2s complement assumption. Also, not really needed as + IV_MIN and -IV_MIN should both be %100...00 and NV-able */ + SETu((UV)IV_MIN); + } + } + } + } else{ + const NV value = SvNV_nomg(sv); + if (value < 0.0) + SETn(-value); + else + SETn(value); + } } return NORMAL; } diff --git a/pp_ctl.c b/pp_ctl.c index c6cbb04b6e9..90b8f29137d 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1644,8 +1644,8 @@ Perl_qerror(pTHX_ SV *err) if (PL_in_eval) { if (PL_in_eval & EVAL_KEEPERR) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, - SVfARG(err)); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, + SVfARG(err)); } else sv_catsv(ERRSV, err); diff --git a/pp_hot.c b/pp_hot.c index 8a54bf0c25c..7451d1a8e42 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1661,6 +1661,14 @@ PPt(pp_add, "(:Number,:Number):Number") const UV auv = (UV)aiv; const UV buv = (UV)biv; if (BUILTIN_UADD_OVERFLOW(auv, buv, &result)) { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("badd", svl, svr); + return NORMAL; + } + else +#endif SETn( (NV)auv + (NV)buv ); } else { if ((auvok & buvok) || result > IV_MAX) @@ -1673,6 +1681,14 @@ PPt(pp_add, "(:Number,:Number):Number") } else { IV value; if (BUILTIN_SADD_OVERFLOW(aiv, biv, &value)) { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("badd", svl, svr); + return NORMAL; + } + else +#endif /*SETn( (NV)(auvok?SvUVX(svl):aiv) + (NV)(buvok?SvUVX(svr):biv) );*/ SETn( (NV)aiv + (NV)biv ); } else { @@ -1736,12 +1752,27 @@ PPt(pp_add, "(:Number,:Number):Number") SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result); else { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("badd", svl, svr); + return NORMAL; + } + else +#endif /* result valid, but out of range for IV. */ SETn( -(NV)result ); } } RETURN; } /* Overflow, drop through to NVs. */ +#ifdef PERL_EXACT_ARITH + else if (UNLIKELY(IS_EXACT_ARITH)) { + PUTBACK; + bigint_arith("badd", svl, svr); + return NORMAL; + } +#endif #endif } } diff --git a/proto.h b/proto.h index d020425d78c..07a04092fc4 100644 --- a/proto.h +++ b/proto.h @@ -434,6 +434,14 @@ PERL_CALLCONV void Perl_av_unshift(pTHX_ AV *av, SSize_t num) #define PERL_ARGS_ASSERT_AV_UNSHIFT \ assert(av) +PERL_CALLCONV void Perl_bigint_arith(pTHX_ const char *op, SV *const left, SV *const right) + __attribute__global__ + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_BIGINT_ARITH \ + assert(op); assert(left); assert(right) + PERL_CALLCONV OP* Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2) diff --git a/sv.c b/sv.c index e444386b582..d2947922cd3 100644 --- a/sv.c +++ b/sv.c @@ -9091,11 +9091,18 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) oops_its_int: #endif if (SvIsUV(sv)) { - if (SvUVX(sv) == UV_MAX) + if (SvUVX(sv) == UV_MAX) { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + bigint_arith("binc", sv, &PL_sv_undef); + return; + } +#endif sv_setnv(sv, UV_MAX_P1); - else + } else { (void)SvIOK_only_UV(sv); - SvUV_set(sv, SvUVX(sv) + 1); + SvUV_set(sv, SvUVX(sv) + 1); + } } else { if (SvIVX(sv) == IV_MAX) sv_setuv(sv, (UV)IV_MAX + 1); diff --git a/uconfig.h b/uconfig.h index ffc482d6a29..cbc935c102e 100644 --- a/uconfig.h +++ b/uconfig.h @@ -5443,6 +5443,14 @@ #define USE_SAFE_HASHITER /**/ #endif +/* USE_EXACT_ARITH: + * This symbol, if defined, indicates that Perl uses exact_arith as default. + */ +#define PERL_EXACT_ARITH +#ifndef USE_EXACT_ARITH +# USE_EXACT_ARITH /**/ +#endif + /* PERL_HASH_FUNC_*: * This symbol defines the used perl hash function variant. * It is set in Configure or via -Dhash_func=, but can be left blank. @@ -5483,6 +5491,6 @@ #endif /* Generated from: - * d295cb5b21070ab7c5076d71ceaa6fe08b12b02a619a95aba11c443ef7f8600a config_h.SH + * 8332c45359765d3e780b77c4e49eefcbaa26c825644302ceda1b1da2375f4790 config_h.SH * 1ad21ed3ecb2fac07b7c4aabef76b2fc7354cc6dee0b561e852a1651f8dd6025 uconfig.sh * ex: set ro: */