From 90045c5df5b3c8853e7740fb72a11aead1c489bb Mon Sep 17 00:00:00 2001
From: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Date: Mon, 10 Jan 2022 17:04:34 +0100
Subject: [PATCH] Fortran: allow IEEE_VALUE to correctly return signaling NaNs
I moved the library implementation of IEEE_VALUE in libgfortran from
Fortran to C code, which gives us access to GCC's built-ins for NaN generation
(both quiet and signalling). It will be perform better than the current
Fortran implementation.
libgfortran/ChangeLog:
PR fortran/82207
* mk-kinds-h.sh: Add values for TINY.
* ieee/ieee_arithmetic.F90: Call C helper functions for
IEEE_VALUE.
* ieee/ieee_helper.c: New functions ieee_value_helper_N for each
floating-point type.
gcc/testsuite/ChangeLog:
PR fortran/82207
* gfortran.dg/ieee/ieee_10.f90: Do not create signaling NaNs.
* gfortran.dg/ieee/signaling_2.f90: New test.
* gfortran.dg/ieee/signaling_2_c.c: New file.
---
gcc/testsuite/gfortran.dg/ieee/ieee_10.f90 | 12 +-
.../gfortran.dg/ieee/signaling_2.f90 | 70 +++++
.../gfortran.dg/ieee/signaling_2_c.c | 8 +
libgfortran/ieee/ieee_arithmetic.F90 | 284 +++---------------
libgfortran/ieee/ieee_helper.c | 74 +++++
libgfortran/mk-kinds-h.sh | 7 +
6 files changed, 203 insertions(+), 252 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/ieee/signaling_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/ieee/signaling_2_c.c
diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee_10.f90 b/gcc/testsuite/gfortran.dg/ieee/ieee_10.f90
index c3ffffcb24d4..a596504ae1e4 100644
--- a/gcc/testsuite/gfortran.dg/ieee/ieee_10.f90
+++ b/gcc/testsuite/gfortran.dg/ieee/ieee_10.f90
@@ -12,8 +12,10 @@ program foo
real x
real(8) y
- x = ieee_value(x, ieee_signaling_nan)
- if (.not. ieee_is_nan(x)) stop 1
+ ! At this point it is unclear what the behavior should be
+ ! for -ffpe-trap=invalid with a signaling NaN
+ !x = ieee_value(x, ieee_signaling_nan)
+ !if (.not. ieee_is_nan(x)) stop 1
x = ieee_value(x, ieee_quiet_nan)
if (.not. ieee_is_nan(x)) stop 2
@@ -22,8 +24,10 @@ program foo
x = ieee_value(x, ieee_negative_inf)
if (ieee_is_finite(x)) stop 4
- y = ieee_value(y, ieee_signaling_nan)
- if (.not. ieee_is_nan(y)) stop 5
+ ! At this point it is unclear what the behavior should be
+ ! for -ffpe-trap=invalid with a signaling NaN
+ !y = ieee_value(y, ieee_signaling_nan)
+ !if (.not. ieee_is_nan(y)) stop 5
y = ieee_value(y, ieee_quiet_nan)
if (.not. ieee_is_nan(y)) stop 6
diff --git a/gcc/testsuite/gfortran.dg/ieee/signaling_2.f90 b/gcc/testsuite/gfortran.dg/ieee/signaling_2.f90
new file mode 100644
index 000000000000..e7e7a4a10f23
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/signaling_2.f90
@@ -0,0 +1,70 @@
+! { dg-do run }
+! { dg-require-effective-target issignaling } */
+! { dg-additional-sources signaling_2_c.c }
+! { dg-additional-options "-w" }
+! the -w option is needed to make cc1 not report a warning for
+! the -fintrinsic-modules-path option passed by ieee.exp
+!
+program test
+ use, intrinsic :: iso_c_binding
+ use, intrinsic :: ieee_arithmetic
+ implicit none
+
+ interface
+ integer(kind=c_int) function isnansf (x) bind(c)
+ import :: c_float, c_int
+ real(kind=c_float), value :: x
+ end function
+
+ integer(kind=c_int) function isnans (x) bind(c)
+ import :: c_double, c_int
+ real(kind=c_double), value :: x
+ end function
+
+ integer(kind=c_int) function isnansl (x) bind(c)
+ import :: c_long_double, c_int
+ real(kind=c_long_double), value :: x
+ end function
+ end interface
+
+ real(kind=c_float) :: x
+ real(kind=c_double) :: y
+ real(kind=c_long_double) :: z
+
+ if (ieee_support_nan(x)) then
+ x = ieee_value(x, ieee_signaling_nan)
+ if (ieee_class(x) /= ieee_signaling_nan) stop 100
+ if (.not. ieee_is_nan(x)) stop 101
+ if (isnansf(x) /= 1) stop 102
+
+ x = ieee_value(x, ieee_quiet_nan)
+ if (ieee_class(x) /= ieee_quiet_nan) stop 103
+ if (.not. ieee_is_nan(x)) stop 104
+ if (isnansf(x) /= 0) stop 105
+ end if
+
+ if (ieee_support_nan(y)) then
+ y = ieee_value(y, ieee_signaling_nan)
+ if (ieee_class(y) /= ieee_signaling_nan) stop 100
+ if (.not. ieee_is_nan(y)) stop 101
+ if (isnans(y) /= 1) stop 102
+
+ y = ieee_value(y, ieee_quiet_nan)
+ if (ieee_class(y) /= ieee_quiet_nan) stop 103
+ if (.not. ieee_is_nan(y)) stop 104
+ if (isnans(y) /= 0) stop 105
+ end if
+
+ if (ieee_support_nan(z)) then
+ z = ieee_value(z, ieee_signaling_nan)
+ if (ieee_class(z) /= ieee_signaling_nan) stop 100
+ if (.not. ieee_is_nan(z)) stop 101
+ if (isnansl(z) /= 1) stop 102
+
+ z = ieee_value(z, ieee_quiet_nan)
+ if (ieee_class(z) /= ieee_quiet_nan) stop 103
+ if (.not. ieee_is_nan(z)) stop 104
+ if (isnansl(z) /= 0) stop 105
+ end if
+
+end program test
diff --git a/gcc/testsuite/gfortran.dg/ieee/signaling_2_c.c b/gcc/testsuite/gfortran.dg/ieee/signaling_2_c.c
new file mode 100644
index 000000000000..ea7fc0467bd7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/signaling_2_c.c
@@ -0,0 +1,8 @@
+#define _GNU_SOURCE
+#include <math.h>
+#include <float.h>
+
+int isnansf (float x) { return issignaling (x) ? 1 : 0; }
+int isnans (double x) { return issignaling (x) ? 1 : 0; }
+int isnansl (long double x) { return issignaling (x) ? 1 : 0; }
+
diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90
index 7e34660eb502..c8ef3e2faeb1 100644
--- a/libgfortran/ieee/ieee_arithmetic.F90
+++ b/libgfortran/ieee/ieee_arithmetic.F90
@@ -915,275 +915,63 @@ contains
! IEEE_VALUE
elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res)
-
real(kind=4), intent(in) :: X
type(IEEE_CLASS_TYPE), intent(in) :: CLASS
- logical flag
-
- select case (CLASS%hidden)
- case (1) ! IEEE_SIGNALING_NAN
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_get_halting_mode(ieee_invalid, flag)
- call ieee_set_halting_mode(ieee_invalid, .false.)
- end if
- res = -1
- res = sqrt(res)
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_set_halting_mode(ieee_invalid, flag)
- end if
- case (2) ! IEEE_QUIET_NAN
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_get_halting_mode(ieee_invalid, flag)
- call ieee_set_halting_mode(ieee_invalid, .false.)
- end if
- res = -1
- res = sqrt(res)
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_set_halting_mode(ieee_invalid, flag)
- end if
- case (3) ! IEEE_NEGATIVE_INF
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_get_halting_mode(ieee_overflow, flag)
- call ieee_set_halting_mode(ieee_overflow, .false.)
- end if
- res = huge(res)
- res = (-res) * res
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_set_halting_mode(ieee_overflow, flag)
- end if
- case (4) ! IEEE_NEGATIVE_NORMAL
- res = -42
- case (5) ! IEEE_NEGATIVE_DENORMAL
- res = -tiny(res)
- res = res / 2
- case (6) ! IEEE_NEGATIVE_ZERO
- res = 0
- res = -res
- case (7) ! IEEE_POSITIVE_ZERO
- res = 0
- case (8) ! IEEE_POSITIVE_DENORMAL
- res = tiny(res)
- res = res / 2
- case (9) ! IEEE_POSITIVE_NORMAL
- res = 42
- case (10) ! IEEE_POSITIVE_INF
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_get_halting_mode(ieee_overflow, flag)
- call ieee_set_halting_mode(ieee_overflow, .false.)
- end if
- res = huge(res)
- res = res * res
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_set_halting_mode(ieee_overflow, flag)
- end if
- case default ! IEEE_OTHER_VALUE, should not happen
- res = 0
- end select
+
+ interface
+ pure real(kind=4) function _gfortrani_ieee_value_helper_4(x)
+ use ISO_C_BINDING, only: C_INT
+ integer(kind=C_INT), value :: x
+ end function
+ end interface
+
+ res = _gfortrani_ieee_value_helper_4(CLASS%hidden)
end function
elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res)
-
real(kind=8), intent(in) :: X
type(IEEE_CLASS_TYPE), intent(in) :: CLASS
- logical flag
-
- select case (CLASS%hidden)
- case (1) ! IEEE_SIGNALING_NAN
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_get_halting_mode(ieee_invalid, flag)
- call ieee_set_halting_mode(ieee_invalid, .false.)
- end if
- res = -1
- res = sqrt(res)
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_set_halting_mode(ieee_invalid, flag)
- end if
- case (2) ! IEEE_QUIET_NAN
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_get_halting_mode(ieee_invalid, flag)
- call ieee_set_halting_mode(ieee_invalid, .false.)
- end if
- res = -1
- res = sqrt(res)
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_set_halting_mode(ieee_invalid, flag)
- end if
- case (3) ! IEEE_NEGATIVE_INF
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_get_halting_mode(ieee_overflow, flag)
- call ieee_set_halting_mode(ieee_overflow, .false.)
- end if
- res = huge(res)
- res = (-res) * res
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_set_halting_mode(ieee_overflow, flag)
- end if
- case (4) ! IEEE_NEGATIVE_NORMAL
- res = -42
- case (5) ! IEEE_NEGATIVE_DENORMAL
- res = -tiny(res)
- res = res / 2
- case (6) ! IEEE_NEGATIVE_ZERO
- res = 0
- res = -res
- case (7) ! IEEE_POSITIVE_ZERO
- res = 0
- case (8) ! IEEE_POSITIVE_DENORMAL
- res = tiny(res)
- res = res / 2
- case (9) ! IEEE_POSITIVE_NORMAL
- res = 42
- case (10) ! IEEE_POSITIVE_INF
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_get_halting_mode(ieee_overflow, flag)
- call ieee_set_halting_mode(ieee_overflow, .false.)
- end if
- res = huge(res)
- res = res * res
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_set_halting_mode(ieee_overflow, flag)
- end if
- case default ! IEEE_OTHER_VALUE, should not happen
- res = 0
- end select
+
+ interface
+ pure real(kind=8) function _gfortrani_ieee_value_helper_8(x)
+ use ISO_C_BINDING, only: C_INT
+ integer(kind=C_INT), value :: x
+ end function
+ end interface
+
+ res = _gfortrani_ieee_value_helper_8(CLASS%hidden)
end function
#ifdef HAVE_GFC_REAL_10
elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res)
-
real(kind=10), intent(in) :: X
type(IEEE_CLASS_TYPE), intent(in) :: CLASS
- logical flag
-
- select case (CLASS%hidden)
- case (1) ! IEEE_SIGNALING_NAN
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_get_halting_mode(ieee_invalid, flag)
- call ieee_set_halting_mode(ieee_invalid, .false.)
- end if
- res = -1
- res = sqrt(res)
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_set_halting_mode(ieee_invalid, flag)
- end if
- case (2) ! IEEE_QUIET_NAN
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_get_halting_mode(ieee_invalid, flag)
- call ieee_set_halting_mode(ieee_invalid, .false.)
- end if
- res = -1
- res = sqrt(res)
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_set_halting_mode(ieee_invalid, flag)
- end if
- case (3) ! IEEE_NEGATIVE_INF
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_get_halting_mode(ieee_overflow, flag)
- call ieee_set_halting_mode(ieee_overflow, .false.)
- end if
- res = huge(res)
- res = (-res) * res
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_set_halting_mode(ieee_overflow, flag)
- end if
- case (4) ! IEEE_NEGATIVE_NORMAL
- res = -42
- case (5) ! IEEE_NEGATIVE_DENORMAL
- res = -tiny(res)
- res = res / 2
- case (6) ! IEEE_NEGATIVE_ZERO
- res = 0
- res = -res
- case (7) ! IEEE_POSITIVE_ZERO
- res = 0
- case (8) ! IEEE_POSITIVE_DENORMAL
- res = tiny(res)
- res = res / 2
- case (9) ! IEEE_POSITIVE_NORMAL
- res = 42
- case (10) ! IEEE_POSITIVE_INF
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_get_halting_mode(ieee_overflow, flag)
- call ieee_set_halting_mode(ieee_overflow, .false.)
- end if
- res = huge(res)
- res = res * res
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_set_halting_mode(ieee_overflow, flag)
- end if
- case default ! IEEE_OTHER_VALUE, should not happen
- res = 0
- end select
+
+ interface
+ pure real(kind=10) function _gfortrani_ieee_value_helper_10(x)
+ use ISO_C_BINDING, only: C_INT
+ integer(kind=C_INT), value :: x
+ end function
+ end interface
+
+ res = _gfortrani_ieee_value_helper_10(CLASS%hidden)
end function
#endif
#ifdef HAVE_GFC_REAL_16
elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res)
-
real(kind=16), intent(in) :: X
type(IEEE_CLASS_TYPE), intent(in) :: CLASS
- logical flag
-
- select case (CLASS%hidden)
- case (1) ! IEEE_SIGNALING_NAN
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_get_halting_mode(ieee_invalid, flag)
- call ieee_set_halting_mode(ieee_invalid, .false.)
- end if
- res = -1
- res = sqrt(res)
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_set_halting_mode(ieee_invalid, flag)
- end if
- case (2) ! IEEE_QUIET_NAN
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_get_halting_mode(ieee_invalid, flag)
- call ieee_set_halting_mode(ieee_invalid, .false.)
- end if
- res = -1
- res = sqrt(res)
- if (ieee_support_halting(ieee_invalid)) then
- call ieee_set_halting_mode(ieee_invalid, flag)
- end if
- case (3) ! IEEE_NEGATIVE_INF
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_get_halting_mode(ieee_overflow, flag)
- call ieee_set_halting_mode(ieee_overflow, .false.)
- end if
- res = huge(res)
- res = (-res) * res
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_set_halting_mode(ieee_overflow, flag)
- end if
- case (4) ! IEEE_NEGATIVE_NORMAL
- res = -42
- case (5) ! IEEE_NEGATIVE_DENORMAL
- res = -tiny(res)
- res = res / 2
- case (6) ! IEEE_NEGATIVE_ZERO
- res = 0
- res = -res
- case (7) ! IEEE_POSITIVE_ZERO
- res = 0
- case (8) ! IEEE_POSITIVE_DENORMAL
- res = tiny(res)
- res = res / 2
- case (9) ! IEEE_POSITIVE_NORMAL
- res = 42
- case (10) ! IEEE_POSITIVE_INF
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_get_halting_mode(ieee_overflow, flag)
- call ieee_set_halting_mode(ieee_overflow, .false.)
- end if
- res = huge(res)
- res = res * res
- if (ieee_support_halting(ieee_overflow)) then
- call ieee_set_halting_mode(ieee_overflow, flag)
- end if
- case default ! IEEE_OTHER_VALUE, should not happen
- res = 0
- end select
+
+ interface
+ pure real(kind=16) function _gfortrani_ieee_value_helper_16(x)
+ use ISO_C_BINDING, only: C_INT
+ integer(kind=C_INT), value :: x
+ end function
+ end interface
+
+ res = _gfortrani_ieee_value_helper_16(CLASS%hidden)
end function
#endif
diff --git a/libgfortran/ieee/ieee_helper.c b/libgfortran/ieee/ieee_helper.c
index 7a103df58f04..794ccec40ee4 100644
--- a/libgfortran/ieee/ieee_helper.c
+++ b/libgfortran/ieee/ieee_helper.c
@@ -116,6 +116,80 @@ CLASSMACRO(16)
#endif
+extern GFC_REAL_4 ieee_value_helper_4 (int);
+internal_proto(ieee_value_helper_4);
+
+extern GFC_REAL_8 ieee_value_helper_8 (int);
+internal_proto(ieee_value_helper_8);
+
+#ifdef HAVE_GFC_REAL_10
+extern GFC_REAL_10 ieee_value_helper_10 (int);
+internal_proto(ieee_value_helper_10);
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+extern GFC_REAL_16 ieee_value_helper_16 (int);
+internal_proto(ieee_value_helper_16);
+#endif
+
+
+#define VALUEMACRO(TYPE, SUFFIX) \
+ GFC_REAL_ ## TYPE ieee_value_helper_ ## TYPE (int type) \
+ { \
+ switch (type) \
+ { \
+ case IEEE_SIGNALING_NAN: \
+ return __builtin_nans ## SUFFIX (""); \
+ \
+ case IEEE_QUIET_NAN: \
+ return __builtin_nan ## SUFFIX (""); \
+ \
+ case IEEE_NEGATIVE_INF: \
+ return - __builtin_inf ## SUFFIX (); \
+ \
+ case IEEE_NEGATIVE_NORMAL: \
+ return -42; \
+ \
+ case IEEE_NEGATIVE_DENORMAL: \
+ return -(GFC_REAL_ ## TYPE ## _TINY) / 2; \
+ \
+ case IEEE_NEGATIVE_ZERO: \
+ return -(GFC_REAL_ ## TYPE) 0; \
+ \
+ case IEEE_POSITIVE_ZERO: \
+ return 0; \
+ \
+ case IEEE_POSITIVE_DENORMAL: \
+ return (GFC_REAL_ ## TYPE ## _TINY) / 2; \
+ \
+ case IEEE_POSITIVE_NORMAL: \
+ return 42; \
+ \
+ case IEEE_POSITIVE_INF: \
+ return __builtin_inf ## SUFFIX (); \
+ \
+ default: \
+ return 0; \
+ } \
+ }
+
+
+VALUEMACRO(4, f)
+VALUEMACRO(8, )
+
+#ifdef HAVE_GFC_REAL_10
+VALUEMACRO(10, l)
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+# ifdef GFC_REAL_16_IS_FLOAT128
+VALUEMACRO(16, f128)
+# else
+VALUEMACRO(16, l)
+# endif
+#endif
+
+
#define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT)
diff --git a/libgfortran/mk-kinds-h.sh b/libgfortran/mk-kinds-h.sh
index 572878ce8912..fb4232eb9544 100755
--- a/libgfortran/mk-kinds-h.sh
+++ b/libgfortran/mk-kinds-h.sh
@@ -87,6 +87,12 @@ for k in $possible_real_kinds; do
| sed 's/ *TRANSFER *//' | sed 's/_.*//'`
rm -f tmq$$.*
+ # Check for the value of TINY
+ echo "print *, tiny(0._$k) ; end" > tmq$$.f90
+ tiny=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \
+ | sed 's/ *TRANSFER *//' | sed 's/_.*//'`
+ rm -f tmq$$.*
+
# Check for the value of DIGITS
echo "print *, digits(0._$k) ; end" > tmq$$.f90
digits=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \
@@ -105,6 +111,7 @@ for k in $possible_real_kinds; do
echo "#define HAVE_GFC_REAL_${k}"
echo "#define HAVE_GFC_COMPLEX_${k}"
echo "#define GFC_REAL_${k}_HUGE ${huge}${suffix}"
+ echo "#define GFC_REAL_${k}_TINY ${tiny}${suffix}"
echo "#define GFC_REAL_${k}_LITERAL_SUFFIX ${suffix}"
if [ "x$suffix" = "x" ]; then
echo "#define GFC_REAL_${k}_LITERAL(X) (X)"
--
GitLab