1 /* FPU-related code for systems with GNU libc. 2 Copyright (C) 2005-2020 Free Software Foundation, Inc. 3 Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr> 4 5 This file is part of the GNU Fortran runtime library (libgfortran). 6 7 Libgfortran is free software; you can redistribute it and/or 8 modify it under the terms of the GNU General Public 9 License as published by the Free Software Foundation; either 10 version 3 of the License, or (at your option) any later version. 11 12 Libgfortran is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 Under Section 7 of GPL version 3, you are granted additional 18 permissions described in the GCC Runtime Library Exception, version 19 3.1, as published by the Free Software Foundation. 20 21 You should have received a copy of the GNU General Public License and 22 a copy of the GCC Runtime Library Exception along with this program; 23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24 <http://www.gnu.org/licenses/>. */ 25 26 /* FPU-related code for systems with the GNU libc, providing the 27 feenableexcept function in fenv.h to set individual exceptions 28 (there's nothing to do that in C99). */ 29 30 #ifdef HAVE_FENV_H 31 #include <fenv.h> 32 #endif 33 34 35 /* Check we can actually store the FPU state in the allocated size. */ 36 _Static_assert (sizeof(fenv_t) <= (size_t) GFC_FPE_STATE_BUFFER_SIZE, 37 "GFC_FPE_STATE_BUFFER_SIZE is too small"); 38 39 40 void set_fpu_trap_exceptions (int trap, int notrap) 41 { 42 int mode_set = 0, mode_clr = 0; 43 44 #ifdef FE_INVALID 45 if (trap & GFC_FPE_INVALID) 46 mode_set |= FE_INVALID; 47 if (notrap & GFC_FPE_INVALID) 48 mode_clr |= FE_INVALID; 49 #endif 50 51 /* Some glibc targets (like alpha) have FE_DENORMAL, but not many. */ 52 #ifdef FE_DENORMAL 53 if (trap & GFC_FPE_DENORMAL) 54 mode_set |= FE_DENORMAL; 55 if (notrap & GFC_FPE_DENORMAL) 56 mode_clr |= FE_DENORMAL; 57 #endif 58 59 #ifdef FE_DIVBYZERO 60 if (trap & GFC_FPE_ZERO) 61 mode_set |= FE_DIVBYZERO; 62 if (notrap & GFC_FPE_ZERO) 63 mode_clr |= FE_DIVBYZERO; 64 #endif 65 66 #ifdef FE_OVERFLOW 67 if (trap & GFC_FPE_OVERFLOW) 68 mode_set |= FE_OVERFLOW; 69 if (notrap & GFC_FPE_OVERFLOW) 70 mode_clr |= FE_OVERFLOW; 71 #endif 72 73 #ifdef FE_UNDERFLOW 74 if (trap & GFC_FPE_UNDERFLOW) 75 mode_set |= FE_UNDERFLOW; 76 if (notrap & GFC_FPE_UNDERFLOW) 77 mode_clr |= FE_UNDERFLOW; 78 #endif 79 80 #ifdef FE_INEXACT 81 if (trap & GFC_FPE_INEXACT) 82 mode_set |= FE_INEXACT; 83 if (notrap & GFC_FPE_INEXACT) 84 mode_clr |= FE_INEXACT; 85 #endif 86 87 /* Clear stalled exception flags. */ 88 feclearexcept (FE_ALL_EXCEPT); 89 90 feenableexcept (mode_set); 91 fedisableexcept (mode_clr); 92 } 93 94 95 int 96 get_fpu_trap_exceptions (void) 97 { 98 int exceptions = fegetexcept (); 99 int res = 0; 100 101 #ifdef FE_INVALID 102 if (exceptions & FE_INVALID) res |= GFC_FPE_INVALID; 103 #endif 104 105 #ifdef FE_DENORMAL 106 if (exceptions & FE_DENORMAL) res |= GFC_FPE_DENORMAL; 107 #endif 108 109 #ifdef FE_DIVBYZERO 110 if (exceptions & FE_DIVBYZERO) res |= GFC_FPE_ZERO; 111 #endif 112 113 #ifdef FE_OVERFLOW 114 if (exceptions & FE_OVERFLOW) res |= GFC_FPE_OVERFLOW; 115 #endif 116 117 #ifdef FE_UNDERFLOW 118 if (exceptions & FE_UNDERFLOW) res |= GFC_FPE_UNDERFLOW; 119 #endif 120 121 #ifdef FE_INEXACT 122 if (exceptions & FE_INEXACT) res |= GFC_FPE_INEXACT; 123 #endif 124 125 return res; 126 } 127 128 129 int 130 support_fpu_trap (int flag) 131 { 132 return support_fpu_flag (flag); 133 } 134 135 136 void set_fpu (void) 137 { 138 #ifndef FE_INVALID 139 if (options.fpe & GFC_FPE_INVALID) 140 estr_write ("Fortran runtime warning: IEEE 'invalid operation' " 141 "exception not supported.\n"); 142 #endif 143 144 #ifndef FE_DENORMAL 145 if (options.fpe & GFC_FPE_DENORMAL) 146 estr_write ("Fortran runtime warning: Floating point 'denormal operand' " 147 "exception not supported.\n"); 148 #endif 149 150 #ifndef FE_DIVBYZERO 151 if (options.fpe & GFC_FPE_ZERO) 152 estr_write ("Fortran runtime warning: IEEE 'division by zero' " 153 "exception not supported.\n"); 154 #endif 155 156 #ifndef FE_OVERFLOW 157 if (options.fpe & GFC_FPE_OVERFLOW) 158 estr_write ("Fortran runtime warning: IEEE 'overflow' " 159 "exception not supported.\n"); 160 #endif 161 162 #ifndef FE_UNDERFLOW 163 if (options.fpe & GFC_FPE_UNDERFLOW) 164 estr_write ("Fortran runtime warning: IEEE 'underflow' " 165 "exception not supported.\n"); 166 #endif 167 168 #ifndef FE_INEXACT 169 if (options.fpe & GFC_FPE_INEXACT) 170 estr_write ("Fortran runtime warning: IEEE 'inexact' " 171 "exception not supported.\n"); 172 #endif 173 174 set_fpu_trap_exceptions (options.fpe, 0); 175 } 176 177 178 int 179 get_fpu_except_flags (void) 180 { 181 int result, set_excepts; 182 183 result = 0; 184 set_excepts = fetestexcept (FE_ALL_EXCEPT); 185 186 #ifdef FE_INVALID 187 if (set_excepts & FE_INVALID) 188 result |= GFC_FPE_INVALID; 189 #endif 190 191 #ifdef FE_DIVBYZERO 192 if (set_excepts & FE_DIVBYZERO) 193 result |= GFC_FPE_ZERO; 194 #endif 195 196 #ifdef FE_OVERFLOW 197 if (set_excepts & FE_OVERFLOW) 198 result |= GFC_FPE_OVERFLOW; 199 #endif 200 201 #ifdef FE_UNDERFLOW 202 if (set_excepts & FE_UNDERFLOW) 203 result |= GFC_FPE_UNDERFLOW; 204 #endif 205 206 #ifdef FE_DENORMAL 207 if (set_excepts & FE_DENORMAL) 208 result |= GFC_FPE_DENORMAL; 209 #endif 210 211 #ifdef FE_INEXACT 212 if (set_excepts & FE_INEXACT) 213 result |= GFC_FPE_INEXACT; 214 #endif 215 216 return result; 217 } 218 219 220 void 221 set_fpu_except_flags (int set, int clear) 222 { 223 int exc_set = 0, exc_clr = 0; 224 225 #ifdef FE_INVALID 226 if (set & GFC_FPE_INVALID) 227 exc_set |= FE_INVALID; 228 else if (clear & GFC_FPE_INVALID) 229 exc_clr |= FE_INVALID; 230 #endif 231 232 #ifdef FE_DIVBYZERO 233 if (set & GFC_FPE_ZERO) 234 exc_set |= FE_DIVBYZERO; 235 else if (clear & GFC_FPE_ZERO) 236 exc_clr |= FE_DIVBYZERO; 237 #endif 238 239 #ifdef FE_OVERFLOW 240 if (set & GFC_FPE_OVERFLOW) 241 exc_set |= FE_OVERFLOW; 242 else if (clear & GFC_FPE_OVERFLOW) 243 exc_clr |= FE_OVERFLOW; 244 #endif 245 246 #ifdef FE_UNDERFLOW 247 if (set & GFC_FPE_UNDERFLOW) 248 exc_set |= FE_UNDERFLOW; 249 else if (clear & GFC_FPE_UNDERFLOW) 250 exc_clr |= FE_UNDERFLOW; 251 #endif 252 253 #ifdef FE_DENORMAL 254 if (set & GFC_FPE_DENORMAL) 255 exc_set |= FE_DENORMAL; 256 else if (clear & GFC_FPE_DENORMAL) 257 exc_clr |= FE_DENORMAL; 258 #endif 259 260 #ifdef FE_INEXACT 261 if (set & GFC_FPE_INEXACT) 262 exc_set |= FE_INEXACT; 263 else if (clear & GFC_FPE_INEXACT) 264 exc_clr |= FE_INEXACT; 265 #endif 266 267 feclearexcept (exc_clr); 268 feraiseexcept (exc_set); 269 } 270 271 272 int 273 support_fpu_flag (int flag) 274 { 275 if (flag & GFC_FPE_INVALID) 276 { 277 #ifndef FE_INVALID 278 return 0; 279 #endif 280 } 281 else if (flag & GFC_FPE_ZERO) 282 { 283 #ifndef FE_DIVBYZERO 284 return 0; 285 #endif 286 } 287 else if (flag & GFC_FPE_OVERFLOW) 288 { 289 #ifndef FE_OVERFLOW 290 return 0; 291 #endif 292 } 293 else if (flag & GFC_FPE_UNDERFLOW) 294 { 295 #ifndef FE_UNDERFLOW 296 return 0; 297 #endif 298 } 299 else if (flag & GFC_FPE_DENORMAL) 300 { 301 #ifndef FE_DENORMAL 302 return 0; 303 #endif 304 } 305 else if (flag & GFC_FPE_INEXACT) 306 { 307 #ifndef FE_INEXACT 308 return 0; 309 #endif 310 } 311 312 return 1; 313 } 314 315 316 int 317 get_fpu_rounding_mode (void) 318 { 319 int rnd_mode; 320 321 rnd_mode = fegetround (); 322 323 switch (rnd_mode) 324 { 325 #ifdef FE_TONEAREST 326 case FE_TONEAREST: 327 return GFC_FPE_TONEAREST; 328 #endif 329 330 #ifdef FE_UPWARD 331 case FE_UPWARD: 332 return GFC_FPE_UPWARD; 333 #endif 334 335 #ifdef FE_DOWNWARD 336 case FE_DOWNWARD: 337 return GFC_FPE_DOWNWARD; 338 #endif 339 340 #ifdef FE_TOWARDZERO 341 case FE_TOWARDZERO: 342 return GFC_FPE_TOWARDZERO; 343 #endif 344 345 default: 346 return 0; /* Should be unreachable. */ 347 } 348 } 349 350 351 void 352 set_fpu_rounding_mode (int mode) 353 { 354 int rnd_mode; 355 356 switch (mode) 357 { 358 #ifdef FE_TONEAREST 359 case GFC_FPE_TONEAREST: 360 rnd_mode = FE_TONEAREST; 361 break; 362 #endif 363 364 #ifdef FE_UPWARD 365 case GFC_FPE_UPWARD: 366 rnd_mode = FE_UPWARD; 367 break; 368 #endif 369 370 #ifdef FE_DOWNWARD 371 case GFC_FPE_DOWNWARD: 372 rnd_mode = FE_DOWNWARD; 373 break; 374 #endif 375 376 #ifdef FE_TOWARDZERO 377 case GFC_FPE_TOWARDZERO: 378 rnd_mode = FE_TOWARDZERO; 379 break; 380 #endif 381 382 default: 383 return; /* Should be unreachable. */ 384 } 385 386 fesetround (rnd_mode); 387 } 388 389 390 int 391 support_fpu_rounding_mode (int mode) 392 { 393 switch (mode) 394 { 395 case GFC_FPE_TONEAREST: 396 #ifdef FE_TONEAREST 397 return 1; 398 #else 399 return 0; 400 #endif 401 402 case GFC_FPE_UPWARD: 403 #ifdef FE_UPWARD 404 return 1; 405 #else 406 return 0; 407 #endif 408 409 case GFC_FPE_DOWNWARD: 410 #ifdef FE_DOWNWARD 411 return 1; 412 #else 413 return 0; 414 #endif 415 416 case GFC_FPE_TOWARDZERO: 417 #ifdef FE_TOWARDZERO 418 return 1; 419 #else 420 return 0; 421 #endif 422 423 default: 424 return 0; /* Should be unreachable. */ 425 } 426 } 427 428 429 void 430 get_fpu_state (void *state) 431 { 432 fegetenv (state); 433 } 434 435 436 void 437 set_fpu_state (void *state) 438 { 439 fesetenv (state); 440 } 441 442 443 /* Underflow in glibc is currently only supported on alpha, through 444 the FE_MAP_UMZ macro and __ieee_set_fp_control() function call. */ 445 446 int 447 support_fpu_underflow_control (int kind __attribute__((unused))) 448 { 449 #if defined(__alpha__) && defined(FE_MAP_UMZ) 450 return (kind == 4 || kind == 8) ? 1 : 0; 451 #else 452 return 0; 453 #endif 454 } 455 456 457 int 458 get_fpu_underflow_mode (void) 459 { 460 #if defined(__alpha__) && defined(FE_MAP_UMZ) 461 462 fenv_t state = __ieee_get_fp_control (); 463 464 /* Return 0 for abrupt underflow (flush to zero), 1 for gradual underflow. */ 465 return (state & FE_MAP_UMZ) ? 0 : 1; 466 467 #else 468 469 return 0; 470 471 #endif 472 } 473 474 475 void 476 set_fpu_underflow_mode (int gradual __attribute__((unused))) 477 { 478 #if defined(__alpha__) && defined(FE_MAP_UMZ) 479 480 fenv_t state = __ieee_get_fp_control (); 481 482 if (gradual) 483 state &= ~FE_MAP_UMZ; 484 else 485 state |= FE_MAP_UMZ; 486 487 __ieee_set_fp_control (state); 488 489 #endif 490 } 491 492