aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/testsuite/ChangeLog4
-rw-r--r--gcc/testsuite/gfortran.dg/ieee/underflow_1.f9050
-rw-r--r--libgfortran/ChangeLog9
-rw-r--r--libgfortran/config/fpu-387.h50
-rw-r--r--libgfortran/config/fpu-aix.h20
-rw-r--r--libgfortran/config/fpu-generic.h21
-rw-r--r--libgfortran/config/fpu-glibc.h50
-rw-r--r--libgfortran/config/fpu-sysv.h20
-rw-r--r--libgfortran/ieee/ieee_arithmetic.F90107
-rw-r--r--libgfortran/libgfortran.h9
10 files changed, 313 insertions, 27 deletions
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b2e6a01..e4cd3bc 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2014-07-09 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ * gfortran.dg/ieee/underflow_1.f90: New file.
+
2014-07-09 Richard Biener <rguenther@suse.de>
PR c-family/61741
diff --git a/gcc/testsuite/gfortran.dg/ieee/underflow_1.f90 b/gcc/testsuite/gfortran.dg/ieee/underflow_1.f90
new file mode 100644
index 0000000..b77a90c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/underflow_1.f90
@@ -0,0 +1,50 @@
+! { dg-do run }
+! { dg-require-effective-target sse2_runtime { target { i?86-*-* x86_64-*-* } } }
+! { dg-additional-options "-msse2 -mfpmath=sse" { target { i?86-*-* x86_64-*-* } } }
+
+program test_underflow_control
+ use ieee_arithmetic
+ use iso_fortran_env
+
+ logical l
+ real, volatile :: x
+ double precision, volatile :: y
+ integer, parameter :: kx = kind(x), ky = kind(y)
+
+ if (ieee_support_underflow_control(x)) then
+
+ x = tiny(x)
+ call ieee_set_underflow_mode(.true.)
+ x = x / 2000._kx
+ if (x == 0) call abort
+ call ieee_get_underflow_mode(l)
+ if (.not. l) call abort
+
+ x = tiny(x)
+ call ieee_set_underflow_mode(.false.)
+ x = x / 2000._kx
+ if (x > 0) call abort
+ call ieee_get_underflow_mode(l)
+ if (l) call abort
+
+ end if
+
+ if (ieee_support_underflow_control(y)) then
+
+ y = tiny(y)
+ call ieee_set_underflow_mode(.true.)
+ y = y / 2000._ky
+ if (y == 0) call abort
+ call ieee_get_underflow_mode(l)
+ if (.not. l) call abort
+
+ y = tiny(y)
+ call ieee_set_underflow_mode(.false.)
+ y = y / 2000._ky
+ if (y > 0) call abort
+ call ieee_get_underflow_mode(l)
+ if (l) call abort
+
+ end if
+
+end program
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index e57f34e..245e6db 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,12 @@
+2014-07-09 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ * libgfortran.h (support_fpu_underflow_control,
+ get_fpu_underflow_mode, set_fpu_underflow_mode): New prototypes.
+ * config/fpu-*.h (support_fpu_underflow_control,
+ get_fpu_underflow_mode, set_fpu_underflow_mode):
+ New functions.
+ * ieee/ieee_arithmetic.F90: Support underflow control.
+
2014-07-08 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* config/fpu-sysv.h (get_fpu_rounding_mode): Use FP_RN, FP_RP,
diff --git a/libgfortran/config/fpu-387.h b/libgfortran/config/fpu-387.h
index 2c5a5fc..201173e 100644
--- a/libgfortran/config/fpu-387.h
+++ b/libgfortran/config/fpu-387.h
@@ -62,6 +62,11 @@ has_sse (void)
#define _FPU_RC_MASK 0x3
+/* Enable flush to zero mode. */
+
+#define MXCSR_FTZ (1 << 15)
+
+
/* This structure corresponds to the layout of the block
written by FSTENV. */
typedef struct
@@ -82,7 +87,6 @@ typedef struct
}
my_fenv_t;
-
/* Check we can actually store the FPU state in the allocated size. */
_Static_assert (sizeof(my_fenv_t) <= (size_t) GFC_FPE_STATE_BUFFER_SIZE,
"GFC_FPE_STATE_BUFFER_SIZE is too small");
@@ -455,3 +459,47 @@ set_fpu_state (void *state)
__asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (envp->__mxcsr));
}
+
+int
+support_fpu_underflow_control (int kind)
+{
+ if (!has_sse())
+ return 0;
+
+ return (kind == 4 || kind == 8) ? 1 : 0;
+}
+
+
+int
+get_fpu_underflow_mode (void)
+{
+ unsigned int cw_sse;
+
+ if (!has_sse())
+ return 1;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+
+ /* Return 0 for abrupt underflow (flush to zero), 1 for gradual underflow. */
+ return (cw_sse & MXCSR_FTZ) ? 0 : 1;
+}
+
+
+void
+set_fpu_underflow_mode (int gradual)
+{
+ unsigned int cw_sse;
+
+ if (!has_sse())
+ return;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+
+ if (gradual)
+ cw_sse &= ~MXCSR_FTZ;
+ else
+ cw_sse |= MXCSR_FTZ;
+
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+}
+
diff --git a/libgfortran/config/fpu-aix.h b/libgfortran/config/fpu-aix.h
index c297045..aec7756 100644
--- a/libgfortran/config/fpu-aix.h
+++ b/libgfortran/config/fpu-aix.h
@@ -417,3 +417,23 @@ set_fpu_state (void *state)
fesetenv (state);
}
+
+int
+support_fpu_underflow_control (int kind __attribute__((unused)))
+{
+ return 0;
+}
+
+
+int
+get_fpu_underflow_mode (void)
+{
+ return 0;
+}
+
+
+void
+set_fpu_underflow_mode (int gradual __attribute__((unused)))
+{
+}
+
diff --git a/libgfortran/config/fpu-generic.h b/libgfortran/config/fpu-generic.h
index bbad875..e739cd7 100644
--- a/libgfortran/config/fpu-generic.h
+++ b/libgfortran/config/fpu-generic.h
@@ -75,3 +75,24 @@ void
set_fpu_rounding_mode (int round __attribute__((unused)))
{
}
+
+
+int
+support_fpu_underflow_control (int kind __attribute__((unused)))
+{
+ return 0;
+}
+
+
+int
+get_fpu_underflow_mode (void)
+{
+ return 0;
+}
+
+
+void
+set_fpu_underflow_mode (int gradual __attribute__((unused)))
+{
+}
+
diff --git a/libgfortran/config/fpu-glibc.h b/libgfortran/config/fpu-glibc.h
index b6ea120..149e8a3 100644
--- a/libgfortran/config/fpu-glibc.h
+++ b/libgfortran/config/fpu-glibc.h
@@ -429,3 +429,53 @@ set_fpu_state (void *state)
fesetenv (state);
}
+
+/* Underflow in glibc is currently only supported on alpha, through
+ the FE_MAP_UMZ macro and __ieee_set_fp_control() function call. */
+
+int
+support_fpu_underflow_control (int kind __attribute__((unused)))
+{
+#if defined(__alpha__) && defined(FE_MAP_UMZ)
+ return (kind == 4 || kind == 8) ? 1 : 0;
+#else
+ return 0;
+#endif
+}
+
+
+int
+get_fpu_underflow_mode (void)
+{
+#if defined(__alpha__) && defined(FE_MAP_UMZ)
+
+ fenv_t state = __ieee_get_fp_control ();
+
+ /* Return 0 for abrupt underflow (flush to zero), 1 for gradual underflow. */
+ return (state & FE_MAP_UMZ) ? 0 : 1;
+
+#else
+
+ return 0;
+
+#endif
+}
+
+
+void
+set_fpu_underflow_mode (int gradual __attribute__((unused)))
+{
+#if defined(__alpha__) && defined(FE_MAP_UMZ)
+
+ fenv_t state = __ieee_get_fp_control ();
+
+ if (gradual)
+ state &= ~FE_MAP_UMZ;
+ else
+ state |= FE_MAP_UMZ;
+
+ __ieee_set_fp_control (state);
+
+#endif
+}
+
diff --git a/libgfortran/config/fpu-sysv.h b/libgfortran/config/fpu-sysv.h
index 559e3f3..225f591 100644
--- a/libgfortran/config/fpu-sysv.h
+++ b/libgfortran/config/fpu-sysv.h
@@ -425,3 +425,23 @@ set_fpu_state (void *s)
fpsetround (state->round);
}
+
+int
+support_fpu_underflow_control (int kind __attribute__((unused)))
+{
+ return 0;
+}
+
+
+int
+get_fpu_underflow_mode (void)
+{
+ return 0;
+}
+
+
+void
+set_fpu_underflow_mode (int gradual __attribute__((unused)))
+{
+}
+
diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90
index 1dce4f7..22ff55b 100644
--- a/libgfortran/ieee/ieee_arithmetic.F90
+++ b/libgfortran/ieee/ieee_arithmetic.F90
@@ -349,6 +349,29 @@ module IEEE_ARITHMETIC
end function
end interface
+ ! IEEE_SUPPORT_UNDERFLOW_CONTROL
+
+ interface IEEE_SUPPORT_UNDERFLOW_CONTROL
+ module procedure IEEE_SUPPORT_UNDERFLOW_CONTROL_4, &
+ IEEE_SUPPORT_UNDERFLOW_CONTROL_8, &
+#ifdef HAVE_GFC_REAL_10
+ IEEE_SUPPORT_UNDERFLOW_CONTROL_10, &
+#endif
+#ifdef HAVE_GFC_REAL_16
+ IEEE_SUPPORT_UNDERFLOW_CONTROL_16, &
+#endif
+ IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG
+ end interface
+ public :: IEEE_SUPPORT_UNDERFLOW_CONTROL
+
+ ! Interface to the FPU-specific function
+ interface
+ pure integer function support_underflow_control_helper(kind) &
+ bind(c, name="_gfortrani_support_fpu_underflow_control")
+ integer, intent(in), value :: kind
+ end function
+ end interface
+
! IEEE_SUPPORT_* generic functions
#if defined(HAVE_GFC_REAL_10) && defined(HAVE_GFC_REAL_16)
@@ -373,7 +396,6 @@ SUPPORTGENERIC(IEEE_SUPPORT_IO)
SUPPORTGENERIC(IEEE_SUPPORT_NAN)
SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
-SUPPORTGENERIC(IEEE_SUPPORT_UNDERFLOW_CONTROL)
contains
@@ -560,7 +582,6 @@ contains
subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE)
implicit none
type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE
- integer :: i
interface
integer function helper() &
@@ -568,9 +589,7 @@ contains
end function
end interface
- ! FIXME: Use intermediate variable i to avoid triggering PR59023
- i = helper()
- ROUND_VALUE = IEEE_ROUND_TYPE(i)
+ ROUND_VALUE = IEEE_ROUND_TYPE(helper())
end subroutine
@@ -596,10 +615,14 @@ contains
subroutine IEEE_GET_UNDERFLOW_MODE (GRADUAL)
implicit none
logical, intent(out) :: GRADUAL
- ! We do not support getting/setting underflow mode yet. We still
- ! provide the procedures to avoid link-time error if a user program
- ! uses it protected by a call to IEEE_SUPPORT_UNDERFLOW_CONTROL
- call abort
+
+ interface
+ integer function helper() &
+ bind(c, name="_gfortrani_get_fpu_underflow_mode")
+ end function
+ end interface
+
+ GRADUAL = (helper() /= 0)
end subroutine
@@ -608,10 +631,15 @@ contains
subroutine IEEE_SET_UNDERFLOW_MODE (GRADUAL)
implicit none
logical, intent(in) :: GRADUAL
- ! We do not support getting/setting underflow mode yet. We still
- ! provide the procedures to avoid link-time error if a user program
- ! uses it protected by a call to IEEE_SUPPORT_UNDERFLOW_CONTROL
- call abort
+
+ interface
+ subroutine helper(val) &
+ bind(c, name="_gfortrani_set_fpu_underflow_mode")
+ integer, value :: val
+ end subroutine
+ end interface
+
+ call helper(merge(1, 0, GRADUAL))
end subroutine
! IEEE_SUPPORT_ROUNDING
@@ -658,6 +686,46 @@ contains
#endif
end function
+! IEEE_SUPPORT_UNDERFLOW_CONTROL
+
+ pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_4 (X) result(res)
+ implicit none
+ real(kind=4), intent(in) :: X
+ res = (support_underflow_control_helper(4) /= 0)
+ end function
+
+ pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_8 (X) result(res)
+ implicit none
+ real(kind=8), intent(in) :: X
+ res = (support_underflow_control_helper(8) /= 0)
+ end function
+
+#ifdef HAVE_GFC_REAL_10
+ pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_10 (X) result(res)
+ implicit none
+ real(kind=10), intent(in) :: X
+ res = .false.
+ end function
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+ pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_16 (X) result(res)
+ implicit none
+ real(kind=16), intent(in) :: X
+ res = .false.
+ end function
+#endif
+
+ pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG () result(res)
+ implicit none
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+ res = .false.
+#else
+ res = (support_underflow_control_helper(4) /= 0 &
+ .and. support_underflow_control_helper(8) /= 0)
+#endif
+ end function
+
! IEEE_SUPPORT_* functions
#define SUPPORTMACRO(NAME, INTKIND, VALUE) \
@@ -801,17 +869,4 @@ SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.false.)
SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.)
#endif
-! IEEE_SUPPORT_UNDERFLOW_CONTROL
-
-SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,4,.false.)
-SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,8,.false.)
-#ifdef HAVE_GFC_REAL_10
-SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,10,.false.)
-#endif
-#ifdef HAVE_GFC_REAL_16
-SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,16,.false.)
-#endif
-SUPPORTMACRO_NOARG(IEEE_SUPPORT_UNDERFLOW_CONTROL,.false.)
-
-
end module IEEE_ARITHMETIC
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index dbc3f29..d2de76f 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -775,6 +775,15 @@ internal_proto(get_fpu_state);
extern void set_fpu_state (void *);
internal_proto(set_fpu_state);
+extern int get_fpu_underflow_mode (void);
+internal_proto(get_fpu_underflow_mode);
+
+extern void set_fpu_underflow_mode (int);
+internal_proto(set_fpu_underflow_mode);
+
+extern int support_fpu_underflow_control (int);
+internal_proto(support_fpu_underflow_control);
+
/* memory.c */
extern void *xmalloc (size_t) __attribute__ ((malloc));
generated by cgit v1.1 at 2024-11-12 19:46:34 +0000