]>
Commit | Line | Data |
---|---|---|
944b8b35 | 1 | /* FPU-related code for systems with GNU libc. |
83ffe9cd | 2 | Copyright (C) 2005-2023 Free Software Foundation, Inc. |
944b8b35 FXC |
3 | Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr> |
4 | ||
1028b2bd | 5 | This file is part of the GNU Fortran runtime library (libgfortran). |
944b8b35 FXC |
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 | |
748086b7 | 10 | version 3 of the License, or (at your option) any later version. |
944b8b35 FXC |
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 | ||
748086b7 JJ |
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. | |
944b8b35 | 20 | |
748086b7 JJ |
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/>. */ | |
944b8b35 FXC |
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 | ||
944b8b35 FXC |
30 | #ifdef HAVE_FENV_H |
31 | #include <fenv.h> | |
32 | #endif | |
33 | ||
944b8b35 | 34 | |
a709346f FXC |
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 | ||
8b198102 FXC |
40 | void set_fpu_trap_exceptions (int trap, int notrap) |
41 | { | |
de0c04f9 UB |
42 | int mode_set = 0, mode_clr = 0; |
43 | ||
944b8b35 | 44 | #ifdef FE_INVALID |
8b198102 | 45 | if (trap & GFC_FPE_INVALID) |
de0c04f9 | 46 | mode_set |= FE_INVALID; |
8b198102 | 47 | if (notrap & GFC_FPE_INVALID) |
de0c04f9 | 48 | mode_clr |= FE_INVALID; |
8b198102 FXC |
49 | #endif |
50 | ||
4a72ba02 | 51 | /* Some glibc targets (like alpha) have FE_DENORMAL, but not many. */ |
8b198102 FXC |
52 | #ifdef FE_DENORMAL |
53 | if (trap & GFC_FPE_DENORMAL) | |
de0c04f9 | 54 | mode_set |= FE_DENORMAL; |
8b198102 | 55 | if (notrap & GFC_FPE_DENORMAL) |
de0c04f9 | 56 | mode_clr |= FE_DENORMAL; |
8b198102 FXC |
57 | #endif |
58 | ||
59 | #ifdef FE_DIVBYZERO | |
60 | if (trap & GFC_FPE_ZERO) | |
de0c04f9 | 61 | mode_set |= FE_DIVBYZERO; |
8b198102 | 62 | if (notrap & GFC_FPE_ZERO) |
de0c04f9 | 63 | mode_clr |= FE_DIVBYZERO; |
8b198102 FXC |
64 | #endif |
65 | ||
66 | #ifdef FE_OVERFLOW | |
67 | if (trap & GFC_FPE_OVERFLOW) | |
de0c04f9 | 68 | mode_set |= FE_OVERFLOW; |
8b198102 | 69 | if (notrap & GFC_FPE_OVERFLOW) |
de0c04f9 | 70 | mode_clr |= FE_OVERFLOW; |
8b198102 FXC |
71 | #endif |
72 | ||
73 | #ifdef FE_UNDERFLOW | |
74 | if (trap & GFC_FPE_UNDERFLOW) | |
de0c04f9 | 75 | mode_set |= FE_UNDERFLOW; |
8b198102 | 76 | if (notrap & GFC_FPE_UNDERFLOW) |
de0c04f9 | 77 | mode_clr |= FE_UNDERFLOW; |
8b198102 FXC |
78 | #endif |
79 | ||
80 | #ifdef FE_INEXACT | |
81 | if (trap & GFC_FPE_INEXACT) | |
de0c04f9 | 82 | mode_set |= FE_INEXACT; |
8b198102 | 83 | if (notrap & GFC_FPE_INEXACT) |
de0c04f9 | 84 | mode_clr |= FE_INEXACT; |
8b198102 | 85 | #endif |
de0c04f9 UB |
86 | |
87 | /* Clear stalled exception flags. */ | |
88 | feclearexcept (FE_ALL_EXCEPT); | |
89 | ||
90 | feenableexcept (mode_set); | |
91 | fedisableexcept (mode_clr); | |
8b198102 FXC |
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 | { | |
05dfdd6c | 132 | return support_fpu_flag (flag); |
8b198102 FXC |
133 | } |
134 | ||
135 | ||
136 | void set_fpu (void) | |
137 | { | |
138 | #ifndef FE_INVALID | |
139 | if (options.fpe & GFC_FPE_INVALID) | |
1028b2bd JB |
140 | estr_write ("Fortran runtime warning: IEEE 'invalid operation' " |
141 | "exception not supported.\n"); | |
944b8b35 FXC |
142 | #endif |
143 | ||
8b198102 | 144 | #ifndef FE_DENORMAL |
944b8b35 | 145 | if (options.fpe & GFC_FPE_DENORMAL) |
57b4d355 | 146 | estr_write ("Fortran runtime warning: Floating point 'denormal operand' " |
1028b2bd | 147 | "exception not supported.\n"); |
944b8b35 FXC |
148 | #endif |
149 | ||
8b198102 | 150 | #ifndef FE_DIVBYZERO |
944b8b35 | 151 | if (options.fpe & GFC_FPE_ZERO) |
1028b2bd JB |
152 | estr_write ("Fortran runtime warning: IEEE 'division by zero' " |
153 | "exception not supported.\n"); | |
944b8b35 FXC |
154 | #endif |
155 | ||
8b198102 | 156 | #ifndef FE_OVERFLOW |
944b8b35 | 157 | if (options.fpe & GFC_FPE_OVERFLOW) |
1028b2bd JB |
158 | estr_write ("Fortran runtime warning: IEEE 'overflow' " |
159 | "exception not supported.\n"); | |
944b8b35 FXC |
160 | #endif |
161 | ||
8b198102 | 162 | #ifndef FE_UNDERFLOW |
944b8b35 | 163 | if (options.fpe & GFC_FPE_UNDERFLOW) |
1028b2bd JB |
164 | estr_write ("Fortran runtime warning: IEEE 'underflow' " |
165 | "exception not supported.\n"); | |
944b8b35 FXC |
166 | #endif |
167 | ||
8b198102 | 168 | #ifndef FE_INEXACT |
57b4d355 | 169 | if (options.fpe & GFC_FPE_INEXACT) |
57b4d355 | 170 | estr_write ("Fortran runtime warning: IEEE 'inexact' " |
1028b2bd | 171 | "exception not supported.\n"); |
944b8b35 | 172 | #endif |
8b198102 FXC |
173 | |
174 | set_fpu_trap_exceptions (options.fpe, 0); | |
944b8b35 | 175 | } |
fa86f4f9 TB |
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 | } | |
82a4f54c TB |
218 | |
219 | ||
8b198102 FXC |
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 | ||
82a4f54c TB |
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 | |
56710419 | 344 | |
4637a1d2 FXC |
345 | #ifdef FE_TONEARESTFROMZERO |
346 | case FE_TONEARESTFROMZERO: | |
347 | return GFC_FPE_AWAY; | |
348 | #endif | |
349 | ||
82a4f54c | 350 | default: |
56710419 | 351 | return 0; /* Should be unreachable. */ |
82a4f54c TB |
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 | |
56710419 | 386 | |
4637a1d2 FXC |
387 | #ifdef FE_TONEARESTFROMZERO |
388 | case GFC_FPE_AWAY: | |
389 | rnd_mode = FE_TONEARESTFROMZERO; | |
390 | break; | |
391 | #endif | |
392 | ||
82a4f54c | 393 | default: |
56710419 | 394 | return; /* Should be unreachable. */ |
82a4f54c TB |
395 | } |
396 | ||
397 | fesetround (rnd_mode); | |
398 | } | |
8b198102 FXC |
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 | ||
5b0936da | 413 | case GFC_FPE_UPWARD: |
8b198102 FXC |
414 | #ifdef FE_UPWARD |
415 | return 1; | |
416 | #else | |
417 | return 0; | |
418 | #endif | |
419 | ||
5b0936da | 420 | case GFC_FPE_DOWNWARD: |
8b198102 FXC |
421 | #ifdef FE_DOWNWARD |
422 | return 1; | |
423 | #else | |
424 | return 0; | |
425 | #endif | |
426 | ||
5b0936da | 427 | case GFC_FPE_TOWARDZERO: |
8b198102 FXC |
428 | #ifdef FE_TOWARDZERO |
429 | return 1; | |
430 | #else | |
431 | return 0; | |
432 | #endif | |
433 | ||
4637a1d2 FXC |
434 | case GFC_FPE_AWAY: |
435 | #ifdef FE_TONEARESTFROMZERO | |
436 | return 1; | |
437 | #else | |
438 | return 0; | |
439 | #endif | |
440 | ||
8b198102 | 441 | default: |
56710419 | 442 | return 0; /* Should be unreachable. */ |
8b198102 FXC |
443 | } |
444 | } | |
445 | ||
446 | ||
447 | void | |
448 | get_fpu_state (void *state) | |
449 | { | |
8b198102 FXC |
450 | fegetenv (state); |
451 | } | |
452 | ||
453 | ||
454 | void | |
455 | set_fpu_state (void *state) | |
456 | { | |
8b198102 FXC |
457 | fesetenv (state); |
458 | } | |
459 | ||
f5168e47 FXC |
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 |