libgfortran/config/fpu-glibc.h

   1 /* FPU-related code for systems with GNU libc.
   2    Copyright (C) 2005-2016 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 #ifdef FE_INVALID
  43   if (trap & GFC_FPE_INVALID)
  44     feenableexcept (FE_INVALID);
  45   if (notrap & GFC_FPE_INVALID)
  46     fedisableexcept (FE_INVALID);
  47 #endif
  48
  49 /* Some glibc targets (like alpha) have FE_DENORMAL, but not many.  */
  50 #ifdef FE_DENORMAL
  51   if (trap & GFC_FPE_DENORMAL)
  52     feenableexcept (FE_DENORMAL);
  53   if (notrap & GFC_FPE_DENORMAL)
  54     fedisableexcept (FE_DENORMAL);
  55 #endif
  56
  57 #ifdef FE_DIVBYZERO
  58   if (trap & GFC_FPE_ZERO)
  59     feenableexcept (FE_DIVBYZERO);
  60   if (notrap & GFC_FPE_ZERO)
  61     fedisableexcept (FE_DIVBYZERO);
  62 #endif
  63
  64 #ifdef FE_OVERFLOW
  65   if (trap & GFC_FPE_OVERFLOW)
  66     feenableexcept (FE_OVERFLOW);
  67   if (notrap & GFC_FPE_OVERFLOW)
  68     fedisableexcept (FE_OVERFLOW);
  69 #endif
  70
  71 #ifdef FE_UNDERFLOW
  72   if (trap & GFC_FPE_UNDERFLOW)
  73     feenableexcept (FE_UNDERFLOW);
  74   if (notrap & GFC_FPE_UNDERFLOW)
  75     fedisableexcept (FE_UNDERFLOW);
  76 #endif
  77
  78 #ifdef FE_INEXACT
  79   if (trap & GFC_FPE_INEXACT)
  80     feenableexcept (FE_INEXACT);
  81   if (notrap & GFC_FPE_INEXACT)
  82     fedisableexcept (FE_INEXACT);
  83 #endif
  84 }
  85
  86
  87 int
  88 get_fpu_trap_exceptions (void)
  89 {
  90   int exceptions = fegetexcept ();
  91   int res = 0;
  92
  93 #ifdef FE_INVALID
  94   if (exceptions & FE_INVALID) res |= GFC_FPE_INVALID;
  95 #endif
  96
  97 #ifdef FE_DENORMAL
  98   if (exceptions & FE_DENORMAL) res |= GFC_FPE_DENORMAL;
  99 #endif
 100
 101 #ifdef FE_DIVBYZERO
 102   if (exceptions & FE_DIVBYZERO) res |= GFC_FPE_ZERO;
 103 #endif
 104
 105 #ifdef FE_OVERFLOW
 106   if (exceptions & FE_OVERFLOW) res |= GFC_FPE_OVERFLOW;
 107 #endif
 108
 109 #ifdef FE_UNDERFLOW
 110   if (exceptions & FE_UNDERFLOW) res |= GFC_FPE_UNDERFLOW;
 111 #endif
 112
 113 #ifdef FE_INEXACT
 114   if (exceptions & FE_INEXACT) res |= GFC_FPE_INEXACT;
 115 #endif
 116
 117   return res;
 118 }
 119
 120
 121 int
 122 support_fpu_trap (int flag)
 123 {
 124   return support_fpu_flag (flag);
 125 }
 126
 127
 128 void set_fpu (void)
 129 {
 130 #ifndef FE_INVALID
 131   if (options.fpe & GFC_FPE_INVALID)
 132     estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
 133                 "exception not supported.\n");
 134 #endif
 135
 136 #ifndef FE_DENORMAL
 137   if (options.fpe & GFC_FPE_DENORMAL)
 138     estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
 139                 "exception not supported.\n");
 140 #endif
 141
 142 #ifndef FE_DIVBYZERO
 143   if (options.fpe & GFC_FPE_ZERO)
 144     estr_write ("Fortran runtime warning: IEEE 'division by zero' "
 145                 "exception not supported.\n");
 146 #endif
 147
 148 #ifndef FE_OVERFLOW
 149   if (options.fpe & GFC_FPE_OVERFLOW)
 150     estr_write ("Fortran runtime warning: IEEE 'overflow' "
 151                 "exception not supported.\n");
 152 #endif
 153
 154 #ifndef FE_UNDERFLOW
 155   if (options.fpe & GFC_FPE_UNDERFLOW)
 156     estr_write ("Fortran runtime warning: IEEE 'underflow' "
 157                 "exception not supported.\n");
 158 #endif
 159
 160 #ifndef FE_INEXACT
 161   if (options.fpe & GFC_FPE_INEXACT)
 162     estr_write ("Fortran runtime warning: IEEE 'inexact' "
 163                 "exception not supported.\n");
 164 #endif
 165
 166   set_fpu_trap_exceptions (options.fpe, 0);
 167 }
 168
 169
 170 int
 171 get_fpu_except_flags (void)
 172 {
 173   int result, set_excepts;
 174
 175   result = 0;
 176   set_excepts = fetestexcept (FE_ALL_EXCEPT);
 177
 178 #ifdef FE_INVALID
 179   if (set_excepts & FE_INVALID)
 180     result |= GFC_FPE_INVALID;
 181 #endif
 182
 183 #ifdef FE_DIVBYZERO
 184   if (set_excepts & FE_DIVBYZERO)
 185     result |= GFC_FPE_ZERO;
 186 #endif
 187
 188 #ifdef FE_OVERFLOW
 189   if (set_excepts & FE_OVERFLOW)
 190     result |= GFC_FPE_OVERFLOW;
 191 #endif
 192
 193 #ifdef FE_UNDERFLOW
 194   if (set_excepts & FE_UNDERFLOW)
 195     result |= GFC_FPE_UNDERFLOW;
 196 #endif
 197
 198 #ifdef FE_DENORMAL
 199   if (set_excepts & FE_DENORMAL)
 200     result |= GFC_FPE_DENORMAL;
 201 #endif
 202
 203 #ifdef FE_INEXACT
 204   if (set_excepts & FE_INEXACT)
 205     result |= GFC_FPE_INEXACT;
 206 #endif
 207
 208   return result;
 209 }
 210
 211
 212 void
 213 set_fpu_except_flags (int set, int clear)
 214 {
 215   int exc_set = 0, exc_clr = 0;
 216
 217 #ifdef FE_INVALID
 218   if (set & GFC_FPE_INVALID)
 219     exc_set |= FE_INVALID;
 220   else if (clear & GFC_FPE_INVALID)
 221     exc_clr |= FE_INVALID;
 222 #endif
 223
 224 #ifdef FE_DIVBYZERO
 225   if (set & GFC_FPE_ZERO)
 226     exc_set |= FE_DIVBYZERO;
 227   else if (clear & GFC_FPE_ZERO)
 228     exc_clr |= FE_DIVBYZERO;
 229 #endif
 230
 231 #ifdef FE_OVERFLOW
 232   if (set & GFC_FPE_OVERFLOW)
 233     exc_set |= FE_OVERFLOW;
 234   else if (clear & GFC_FPE_OVERFLOW)
 235     exc_clr |= FE_OVERFLOW;
 236 #endif
 237
 238 #ifdef FE_UNDERFLOW
 239   if (set & GFC_FPE_UNDERFLOW)
 240     exc_set |= FE_UNDERFLOW;
 241   else if (clear & GFC_FPE_UNDERFLOW)
 242     exc_clr |= FE_UNDERFLOW;
 243 #endif
 244
 245 #ifdef FE_DENORMAL
 246   if (set & GFC_FPE_DENORMAL)
 247     exc_set |= FE_DENORMAL;
 248   else if (clear & GFC_FPE_DENORMAL)
 249     exc_clr |= FE_DENORMAL;
 250 #endif
 251
 252 #ifdef FE_INEXACT
 253   if (set & GFC_FPE_INEXACT)
 254     exc_set |= FE_INEXACT;
 255   else if (clear & GFC_FPE_INEXACT)
 256     exc_clr |= FE_INEXACT;
 257 #endif
 258
 259   feclearexcept (exc_clr);
 260   feraiseexcept (exc_set);
 261 }
 262
 263
 264 int
 265 support_fpu_flag (int flag)
 266 {
 267   if (flag & GFC_FPE_INVALID)
 268   {
 269 #ifndef FE_INVALID
 270     return 0;
 271 #endif
 272   }
 273   else if (flag & GFC_FPE_ZERO)
 274   {
 275 #ifndef FE_DIVBYZERO
 276     return 0;
 277 #endif
 278   }
 279   else if (flag & GFC_FPE_OVERFLOW)
 280   {
 281 #ifndef FE_OVERFLOW
 282     return 0;
 283 #endif
 284   }
 285   else if (flag & GFC_FPE_UNDERFLOW)
 286   {
 287 #ifndef FE_UNDERFLOW
 288     return 0;
 289 #endif
 290   }
 291   else if (flag & GFC_FPE_DENORMAL)
 292   {
 293 #ifndef FE_DENORMAL
 294     return 0;
 295 #endif
 296   }
 297   else if (flag & GFC_FPE_INEXACT)
 298   {
 299 #ifndef FE_INEXACT
 300     return 0;
 301 #endif
 302   }
 303
 304   return 1;
 305 }
 306
 307
 308 int
 309 get_fpu_rounding_mode (void)
 310 {
 311   int rnd_mode;
 312
 313   rnd_mode = fegetround ();
 314
 315   switch (rnd_mode)
 316     {
 317 #ifdef FE_TONEAREST
 318       case FE_TONEAREST:
 319         return GFC_FPE_TONEAREST;
 320 #endif
 321
 322 #ifdef FE_UPWARD
 323       case FE_UPWARD:
 324         return GFC_FPE_UPWARD;
 325 #endif
 326
 327 #ifdef FE_DOWNWARD
 328       case FE_DOWNWARD:
 329         return GFC_FPE_DOWNWARD;
 330 #endif
 331
 332 #ifdef FE_TOWARDZERO
 333       case FE_TOWARDZERO:
 334         return GFC_FPE_TOWARDZERO;
 335 #endif
 336
 337       default:
 338         return 0; /* Should be unreachable.  */
 339     }
 340 }
 341
 342
 343 void
 344 set_fpu_rounding_mode (int mode)
 345 {
 346   int rnd_mode;
 347
 348   switch (mode)
 349     {
 350 #ifdef FE_TONEAREST
 351       case GFC_FPE_TONEAREST:
 352         rnd_mode = FE_TONEAREST;
 353         break;
 354 #endif
 355
 356 #ifdef FE_UPWARD
 357       case GFC_FPE_UPWARD:
 358         rnd_mode = FE_UPWARD;
 359         break;
 360 #endif
 361
 362 #ifdef FE_DOWNWARD
 363       case GFC_FPE_DOWNWARD:
 364         rnd_mode = FE_DOWNWARD;
 365         break;
 366 #endif
 367
 368 #ifdef FE_TOWARDZERO
 369       case GFC_FPE_TOWARDZERO:
 370         rnd_mode = FE_TOWARDZERO;
 371         break;
 372 #endif
 373
 374       default:
 375         return; /* Should be unreachable.  */
 376     }
 377
 378   fesetround (rnd_mode);
 379 }
 380
 381
 382 int
 383 support_fpu_rounding_mode (int mode)
 384 {
 385   switch (mode)
 386     {
 387       case GFC_FPE_TONEAREST:
 388 #ifdef FE_TONEAREST
 389         return 1;
 390 #else
 391         return 0;
 392 #endif
 393
 394       case GFC_FPE_UPWARD:
 395 #ifdef FE_UPWARD
 396         return 1;
 397 #else
 398         return 0;
 399 #endif
 400
 401       case GFC_FPE_DOWNWARD:
 402 #ifdef FE_DOWNWARD
 403         return 1;
 404 #else
 405         return 0;
 406 #endif
 407
 408       case GFC_FPE_TOWARDZERO:
 409 #ifdef FE_TOWARDZERO
 410         return 1;
 411 #else
 412         return 0;
 413 #endif
 414
 415       default:
 416         return 0; /* Should be unreachable.  */
 417     }
 418 }
 419
 420
 421 void
 422 get_fpu_state (void *state)
 423 {
 424   fegetenv (state);
 425 }
 426
 427
 428 void
 429 set_fpu_state (void *state)
 430 {
 431   fesetenv (state);
 432 }
 433
 434
 435 /* Underflow in glibc is currently only supported on alpha, through
 436    the FE_MAP_UMZ macro and __ieee_set_fp_control() function call.  */
 437
 438 int
 439 support_fpu_underflow_control (int kind __attribute__((unused)))
 440 {
 441 #if defined(__alpha__) && defined(FE_MAP_UMZ)
 442   return (kind == 4 || kind == 8) ? 1 : 0;
 443 #else
 444   return 0;
 445 #endif
 446 }
 447
 448
 449 int
 450 get_fpu_underflow_mode (void)
 451 {
 452 #if defined(__alpha__) && defined(FE_MAP_UMZ)
 453
 454   fenv_t state = __ieee_get_fp_control ();
 455
 456   /* Return 0 for abrupt underflow (flush to zero), 1 for gradual underflow.  */
 457   return (state & FE_MAP_UMZ) ? 0 : 1;
 458
 459 #else
 460
 461   return 0;
 462
 463 #endif
 464 }
 465
 466
 467 void
 468 set_fpu_underflow_mode (int gradual __attribute__((unused)))
 469 {
 470 #if defined(__alpha__) && defined(FE_MAP_UMZ)
 471
 472   fenv_t state = __ieee_get_fp_control ();
 473
 474   if (gradual)
 475     state &= ~FE_MAP_UMZ;
 476   else
 477     state |= FE_MAP_UMZ;
 478
 479   __ieee_set_fp_control (state);
 480
 481 #endif
 482 }
 483