summaryrefslogtreecommitdiffstats
path: root/libgfortran
diff options
context:
space:
mode:
authorFrancois-Xavier Coudert <fxcoudert@gcc.gnu.org>2022-01-10 17:04:34 +0100
committerFrancois-Xavier Coudert <fxcoudert@gmail.com>2022-01-16 22:57:45 +0100
commit90045c5df5b3c8853e7740fb72a11aead1c489bb (patch)
tree5a59d689ecb0d21bb9aa1cb3e3a1d2e479a5f07b /libgfortran
parentlibstdc++: Ignore deprecated warnings [PR104037] (diff)
downloadgcc-90045c5df5b3c8853e7740fb72a11aead1c489bb.tar.gz
gcc-90045c5df5b3c8853e7740fb72a11aead1c489bb.tar.bz2
gcc-90045c5df5b3c8853e7740fb72a11aead1c489bb.tar.xz
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.
Diffstat (limited to 'libgfortran')
-rw-r--r--libgfortran/ieee/ieee_arithmetic.F90284
-rw-r--r--libgfortran/ieee/ieee_helper.c74
-rwxr-xr-xlibgfortran/mk-kinds-h.sh7
3 files changed, 117 insertions, 248 deletions
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
915 ! IEEE_VALUE 915 ! IEEE_VALUE
916 916
917 elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res) 917 elemental real(kind=4) function IEEE_VALUE_4(X, CLASS) result(res)
918
919 real(kind=4), intent(in) :: X 918 real(kind=4), intent(in) :: X
920 type(IEEE_CLASS_TYPE), intent(in) :: CLASS 919 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
921 logical flag 920
922 921 interface
923 select case (CLASS%hidden) 922 pure real(kind=4) function _gfortrani_ieee_value_helper_4(x)
924 case (1) ! IEEE_SIGNALING_NAN 923 use ISO_C_BINDING, only: C_INT
925 if (ieee_support_halting(ieee_invalid)) then 924 integer(kind=C_INT), value :: x
926 call ieee_get_halting_mode(ieee_invalid, flag) 925 end function
927 call ieee_set_halting_mode(ieee_invalid, .false.) 926 end interface
928 end if 927
929 res = -1 928 res = _gfortrani_ieee_value_helper_4(CLASS%hidden)
930 res = sqrt(res)
931 if (ieee_support_halting(ieee_invalid)) then
932 call ieee_set_halting_mode(ieee_invalid, flag)
933 end if
934 case (2) ! IEEE_QUIET_NAN
935 if (ieee_support_halting(ieee_invalid)) then
936 call ieee_get_halting_mode(ieee_invalid, flag)
937 call ieee_set_halting_mode(ieee_invalid, .false.)
938 end if
939 res = -1
940 res = sqrt(res)
941 if (ieee_support_halting(ieee_invalid)) then
942 call ieee_set_halting_mode(ieee_invalid, flag)
943 end if
944 case (3) ! IEEE_NEGATIVE_INF
945 if (ieee_support_halting(ieee_overflow)) then
946 call ieee_get_halting_mode(ieee_overflow, flag)
947 call ieee_set_halting_mode(ieee_overflow, .false.)
948 end if
949 res = huge(res)
950 res = (-res) * res
951 if (ieee_support_halting(ieee_overflow)) then
952 call ieee_set_halting_mode(ieee_overflow, flag)
953 end if
954 case (4) ! IEEE_NEGATIVE_NORMAL
955 res = -42
956 case (5) ! IEEE_NEGATIVE_DENORMAL
957 res = -tiny(res)
958 res = res / 2
959 case (6) ! IEEE_NEGATIVE_ZERO
960 res = 0
961 res = -res
962 case (7) ! IEEE_POSITIVE_ZERO
963 res = 0
964 case (8) ! IEEE_POSITIVE_DENORMAL
965 res = tiny(res)
966 res = res / 2
967 case (9) ! IEEE_POSITIVE_NORMAL
968 res = 42
969 case (10) ! IEEE_POSITIVE_INF
970 if (ieee_support_halting(ieee_overflow)) then
971 call ieee_get_halting_mode(ieee_overflow, flag)
972 call ieee_set_halting_mode(ieee_overflow, .false.)
973 end if
974 res = huge(res)
975 res = res * res
976 if (ieee_support_halting(ieee_overflow)) then
977 call ieee_set_halting_mode(ieee_overflow, flag)
978 end if
979 case default ! IEEE_OTHER_VALUE, should not happen
980 res = 0
981 end select
982 end function 929 end function
983 930
984 elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res) 931 elemental real(kind=8) function IEEE_VALUE_8(X, CLASS) result(res)
985
986 real(kind=8), intent(in) :: X 932 real(kind=8), intent(in) :: X
987 type(IEEE_CLASS_TYPE), intent(in) :: CLASS 933 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
988 logical flag 934
989 935 interface
990 select case (CLASS%hidden) 936 pure real(kind=8) function _gfortrani_ieee_value_helper_8(x)
991 case (1) ! IEEE_SIGNALING_NAN 937 use ISO_C_BINDING, only: C_INT
992 if (ieee_support_halting(ieee_invalid)) then 938 integer(kind=C_INT), value :: x
993 call ieee_get_halting_mode(ieee_invalid, flag) 939 end function
994 call ieee_set_halting_mode(ieee_invalid, .false.) 940 end interface
995 end if 941
996 res = -1 942 res = _gfortrani_ieee_value_helper_8(CLASS%hidden)
997 res = sqrt(res)
998 if (ieee_support_halting(ieee_invalid)) then
999 call ieee_set_halting_mode(ieee_invalid, flag)
1000 end if
1001 case (2) ! IEEE_QUIET_NAN
1002 if (ieee_support_halting(ieee_invalid)) then
1003 call ieee_get_halting_mode(ieee_invalid, flag)
1004 call ieee_set_halting_mode(ieee_invalid, .false.)
1005 end if
1006 res = -1
1007 res = sqrt(res)
1008 if (ieee_support_halting(ieee_invalid)) then
1009 call ieee_set_halting_mode(ieee_invalid, flag)
1010 end if
1011 case (3) ! IEEE_NEGATIVE_INF
1012 if (ieee_support_halting(ieee_overflow)) then
1013 call ieee_get_halting_mode(ieee_overflow, flag)
1014 call ieee_set_halting_mode(ieee_overflow, .false.)
1015 end if
1016 res = huge(res)
1017 res = (-res) * res
1018 if (ieee_support_halting(ieee_overflow)) then
1019 call ieee_set_halting_mode(ieee_overflow, flag)
1020 end if
1021 case (4) ! IEEE_NEGATIVE_NORMAL
1022 res = -42
1023 case (5) ! IEEE_NEGATIVE_DENORMAL
1024 res = -tiny(res)
1025 res = res / 2
1026 case (6) ! IEEE_NEGATIVE_ZERO
1027 res = 0
1028 res = -res
1029 case (7) ! IEEE_POSITIVE_ZERO
1030 res = 0
1031 case (8) ! IEEE_POSITIVE_DENORMAL
1032 res = tiny(res)
1033 res = res / 2
1034 case (9) ! IEEE_POSITIVE_NORMAL
1035 res = 42
1036 case (10) ! IEEE_POSITIVE_INF
1037 if (ieee_support_halting(ieee_overflow)) then
1038 call ieee_get_halting_mode(ieee_overflow, flag)
1039 call ieee_set_halting_mode(ieee_overflow, .false.)
1040 end if
1041 res = huge(res)
1042 res = res * res
1043 if (ieee_support_halting(ieee_overflow)) then
1044 call ieee_set_halting_mode(ieee_overflow, flag)
1045 end if
1046 case default ! IEEE_OTHER_VALUE, should not happen
1047 res = 0
1048 end select
1049 end function 943 end function
1050 944
1051#ifdef HAVE_GFC_REAL_10 945#ifdef HAVE_GFC_REAL_10
1052 elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res) 946 elemental real(kind=10) function IEEE_VALUE_10(X, CLASS) result(res)
1053
1054 real(kind=10), intent(in) :: X 947 real(kind=10), intent(in) :: X
1055 type(IEEE_CLASS_TYPE), intent(in) :: CLASS 948 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
1056 logical flag 949
1057 950 interface
1058 select case (CLASS%hidden) 951 pure real(kind=10) function _gfortrani_ieee_value_helper_10(x)
1059 case (1) ! IEEE_SIGNALING_NAN 952 use ISO_C_BINDING, only: C_INT
1060 if (ieee_support_halting(ieee_invalid)) then 953 integer(kind=C_INT), value :: x
1061 call ieee_get_halting_mode(ieee_invalid, flag) 954 end function
1062 call ieee_set_halting_mode(ieee_invalid, .false.) 955 end interface
1063 end if 956
1064 res = -1 957 res = _gfortrani_ieee_value_helper_10(CLASS%hidden)
1065 res = sqrt(res)
1066 if (ieee_support_halting(ieee_invalid)) then
1067 call ieee_set_halting_mode(ieee_invalid, flag)
1068 end if
1069 case (2) ! IEEE_QUIET_NAN
1070 if (ieee_support_halting(ieee_invalid)) then
1071 call ieee_get_halting_mode(ieee_invalid, flag)
1072 call ieee_set_halting_mode(ieee_invalid, .false.)
1073 end if
1074 res = -1
1075 res = sqrt(res)
1076 if (ieee_support_halting(ieee_invalid)) then
1077 call ieee_set_halting_mode(ieee_invalid, flag)
1078 end if
1079 case (3) ! IEEE_NEGATIVE_INF
1080 if (ieee_support_halting(ieee_overflow)) then
1081 call ieee_get_halting_mode(ieee_overflow, flag)
1082 call ieee_set_halting_mode(ieee_overflow, .false.)
1083 end if
1084 res = huge(res)
1085 res = (-res) * res
1086 if (ieee_support_halting(ieee_overflow)) then
1087 call ieee_set_halting_mode(ieee_overflow, flag)
1088 end if
1089 case (4) ! IEEE_NEGATIVE_NORMAL
1090 res = -42
1091 case (5) ! IEEE_NEGATIVE_DENORMAL
1092 res = -tiny(res)
1093 res = res / 2
1094 case (6) ! IEEE_NEGATIVE_ZERO
1095 res = 0
1096 res = -res
1097 case (7) ! IEEE_POSITIVE_ZERO
1098 res = 0
1099 case (8) ! IEEE_POSITIVE_DENORMAL
1100 res = tiny(res)
1101 res = res / 2
1102 case (9) ! IEEE_POSITIVE_NORMAL
1103 res = 42
1104 case (10) ! IEEE_POSITIVE_INF
1105 if (ieee_support_halting(ieee_overflow)) then
1106 call ieee_get_halting_mode(ieee_overflow, flag)
1107 call ieee_set_halting_mode(ieee_overflow, .false.)
1108 end if
1109 res = huge(res)
1110 res = res * res
1111 if (ieee_support_halting(ieee_overflow)) then
1112 call ieee_set_halting_mode(ieee_overflow, flag)
1113 end if
1114 case default ! IEEE_OTHER_VALUE, should not happen
1115 res = 0
1116 end select
1117 end function 958 end function
1118 959
1119#endif 960#endif
1120 961
1121#ifdef HAVE_GFC_REAL_16 962#ifdef HAVE_GFC_REAL_16
1122 elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res) 963 elemental real(kind=16) function IEEE_VALUE_16(X, CLASS) result(res)
1123
1124 real(kind=16), intent(in) :: X 964 real(kind=16), intent(in) :: X
1125 type(IEEE_CLASS_TYPE), intent(in) :: CLASS 965 type(IEEE_CLASS_TYPE), intent(in) :: CLASS
1126 logical flag 966
1127 967 interface
1128 select case (CLASS%hidden) 968 pure real(kind=16) function _gfortrani_ieee_value_helper_16(x)
1129 case (1) ! IEEE_SIGNALING_NAN 969 use ISO_C_BINDING, only: C_INT
1130 if (ieee_support_halting(ieee_invalid)) then 970 integer(kind=C_INT), value :: x
1131 call ieee_get_halting_mode(ieee_invalid, flag) 971 end function
1132 call ieee_set_halting_mode(ieee_invalid, .false.) 972 end interface
1133 end if 973
1134 res = -1 974 res = _gfortrani_ieee_value_helper_16(CLASS%hidden)
1135 res = sqrt(res)
1136 if (ieee_support_halting(ieee_invalid)) then
1137 call ieee_set_halting_mode(ieee_invalid, flag)
1138 end if
1139 case (2) ! IEEE_QUIET_NAN
1140 if (ieee_support_halting(ieee_invalid)) then
1141 call ieee_get_halting_mode(ieee_invalid, flag)
1142 call ieee_set_halting_mode(ieee_invalid, .false.)
1143 end if
1144 res = -1
1145 res = sqrt(res)
1146 if (ieee_support_halting(ieee_invalid)) then
1147 call ieee_set_halting_mode(ieee_invalid, flag)
1148 end if
1149 case (3) ! IEEE_NEGATIVE_INF
1150 if (ieee_support_halting(ieee_overflow)) then
1151 call ieee_get_halting_mode(ieee_overflow, flag)
1152 call ieee_set_halting_mode(ieee_overflow, .false.)
1153 end if
1154 res = huge(res)
1155 res = (-res) * res
1156 if (ieee_support_halting(ieee_overflow)) then
1157 call ieee_set_halting_mode(ieee_overflow, flag)
1158 end if
1159 case (4) ! IEEE_NEGATIVE_NORMAL
1160 res = -42
1161 case (5) ! IEEE_NEGATIVE_DENORMAL
1162 res = -tiny(res)
1163 res = res / 2
1164 case (6) ! IEEE_NEGATIVE_ZERO
1165 res = 0
1166 res = -res
1167 case (7) ! IEEE_POSITIVE_ZERO
1168 res = 0
1169 case (8) ! IEEE_POSITIVE_DENORMAL
1170 res = tiny(res)
1171 res = res / 2
1172 case (9) ! IEEE_POSITIVE_NORMAL
1173 res = 42
1174 case (10) ! IEEE_POSITIVE_INF
1175 if (ieee_support_halting(ieee_overflow)) then
1176 call ieee_get_halting_mode(ieee_overflow, flag)
1177 call ieee_set_halting_mode(ieee_overflow, .false.)
1178 end if
1179 res = huge(res)
1180 res = res * res
1181 if (ieee_support_halting(ieee_overflow)) then
1182 call ieee_set_halting_mode(ieee_overflow, flag)
1183 end if
1184 case default ! IEEE_OTHER_VALUE, should not happen
1185 res = 0
1186 end select
1187 end function 975 end function
1188#endif 976#endif
1189 977
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)
116#endif 116#endif
117 117
118 118
119extern GFC_REAL_4 ieee_value_helper_4 (int);
120internal_proto(ieee_value_helper_4);
121
122extern GFC_REAL_8 ieee_value_helper_8 (int);
123internal_proto(ieee_value_helper_8);
124
125#ifdef HAVE_GFC_REAL_10
126extern GFC_REAL_10 ieee_value_helper_10 (int);
127internal_proto(ieee_value_helper_10);
128#endif
129
130#ifdef HAVE_GFC_REAL_16
131extern GFC_REAL_16 ieee_value_helper_16 (int);
132internal_proto(ieee_value_helper_16);
133#endif
134
135
136#define VALUEMACRO(TYPE, SUFFIX) \
137 GFC_REAL_ ## TYPE ieee_value_helper_ ## TYPE (int type) \
138 { \
139 switch (type) \
140 { \
141 case IEEE_SIGNALING_NAN: \
142 return __builtin_nans ## SUFFIX (""); \
143 \
144 case IEEE_QUIET_NAN: \
145 return __builtin_nan ## SUFFIX (""); \
146 \
147 case IEEE_NEGATIVE_INF: \
148 return - __builtin_inf ## SUFFIX (); \
149 \
150 case IEEE_NEGATIVE_NORMAL: \
151 return -42; \
152 \
153 case IEEE_NEGATIVE_DENORMAL: \
154 return -(GFC_REAL_ ## TYPE ## _TINY) / 2; \
155 \
156 case IEEE_NEGATIVE_ZERO: \
157 return -(GFC_REAL_ ## TYPE) 0; \
158 \
159 case IEEE_POSITIVE_ZERO: \
160 return 0; \
161 \
162 case IEEE_POSITIVE_DENORMAL: \
163 return (GFC_REAL_ ## TYPE ## _TINY) / 2; \
164 \
165 case IEEE_POSITIVE_NORMAL: \
166 return 42; \
167 \
168 case IEEE_POSITIVE_INF: \
169 return __builtin_inf ## SUFFIX (); \
170 \
171 default: \
172 return 0; \
173 } \
174 }
175
176
177VALUEMACRO(4, f)
178VALUEMACRO(8, )
179
180#ifdef HAVE_GFC_REAL_10
181VALUEMACRO(10, l)
182#endif
183
184#ifdef HAVE_GFC_REAL_16
185# ifdef GFC_REAL_16_IS_FLOAT128
186VALUEMACRO(16, f128)
187# else
188VALUEMACRO(16, l)
189# endif
190#endif
191
192
119#define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \ 193#define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
120 GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \ 194 GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
121 GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT) 195 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
87 | sed 's/ *TRANSFER *//' | sed 's/_.*//'` 87 | sed 's/ *TRANSFER *//' | sed 's/_.*//'`
88 rm -f tmq$$.* 88 rm -f tmq$$.*
89 89
90 # Check for the value of TINY
91 echo "print *, tiny(0._$k) ; end" > tmq$$.f90
92 tiny=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \
93 | sed 's/ *TRANSFER *//' | sed 's/_.*//'`
94 rm -f tmq$$.*
95
90 # Check for the value of DIGITS 96 # Check for the value of DIGITS
91 echo "print *, digits(0._$k) ; end" > tmq$$.f90 97 echo "print *, digits(0._$k) ; end" > tmq$$.f90
92 digits=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \ 98 digits=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \
@@ -105,6 +111,7 @@ for k in $possible_real_kinds; do
105 echo "#define HAVE_GFC_REAL_${k}" 111 echo "#define HAVE_GFC_REAL_${k}"
106 echo "#define HAVE_GFC_COMPLEX_${k}" 112 echo "#define HAVE_GFC_COMPLEX_${k}"
107 echo "#define GFC_REAL_${k}_HUGE ${huge}${suffix}" 113 echo "#define GFC_REAL_${k}_HUGE ${huge}${suffix}"
114 echo "#define GFC_REAL_${k}_TINY ${tiny}${suffix}"
108 echo "#define GFC_REAL_${k}_LITERAL_SUFFIX ${suffix}" 115 echo "#define GFC_REAL_${k}_LITERAL_SUFFIX ${suffix}"
109 if [ "x$suffix" = "x" ]; then 116 if [ "x$suffix" = "x" ]; then
110 echo "#define GFC_REAL_${k}_LITERAL(X) (X)" 117 echo "#define GFC_REAL_${k}_LITERAL(X) (X)"