OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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.
This commit is contained in:
Francois-Xavier Coudert 2022-01-10 17:04:34 +01:00 committed by Francois-Xavier Coudert
parent bca1c431af
commit 90045c5df5
6 changed files with 199 additions and 248 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/testsuite/gfortran.dg/ieee/ieee_10.f90
View File

@ -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

70
gcc/testsuite/gfortran.dg/ieee/signaling_2.f90 Normal file
View File

@ -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

8
gcc/testsuite/gfortran.dg/ieee/signaling_2_c.c Normal file
View File

@ -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; }

276
libgfortran/ieee/ieee_arithmetic.F90
View File

@ -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

74
libgfortran/ieee/ieee_helper.c
View File

@ -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)

7
libgfortran/mk-kinds-h.sh
View File

@ -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)"