From f32233a15bd2de796233680c5b05e4fe591799aa Mon Sep 17 00:00:00 2001 From: Reini Urban Date: Tue, 31 May 2016 18:39:53 +0200 Subject: [PATCH] exact_arith: implement it Promote on overflow to bigint/num, and not to NV. This is a new lexical user-pragma to use exact arithmetic without loosing precision on all builtin arithmetic ops. As in perl6. It is of course a bit slower than without. Closes #21. --- Configure | 28 +++++++ MANIFEST | 2 + Porting/Maintainers.pl | 1 + config_h.SH | 8 ++ embed.fnc | 1 + embed.h | 1 + ext/Config/Config_xs.in | 1 + lib/exact_arith.pm | 30 +++++++ lib/exact_arith.t | 24 ++++++ perl.c | 6 ++ perl.h | 8 +- pod/perlcdelta.pod | 11 +-- pp.c | 180 +++++++++++++++++++++++++++++++--------- pp_hot.c | 27 ++++++ proto.h | 8 ++ sv.c | 10 ++- uconfig.h | 10 ++- 17 files changed, 306 insertions(+), 50 deletions(-) create mode 100644 lib/exact_arith.pm create mode 100644 lib/exact_arith.t diff --git a/Configure b/Configure index a453447b74f..ca1ccc5f1cc 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 @@ -25913,6 +25940,7 @@ usecrosscompile='$usecrosscompile' usedevel='$usedevel' usedl='$usedl' usedtrace='$usedtrace' +useexactarith='$useexactarith' usefaststdio='$usefaststdio' useffi='$useffi' useithreads='$useithreads' diff --git a/MANIFEST b/MANIFEST index f3e97d61528..44bef4a6631 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5686,6 +5686,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 c47a211f6c8..487441abb61 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 3fcf0e242c1..54e811bce1b 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 7309dce45e5..2cfa3c2c907 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 55266e92832..6126c8005d7 100644 --- a/ext/Config/Config_xs.in +++ b/ext/Config/Config_xs.in @@ -1496,6 +1496,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..9a0a2b116f7 --- /dev/null +++ b/lib/exact_arith.pm @@ -0,0 +1,30 @@ +package exact_arith; +our $VERSION = '0.01'; +sub unimport { delete $^H{exact_arith}; } +sub import { $^H{exact_arith} = 1; } + +1; +__END__ + +=head1 NAME + +exact_arith - promote on overflow to bigint/num + +=head1 SYNOPSIS + + use exact_arith; + print 18446744073709551614 * 2; # => 36893488147419103228, a bigint object + + { no exact_arith; + print 18446744073709551614 * 2; # => 3.68934881474191e+19 + } + +=head1 DESCRIPTION + +This is a new lexical user-pragma since cperl5.24 to use exact +arithmetic, without loosing precision on all builtin arithmetic ops. +As in perl6. + +It is of course a bit slower, than without. + +=cut diff --git a/lib/exact_arith.t b/lib/exact_arith.t new file mode 100644 index 00000000000..41d1e52e499 --- /dev/null +++ b/lib/exact_arith.t @@ -0,0 +1,24 @@ +#!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*- + +BEGIN { + chdir 't' if -d 't'; + @INC = ( '.', '../lib' ); +} + +use strict; +require '../t/test.pl'; +plan(4); + +$|=1; + +use exact_arith; +my $n = 18446744073709551614 * 2; # => 36893488147419103228, a bigint object +is(ref $n, 'bigint'); +is($n, 36893488147419103228); + +{ + no exact_arith; + my $m = 18446744073709551614 * 2; + is(ref $n, ''); + is($n, 3.68934881474191e+19); +} diff --git a/perl.c b/perl.c index e892cec1b51..73cee617407 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 @@ -2031,6 +2034,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 a719cd66c4d..f94d1c072d4 100644 --- a/perl.h +++ b/perl.h @@ -314,9 +314,11 @@ RX_ENGINE(rx_sv)->dupe(aTHX_ (rx_sv),(param)) #endif - - - +#ifdef PERL_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 diff --git a/pod/perlcdelta.pod b/pod/perlcdelta.pod index 8f87d5cf00f..5cae0605674 100644 --- a/pod/perlcdelta.pod +++ b/pod/perlcdelta.pod @@ -513,14 +513,11 @@ release manager will have to investigate the situation carefully.) =over 4 -=item L 0.01c +=item L 0.01 -ffi helpers and ffi types. - -=item L - -Allow hash iterators changing keys for back-compat. -See L. +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.80 diff --git a/pp.c b/pp.c index 5d4eea74fd9..6116527b374 100644 --- a/pp.c +++ b/pp.c @@ -1458,6 +1458,11 @@ PP(pp_pow) if (iv >= 0) { power = iv; } else { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) + bigint_arith("bpow", svl, svr); + else +#endif goto float_pow; /* Can't do negative powers this way. */ } } @@ -1498,8 +1503,18 @@ 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)) { + bigint_arith("bpow", svl, svr); + RETURN; + } +#endif + else + SETn( result ); RETURN; } else { unsigned int highbit = 8 * sizeof(UV); @@ -1534,8 +1549,13 @@ 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)) + bigint_arith("bpow", svl, svr); + else +#endif + /* answer negative, doesn't fit */ + SETn( -(NV)result ); RETURN; } } @@ -1655,8 +1675,14 @@ 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)) { + bigint_arith("bmul", svl, svr); + RETURN; + } +#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)) { @@ -1693,6 +1719,12 @@ 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)) { + bigint_arith("bmul", svl, svr); + RETURN; + } else +#endif SETn( (NV)auv * (NV)buv ); } else { if ((auvok & buvok) || result > IV_MAX) @@ -1705,6 +1737,12 @@ PP(pp_multiply) } else { IV value; if (BUILTIN_SMUL_OVERFLOW(aiv, biv, &value)) { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + bigint_arith("bmul", svl, svr); + RETURN; + } else +#endif SETn( (NV)aiv * (NV)biv ); } else { SETi( value ); @@ -1839,6 +1877,53 @@ PP(pp_multiply) } } +/* +=for apidoc AMp|void|bigint_arith + +Does a binary arithmetic op via bigint and string eval, +when requested via use exact_arith. + +Slow but exact. + +=cut +*/ + +void +Perl_bigint_arith(pTHX_ const char *op, SV* const left, SV* const right) { + dSP; + SV* sv; + PERL_ARGS_ASSERT_BIGINT_ARITH; + + PUSHSTACKi(PERLSI_REQUIRE); + sv = Perl_newSVpvf(aTHX_ "require Math::BigInt; Math::BigInt->%s(", op); + if (SvIOK(left)) { + if (SvUOK(left)) + sv_catpvf(aTHX_ sv, "%"UVuf"", SvUVX(left)); + else + sv_catpvf(aTHX_ sv, "%"IVdf"", SvIVX(left)); + } else { + STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD(); + /* full precision, not just %g. TODO long double */ + sv_catpvf(aTHX_ sv, "%.15g, ", SvNVX(left)); + RESTORE_LC_NUMERIC_UNDERLYING(); + } + if (SvIOK(right)) { + if (SvUOK(right)) + sv_catpvf(aTHX_ sv, ", %"UVuf");", SvUVX(right)); + else + sv_catpvf(aTHX_ sv, ", %"IVdf");", SvIVX(right)); + } else if (SvNOK(right)) { + STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD(); + sv_catpvf(aTHX_ sv, ", %.15g);", SvNVX(right)); + RESTORE_LC_NUMERIC_UNDERLYING(); + } else { + sv_catpvf(aTHX_ sv, ");"); + } + eval_sv(sv_2mortal(sv), G_SCALAR); + POPSTACK; + PUTBACK; +} + PP(pp_divide) { dSP; dATARGET; SV *svl, *svr; @@ -1947,6 +2032,12 @@ 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)) { + bigint_arith("bdiv", svl, svr); + RETURN; + } else +#endif /* It's exact but too negative for IV. */ SETn( -(NV)result ); } @@ -2399,6 +2490,11 @@ PP(pp_subtract) SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result); else { +#ifdef PERL_EXACT_ARITH + if (UNLIKELY(IS_EXACT_ARITH)) { + bigint_arith("bsub", svl, svr); + } else +#endif /* result valid, but out of range for IV. */ SETn( -(NV)result ); } @@ -3594,14 +3690,24 @@ 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)) { + bigint_arith("bfloor", sv, &PL_sv_undef); + } 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)) { + bigint_arith("bceil", sv, &PL_sv_undef); + } else +#endif + SETn(Perl_ceil(value)); } } } @@ -3614,37 +3720,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_hot.c b/pp_hot.c index 032f7d12e03..69be65d5643 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1643,6 +1643,13 @@ 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)) { + bigint_arith("badd", svl, svr); + RETURN; + } + else +#endif SETn( (NV)auv + (NV)buv ); } else { if ((auvok & buvok) || result > IV_MAX) @@ -1655,6 +1662,13 @@ 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)) { + bigint_arith("badd", svl, svr); + RETURN; + } + else +#endif /*SETn( (NV)(auvok?SvUVX(svl):aiv) + (NV)(buvok?SvUVX(svr):biv) );*/ SETn( (NV)aiv + (NV)biv ); } else { @@ -1718,12 +1732,25 @@ 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)) { + bigint_arith("badd", svl, svr); + RETURN; + } + 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)) { + bigint_arith("badd", svl, svr); + RETURN; + } +#endif #endif } } diff --git a/proto.h b/proto.h index c6192b92ef6..4236c03ae7e 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..066fc5d63ad 100644 --- a/sv.c +++ b/sv.c @@ -9091,9 +9091,15 @@ 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); } else { 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: */