Skip to content
Snippets Groups Projects
Commit 90045c5d authored by Francois-Xavier Coudert's avatar Francois-Xavier Coudert Committed by Francois-Xavier Coudert
Browse files

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.
parent bca1c431
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
gcc/testsuite/gfortran.dg/ieee/ieee_10.f90
+ 8
− 4
View file @ 90045c5d
...@@ -12,8 +12,10 @@ program foo ...@@ -12,8 +12,10 @@ program foo
real x real x
real(8) y real(8) y
x = ieee_value(x, ieee_signaling_nan) ! At this point it is unclear what the behavior should be
if (.not. ieee_is_nan(x)) stop 1 ! 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) x = ieee_value(x, ieee_quiet_nan)
if (.not. ieee_is_nan(x)) stop 2 if (.not. ieee_is_nan(x)) stop 2
...@@ -22,8 +24,10 @@ program foo ...@@ -22,8 +24,10 @@ program foo
x = ieee_value(x, ieee_negative_inf) x = ieee_value(x, ieee_negative_inf)
if (ieee_is_finite(x)) stop 4 if (ieee_is_finite(x)) stop 4
y = ieee_value(y, ieee_signaling_nan) ! At this point it is unclear what the behavior should be
if (.not. ieee_is_nan(y)) stop 5 ! 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) y = ieee_value(y, ieee_quiet_nan)
if (.not. ieee_is_nan(y)) stop 6 if (.not. ieee_is_nan(y)) stop 6
......
gcc/testsuite/gfortran.dg/ieee/signaling_2.f90 0 → 100644
+ 70
− 0
View file @ 90045c5d
! { 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
gcc/testsuite/gfortran.dg/ieee/signaling_2_c.c 0 → 100644
+ 8
− 0
View file @ 90045c5d
#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; }
libgfortran/ieee/ieee_arithmetic.F90
+ 36
− 248
View file @ 90045c5d
...@@ -915,275 +915,63 @@ contains ...@@ -915,275 +915,63 @@ contains
! IEEE_VALUE ! IEEE_VALUE
elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res) elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res)
real(kind=4), intent(in) :: X real(kind=4), intent(in) :: X
type(IEEE_CLASS_TYPE), intent(in) :: CLASS type(IEEE_CLASS_TYPE), intent(in) :: CLASS
logical flag
interface
select case (CLASS%hidden) pure real(kind=4) function _gfortrani_ieee_value_helper_4(x)
case (1) ! IEEE_SIGNALING_NAN use ISO_C_BINDING, only: C_INT
if (ieee_support_halting(ieee_invalid)) then integer(kind=C_INT), value :: x
call ieee_get_halting_mode(ieee_invalid, flag) end function
call ieee_set_halting_mode(ieee_invalid, .false.) end interface
end if
res = -1 res = _gfortrani_ieee_value_helper_4(CLASS%hidden)
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
end function end function
elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res) elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res)
real(kind=8), intent(in) :: X real(kind=8), intent(in) :: X
type(IEEE_CLASS_TYPE), intent(in) :: CLASS type(IEEE_CLASS_TYPE), intent(in) :: CLASS
logical flag
interface
select case (CLASS%hidden) pure real(kind=8) function _gfortrani_ieee_value_helper_8(x)
case (1) ! IEEE_SIGNALING_NAN use ISO_C_BINDING, only: C_INT
if (ieee_support_halting(ieee_invalid)) then integer(kind=C_INT), value :: x
call ieee_get_halting_mode(ieee_invalid, flag) end function
call ieee_set_halting_mode(ieee_invalid, .false.) end interface
end if
res = -1 res = _gfortrani_ieee_value_helper_8(CLASS%hidden)
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
end function end function
#ifdef HAVE_GFC_REAL_10 #ifdef HAVE_GFC_REAL_10
elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res) elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res)
real(kind=10), intent(in) :: X real(kind=10), intent(in) :: X
type(IEEE_CLASS_TYPE), intent(in) :: CLASS type(IEEE_CLASS_TYPE), intent(in) :: CLASS
logical flag
interface
select case (CLASS%hidden) pure real(kind=10) function _gfortrani_ieee_value_helper_10(x)
case (1) ! IEEE_SIGNALING_NAN use ISO_C_BINDING, only: C_INT
if (ieee_support_halting(ieee_invalid)) then integer(kind=C_INT), value :: x
call ieee_get_halting_mode(ieee_invalid, flag) end function
call ieee_set_halting_mode(ieee_invalid, .false.) end interface
end if
res = -1 res = _gfortrani_ieee_value_helper_10(CLASS%hidden)
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
end function end function
#endif #endif
#ifdef HAVE_GFC_REAL_16 #ifdef HAVE_GFC_REAL_16
elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res) elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res)
real(kind=16), intent(in) :: X real(kind=16), intent(in) :: X
type(IEEE_CLASS_TYPE), intent(in) :: CLASS type(IEEE_CLASS_TYPE), intent(in) :: CLASS
logical flag
interface
select case (CLASS%hidden) pure real(kind=16) function _gfortrani_ieee_value_helper_16(x)
case (1) ! IEEE_SIGNALING_NAN use ISO_C_BINDING, only: C_INT
if (ieee_support_halting(ieee_invalid)) then integer(kind=C_INT), value :: x
call ieee_get_halting_mode(ieee_invalid, flag) end function
call ieee_set_halting_mode(ieee_invalid, .false.) end interface
end if
res = -1 res = _gfortrani_ieee_value_helper_16(CLASS%hidden)
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
end function end function
#endif #endif
......
libgfortran/ieee/ieee_helper.c
+ 74
− 0
View file @ 90045c5d
...@@ -116,6 +116,80 @@ CLASSMACRO(16) ...@@ -116,6 +116,80 @@ CLASSMACRO(16)
#endif #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 | \ #define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \ GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT) GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT)
......
libgfortran/mk-kinds-h.sh
+ 7
− 0
View file @ 90045c5d
...@@ -87,6 +87,12 @@ for k in $possible_real_kinds; do ...@@ -87,6 +87,12 @@ for k in $possible_real_kinds; do
| sed 's/ *TRANSFER *//' | sed 's/_.*//'` | sed 's/ *TRANSFER *//' | sed 's/_.*//'`
rm -f tmq$$.* 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 # Check for the value of DIGITS
echo "print *, digits(0._$k) ; end" > tmq$$.f90 echo "print *, digits(0._$k) ; end" > tmq$$.f90
digits=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \ digits=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \
...@@ -105,6 +111,7 @@ for k in $possible_real_kinds; do ...@@ -105,6 +111,7 @@ for k in $possible_real_kinds; do
echo "#define HAVE_GFC_REAL_${k}" echo "#define HAVE_GFC_REAL_${k}"
echo "#define HAVE_GFC_COMPLEX_${k}" echo "#define HAVE_GFC_COMPLEX_${k}"
echo "#define GFC_REAL_${k}_HUGE ${huge}${suffix}" echo "#define GFC_REAL_${k}_HUGE ${huge}${suffix}"
echo "#define GFC_REAL_${k}_TINY ${tiny}${suffix}"
echo "#define GFC_REAL_${k}_LITERAL_SUFFIX ${suffix}" echo "#define GFC_REAL_${k}_LITERAL_SUFFIX ${suffix}"
if [ "x$suffix" = "x" ]; then if [ "x$suffix" = "x" ]; then
echo "#define GFC_REAL_${k}_LITERAL(X) (X)" echo "#define GFC_REAL_${k}_LITERAL(X) (X)"
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment