* 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.

	* gfortran.dg/ieee/underflow_1.f90: New file.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@212407 138bc75d-0d04-0410-961f-82ee72b054a4

8 files changed, 259 insertions, 27 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index e57f34e711d..245e6dbed5b 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 2c5a5fcc6fa..201173e5813 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 c2970452bc1..aec7756fda5 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 bbad875f40e..e739cd7bc26 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 b6ea1203a62..149e8a3ac92 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 559e3f34348..225f591af72 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 1dce4f79ee4..22ff55b9a80 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 dbc3f29cd60..d2de76fcb92 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));