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