* [PATCH] Fortran: make IEEE_VALUE produce signaling NaNs
@ 2022-01-10 17:32 FX
2022-01-16 13:03 ` Mikael Morin
0 siblings, 1 reply; 4+ messages in thread
From: FX @ 2022-01-10 17:32 UTC (permalink / raw)
To: fortran; +Cc: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 1187 bytes --]
Hi,
Second part of a three-patch series to fix PR 82207 (https://gcc.gnu.org/bugzilla/show_bug.cgi?id=82207), making gfortran handle signaling NaNs. This part fixes the library code implementing IEEE_VALUE. To do so, I switched that part of library code from Fortran to C, because in C we have access to all GCC built-ins related to NaNs/infinities/etc, which is super useful for generating the right bit patterns (instead of using roundabout ways, like the previous Fortran implementation, for which I am guilty).
I needed to add to kinds.h the value of TINY for each floating-point (which is used to produce denormals, by halving TINY).
The patch comes with a testcase, which is still conditional on issignaling support at this stage (and therefore will run on glibc targets only).
I had to amend the gfortran.dg/ieee/ieee_10.f90 testcase, which produces signaling NaNs while -ffpe-trap=invalid is set. It passed before, but only by accident, because we were not actually generating signaling NaNs. I’m not sure what is the expected behaviour, but the patch does not affect the real behaviour.
Bootstrapped and regtested on x86_64-pc-gnu-linux. OK to commit?
FX
[-- Attachment #2: 0001-Fortran-Allow-IEEE_CLASS-to-identify-signaling-NaNs.patch --]
[-- Type: application/octet-stream, Size: 8566 bytes --]
From b341ad50e2d228de60e86dd6ffbd09b8733ef468 Mon Sep 17 00:00:00 2001
From: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Date: Sun, 2 Jan 2022 11:36:23 +0100
Subject: [PATCH] Fortran: Allow IEEE_CLASS to identify signaling NaNs
We use the issignaling macro, present in some libc's (notably glibc),
when it is available. Compile all IEEE-related files in the library
(both C and Fortran sources) with -fsignaling-nans to ensure maximum
compatibility.
libgfortran/ChangeLog:
PR fortran/82207
* Makefile.am: Pass -fsignaling-nans for IEEE files.
* Makefile.in: Regenerate.
* ieee/ieee_helper.c: Use issignaling macro to recognized
signaling NaNs.
gcc/testsuite/ChangeLog:
PR fortran/82207
* gfortran.dg/ieee/signaling_1.f90: New test.
* gfortran.dg/ieee/signaling_1_c.c: New file.
---
.../gfortran.dg/ieee/signaling_1.f90 | 89 +++++++++++++++++++
.../gfortran.dg/ieee/signaling_1_c.c | 14 +++
libgfortran/Makefile.am | 8 +-
libgfortran/Makefile.in | 6 +-
libgfortran/ieee/ieee_helper.c | 15 +++-
5 files changed, 128 insertions(+), 4 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/ieee/signaling_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/ieee/signaling_1_c.c
diff --git a/gcc/testsuite/gfortran.dg/ieee/signaling_1.f90 b/gcc/testsuite/gfortran.dg/ieee/signaling_1.f90
new file mode 100644
index 00000000000..a1403e6ce16
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/signaling_1.f90
@@ -0,0 +1,89 @@
+! { dg-do run }
+! { dg-require-effective-target issignaling } */
+! { dg-additional-sources signaling_1_c.c }
+! { dg-options "-fsignaling-nans" }
+!
+program test
+ use, intrinsic :: iso_c_binding
+ use, intrinsic :: ieee_arithmetic
+ implicit none
+
+ interface
+ real(kind=c_float) function create_nansf () bind(c)
+ import :: c_float
+ end function
+
+ real(kind=c_double) function create_nans () bind(c)
+ import :: c_double
+ end function
+
+ real(kind=c_long_double) function create_nansl () bind(c)
+ import :: c_long_double
+ 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 = create_nansf()
+ if (ieee_class(x) /= ieee_signaling_nan) stop 100
+ if (.not. ieee_is_nan(x)) stop 101
+ if (ieee_is_negative(x)) stop 102
+ if (ieee_is_finite(x)) stop 103
+ if (ieee_is_normal(x)) stop 104
+ if (.not. ieee_unordered(x, x)) stop 105
+ if (.not. ieee_unordered(x, 1._c_float)) stop 106
+
+ x = ieee_value(y, ieee_quiet_nan)
+ if (ieee_class(x) /= ieee_quiet_nan) stop 107
+ if (.not. ieee_is_nan(x)) stop 108
+ if (ieee_is_negative(x)) stop 109
+ if (ieee_is_finite(x)) stop 110
+ if (ieee_is_normal(x)) stop 111
+ if (.not. ieee_unordered(x, x)) stop 112
+ if (.not. ieee_unordered(x, 1._c_double)) stop 113
+ end if
+
+ if (ieee_support_nan(y)) then
+ y = create_nans()
+ if (ieee_class(y) /= ieee_signaling_nan) stop 200
+ if (.not. ieee_is_nan(y)) stop 201
+ if (ieee_is_negative(y)) stop 202
+ if (ieee_is_finite(y)) stop 203
+ if (ieee_is_normal(y)) stop 204
+ if (.not. ieee_unordered(y, x)) stop 205
+ if (.not. ieee_unordered(y, 1._c_double)) stop 206
+
+ y = ieee_value(y, ieee_quiet_nan)
+ if (ieee_class(y) /= ieee_quiet_nan) stop 207
+ if (.not. ieee_is_nan(y)) stop 208
+ if (ieee_is_negative(y)) stop 209
+ if (ieee_is_finite(y)) stop 210
+ if (ieee_is_normal(y)) stop 211
+ if (.not. ieee_unordered(y, y)) stop 212
+ if (.not. ieee_unordered(y, 1._c_double)) stop 213
+ end if
+
+ if (ieee_support_nan(z)) then
+ z = create_nansl()
+ if (ieee_class(z) /= ieee_signaling_nan) stop 300
+ if (.not. ieee_is_nan(z)) stop 301
+ if (ieee_is_negative(z)) stop 302
+ if (ieee_is_finite(z)) stop 303
+ if (ieee_is_normal(z)) stop 304
+ if (.not. ieee_unordered(z, z)) stop 305
+ if (.not. ieee_unordered(z, 1._c_long_double)) stop 306
+
+ z = ieee_value(y, ieee_quiet_nan)
+ if (ieee_class(z) /= ieee_quiet_nan) stop 307
+ if (.not. ieee_is_nan(z)) stop 308
+ if (ieee_is_negative(z)) stop 309
+ if (ieee_is_finite(z)) stop 310
+ if (ieee_is_normal(z)) stop 311
+ if (.not. ieee_unordered(z, z)) stop 312
+ if (.not. ieee_unordered(z, 1._c_double)) stop 313
+ end if
+
+end program test
diff --git a/gcc/testsuite/gfortran.dg/ieee/signaling_1_c.c b/gcc/testsuite/gfortran.dg/ieee/signaling_1_c.c
new file mode 100644
index 00000000000..ab19bb7eae7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/signaling_1_c.c
@@ -0,0 +1,14 @@
+float create_nansf (void)
+{
+ return __builtin_nansf("");
+}
+
+double create_nans (void)
+{
+ return __builtin_nans("");
+}
+
+long double create_nansl (void)
+{
+ return __builtin_nansl("");
+}
diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am
index 008f2e7549c..b7ef912a440 100644
--- a/libgfortran/Makefile.am
+++ b/libgfortran/Makefile.am
@@ -185,6 +185,8 @@ endif
if IEEE_SUPPORT
+gfor_ieee_helper_src=ieee/ieee_helper.c
+
gfor_helper_src+=ieee/ieee_helper.c
gfor_ieee_src= \
@@ -991,9 +993,13 @@ selected_real_kind.lo selected_int_kind.lo: AM_FCFLAGS += -fallow-leading-unders
if IEEE_SUPPORT
# Add flags for IEEE modules
-$(patsubst %.F90,%.lo,$(notdir $(gfor_ieee_src))): AM_FCFLAGS += -Wno-unused-dummy-argument -Wno-c-binding-type -ffree-line-length-0 -fallow-leading-underscore
+$(patsubst %.F90,%.lo,$(notdir $(gfor_ieee_src))): AM_FCFLAGS += -Wno-unused-dummy-argument -Wno-c-binding-type -ffree-line-length-0 -fallow-leading-underscore -fsignaling-nans
+
+# Add flags for IEEE helper code
+$(patsubst %.c,%.lo,$(notdir $(gfor_ieee_helper_src))): AM_CFLAGS += -fsignaling-nans
endif
+
# Dependencies between IEEE_ARITHMETIC and IEEE_EXCEPTIONS
ieee_arithmetic.lo: ieee/ieee_arithmetic.F90 ieee_exceptions.lo
$(LTPPFCCOMPILE) -c -o $@ $<
diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in
index 5dac04e171e..3684b2aaa75 100644
--- a/libgfortran/Makefile.in
+++ b/libgfortran/Makefile.in
@@ -779,6 +779,7 @@ gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
intrinsics/selected_real_kind.f90 intrinsics/trigd.c \
intrinsics/unpack_generic.c runtime/in_pack_generic.c \
runtime/in_unpack_generic.c $(am__append_3) $(am__append_4)
+@IEEE_SUPPORT_TRUE@gfor_ieee_helper_src = ieee/ieee_helper.c
@IEEE_SUPPORT_FALSE@gfor_ieee_src =
@IEEE_SUPPORT_TRUE@gfor_ieee_src = \
@IEEE_SUPPORT_TRUE@ieee/ieee_arithmetic.F90 \
@@ -6999,7 +7000,10 @@ $(patsubst %.F90,%.lo,$(patsubst %.f90,%.lo,$(notdir $(gfor_specific_src)))): AM
selected_real_kind.lo selected_int_kind.lo: AM_FCFLAGS += -fallow-leading-underscore
# Add flags for IEEE modules
-@IEEE_SUPPORT_TRUE@$(patsubst %.F90,%.lo,$(notdir $(gfor_ieee_src))): AM_FCFLAGS += -Wno-unused-dummy-argument -Wno-c-binding-type -ffree-line-length-0 -fallow-leading-underscore
+@IEEE_SUPPORT_TRUE@$(patsubst %.F90,%.lo,$(notdir $(gfor_ieee_src))): AM_FCFLAGS += -Wno-unused-dummy-argument -Wno-c-binding-type -ffree-line-length-0 -fallow-leading-underscore -fsignaling-nans
+
+# Add flags for IEEE helper code
+@IEEE_SUPPORT_TRUE@$(patsubst %.c,%.lo,$(notdir $(gfor_ieee_helper_src))): AM_CFLAGS += -fsignaling-nans
# Dependencies between IEEE_ARITHMETIC and IEEE_EXCEPTIONS
ieee_arithmetic.lo: ieee/ieee_arithmetic.F90 ieee_exceptions.lo
diff --git a/libgfortran/ieee/ieee_helper.c b/libgfortran/ieee/ieee_helper.c
index fd2ba69488b..5a824a180e2 100644
--- a/libgfortran/ieee/ieee_helper.c
+++ b/libgfortran/ieee/ieee_helper.c
@@ -25,6 +25,15 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include "libgfortran.h"
+
+/* Check support for issignaling macro.
+ TODO: In the future, provide fallback implementations for IEEE types,
+ because many libc's do not have issignaling yet. */
+#ifndef issignaling
+# define issignaling(X) 0
+#endif
+
+
/* Prototypes. */
extern int ieee_class_helper_4 (GFC_REAL_4 *);
@@ -86,8 +95,10 @@ enum {
\
if (res == IEEE_QUIET_NAN) \
{ \
- /* TODO: Handle signaling NaNs */ \
- return res; \
+ if (issignaling (*value)) \
+ return IEEE_SIGNALING_NAN; \
+ else \
+ return IEEE_QUIET_NAN; \
} \
\
return res; \
--
2.25.1
[-- Attachment #3: Type: text/plain, Size: 2 bytes --]
[-- Attachment #4: 0001-Fortran-allow-IEEE_VALUE-to-correctly-return-signali.patch --]
[-- Type: application/octet-stream, Size: 20795 bytes --]
From 6b2774858263dd77edb7047324eb83dd18b7b76c 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_1.f90: Adjust options.
* 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_1.f90 | 4 +-
.../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 +
7 files changed, 206 insertions(+), 253 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 c3ffffcb24d..a596504ae1e 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_1.f90 b/gcc/testsuite/gfortran.dg/ieee/signaling_1.f90
index a1403e6ce16..3d846fc1038 100644
--- a/gcc/testsuite/gfortran.dg/ieee/signaling_1.f90
+++ b/gcc/testsuite/gfortran.dg/ieee/signaling_1.f90
@@ -1,7 +1,9 @@
! { dg-do run }
! { dg-require-effective-target issignaling } */
! { dg-additional-sources signaling_1_c.c }
-! { dg-options "-fsignaling-nans" }
+! { dg-additional-options "-w" }
+! the -w option is needed to make f951 not report a warning for
+! the -fintrinsic-modules-path option passed by ieee.exp
!
program test
use, intrinsic :: iso_c_binding
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 00000000000..df2016bba9b
--- /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 f951 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 00000000000..ea7fc0467bd
--- /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 7e34660eb50..c8ef3e2faeb 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 7a103df58f0..794ccec40ee 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 572878ce891..fb4232eb954 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)"
--
2.25.1
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [PATCH] Fortran: make IEEE_VALUE produce signaling NaNs
2022-01-10 17:32 [PATCH] Fortran: make IEEE_VALUE produce signaling NaNs FX
@ 2022-01-16 13:03 ` Mikael Morin
2022-01-16 22:02 ` FX
0 siblings, 1 reply; 4+ messages in thread
From: Mikael Morin @ 2022-01-16 13:03 UTC (permalink / raw)
To: FX, fortran; +Cc: gcc-patches
Hello,
Le 10/01/2022 à 18:32, FX via Fortran a écrit :
> Hi,
>
> Second part of a three-patch series to fix PR 82207 (https://gcc.gnu.org/bugzilla/show_bug.cgi?id=82207), making gfortran handle signaling NaNs. This part fixes the library code implementing IEEE_VALUE. To do so, I switched that part of library code from Fortran to C, because in C we have access to all GCC built-ins related to NaNs/infinities/etc, which is super useful for generating the right bit patterns (instead of using roundabout ways, like the previous Fortran implementation, for which I am guilty).
>
> I needed to add to kinds.h the value of TINY for each floating-point (which is used to produce denormals, by halving TINY).
>
> The patch comes with a testcase, which is still conditional on issignaling support at this stage (and therefore will run on glibc targets only).
>
> I had to amend the gfortran.dg/ieee/ieee_10.f90 testcase, which produces signaling NaNs while -ffpe-trap=invalid is set. It passed before, but only by accident, because we were not actually generating signaling NaNs. I’m not sure what is the expected behaviour, but the patch does not affect the real behaviour.
>
> Bootstrapped and regtested on x86_64-pc-gnu-linux. OK to commit?
>
This looks good to me. Thanks.
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [PATCH] Fortran: make IEEE_VALUE produce signaling NaNs
2022-01-16 13:03 ` Mikael Morin
@ 2022-01-16 22:02 ` FX
2022-01-16 23:04 ` FX
0 siblings, 1 reply; 4+ messages in thread
From: FX @ 2022-01-16 22:02 UTC (permalink / raw)
To: Mikael Morin; +Cc: fortran, gcc-patches
Thanks Mikael,
> This looks good to me. Thanks.
Thanks. Pushed: https://gcc.gnu.org/git/?p=gcc.git;a=commit;h=90045c5df5b3c8853e7740fb72a11aead1c489bb
FX
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [PATCH] Fortran: make IEEE_VALUE produce signaling NaNs
2022-01-16 22:02 ` FX
@ 2022-01-16 23:04 ` FX
0 siblings, 0 replies; 4+ messages in thread
From: FX @ 2022-01-16 23:04 UTC (permalink / raw)
To: François-Xavier Coudert; +Cc: Mikael Morin, fortran, gcc-patches
Hi Mikael, team,
> Thanks. Pushed: https://gcc.gnu.org/git/?p=gcc.git;a=commit;h=90045c5df5b3c8853e7740fb72a11aead1c489bb
Pushed a further commit to XFAIL the testcases on x87:
https://gcc.gnu.org/git/?p=gcc.git;a=commit;h=86e3b476d5defaa79c94d40b76cbeec21cd02e5f
There the ABI does not allow us to meaningfully pass signaling NaNs in float and double types, sadly.
FX
^ permalink raw reply [flat|nested] 4+ messages in thread
end of thread, other threads:[~2022-01-16 23:04 UTC | newest]
Thread overview: 4+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-01-10 17:32 [PATCH] Fortran: make IEEE_VALUE produce signaling NaNs FX
2022-01-16 13:03 ` Mikael Morin
2022-01-16 22:02 ` FX
2022-01-16 23:04 ` FX
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).