From: Jarkko Hietaniemi Date: Sun, 14 Sep 2014 19:43:55 +0000 (-0400) Subject: quadmath NV formatted I/O. X-Git-Tag: v5.21.4~34 X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/a4eca1d4e93229f61c43cff9ccf327446a06c800 quadmath NV formatted I/O. --- diff --git a/embed.fnc b/embed.fnc index 1214bf7..a8789ac 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2433,8 +2433,10 @@ sn |void |mem_log_common |enum mem_log_type mlt|const UV n|const UV typesize \ #endif #if defined(PERL_IN_NUMERIC_C) +#ifndef USE_QUADMATH sn |NV|mulexp10 |NV value|I32 exponent #endif +#endif #if defined(PERL_IN_UTF8_C) sRM |UV |check_locale_boundary_crossing|NN const U8* const p|const UV result|NN U8* const ustrp|NN STRLEN *lenp @@ -2644,6 +2646,10 @@ Apnod |int |my_sprintf |NN char *buffer|NN const char *pat|... Apnodf |int |my_snprintf |NN char *buffer|const Size_t len|NN const char *format|... Apnod |int |my_vsnprintf |NN char *buffer|const Size_t len|NN const char *format|va_list ap +#ifdef USE_QUADMATH +Apnd |const char* |quadmath_format_single|NN const char* format +Apnd |bool|quadmath_format_needed|NN const char* format +#endif : Used in mg.c, sv.c px |void |my_clearenv diff --git a/embed.h b/embed.h index c658570..cd5c1d2 100644 --- a/embed.h +++ b/embed.h @@ -878,6 +878,10 @@ #define PerlIO_unread(a,b,c) Perl_PerlIO_unread(aTHX_ a,b,c) #define PerlIO_write(a,b,c) Perl_PerlIO_write(aTHX_ a,b,c) #endif +#if defined(USE_QUADMATH) +#define quadmath_format_needed Perl_quadmath_format_needed +#define quadmath_format_single Perl_quadmath_format_single +#endif #if defined(WIN32) #define my_setlocale(a,b) Perl_my_setlocale(aTHX_ a,b) #endif @@ -1355,6 +1359,11 @@ #define utf16_textfilter(a,b,c) S_utf16_textfilter(aTHX_ a,b,c) # endif # endif +# if !defined(USE_QUADMATH) +# if defined(PERL_IN_NUMERIC_C) +#define mulexp10 S_mulexp10 +# endif +# endif # if !defined(WIN32) #define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c) # endif @@ -1486,9 +1495,6 @@ #define mro_gather_and_rename(a,b,c,d,e) S_mro_gather_and_rename(aTHX_ a,b,c,d,e) #define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b) # endif -# if defined(PERL_IN_NUMERIC_C) -#define mulexp10 S_mulexp10 -# endif # if defined(PERL_IN_OP_C) #define aassign_common_vars(a) S_aassign_common_vars(aTHX_ a) #define apply_attrs(a,b,c) S_apply_attrs(aTHX_ a,b,c) diff --git a/numeric.c b/numeric.c index 427900b..5691120 100644 --- a/numeric.c +++ b/numeric.c @@ -965,6 +965,7 @@ Perl_grok_atou(const char *pv, const char** endptr) return val; } +#ifndef USE_QUADMATH STATIC NV S_mulexp10(NV value, I32 exponent) { @@ -1043,12 +1044,17 @@ S_mulexp10(NV value, I32 exponent) } return negative ? value / result : value * result; } +#endif /* #ifndef USE_QUADMATH */ NV Perl_my_atof(pTHX_ const char* s) { NV x = 0.0; -#ifdef USE_LOCALE_NUMERIC +#ifdef USE_QUADMATH + Perl_my_atof2(aTHX_ s, &x); + return x; +#else +# ifdef USE_LOCALE_NUMERIC PERL_ARGS_ASSERT_MY_ATOF; { @@ -1081,8 +1087,9 @@ Perl_my_atof(pTHX_ const char* s) Perl_atof2(s, x); RESTORE_LC_NUMERIC(); } -#else +# else Perl_atof2(s, x); +# endif #endif return x; } @@ -1162,12 +1169,14 @@ S_my_atof_infnan(const char* s, bool negative, const char* send, NV* value) char* Perl_my_atof2(pTHX_ const char* orig, NV* value) { - NV result[3] = {0.0, 0.0, 0.0}; const char* s = orig; -#ifdef USE_PERL_ATOF - UV accumulator[2] = {0,0}; /* before/after dp */ - bool negative = 0; + NV result[3] = {0.0, 0.0, 0.0}; +#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH) const char* send = s + strlen(orig); /* one past the last */ + bool negative = 0; +#endif +#if defined(USE_PERL_ATOF) && !defined(USE_QUADMATH) + UV accumulator[2] = {0,0}; /* before/after dp */ bool seen_digit = 0; I32 exp_adjust[2] = {0,0}; I32 exp_acc[2] = {-1, -1}; @@ -1177,9 +1186,39 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) I32 digit = 0; I32 old_digit = 0; I32 sig_digits = 0; /* noof significant digits seen so far */ +#endif +#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH) PERL_ARGS_ASSERT_MY_ATOF2; + /* leading whitespace */ + while (isSPACE(*s)) + ++s; + + /* sign */ + switch (*s) { + case '-': + negative = 1; + /* FALLTHROUGH */ + case '+': + ++s; + } +#endif + +#ifdef USE_QUADMATH + { + char* endp; + if ((endp = S_my_atof_infnan(s, negative, send, value))) + return endp; + result[2] = strtoflt128(s, &endp); + if (s != endp) { + *value = negative ? -result[2] : result[2]; + return endp; + } + return NULL; + } +#elif defined(USE_PERL_ATOF) + /* There is no point in processing more significant digits * than the NV can hold. Note that NV_DIG is a lower-bound value, * while we need an upper-bound value. We add 2 to account for this; @@ -1209,19 +1248,6 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) /* the max number we can accumulate in a UV, and still safely do 10*N+9 */ #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10)) - /* leading whitespace */ - while (isSPACE(*s)) - ++s; - - /* sign */ - switch (*s) { - case '-': - negative = 1; - /* FALLTHROUGH */ - case '+': - ++s; - } - { const char* endp; if ((endp = S_my_atof_infnan(s, negative, send, value))) diff --git a/perl.h b/perl.h index 751df86..d711b20 100644 --- a/perl.h +++ b/perl.h @@ -1562,6 +1562,10 @@ EXTERN_C char *crypt(const char *, const char *); #define PERL_SNPRINTF_CHECK(len, max, api) STMT_START { if ((max) > 0 && (Size_t)len >= (max)) Perl_croak_nocontext("panic: %s buffer overflow", STRINGIFY(api)); } STMT_END +#ifdef USE_QUADMATH +# define my_snprintf Perl_my_snprintf +# define PERL_MY_SNPRINTF_GUARDED +#else #if defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC) # ifdef PERL_USE_GCC_BRACE_GROUPS # define my_snprintf(buffer, max, ...) ({ int len = snprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, snprintf); len; }) @@ -1573,7 +1577,10 @@ EXTERN_C char *crypt(const char *, const char *); # define my_snprintf Perl_my_snprintf # define PERL_MY_SNPRINTF_GUARDED #endif +#endif +/* There is no quadmath_vsnprintf, and therefore my_vsnprintf() + * dies if called under USE_QUADMATH. */ #if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC) # ifdef PERL_USE_GCC_BRACE_GROUPS # define my_vsnprintf(buffer, max, ...) ({ int len = vsnprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, vsnprintf); len; }) diff --git a/pp_ctl.c b/pp_ctl.c index db125b8..5036eda 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -825,11 +825,25 @@ PP(pp_formline) int len; DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); +#ifdef USE_QUADMATH + { + const char* qfmt = quadmath_format_single(fmt); + int len; + if (!qfmt) + Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt); + len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value); + if (len == -1) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); + if (qfmt != fmt) + Safefree(fmt); + } +#else /* we generate fmt ourselves so it is safe */ GCC_DIAG_IGNORE(-Wformat-nonliteral); len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value); - PERL_MY_SNPRINTF_POST_GUARD(len, max); GCC_DIAG_RESTORE; +#endif + PERL_MY_SNPRINTF_POST_GUARD(len, max); RESTORE_LC_NUMERIC(); } t += fieldsize; diff --git a/proto.h b/proto.h index a0b5c43..d6d3a86 100644 --- a/proto.h +++ b/proto.h @@ -5336,6 +5336,11 @@ PERL_CALLCONV int Perl_my_sprintf(char *buffer, const char *pat, ...) assert(buffer); assert(pat) #endif +#if !defined(USE_QUADMATH) +# if defined(PERL_IN_NUMERIC_C) +STATIC NV S_mulexp10(NV value, I32 exponent); +# endif +#endif #if !defined(WIN32) PERL_CALLCONV bool Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) __attribute__nonnull__(pTHX_1); @@ -6120,9 +6125,6 @@ STATIC AV* S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level) assert(stash) #endif -#if defined(PERL_IN_NUMERIC_C) -STATIC NV S_mulexp10(NV value, I32 exponent); -#endif #if defined(PERL_IN_OP_C) PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o); STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) @@ -8068,6 +8070,18 @@ PERL_CALLCONV SSize_t Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_ assert(vbuf) #endif +#if defined(USE_QUADMATH) +PERL_CALLCONV bool Perl_quadmath_format_needed(const char* format) + __attribute__nonnull__(1); +#define PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED \ + assert(format) + +PERL_CALLCONV const char* Perl_quadmath_format_single(const char* format) + __attribute__nonnull__(1); +#define PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE \ + assert(format) + +#endif #if defined(WIN32) PERL_CALLCONV char* Perl_my_setlocale(pTHX_ int category, const char* locale) __attribute__pure__; diff --git a/sv.c b/sv.c index 3f7fce6..04c2826 100644 --- a/sv.c +++ b/sv.c @@ -40,6 +40,14 @@ char *gconvert(double, int, int, char *); #endif +#ifdef USE_QUADMATH +# define SNPRINTF_G(nv, buffer, size, ndig) \ + quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv)) +#else +# define SNPRINTF_G(nv, buffer, size, ndig) \ + PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer)) +#endif + #ifdef PERL_NEW_COPY_ON_WRITE # ifndef SV_COW_THRESHOLD # define SV_COW_THRESHOLD 0 /* COW iff len > K */ @@ -3045,12 +3053,13 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) /* some Xenix systems wipe out errno here */ #ifndef USE_LOCALE_NUMERIC - PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s)); + SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG); + SvPOK_on(sv); #else { DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); - PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s)); + SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG); /* If the radix character is UTF-8, and actually is in the * output, turn on the UTF-8 flag for the scalar */ @@ -11023,9 +11032,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (digits && digits < sizeof(ebuf) - NV_DIG - 10) { /* 0, point, slack */ STORE_LC_NUMERIC_SET_TO_NEEDED(); - PERL_UNUSED_RESULT(Gconvert(nv, (int)digits, 0, ebuf)); + SNPRINTF_G(nv, ebuf, size, digits); sv_catpv_nomg(sv, ebuf); - if (*ebuf) /* May return an empty string for digits==0 */ + if (*ebuf) /* May return an empty string for digits==0 */ return; } } else if (!digits) { @@ -11088,7 +11097,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * the time it is not (most compilers these days recognize * "long double", even if only as a synonym for "double"). */ -#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && defined(PERL_PRIgldbl) +#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \ + defined(PERL_PRIgldbl) && !defined(USE_QUADMATH) long double fv; # define FV_ISFINITE(x) Perl_isfinitel(x) # define FV_GF PERL_PRIgldbl @@ -11394,6 +11404,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE) case 'L': /* Ld */ /* FALLTHROUGH */ +#ifdef USE_QUADMATH + case 'Q': + /* FALLTHROUGH */ +#endif #if IVSIZE >= 8 case 'q': /* qd */ #endif @@ -11823,7 +11837,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * The only case where you can pull off long doubles * is when the format specifier explicitly asks so with * e.g. "%Lg". */ -#if LONG_DOUBLESIZE > DOUBLESIZE +#ifdef USE_QUADMATH + fv = intsize == 'q' ? + va_arg(*args, NV) : va_arg(*args, double); +#elif LONG_DOUBLESIZE > DOUBLESIZE fv = intsize == 'q' ? va_arg(*args, long double) : va_arg(*args, double); #else @@ -11973,7 +11990,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p aka precis is 0 */ if ( c == 'g' && precis ) { STORE_LC_NUMERIC_SET_TO_NEEDED(); - PERL_UNUSED_RESULT(Gconvert((NV)fv, (int)precis, 0, PL_efloatbuf)); + SNPRINTF_G(fv, PL_efloatbuf, PL_efloatsize, precis); /* May return an empty string for digits==0 */ if (*PL_efloatbuf) { elen = strlen(PL_efloatbuf); @@ -12178,9 +12195,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* Copy the one or more characters in a long double * format before the 'base' ([efgEFG]) character to * the format string. */ +#ifdef USE_QUADMATH + *--ptr = 'Q'; +#else static char const ldblf[] = PERL_PRIfldbl; char const *p = ldblf + sizeof(ldblf) - 3; while (p >= ldblf) { *--ptr = *p--; } +#endif } #endif if (has_precis) { @@ -12211,7 +12232,19 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* hopefully the above makes ptr a very constrained format * that is safe to use, even though it's not literal */ GCC_DIAG_IGNORE(-Wformat-nonliteral); -#if defined(HAS_LONG_DOUBLE) +#ifdef USE_QUADMATH + { + const char* qfmt = quadmath_format_single(ptr); + if (!qfmt) + Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr); + elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize, + qfmt, fv); + if ((IV)elen == -1) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt); + if (qfmt != ptr) + Safefree(qfmt); + } +#elif defined(HAS_LONG_DOUBLE) elen = ((intsize == 'q') ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv) : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv)); diff --git a/util.c b/util.c index e87813b..ae3b833 100644 --- a/util.c +++ b/util.c @@ -4908,6 +4908,112 @@ Perl_my_sprintf(char *buffer, const char* pat, ...) #endif /* +=for apidoc quadmath_format_single + +quadmath_snprintf() is very strict about its format string and will +fail, returning -1, if the format is invalid. It acccepts exactly +one format spec. + +quadmath_format_single() checks that the intended single spec looks +sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>, +and has C before it. This is not a full "printf syntax check", +just the basics. + +Returns the format if it is valid, NULL if not. + +quadmath_format_single() can and will actually patch in the missing +C, if necessary. In this case it will return the modified copy of +the format, B + +See also L. + +=cut +*/ +#ifdef USE_QUADMATH +const char* +Perl_quadmath_format_single(const char* format) +{ + STRLEN len; + + PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE; + + if (format[0] != '%' || strchr(format + 1, '%')) + return NULL; + len = strlen(format); + /* minimum length three: %Qg */ + if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL) + return NULL; + if (format[len - 2] != 'Q') { + char* fixed; + Newx(fixed, len + 1, char); + memcpy(fixed, format, len - 1); + fixed[len - 1] = 'Q'; + fixed[len ] = format[len - 1]; + fixed[len + 1] = 0; + return (const char*)fixed; + } + return format; +} +#endif + +/* +=for apidoc quadmath_format_needed + +quadmath_format_needed() returns true if the format string seems to +contain at least one non-Q-prefixed %[efgaEFGA] format specifier, +or returns false otherwise. + +The format specifier detection is not complete printf-syntax detection, +but it should catch most common cases. + +If true is returned, those arguments B in theory be processed +with quadmath_snprintf(), but in case there is more than one such +format specifier (see L), and if there is +anything else beyond that one (even just a single byte), they +B be processed because quadmath_snprintf() is very strict, +accepting only one format spec, and nothing else. +In this case, the code should probably fail. + +=cut +*/ +#ifdef USE_QUADMATH +bool +Perl_quadmath_format_needed(const char* format) +{ + const char *p = format; + const char *q; + + PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED; + + while ((q = strchr(p, '%'))) { + q++; + if (*q == '+') /* plus */ + q++; + if (*q == '#') /* alt */ + q++; + if (*q == '*') /* width */ + q++; + else { + if (isDIGIT(*q)) { + while (isDIGIT(*q)) q++; + } + } + if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */ + q++; + if (*q == '*') + q++; + else + while (isDIGIT(*q)) q++; + } + if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */ + return TRUE; + p = q + 1; + } + return FALSE; +} +#endif + +/* =for apidoc my_snprintf The C library C functionality, if available and @@ -4922,17 +5028,59 @@ getting C. int Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) { - int retval; + int retval = -1; va_list ap; PERL_ARGS_ASSERT_MY_SNPRINTF; #ifndef HAS_VSNPRINTF PERL_UNUSED_VAR(len); #endif va_start(ap, format); +#ifdef USE_QUADMATH + { + const char* qfmt = quadmath_format_single(format); + bool quadmath_valid = FALSE; + if (qfmt) { + /* If the format looked promising, use it as quadmath. */ + retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV)); + if (retval == -1) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); + quadmath_valid = TRUE; + if (qfmt != format) + Safefree(qfmt); + qfmt = NULL; + } + assert(qfmt == NULL); + /* quadmath_format_single() will return false for example for + * "foo = %g", or simply "%g". We could handle the %g by + * using quadmath for the NV args. More complex cases of + * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise + * quadmath-valid but has stuff in front). + * + * Handling the "Q-less" cases right would require walking + * through the va_list and rewriting the format, calling + * quadmath for the NVs, building a new va_list, and then + * letting vsnprintf/vsprintf to take care of the other + * arguments. This may be doable. + * + * We do not attempt that now. But for paranoia, we here try + * to detect some common (but not all) cases where the + * "Q-less" %[efgaEFGA] formats are present, and die if + * detected. This doesn't fix the problem, but it stops the + * vsnprintf/vsprintf pulling doubles off the va_list when + * __float128 NVs should be pulled off instead. + * + * If quadmath_format_needed() returns false, we are reasonably + * certain that we can call vnsprintf() or vsprintf() safely. */ + if (!quadmath_valid && quadmath_format_needed(format)) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format); + + } +#endif + if (retval == -1) #ifdef HAS_VSNPRINTF - retval = vsnprintf(buffer, len, format, ap); + retval = vsnprintf(buffer, len, format, ap); #else - retval = vsprintf(buffer, format, ap); + retval = vsprintf(buffer, format, ap); #endif va_end(ap); /* vsprintf() shows failure with < 0 */ @@ -4961,6 +5109,14 @@ C instead, or getting C. int Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) { +#ifdef USE_QUADMATH + PERL_UNUSED_ARG(buffer); + PERL_UNUSED_ARG(len); + PERL_UNUSED_ARG(format); + PERL_UNUSED_ARG(ap); + Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath"); + return 0; +#else int retval; #ifdef NEED_VA_COPY va_list apc; @@ -4993,6 +5149,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap ) Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); return retval; +#endif } void