mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-02-01 21:50:25 +08:00
fortran, libgfortran: Add remaining missing *_r17 symbols
Following patch adds remaining missing *_r17 entrypoints, so that we have 91 *_r16 and 91 *_r17 entrypoints (and 24 *_c16 and 24 *_c17). This fixes: FAIL: gfortran.dg/dec_math.f90 -O0 execution test FAIL: gfortran.dg/dec_math.f90 -O1 execution test FAIL: gfortran.dg/dec_math.f90 -O2 execution test FAIL: gfortran.dg/dec_math.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions execution test FAIL: gfortran.dg/dec_math.f90 -O3 -g execution test FAIL: gfortran.dg/dec_math.f90 -Os execution test FAIL: gfortran.dg/ieee/dec_math_1.f90 -O0 execution test FAIL: gfortran.dg/ieee/dec_math_1.f90 -O1 execution test FAIL: gfortran.dg/ieee/dec_math_1.f90 -O2 execution test FAIL: gfortran.dg/ieee/dec_math_1.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions execution test FAIL: gfortran.dg/ieee/dec_math_1.f90 -O3 -g execution test FAIL: gfortran.dg/ieee/dec_math_1.f90 -Os execution test 2022-01-04 Jakub Jelinek <jakub@redhat.com> gcc/fortran/ * trans-intrinsic.c (gfc_get_intrinsic_lib_fndecl): Use gfc_type_abi_kind. libgfortran/ * libgfortran.h (GFC_REAL_17_INFINITY, GFC_REAL_17_QUIET_NAN): Define. (__erfcieee128): Declare. * intrinsics/trigd.c (_gfortran_sind_r17, _gfortran_cosd_r17, _gfortran_tand_r17): Define for HAVE_GFC_REAL_17. * intrinsics/random.c (random_r17, arandom_r17, rnumber_17): Define. * intrinsics/erfc_scaled.c (ERFC_SCALED): Define. (erfc_scaled_r16): Use ERFC_SCALED macro. (erfc_scaled_r17): Define.
This commit is contained in:
Jakub Jelinek
parent
06a74228ce
commit
5db042b2b8
@ -881,7 +881,7 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
|
|||||||
{
|
{
|
||||||
snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
|
snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
|
||||||
ts->type == BT_COMPLEX ? 'c' : 'r',
|
ts->type == BT_COMPLEX ? 'c' : 'r',
|
||||||
ts->kind);
|
gfc_type_abi_kind (ts));
|
||||||
}
|
}
|
||||||
|
|
||||||
argtypes = NULL;
|
argtypes = NULL;
|
||||||
|
|||||||
@ -75,52 +75,91 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
#define ERFC_SCALED(k) \
|
||||||
|
GFC_REAL_ ## k \
|
||||||
|
erfc_scaled_r ## k (GFC_REAL_ ## k x) \
|
||||||
|
{ \
|
||||||
|
if (x < _THRESH) \
|
||||||
|
{ \
|
||||||
|
return _INF; \
|
||||||
|
} \
|
||||||
|
if (x < 12) \
|
||||||
|
{ \
|
||||||
|
/* Compute directly as ERFC_SCALED(x) = ERFC(x) * EXP(X**2). \
|
||||||
|
This is not perfect, but much better than netlib. */ \
|
||||||
|
return _ERFC(x) * _EXP(x * x); \
|
||||||
|
} \
|
||||||
|
else \
|
||||||
|
{ \
|
||||||
|
/* Calculate ERFC_SCALED(x) using a power series in 1/x: \
|
||||||
|
ERFC_SCALED(x) = 1 / (x * sqrt(pi)) \
|
||||||
|
* (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1)) \
|
||||||
|
/ (2 * x**2)**n) \
|
||||||
|
*/ \
|
||||||
|
GFC_REAL_ ## k sum = 0, oldsum; \
|
||||||
|
GFC_REAL_ ## k inv2x2 = 1 / (2 * x * x); \
|
||||||
|
GFC_REAL_ ## k fac = 1; \
|
||||||
|
int n = 1; \
|
||||||
|
\
|
||||||
|
while (n < 200) \
|
||||||
|
{ \
|
||||||
|
fac *= - (2*n - 1) * inv2x2; \
|
||||||
|
oldsum = sum; \
|
||||||
|
sum += fac; \
|
||||||
|
\
|
||||||
|
if (sum == oldsum) \
|
||||||
|
break; \
|
||||||
|
\
|
||||||
|
n++; \
|
||||||
|
} \
|
||||||
|
\
|
||||||
|
return (1 + sum) / x * (_M_2_SQRTPI / 2); \
|
||||||
|
} \
|
||||||
|
}
|
||||||
|
|
||||||
#if defined(_ERFC) && defined(_EXP)
|
#if defined(_ERFC) && defined(_EXP)
|
||||||
|
|
||||||
extern GFC_REAL_16 erfc_scaled_r16 (GFC_REAL_16);
|
extern GFC_REAL_16 erfc_scaled_r16 (GFC_REAL_16);
|
||||||
export_proto(erfc_scaled_r16);
|
export_proto(erfc_scaled_r16);
|
||||||
|
|
||||||
GFC_REAL_16
|
ERFC_SCALED(16)
|
||||||
erfc_scaled_r16 (GFC_REAL_16 x)
|
|
||||||
{
|
|
||||||
if (x < _THRESH)
|
|
||||||
{
|
|
||||||
return _INF;
|
|
||||||
}
|
|
||||||
if (x < 12)
|
|
||||||
{
|
|
||||||
/* Compute directly as ERFC_SCALED(x) = ERFC(x) * EXP(X**2).
|
|
||||||
This is not perfect, but much better than netlib. */
|
|
||||||
return _ERFC(x) * _EXP(x * x);
|
|
||||||
}
|
|
||||||
else
|
|
||||||
{
|
|
||||||
/* Calculate ERFC_SCALED(x) using a power series in 1/x:
|
|
||||||
ERFC_SCALED(x) = 1 / (x * sqrt(pi))
|
|
||||||
* (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
|
|
||||||
/ (2 * x**2)**n)
|
|
||||||
*/
|
|
||||||
GFC_REAL_16 sum = 0, oldsum;
|
|
||||||
GFC_REAL_16 inv2x2 = 1 / (2 * x * x);
|
|
||||||
GFC_REAL_16 fac = 1;
|
|
||||||
int n = 1;
|
|
||||||
|
|
||||||
while (n < 200)
|
|
||||||
{
|
|
||||||
fac *= - (2*n - 1) * inv2x2;
|
|
||||||
oldsum = sum;
|
|
||||||
sum += fac;
|
|
||||||
|
|
||||||
if (sum == oldsum)
|
|
||||||
break;
|
|
||||||
|
|
||||||
n++;
|
|
||||||
}
|
|
||||||
|
|
||||||
return (1 + sum) / x * (_M_2_SQRTPI / 2);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
#undef _THRESH
|
||||||
|
#undef _M_2_SQRTPI
|
||||||
|
#undef _INF
|
||||||
|
#undef _ERFC
|
||||||
|
#undef _EXP
|
||||||
|
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#ifdef HAVE_GFC_REAL_17
|
||||||
|
|
||||||
|
/* For quadruple-precision, netlib's implementation is
|
||||||
|
not accurate enough. We provide another one. */
|
||||||
|
|
||||||
|
# define _THRESH -106.566990228185312813205074546585730Q
|
||||||
|
# define _M_2_SQRTPI M_2_SQRTPIq
|
||||||
|
# define _INF __builtin_inff128()
|
||||||
|
# ifdef POWER_IEEE128
|
||||||
|
# define _ERFC(x) __erfcieee128(x)
|
||||||
|
# define _EXP(x) __expieee128(x)
|
||||||
|
# else
|
||||||
|
# define _ERFC(x) erfcq(x)
|
||||||
|
# define _EXP(x) expq(x)
|
||||||
|
# endif
|
||||||
|
|
||||||
|
extern GFC_REAL_17 erfc_scaled_r17 (GFC_REAL_17);
|
||||||
|
export_proto(erfc_scaled_r17);
|
||||||
|
|
||||||
|
ERFC_SCALED(17)
|
||||||
|
|
||||||
|
#undef _THRESH
|
||||||
|
#undef _M_2_SQRTPI
|
||||||
|
#undef _INF
|
||||||
|
#undef _ERFC
|
||||||
|
#undef _EXP
|
||||||
|
#undef ERFC_SCALED
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|||||||
@ -79,6 +79,16 @@ export_proto(arandom_r16);
|
|||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
#ifdef HAVE_GFC_REAL_17
|
||||||
|
|
||||||
|
extern void random_r17 (GFC_REAL_17 *);
|
||||||
|
iexport_proto(random_r17);
|
||||||
|
|
||||||
|
extern void arandom_r17 (gfc_array_r17 *);
|
||||||
|
export_proto(arandom_r17);
|
||||||
|
|
||||||
|
#endif
|
||||||
|
|
||||||
#ifdef __GTHREAD_MUTEX_INIT
|
#ifdef __GTHREAD_MUTEX_INIT
|
||||||
static __gthread_mutex_t random_lock = __GTHREAD_MUTEX_INIT;
|
static __gthread_mutex_t random_lock = __GTHREAD_MUTEX_INIT;
|
||||||
#else
|
#else
|
||||||
@ -161,6 +171,27 @@ rnumber_16 (GFC_REAL_16 *f, GFC_UINTEGER_8 v1, GFC_UINTEGER_8 v2)
|
|||||||
}
|
}
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
#ifdef HAVE_GFC_REAL_17
|
||||||
|
|
||||||
|
/* For REAL(KIND=16), we only need to mask off the lower bits. */
|
||||||
|
|
||||||
|
static void
|
||||||
|
rnumber_17 (GFC_REAL_17 *f, GFC_UINTEGER_8 v1, GFC_UINTEGER_8 v2)
|
||||||
|
{
|
||||||
|
GFC_UINTEGER_8 mask;
|
||||||
|
#if GFC_REAL_17_RADIX == 2
|
||||||
|
mask = ~ (GFC_UINTEGER_8) 0u << (128 - GFC_REAL_17_DIGITS);
|
||||||
|
#elif GFC_REAL_17_RADIX == 16
|
||||||
|
mask = ~ (GFC_UINTEGER_8) 0u << ((32 - GFC_REAL_17_DIGITS) * 4);
|
||||||
|
#else
|
||||||
|
#error "GFC_REAL_17_RADIX has unknown value"
|
||||||
|
#endif
|
||||||
|
v2 = v2 & mask;
|
||||||
|
*f = (GFC_REAL_17) v1 * GFC_REAL_17_LITERAL(0x1.p-64)
|
||||||
|
+ (GFC_REAL_17) v2 * GFC_REAL_17_LITERAL(0x1.p-128);
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
|
||||||
/*
|
/*
|
||||||
|
|
||||||
@ -443,6 +474,28 @@ random_r16 (GFC_REAL_16 *x)
|
|||||||
iexport(random_r16);
|
iexport(random_r16);
|
||||||
|
|
||||||
|
|
||||||
|
#endif
|
||||||
|
|
||||||
|
/* This function produces a REAL(16) value from the uniform distribution
|
||||||
|
with range [0,1). */
|
||||||
|
|
||||||
|
#ifdef HAVE_GFC_REAL_17
|
||||||
|
|
||||||
|
void
|
||||||
|
random_r17 (GFC_REAL_17 *x)
|
||||||
|
{
|
||||||
|
GFC_UINTEGER_8 r1, r2;
|
||||||
|
prng_state* rs = get_rand_state();
|
||||||
|
|
||||||
|
if (unlikely (!rs->init))
|
||||||
|
init_rand_state (rs, false);
|
||||||
|
r1 = prng_next (rs);
|
||||||
|
r2 = prng_next (rs);
|
||||||
|
rnumber_17 (x, r1, r2);
|
||||||
|
}
|
||||||
|
iexport(random_r17);
|
||||||
|
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
/* This function fills a REAL(4) array with values from the uniform
|
/* This function fills a REAL(4) array with values from the uniform
|
||||||
@ -719,6 +772,77 @@ arandom_r16 (gfc_array_r16 *x)
|
|||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
#ifdef HAVE_GFC_REAL_17
|
||||||
|
|
||||||
|
/* This function fills a REAL(16) array with values from the uniform
|
||||||
|
distribution with range [0,1). */
|
||||||
|
|
||||||
|
void
|
||||||
|
arandom_r17 (gfc_array_r17 *x)
|
||||||
|
{
|
||||||
|
index_type count[GFC_MAX_DIMENSIONS];
|
||||||
|
index_type extent[GFC_MAX_DIMENSIONS];
|
||||||
|
index_type stride[GFC_MAX_DIMENSIONS];
|
||||||
|
index_type stride0;
|
||||||
|
index_type dim;
|
||||||
|
GFC_REAL_17 *dest;
|
||||||
|
prng_state* rs = get_rand_state();
|
||||||
|
|
||||||
|
dest = x->base_addr;
|
||||||
|
|
||||||
|
dim = GFC_DESCRIPTOR_RANK (x);
|
||||||
|
|
||||||
|
for (index_type n = 0; n < dim; n++)
|
||||||
|
{
|
||||||
|
count[n] = 0;
|
||||||
|
stride[n] = GFC_DESCRIPTOR_STRIDE(x,n);
|
||||||
|
extent[n] = GFC_DESCRIPTOR_EXTENT(x,n);
|
||||||
|
if (extent[n] <= 0)
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
stride0 = stride[0];
|
||||||
|
|
||||||
|
if (unlikely (!rs->init))
|
||||||
|
init_rand_state (rs, false);
|
||||||
|
|
||||||
|
while (dest)
|
||||||
|
{
|
||||||
|
/* random_r17 (dest); */
|
||||||
|
uint64_t r1 = prng_next (rs);
|
||||||
|
uint64_t r2 = prng_next (rs);
|
||||||
|
rnumber_17 (dest, r1, r2);
|
||||||
|
|
||||||
|
/* Advance to the next element. */
|
||||||
|
dest += stride0;
|
||||||
|
count[0]++;
|
||||||
|
/* Advance to the next source element. */
|
||||||
|
index_type n = 0;
|
||||||
|
while (count[n] == extent[n])
|
||||||
|
{
|
||||||
|
/* When we get to the end of a dimension, reset it and increment
|
||||||
|
the next dimension. */
|
||||||
|
count[n] = 0;
|
||||||
|
/* We could precalculate these products, but this is a less
|
||||||
|
frequently used path so probably not worth it. */
|
||||||
|
dest -= stride[n] * extent[n];
|
||||||
|
n++;
|
||||||
|
if (n == dim)
|
||||||
|
{
|
||||||
|
dest = NULL;
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
count[n]++;
|
||||||
|
dest += stride[n];
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
#endif
|
||||||
|
|
||||||
|
|
||||||
/* Number of elements in master_state array. */
|
/* Number of elements in master_state array. */
|
||||||
#define SZU64 (sizeof (master_state.s) / sizeof (uint64_t))
|
#define SZU64 (sizeof (master_state.s) / sizeof (uint64_t))
|
||||||
|
|||||||
@ -289,3 +289,42 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||||||
#undef HAVE_INFINITY_KIND
|
#undef HAVE_INFINITY_KIND
|
||||||
|
|
||||||
#endif /* HAVE_GFC_REAL_16 */
|
#endif /* HAVE_GFC_REAL_16 */
|
||||||
|
|
||||||
|
#ifdef HAVE_GFC_REAL_17
|
||||||
|
|
||||||
|
/* Build _gfortran_sind_r17, _gfortran_cosd_r17, and _gfortran_tand_r17 */
|
||||||
|
|
||||||
|
#define KIND 17
|
||||||
|
#define TINY 0x1.p-16400 /* ~= 1.28e-4937 */
|
||||||
|
#undef SIND_SMALL /* not precise */
|
||||||
|
|
||||||
|
/* Proper float128 precision. */
|
||||||
|
#define COSD_SMALL 0x1.p-51 /* ~= 4.441e-16 */
|
||||||
|
#define COSD30 8.66025403784438646763723170752936183e-01
|
||||||
|
#define PIO180H 1.74532925199433197605003442731685936e-02
|
||||||
|
#define PIO180L -2.39912634365882824665106671063098954e-17
|
||||||
|
|
||||||
|
/* libquadmath or glibc 2.32+: HAVE_*Q are never defined. They must be available. */
|
||||||
|
#define ENABLE_SIND
|
||||||
|
#define ENABLE_COSD
|
||||||
|
#define ENABLE_TAND
|
||||||
|
|
||||||
|
#ifdef GFC_REAL_17_INFINITY
|
||||||
|
#define HAVE_INFINITY_KIND
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#include "trigd_lib.inc"
|
||||||
|
|
||||||
|
#undef KIND
|
||||||
|
#undef TINY
|
||||||
|
#undef COSD_SMALL
|
||||||
|
#undef SIND_SMALL
|
||||||
|
#undef COSD30
|
||||||
|
#undef PIO180H
|
||||||
|
#undef PIO180L
|
||||||
|
#undef ENABLE_SIND
|
||||||
|
#undef ENABLE_COSD
|
||||||
|
#undef ENABLE_TAND
|
||||||
|
#undef HAVE_INFINITY_KIND
|
||||||
|
|
||||||
|
#endif /* HAVE_GFC_REAL_17 */
|
||||||
|
|||||||
@ -324,6 +324,9 @@ typedef GFC_UINTEGER_4 gfc_char4_t;
|
|||||||
# define GFC_REAL_16_INFINITY __builtin_infq ()
|
# define GFC_REAL_16_INFINITY __builtin_infq ()
|
||||||
# endif
|
# endif
|
||||||
# endif
|
# endif
|
||||||
|
# ifdef HAVE_GFC_REAL_17
|
||||||
|
# define GFC_REAL_17_INFINITY __builtin_inff128 ()
|
||||||
|
# endif
|
||||||
#endif
|
#endif
|
||||||
#if __FLT_HAS_QUIET_NAN__
|
#if __FLT_HAS_QUIET_NAN__
|
||||||
# define GFC_REAL_4_QUIET_NAN __builtin_nanf ("")
|
# define GFC_REAL_4_QUIET_NAN __builtin_nanf ("")
|
||||||
@ -342,6 +345,9 @@ typedef GFC_UINTEGER_4 gfc_char4_t;
|
|||||||
# define GFC_REAL_16_QUIET_NAN nanq ("")
|
# define GFC_REAL_16_QUIET_NAN nanq ("")
|
||||||
# endif
|
# endif
|
||||||
# endif
|
# endif
|
||||||
|
# ifdef HAVE_GFC_REAL_17
|
||||||
|
# define GFC_REAL_17_QUIET_NAN __builtin_nanf128 ("")
|
||||||
|
# endif
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
typedef struct descriptor_dimension
|
typedef struct descriptor_dimension
|
||||||
@ -1966,6 +1972,8 @@ extern __float128 __coshieee128 (__float128)
|
|||||||
__attribute__ ((__nothrow__, __leaf__));
|
__attribute__ ((__nothrow__, __leaf__));
|
||||||
extern __float128 __cosieee128 (__float128)
|
extern __float128 __cosieee128 (__float128)
|
||||||
__attribute__ ((__nothrow__, __leaf__));
|
__attribute__ ((__nothrow__, __leaf__));
|
||||||
|
extern __float128 __erfcieee128 (__float128)
|
||||||
|
__attribute__ ((__nothrow__, __leaf__));
|
||||||
extern __float128 __erfieee128 (__float128)
|
extern __float128 __erfieee128 (__float128)
|
||||||
__attribute__ ((__nothrow__, __leaf__));
|
__attribute__ ((__nothrow__, __leaf__));
|
||||||
extern __float128 __expieee128 (__float128)
|
extern __float128 __expieee128 (__float128)
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user