1 /* SysV FPU-related code (for systems not otherwise supported).
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 SysV platforms with fpsetmask(). */
27
28 /* BSD and Solaris systems have slightly different types and functions
29 naming. We deal with these here, to simplify the code below. */
30
31 #if HAVE_FP_EXCEPT
32 # define FP_EXCEPT_TYPE fp_except
33 #elif HAVE_FP_EXCEPT_T
34 # define FP_EXCEPT_TYPE fp_except_t
35 #else
36 choke me
37 #endif
38
39 #if HAVE_FP_RND
40 # define FP_RND_TYPE fp_rnd
41 #elif HAVE_FP_RND_T
42 # define FP_RND_TYPE fp_rnd_t
43 #else
44 choke me
45 #endif
46
47 #if HAVE_FPSETSTICKY
48 # define FPSETSTICKY fpsetsticky
49 #elif HAVE_FPRESETSTICKY
50 # define FPSETSTICKY fpresetsticky
51 #else
52 choke me
53 #endif
54
55
56 void
57 set_fpu_trap_exceptions (int trap, int notrap)
58 {
59 FP_EXCEPT_TYPE cw = fpgetmask();
60
61 #ifdef FP_X_INV
62 if (trap & GFC_FPE_INVALID)
63 cw |= FP_X_INV;
64 if (notrap & GFC_FPE_INVALID)
65 cw &= ~FP_X_INV;
66 #endif
67
68 #ifdef FP_X_DNML
69 if (trap & GFC_FPE_DENORMAL)
70 cw |= FP_X_DNML;
71 if (notrap & GFC_FPE_DENORMAL)
72 cw &= ~FP_X_DNML;
73 #endif
74
75 #ifdef FP_X_DZ
76 if (trap & GFC_FPE_ZERO)
77 cw |= FP_X_DZ;
78 if (notrap & GFC_FPE_ZERO)
79 cw &= ~FP_X_DZ;
80 #endif
81
82 #ifdef FP_X_OFL
83 if (trap & GFC_FPE_OVERFLOW)
84 cw |= FP_X_OFL;
85 if (notrap & GFC_FPE_OVERFLOW)
86 cw &= ~FP_X_OFL;
87 #endif
88
89 #ifdef FP_X_UFL
90 if (trap & GFC_FPE_UNDERFLOW)
91 cw |= FP_X_UFL;
92 if (notrap & GFC_FPE_UNDERFLOW)
93 cw &= ~FP_X_UFL;
94 #endif
95
96 #ifdef FP_X_IMP
97 if (trap & GFC_FPE_INEXACT)
98 cw |= FP_X_IMP;
99 if (notrap & GFC_FPE_INEXACT)
100 cw &= ~FP_X_IMP;
101 #endif
102
103 fpsetmask(cw);
104 }
105
106
107 int
108 get_fpu_trap_exceptions (void)
109 {
110 int res = 0;
111 FP_EXCEPT_TYPE cw = fpgetmask();
112
113 #ifdef FP_X_INV
114 if (cw & FP_X_INV) res |= GFC_FPE_INVALID;
115 #endif
116
117 #ifdef FP_X_DNML
118 if (cw & FP_X_DNML) res |= GFC_FPE_DENORMAL;
119 #endif
120
121 #ifdef FP_X_DZ
122 if (cw & FP_X_DZ) res |= GFC_FPE_ZERO;
123 #endif
124
125 #ifdef FP_X_OFL
126 if (cw & FP_X_OFL) res |= GFC_FPE_OVERFLOW;
127 #endif
128
129 #ifdef FP_X_UFL
130 if (cw & FP_X_UFL) res |= GFC_FPE_UNDERFLOW;
131 #endif
132
133 #ifdef FP_X_IMP
134 if (cw & FP_X_IMP) res |= GFC_FPE_INEXACT;
135 #endif
136
137 return res;
138 }
139
140
141 int
142 support_fpu_trap (int flag)
143 {
144 return support_fpu_flag (flag);
145 }
146
147
148 void
149 set_fpu (void)
150 {
151 #ifndef FP_X_INV
152 if (options.fpe & GFC_FPE_INVALID)
153 estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
154 "exception not supported.\n");
155 #endif
156
157 #ifndef FP_X_DNML
158 if (options.fpe & GFC_FPE_DENORMAL)
159 estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
160 "exception not supported.\n");
161 #endif
162
163 #ifndef FP_X_DZ
164 if (options.fpe & GFC_FPE_ZERO)
165 estr_write ("Fortran runtime warning: IEEE 'division by zero' "
166 "exception not supported.\n");
167 #endif
168
169 #ifndef FP_X_OFL
170 if (options.fpe & GFC_FPE_OVERFLOW)
171 estr_write ("Fortran runtime warning: IEEE 'overflow' "
172 "exception not supported.\n");
173 #endif
174
175 #ifndef FP_X_UFL
176 if (options.fpe & GFC_FPE_UNDERFLOW)
177 estr_write ("Fortran runtime warning: IEEE 'underflow' "
178 "exception not supported.\n");
179 #endif
180
181 #ifndef FP_X_IMP
182 if (options.fpe & GFC_FPE_INEXACT)
183 estr_write ("Fortran runtime warning: IEEE 'inexact' "
184 "exception not supported.\n");
185 #endif
186
187 set_fpu_trap_exceptions (options.fpe, 0);
188 }
189
190
191 int
192 get_fpu_except_flags (void)
193 {
194 int result;
195 FP_EXCEPT_TYPE set_excepts;
196
197 result = 0;
198 set_excepts = fpgetsticky ();
199
200 #ifdef FP_X_INV
201 if (set_excepts & FP_X_INV)
202 result |= GFC_FPE_INVALID;
203 #endif
204
205 #ifdef FP_X_DZ
206 if (set_excepts & FP_X_DZ)
207 result |= GFC_FPE_ZERO;
208 #endif
209
210 #ifdef FP_X_OFL
211 if (set_excepts & FP_X_OFL)
212 result |= GFC_FPE_OVERFLOW;
213 #endif
214
215 #ifdef FP_X_UFL
216 if (set_excepts & FP_X_UFL)
217 result |= GFC_FPE_UNDERFLOW;
218 #endif
219
220 #ifdef FP_X_DNML
221 if (set_excepts & FP_X_DNML)
222 result |= GFC_FPE_DENORMAL;
223 #endif
224
225 #ifdef FP_X_IMP
226 if (set_excepts & FP_X_IMP)
227 result |= GFC_FPE_INEXACT;
228 #endif
229
230 return result;
231 }
232
233
234 void
235 set_fpu_except_flags (int set, int clear)
236 {
237 FP_EXCEPT_TYPE flags;
238
239 flags = fpgetsticky ();
240
241 #ifdef FP_X_INV
242 if (set & GFC_FPE_INVALID)
243 flags |= FP_X_INV;
244 if (clear & GFC_FPE_INVALID)
245 flags &= ~FP_X_INV;
246 #endif
247
248 #ifdef FP_X_DZ
249 if (set & GFC_FPE_ZERO)
250 flags |= FP_X_DZ;
251 if (clear & GFC_FPE_ZERO)
252 flags &= ~FP_X_DZ;
253 #endif
254
255 #ifdef FP_X_OFL
256 if (set & GFC_FPE_OVERFLOW)
257 flags |= FP_X_OFL;
258 if (clear & GFC_FPE_OVERFLOW)
259 flags &= ~FP_X_OFL;
260 #endif
261
262 #ifdef FP_X_UFL
263 if (set & GFC_FPE_UNDERFLOW)
264 flags |= FP_X_UFL;
265 if (clear & GFC_FPE_UNDERFLOW)
266 flags &= ~FP_X_UFL;
267 #endif
268
269 #ifdef FP_X_DNML
270 if (set & GFC_FPE_DENORMAL)
271 flags |= FP_X_DNML;
272 if (clear & GFC_FPE_DENORMAL)
273 flags &= ~FP_X_DNML;
274 #endif
275
276 #ifdef FP_X_IMP
277 if (set & GFC_FPE_INEXACT)
278 flags |= FP_X_IMP;
279 if (clear & GFC_FPE_INEXACT)
280 flags &= ~FP_X_IMP;
281 #endif
282
283 FPSETSTICKY (flags);
284 }
285
286
287 int
288 support_fpu_flag (int flag)
289 {
290 if (flag & GFC_FPE_INVALID)
291 {
292 #ifndef FP_X_INV
293 return 0;
294 #endif
295 }
296 else if (flag & GFC_FPE_ZERO)
297 {
298 #ifndef FP_X_DZ
299 return 0;
300 #endif
301 }
302 else if (flag & GFC_FPE_OVERFLOW)
303 {
304 #ifndef FP_X_OFL
305 return 0;
306 #endif
307 }
308 else if (flag & GFC_FPE_UNDERFLOW)
309 {
310 #ifndef FP_X_UFL
311 return 0;
312 #endif
313 }
314 else if (flag & GFC_FPE_DENORMAL)
315 {
316 #ifndef FP_X_DNML
317 return 0;
318 #endif
319 }
320 else if (flag & GFC_FPE_INEXACT)
321 {
322 #ifndef FP_X_IMP
323 return 0;
324 #endif
325 }
326
327 return 1;
328 }
329
330
331 int
332 get_fpu_rounding_mode (void)
333 {
334 switch (fpgetround ())
335 {
336 case FP_RN:
337 return GFC_FPE_TONEAREST;
338 case FP_RP:
339 return GFC_FPE_UPWARD;
340 case FP_RM:
341 return GFC_FPE_DOWNWARD;
342 case FP_RZ:
343 return GFC_FPE_TOWARDZERO;
344 default:
345 return 0; /* Should be unreachable. */
346 }
347 }
348
349
350 void
351 set_fpu_rounding_mode (int mode)
352 {
353 FP_RND_TYPE rnd_mode;
354
355 switch (mode)
356 {
357 case GFC_FPE_TONEAREST:
358 rnd_mode = FP_RN;
359 break;
360 case GFC_FPE_UPWARD:
361 rnd_mode = FP_RP;
362 break;
363 case GFC_FPE_DOWNWARD:
364 rnd_mode = FP_RM;
365 break;
366 case GFC_FPE_TOWARDZERO:
367 rnd_mode = FP_RZ;
368 break;
369 default:
370 return; /* Should be unreachable. */
371 }
372 fpsetround (rnd_mode);
373 }
374
375
376 int
377 support_fpu_rounding_mode (int mode)
378 {
379 if (mode == GFC_FPE_AWAY)
380 return 0;
381 else
382 return 1;
383 }
384
385
386 typedef struct
387 {
388 FP_EXCEPT_TYPE mask;
389 FP_EXCEPT_TYPE sticky;
390 FP_RND_TYPE round;
391 } fpu_state_t;
392
393
394 /* Check we can actually store the FPU state in the allocated size. */
395 _Static_assert (sizeof(fpu_state_t) <= (size_t) GFC_FPE_STATE_BUFFER_SIZE,
396 "GFC_FPE_STATE_BUFFER_SIZE is too small");
397
398
399 void
400 get_fpu_state (void *s)
401 {
402 fpu_state_t *state = s;
403
404 state->mask = fpgetmask ();
405 state->sticky = fpgetsticky ();
406 state->round = fpgetround ();
407 }
408
409 void
410 set_fpu_state (void *s)
411 {
412 fpu_state_t *state = s;
413
414 fpsetmask (state->mask);
415 FPSETSTICKY (state->sticky);
416 fpsetround (state->round);
417 }
418
419
420 int
421 support_fpu_underflow_control (int kind __attribute__((unused)))
422 {
423 return 0;
424 }
425
426
427 int
428 get_fpu_underflow_mode (void)
429 {
430 return 0;
431 }
432
433
434 void
435 set_fpu_underflow_mode (int gradual __attribute__((unused)))
436 {
437 }
438