1/* SysV FPU-related code (for systems not otherwise supported).
2   Copyright (C) 2005-2020 Free Software Foundation, Inc.
3   Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr>
4
5This file is part of the GNU Fortran runtime library (libgfortran).
6
7Libgfortran is free software; you can redistribute it and/or
8modify it under the terms of the GNU General Public
9License as published by the Free Software Foundation; either
10version 3 of the License, or (at your option) any later version.
11
12Libgfortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.
16
17Under Section 7 of GPL version 3, you are granted additional
18permissions described in the GCC Runtime Library Exception, version
193.1, as published by the Free Software Foundation.
20
21You should have received a copy of the GNU General Public License and
22a copy of the GCC Runtime Library Exception along with this program;
23see 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
56void
57set_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
107int
108get_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
141int
142support_fpu_trap (int flag)
143{
144  return support_fpu_flag (flag);
145}
146
147
148void
149set_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
191int
192get_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
234void
235set_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
287int
288support_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
331int
332get_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
350void
351set_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
376int
377support_fpu_rounding_mode (int mode __attribute__((unused)))
378{
379  return 1;
380}
381
382
383typedef struct
384{
385  FP_EXCEPT_TYPE mask;
386  FP_EXCEPT_TYPE sticky;
387  FP_RND_TYPE round;
388} fpu_state_t;
389
390
391/* Check we can actually store the FPU state in the allocated size.  */
392_Static_assert (sizeof(fpu_state_t) <= (size_t) GFC_FPE_STATE_BUFFER_SIZE,
393		"GFC_FPE_STATE_BUFFER_SIZE is too small");
394
395
396void
397get_fpu_state (void *s)
398{
399  fpu_state_t *state = s;
400
401  state->mask = fpgetmask ();
402  state->sticky = fpgetsticky ();
403  state->round = fpgetround ();
404}
405
406void
407set_fpu_state (void *s)
408{
409  fpu_state_t *state = s;
410
411  fpsetmask (state->mask);
412  FPSETSTICKY (state->sticky);
413  fpsetround (state->round);
414}
415
416
417int
418support_fpu_underflow_control (int kind __attribute__((unused)))
419{
420  return 0;
421}
422
423
424int
425get_fpu_underflow_mode (void)
426{
427  return 0;
428}
429
430
431void
432set_fpu_underflow_mode (int gradual __attribute__((unused)))
433{
434}
435
436