+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
--- /dev/null
+! { 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
+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,
#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
}
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");
__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));
+}
+
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)))
+{
+}
+
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)))
+{
+}
+
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
+}
+
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)))
+{
+}
+
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)
SUPPORTGENERIC(IEEE_SUPPORT_NAN)
SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
-SUPPORTGENERIC(IEEE_SUPPORT_UNDERFLOW_CONTROL)
contains
subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE)
implicit none
type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE
- integer :: i
interface
integer function helper() &
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
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
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
#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) \
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
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));
projects / thirdparty / gcc.git / commitdiff
