OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

libgfortran.h (support_fpu_underflow_control, [...]): New prototypes. 

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

From-SVN: r212407
This commit is contained in:
Francois-Xavier Coudert 2014-07-09 20:32:12 +00:00 committed by François-Xavier Coudert
parent 958c1d61b1
commit f5168e47a8
10 changed files with 313 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/testsuite/ChangeLog
View File

@ -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

50
gcc/testsuite/gfortran.dg/ieee/underflow_1.f90 Normal file
View File

@ -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

9
libgfortran/ChangeLog
View File

@ -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,

50
libgfortran/config/fpu-387.h
View File

@ -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));
}

20
libgfortran/config/fpu-aix.h
View File

@ -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)))
{
}

21
libgfortran/config/fpu-generic.h
View File

@ -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)))
{
}

50
libgfortran/config/fpu-glibc.h
View File

@ -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
}

20
libgfortran/config/fpu-sysv.h
View File

@ -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)))
{
}

107
libgfortran/ieee/ieee_arithmetic.F90
View File

@ -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

9
libgfortran/libgfortran.h
View File

@ -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));