libgfortran/config/fpu-glibc.h

   1 /* FPU-related code for systems with GNU libc.
   2    Copyright (C) 2005-2021 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