libgfortran/config/fpu-glibc.h

   1 /* FPU-related code for systems with GNU libc.
   2    Copyright (C) 2005-2023 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 #ifdef FE_TONEARESTFROMZERO
 346       case FE_TONEARESTFROMZERO:
 347         return GFC_FPE_AWAY;
 348 #endif
 349
 350       default:
 351         return 0; /* Should be unreachable.  */
 352     }
 353 }
 354
 355
 356 void
 357 set_fpu_rounding_mode (int mode)
 358 {
 359   int rnd_mode;
 360
 361   switch (mode)
 362     {
 363 #ifdef FE_TONEAREST
 364       case GFC_FPE_TONEAREST:
 365         rnd_mode = FE_TONEAREST;
 366         break;
 367 #endif
 368
 369 #ifdef FE_UPWARD
 370       case GFC_FPE_UPWARD:
 371         rnd_mode = FE_UPWARD;
 372         break;
 373 #endif
 374
 375 #ifdef FE_DOWNWARD
 376       case GFC_FPE_DOWNWARD:
 377         rnd_mode = FE_DOWNWARD;
 378         break;
 379 #endif
 380
 381 #ifdef FE_TOWARDZERO
 382       case GFC_FPE_TOWARDZERO:
 383         rnd_mode = FE_TOWARDZERO;
 384         break;
 385 #endif
 386
 387 #ifdef FE_TONEARESTFROMZERO
 388       case GFC_FPE_AWAY:
 389         rnd_mode = FE_TONEARESTFROMZERO;
 390         break;
 391 #endif
 392
 393       default:
 394         return; /* Should be unreachable.  */
 395     }
 396
 397   fesetround (rnd_mode);
 398 }
 399
 400
 401 int
 402 support_fpu_rounding_mode (int mode)
 403 {
 404   switch (mode)
 405     {
 406       case GFC_FPE_TONEAREST:
 407 #ifdef FE_TONEAREST
 408         return 1;
 409 #else
 410         return 0;
 411 #endif
 412
 413       case GFC_FPE_UPWARD:
 414 #ifdef FE_UPWARD
 415         return 1;
 416 #else
 417         return 0;
 418 #endif
 419
 420       case GFC_FPE_DOWNWARD:
 421 #ifdef FE_DOWNWARD
 422         return 1;
 423 #else
 424         return 0;
 425 #endif
 426
 427       case GFC_FPE_TOWARDZERO:
 428 #ifdef FE_TOWARDZERO
 429         return 1;
 430 #else
 431         return 0;
 432 #endif
 433
 434       case GFC_FPE_AWAY:
 435 #ifdef FE_TONEARESTFROMZERO
 436         return 1;
 437 #else
 438         return 0;
 439 #endif
 440
 441       default:
 442         return 0; /* Should be unreachable.  */
 443     }
 444 }
 445
 446
 447 void
 448 get_fpu_state (void *state)
 449 {
 450   fegetenv (state);
 451 }
 452
 453
 454 void
 455 set_fpu_state (void *state)
 456 {
 457   fesetenv (state);
 458 }
 459
 460
 461 /* Underflow in glibc is currently only supported on alpha, through
 462    the FE_MAP_UMZ macro and __ieee_set_fp_control() function call.  */
 463
 464 int
 465 support_fpu_underflow_control (int kind __attribute__((unused)))
 466 {
 467 #if defined(__alpha__) && defined(FE_MAP_UMZ)
 468   return (kind == 4 || kind == 8) ? 1 : 0;
 469 #else
 470   return 0;
 471 #endif
 472 }
 473
 474
 475 int
 476 get_fpu_underflow_mode (void)
 477 {
 478 #if defined(__alpha__) && defined(FE_MAP_UMZ)
 479
 480   fenv_t state = __ieee_get_fp_control ();
 481
 482   /* Return 0 for abrupt underflow (flush to zero), 1 for gradual underflow.  */
 483   return (state & FE_MAP_UMZ) ? 0 : 1;
 484
 485 #else
 486
 487   return 0;
 488
 489 #endif
 490 }
 491
 492
 493 void
 494 set_fpu_underflow_mode (int gradual __attribute__((unused)))
 495 {
 496 #if defined(__alpha__) && defined(FE_MAP_UMZ)
 497
 498   fenv_t state = __ieee_get_fp_control ();
 499
 500   if (gradual)
 501     state &= ~FE_MAP_UMZ;
 502   else
 503     state |= FE_MAP_UMZ;
 504
 505   __ieee_set_fp_control (state);
 506
 507 #endif
 508 }
 509