libgfortran/config/fpu-glibc.h

   1 /* FPU-related code for systems with GNU libc.
   2    Copyright (C) 2005-2019 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   int exceptions = 0;
 133   int old;
 134
 135   if (!support_fpu_flag (flag))
 136     return 0;
 137
 138 #ifdef FE_INVALID
 139   if (flag & GFC_FPE_INVALID) exceptions |= FE_INVALID;
 140 #endif
 141
 142 #ifdef FE_DIVBYZERO
 143   if (flag & GFC_FPE_ZERO) exceptions |= FE_DIVBYZERO;
 144 #endif
 145
 146 #ifdef FE_OVERFLOW
 147   if (flag & GFC_FPE_OVERFLOW) exceptions |= FE_OVERFLOW;
 148 #endif
 149
 150 #ifdef FE_UNDERFLOW
 151   if (flag & GFC_FPE_UNDERFLOW) exceptions |= FE_UNDERFLOW;
 152 #endif
 153
 154 #ifdef FE_DENORMAL
 155   if (flag & GFC_FPE_DENORMAL) exceptions |= FE_DENORMAL;
 156 #endif
 157
 158 #ifdef FE_INEXACT
 159   if (flag & GFC_FPE_INEXACT) exceptions |= FE_INEXACT;
 160 #endif
 161
 162   old = feenableexcept (exceptions);
 163   if (old == -1)
 164     return 0;
 165   fedisableexcept (exceptions & ~old);
 166   return 1;
 167 }
 168
 169
 170 void set_fpu (void)
 171 {
 172 #ifndef FE_INVALID
 173   if (options.fpe & GFC_FPE_INVALID)
 174     estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
 175                 "exception not supported.\n");
 176 #endif
 177
 178 #ifndef FE_DENORMAL
 179   if (options.fpe & GFC_FPE_DENORMAL)
 180     estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
 181                 "exception not supported.\n");
 182 #endif
 183
 184 #ifndef FE_DIVBYZERO
 185   if (options.fpe & GFC_FPE_ZERO)
 186     estr_write ("Fortran runtime warning: IEEE 'division by zero' "
 187                 "exception not supported.\n");
 188 #endif
 189
 190 #ifndef FE_OVERFLOW
 191   if (options.fpe & GFC_FPE_OVERFLOW)
 192     estr_write ("Fortran runtime warning: IEEE 'overflow' "
 193                 "exception not supported.\n");
 194 #endif
 195
 196 #ifndef FE_UNDERFLOW
 197   if (options.fpe & GFC_FPE_UNDERFLOW)
 198     estr_write ("Fortran runtime warning: IEEE 'underflow' "
 199                 "exception not supported.\n");
 200 #endif
 201
 202 #ifndef FE_INEXACT
 203   if (options.fpe & GFC_FPE_INEXACT)
 204     estr_write ("Fortran runtime warning: IEEE 'inexact' "
 205                 "exception not supported.\n");
 206 #endif
 207
 208   set_fpu_trap_exceptions (options.fpe, 0);
 209 }
 210
 211
 212 int
 213 get_fpu_except_flags (void)
 214 {
 215   int result, set_excepts;
 216
 217   result = 0;
 218   set_excepts = fetestexcept (FE_ALL_EXCEPT);
 219
 220 #ifdef FE_INVALID
 221   if (set_excepts & FE_INVALID)
 222     result |= GFC_FPE_INVALID;
 223 #endif
 224
 225 #ifdef FE_DIVBYZERO
 226   if (set_excepts & FE_DIVBYZERO)
 227     result |= GFC_FPE_ZERO;
 228 #endif
 229
 230 #ifdef FE_OVERFLOW
 231   if (set_excepts & FE_OVERFLOW)
 232     result |= GFC_FPE_OVERFLOW;
 233 #endif
 234
 235 #ifdef FE_UNDERFLOW
 236   if (set_excepts & FE_UNDERFLOW)
 237     result |= GFC_FPE_UNDERFLOW;
 238 #endif
 239
 240 #ifdef FE_DENORMAL
 241   if (set_excepts & FE_DENORMAL)
 242     result |= GFC_FPE_DENORMAL;
 243 #endif
 244
 245 #ifdef FE_INEXACT
 246   if (set_excepts & FE_INEXACT)
 247     result |= GFC_FPE_INEXACT;
 248 #endif
 249
 250   return result;
 251 }
 252
 253
 254 void
 255 set_fpu_except_flags (int set, int clear)
 256 {
 257   int exc_set = 0, exc_clr = 0;
 258
 259 #ifdef FE_INVALID
 260   if (set & GFC_FPE_INVALID)
 261     exc_set |= FE_INVALID;
 262   else if (clear & GFC_FPE_INVALID)
 263     exc_clr |= FE_INVALID;
 264 #endif
 265
 266 #ifdef FE_DIVBYZERO
 267   if (set & GFC_FPE_ZERO)
 268     exc_set |= FE_DIVBYZERO;
 269   else if (clear & GFC_FPE_ZERO)
 270     exc_clr |= FE_DIVBYZERO;
 271 #endif
 272
 273 #ifdef FE_OVERFLOW
 274   if (set & GFC_FPE_OVERFLOW)
 275     exc_set |= FE_OVERFLOW;
 276   else if (clear & GFC_FPE_OVERFLOW)
 277     exc_clr |= FE_OVERFLOW;
 278 #endif
 279
 280 #ifdef FE_UNDERFLOW
 281   if (set & GFC_FPE_UNDERFLOW)
 282     exc_set |= FE_UNDERFLOW;
 283   else if (clear & GFC_FPE_UNDERFLOW)
 284     exc_clr |= FE_UNDERFLOW;
 285 #endif
 286
 287 #ifdef FE_DENORMAL
 288   if (set & GFC_FPE_DENORMAL)
 289     exc_set |= FE_DENORMAL;
 290   else if (clear & GFC_FPE_DENORMAL)
 291     exc_clr |= FE_DENORMAL;
 292 #endif
 293
 294 #ifdef FE_INEXACT
 295   if (set & GFC_FPE_INEXACT)
 296     exc_set |= FE_INEXACT;
 297   else if (clear & GFC_FPE_INEXACT)
 298     exc_clr |= FE_INEXACT;
 299 #endif
 300
 301   feclearexcept (exc_clr);
 302   feraiseexcept (exc_set);
 303 }
 304
 305
 306 int
 307 support_fpu_flag (int flag)
 308 {
 309   if (flag & GFC_FPE_INVALID)
 310   {
 311 #ifndef FE_INVALID
 312     return 0;
 313 #endif
 314   }
 315   else if (flag & GFC_FPE_ZERO)
 316   {
 317 #ifndef FE_DIVBYZERO
 318     return 0;
 319 #endif
 320   }
 321   else if (flag & GFC_FPE_OVERFLOW)
 322   {
 323 #ifndef FE_OVERFLOW
 324     return 0;
 325 #endif
 326   }
 327   else if (flag & GFC_FPE_UNDERFLOW)
 328   {
 329 #ifndef FE_UNDERFLOW
 330     return 0;
 331 #endif
 332   }
 333   else if (flag & GFC_FPE_DENORMAL)
 334   {
 335 #ifndef FE_DENORMAL
 336     return 0;
 337 #endif
 338   }
 339   else if (flag & GFC_FPE_INEXACT)
 340   {
 341 #ifndef FE_INEXACT
 342     return 0;
 343 #endif
 344   }
 345
 346   return 1;
 347 }
 348
 349
 350 int
 351 get_fpu_rounding_mode (void)
 352 {
 353   int rnd_mode;
 354
 355   rnd_mode = fegetround ();
 356
 357   switch (rnd_mode)
 358     {
 359 #ifdef FE_TONEAREST
 360       case FE_TONEAREST:
 361         return GFC_FPE_TONEAREST;
 362 #endif
 363
 364 #ifdef FE_UPWARD
 365       case FE_UPWARD:
 366         return GFC_FPE_UPWARD;
 367 #endif
 368
 369 #ifdef FE_DOWNWARD
 370       case FE_DOWNWARD:
 371         return GFC_FPE_DOWNWARD;
 372 #endif
 373
 374 #ifdef FE_TOWARDZERO
 375       case FE_TOWARDZERO:
 376         return GFC_FPE_TOWARDZERO;
 377 #endif
 378
 379       default:
 380         return 0; /* Should be unreachable.  */
 381     }
 382 }
 383
 384
 385 void
 386 set_fpu_rounding_mode (int mode)
 387 {
 388   int rnd_mode;
 389
 390   switch (mode)
 391     {
 392 #ifdef FE_TONEAREST
 393       case GFC_FPE_TONEAREST:
 394         rnd_mode = FE_TONEAREST;
 395         break;
 396 #endif
 397
 398 #ifdef FE_UPWARD
 399       case GFC_FPE_UPWARD:
 400         rnd_mode = FE_UPWARD;
 401         break;
 402 #endif
 403
 404 #ifdef FE_DOWNWARD
 405       case GFC_FPE_DOWNWARD:
 406         rnd_mode = FE_DOWNWARD;
 407         break;
 408 #endif
 409
 410 #ifdef FE_TOWARDZERO
 411       case GFC_FPE_TOWARDZERO:
 412         rnd_mode = FE_TOWARDZERO;
 413         break;
 414 #endif
 415
 416       default:
 417         return; /* Should be unreachable.  */
 418     }
 419
 420   fesetround (rnd_mode);
 421 }
 422
 423
 424 int
 425 support_fpu_rounding_mode (int mode)
 426 {
 427   switch (mode)
 428     {
 429       case GFC_FPE_TONEAREST:
 430 #ifdef FE_TONEAREST
 431         return 1;
 432 #else
 433         return 0;
 434 #endif
 435
 436       case GFC_FPE_UPWARD:
 437 #ifdef FE_UPWARD
 438         return 1;
 439 #else
 440         return 0;
 441 #endif
 442
 443       case GFC_FPE_DOWNWARD:
 444 #ifdef FE_DOWNWARD
 445         return 1;
 446 #else
 447         return 0;
 448 #endif
 449
 450       case GFC_FPE_TOWARDZERO:
 451 #ifdef FE_TOWARDZERO
 452         return 1;
 453 #else
 454         return 0;
 455 #endif
 456
 457       default:
 458         return 0; /* Should be unreachable.  */
 459     }
 460 }
 461
 462
 463 void
 464 get_fpu_state (void *state)
 465 {
 466   fegetenv (state);
 467 }
 468
 469
 470 void
 471 set_fpu_state (void *state)
 472 {
 473   fesetenv (state);
 474 }
 475
 476
 477 /* Underflow in glibc is currently only supported on alpha, through
 478    the FE_MAP_UMZ macro and __ieee_set_fp_control() function call.  */
 479
 480 int
 481 support_fpu_underflow_control (int kind __attribute__((unused)))
 482 {
 483 #if defined(__alpha__) && defined(FE_MAP_UMZ)
 484   return (kind == 4 || kind == 8) ? 1 : 0;
 485 #else
 486   return 0;
 487 #endif
 488 }
 489
 490
 491 int
 492 get_fpu_underflow_mode (void)
 493 {
 494 #if defined(__alpha__) && defined(FE_MAP_UMZ)
 495
 496   fenv_t state = __ieee_get_fp_control ();
 497
 498   /* Return 0 for abrupt underflow (flush to zero), 1 for gradual underflow.  */
 499   return (state & FE_MAP_UMZ) ? 0 : 1;
 500
 501 #else
 502
 503   return 0;
 504
 505 #endif
 506 }
 507
 508
 509 void
 510 set_fpu_underflow_mode (int gradual __attribute__((unused)))
 511 {
 512 #if defined(__alpha__) && defined(FE_MAP_UMZ)
 513
 514   fenv_t state = __ieee_get_fp_control ();
 515
 516   if (gradual)
 517     state &= ~FE_MAP_UMZ;
 518   else
 519     state |= FE_MAP_UMZ;
 520
 521   __ieee_set_fp_control (state);
 522
 523 #endif
 524 }
 525