public inbox for gcc-patches@gcc.gnu.org
 help / color / mirror / Atom feed
* [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions
@ 2022-08-31 13:46 FX
  2022-08-31 14:22 ` FX
  0 siblings, 1 reply; 10+ messages in thread
From: FX @ 2022-08-31 13:46 UTC (permalink / raw)
  To: fortran; +Cc: gcc-patches

[-- Attachment #1: Type: text/plain, Size: 689 bytes --]

Hi,

These functions were added in Fortran 2018: https://gcc.gnu.org/wiki/Fortran2018Status
When it comes to floating-point and IEEE compliance, gfortran fully implements the 2003 and 2008 standards. In a series of patch, as time permits, I would like to add all Fortran 2018 features before the GCC 13 release process begins.

Regarding this patch, the functions are added to the IEEE_ARITHMETIC module, but are entirely expanded in the front-end, using GCC built-ins. They will benefit fully from middle-end optimisation where relevant, and on many targets FMA will reduce to a single instruction (as expected).

Regression-tested on x86_64-pc-linux-gnu. OK to commit?

FX



[-- Attachment #2: 0001-fortran-Add-IEEE_SIGNBIT-and-IEEE_FMA-functions.patch --]
[-- Type: application/octet-stream, Size: 17948 bytes --]

From 1d4c907467001b6ad1f09cdf3615f675ece650df Mon Sep 17 00:00:00 2001
From: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Date: Wed, 31 Aug 2022 15:22:50 +0200
Subject: [PATCH] fortran: Add IEEE_SIGNBIT and IEEE_FMA functions

The functions are added to the IEEE_ARITHMETIC module, but
are entirely expanded in the front-end, using GCC built-ins.

2022-08-31  Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>

	PR fortran/95644

gcc/fortran/
	* f95-lang.cc (gfc_init_builtin_functions): Declare FMA
	built-ins.
	* mathbuiltins.def: Declare FMA built-ins.
	* trans-intrinsic.cc (conv_intrinsic_ieee_fma): New function.
	(conv_intrinsic_ieee_signbit): New function.
	(gfc_build_intrinsic_lib_fndecls): Add cases for FMA and
	SIGNBIT.

gcc/testsuite/
	* gfortran.dg/ieee/fma_1.f90: New test.
	* gfortran.dg/ieee/signbit_1.f90: New test.

libgfortran/
	* ieee/ieee_arithmetic.F90: Add IEEE_SIGNBIT and IEEE_FMA.
---
 gcc/fortran/f95-lang.cc                      |  16 ++
 gcc/fortran/mathbuiltins.def                 |   1 +
 gcc/fortran/trans-intrinsic.cc               |  51 +++++-
 gcc/testsuite/gfortran.dg/ieee/fma_1.f90     | 100 +++++++++++
 gcc/testsuite/gfortran.dg/ieee/signbit_1.f90 | 166 +++++++++++++++++++
 libgfortran/ieee/ieee_arithmetic.F90         |  66 ++++++++
 6 files changed, 398 insertions(+), 2 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/ieee/fma_1.f90
 create mode 100644 gcc/testsuite/gfortran.dg/ieee/signbit_1.f90

diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 10ac8a95b87..ff4bf800e49 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -1281,6 +1281,22 @@ gfc_init_builtin_functions (void)
 		      "__builtin_assume_aligned",
 		      ATTR_CONST_NOTHROW_LEAF_LIST);
 
+  ftype = build_function_type_list (long_double_type_node, long_double_type_node,
+				    long_double_type_node, long_double_type_node,
+				    NULL_TREE);
+  gfc_define_builtin ("__builtin_fmal", ftype, BUILT_IN_FMAL,
+		      "fmal", ATTR_CONST_NOTHROW_LEAF_LIST);
+  ftype = build_function_type_list (double_type_node, double_type_node,
+				    double_type_node, double_type_node,
+				    NULL_TREE);
+  gfc_define_builtin ("__builtin_fma", ftype, BUILT_IN_FMA,
+		      "fma", ATTR_CONST_NOTHROW_LEAF_LIST);
+  ftype = build_function_type_list (float_type_node, float_type_node,
+				    float_type_node, float_type_node,
+				    NULL_TREE);
+  gfc_define_builtin ("__builtin_fmaf", ftype, BUILT_IN_FMAF,
+		      "fmaf", ATTR_CONST_NOTHROW_LEAF_LIST);
+
   gfc_define_builtin ("__emutls_get_address",
 		      builtin_types[BT_FN_PTR_PTR],
 		      BUILT_IN_EMUTLS_GET_ADDRESS,
diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def
index 615214ebcd6..9d55c34cda8 100644
--- a/gcc/fortran/mathbuiltins.def
+++ b/gcc/fortran/mathbuiltins.def
@@ -60,6 +60,7 @@ OTHER_BUILTIN (CABS,      "cabs",      cabs,    true)
 OTHER_BUILTIN (COPYSIGN,  "copysign",  2,       true)
 OTHER_BUILTIN (CPOW,      "cpow",      cpow,    true)
 OTHER_BUILTIN (FABS,      "fabs",      1,       true)
+OTHER_BUILTIN (FMA,       "fma",       3,       true)
 OTHER_BUILTIN (FMOD,      "fmod",      2,       true)
 OTHER_BUILTIN (FREXP,     "frexp",     frexp,   false)
 OTHER_BUILTIN (LOGB,      "logb",      1,       true)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index ec116fff26e..bb938026828 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -695,7 +695,7 @@ gfc_build_intrinsic_lib_fndecls (void)
        C99-like library functions.  For now, we only handle _Float128
        q-suffixed or IEC 60559 f128-suffixed functions.  */
 
-    tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
+    tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
     tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
 
     memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
@@ -715,6 +715,8 @@ gfc_build_intrinsic_lib_fndecls (void)
 					     type, NULL_TREE);
     /* type (*) (type, type) */
     func_2 = build_function_type_list (type, type, type, NULL_TREE);
+    /* type (*) (type, type, type) */
+    func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
     /* type (*) (type, &int) */
     func_frexp
       = build_function_type_list (type,
@@ -9781,7 +9783,7 @@ conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
 }
 
 
-/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
+/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
    and IEEE_UNORDERED, which translate directly to GCC type-generic
    built-ins.  */
 
@@ -9801,6 +9803,23 @@ conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
 }
 
 
+/* Generate code for intrinsics IEEE_SIGNBIT.  */
+
+static void
+conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
+{
+  tree arg, signbit;
+
+  conv_ieee_function_args (se, expr, &arg, 1);
+  signbit = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_SIGNBIT),
+				 1, arg);
+  signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			     signbit, integer_zero_node);
+  se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
+}
+
+
 /* Generate code for IEEE_IS_NORMAL intrinsic:
      IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0)  */
 
@@ -10207,6 +10226,30 @@ conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
 }
 
 
+/* Generate code for IEEE_FMA.  */
+
+static void
+conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
+{
+  tree args[3], decl, call;
+  int argprec;
+
+  conv_ieee_function_args (se, expr, args, 3);
+
+  /* All three arguments should have the same type.  */
+  gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
+  gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
+
+  /* Call the type-generic FMA built-in.  */
+  argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
+  decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
+  call = build_call_expr_loc_array (input_location, decl, 3, args);
+
+  /* Convert to the final type.  */
+  se->expr = fold_convert (TREE_TYPE (args[0]), call);
+}
+
+
 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
    module.  */
 
@@ -10221,6 +10264,8 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
     conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
   else if (startswith (name, "_gfortran_ieee_unordered"))
     conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
+  else if (startswith (name, "_gfortran_ieee_signbit"))
+    conv_intrinsic_ieee_signbit (se, expr);
   else if (startswith (name, "_gfortran_ieee_is_normal"))
     conv_intrinsic_ieee_is_normal (se, expr);
   else if (startswith (name, "_gfortran_ieee_is_negative"))
@@ -10241,6 +10286,8 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
     conv_intrinsic_ieee_class (se, expr);
   else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
     conv_intrinsic_ieee_value (se, expr);
+  else if (startswith (name, "_gfortran_ieee_fma"))
+    conv_intrinsic_ieee_fma (se, expr);
   else
     /* It is not among the functions we translate directly.  We return
        false, so a library function call is emitted.  */
diff --git a/gcc/testsuite/gfortran.dg/ieee/fma_1.f90 b/gcc/testsuite/gfortran.dg/ieee/fma_1.f90
new file mode 100644
index 00000000000..28fcd642861
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/fma_1.f90
@@ -0,0 +1,100 @@
+! Test IEEE_FMA
+! { dg-do run }
+
+  use, intrinsic :: ieee_features
+  use, intrinsic :: ieee_exceptions
+  use, intrinsic :: ieee_arithmetic
+  implicit none
+
+  integer :: ex
+
+  real :: sx1, sx2, sx3
+  double precision :: dx1, dx2, dx3
+
+  ! k1 and k2 will be large real kinds, if supported, and single/double
+  ! otherwise
+  integer, parameter :: k1 = &
+    max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.))
+  integer, parameter :: k2 = &
+    max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0))
+
+  real(kind=k1) :: lx1, lx2, lx3
+  real(kind=k2) :: wx1, wx2, wx3
+
+  ! Float
+
+  sx1 = 3 ; sx2 = 2 ; sx3 = 1
+  if (ieee_fma(sx1, sx2, sx3) /= 7) stop 1
+  sx1 = 0 ; sx2 = 2 ; sx3 = 1
+  if (ieee_fma(sx1, sx2, sx3) /= 1) stop 2
+  sx1 = 3 ; sx2 = 2 ; sx3 = 0
+  if (ieee_fma(sx1, sx2, sx3) /= 6) stop 3
+
+  ex = int(log(rrspacing(real(1, kind(sx1)))) / log(real(2, kind(sx1)))) - 1
+  sx1 = 1 + spacing(real(1, kind(sx1)))
+  sx2 = 2 ; sx2 = sx2 ** ex ; sx2 = sx2 * 3
+  sx3 = -sx2
+
+  print *, sx1 * sx2 + sx3
+  print *, ieee_fma(sx1, sx2, sx3)
+  if (ieee_fma(sx1, sx2, sx3) /= real(3, kind(sx1)) / 2) stop 4
+  if (ieee_fma(sx1, sx2, sx3) == sx1 * sx2 + sx3) stop 5
+
+  ! Double
+
+  dx1 = 3 ; dx2 = 2 ; dx3 = 1
+  if (ieee_fma(dx1, dx2, dx3) /= 7) stop 1
+  dx1 = 0 ; dx2 = 2 ; dx3 = 1
+  if (ieee_fma(dx1, dx2, dx3) /= 1) stop 2
+  dx1 = 3 ; dx2 = 2 ; dx3 = 0
+  if (ieee_fma(dx1, dx2, dx3) /= 6) stop 3
+
+  ex = int(log(rrspacing(real(1, kind(dx1)))) / log(real(2, kind(dx1)))) - 1
+  dx1 = 1 + spacing(real(1, kind(dx1)))
+  dx2 = 2 ; dx2 = dx2 ** ex ; dx2 = dx2 * 3
+  dx3 = -dx2
+
+  print *, dx1 * dx2 + dx3
+  print *, ieee_fma(dx1, dx2, dx3)
+  if (ieee_fma(dx1, dx2, dx3) /= real(3, kind(dx1)) / 2) stop 4
+  if (ieee_fma(dx1, dx2, dx3) == dx1 * dx2 + dx3) stop 5
+
+  ! Large kind 1
+
+  lx1 = 3 ; lx2 = 2 ; lx3 = 1
+  if (ieee_fma(lx1, lx2, lx3) /= 7) stop 1
+  lx1 = 0 ; lx2 = 2 ; lx3 = 1
+  if (ieee_fma(lx1, lx2, lx3) /= 1) stop 2
+  lx1 = 3 ; lx2 = 2 ; lx3 = 0
+  if (ieee_fma(lx1, lx2, lx3) /= 6) stop 3
+
+  ex = int(log(rrspacing(real(1, kind(lx1)))) / log(real(2, kind(lx1)))) - 1
+  lx1 = 1 + spacing(real(1, kind(lx1)))
+  lx2 = 2 ; lx2 = lx2 ** ex ; lx2 = lx2 * 3
+  lx3 = -lx2
+
+  print *, lx1 * lx2 + lx3
+  print *, ieee_fma(lx1, lx2, lx3)
+  if (ieee_fma(lx1, lx2, lx3) /= real(3, kind(lx1)) / 2) stop 4
+  if (ieee_fma(lx1, lx2, lx3) == lx1 * lx2 + lx3) stop 5
+
+  ! Large kind 2
+
+  wx1 = 3 ; wx2 = 2 ; wx3 = 1
+  if (ieee_fma(wx1, wx2, wx3) /= 7) stop 1
+  wx1 = 0 ; wx2 = 2 ; wx3 = 1
+  if (ieee_fma(wx1, wx2, wx3) /= 1) stop 2
+  wx1 = 3 ; wx2 = 2 ; wx3 = 0
+  if (ieee_fma(wx1, wx2, wx3) /= 6) stop 3
+
+  ex = int(log(rrspacing(real(1, kind(wx1)))) / log(real(2, kind(wx1)))) - 1
+  wx1 = 1 + spacing(real(1, kind(wx1)))
+  wx2 = 2 ; wx2 = wx2 ** ex ; wx2 = wx2 * 3
+  wx3 = -wx2
+
+  print *, wx1 * wx2 + wx3
+  print *, ieee_fma(wx1, wx2, wx3)
+  if (ieee_fma(wx1, wx2, wx3) /= real(3, kind(wx1)) / 2) stop 4
+  if (ieee_fma(wx1, wx2, wx3) == wx1 * wx2 + wx3) stop 5
+
+end
diff --git a/gcc/testsuite/gfortran.dg/ieee/signbit_1.f90 b/gcc/testsuite/gfortran.dg/ieee/signbit_1.f90
new file mode 100644
index 00000000000..5d6e41de739
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/signbit_1.f90
@@ -0,0 +1,166 @@
+! Test IEEE_SIGNBIT
+! { dg-do run }
+
+  use, intrinsic :: ieee_features
+  use, intrinsic :: ieee_exceptions
+  use, intrinsic :: ieee_arithmetic
+  implicit none
+
+  real :: sx1
+  double precision :: dx1
+
+  ! k1 and k2 will be large real kinds, if supported, and single/double
+  ! otherwise
+  integer, parameter :: k1 = &
+    max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.))
+  integer, parameter :: k2 = &
+    max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0))
+
+  real(kind=k1) :: xk1
+  real(kind=k2) :: xk2
+
+  ! Float
+
+  sx1 = 1.3
+  if (ieee_signbit(sx1)) stop 1
+  sx1 = huge(sx1)
+  if (ieee_signbit(sx1)) stop 2
+  sx1 = ieee_value(sx1, ieee_positive_inf)
+  if (ieee_signbit(sx1)) stop 3
+  sx1 = tiny(sx1)
+  if (ieee_signbit(sx1)) stop 4
+  sx1 = tiny(sx1)
+  sx1 = sx1 / 101
+  if (ieee_signbit(sx1)) stop 5
+  sx1 = 0
+  if (ieee_signbit(sx1)) stop 6
+  sx1 = ieee_value(sx1, ieee_quiet_nan)
+  if (ieee_signbit(sx1)) stop 7
+
+  sx1 = -1.3
+  if (.not. ieee_signbit(sx1)) stop 8
+  sx1 = -huge(sx1)
+  if (.not. ieee_signbit(sx1)) stop 9
+  sx1 = -ieee_value(sx1, ieee_positive_inf)
+  if (.not. ieee_signbit(sx1)) stop 10
+  sx1 = -tiny(sx1)
+  if (.not. ieee_signbit(sx1)) stop 11
+  sx1 = -tiny(sx1)
+  sx1 = sx1 / 101
+  if (.not. ieee_signbit(sx1)) stop 12
+  sx1 = 0
+  sx1 = -sx1
+  if (.not. ieee_signbit(sx1)) stop 13
+  sx1 = ieee_value(sx1, ieee_quiet_nan)
+  sx1 = -sx1
+  if (.not. ieee_signbit(sx1)) stop 14
+
+  ! Double
+
+  dx1 = 1.3
+  if (ieee_signbit(dx1)) stop 1
+  dx1 = huge(dx1)
+  if (ieee_signbit(dx1)) stop 2
+  dx1 = ieee_value(dx1, ieee_positive_inf)
+  if (ieee_signbit(dx1)) stop 3
+  dx1 = tiny(dx1)
+  if (ieee_signbit(dx1)) stop 4
+  dx1 = tiny(dx1)
+  dx1 = dx1 / 101
+  if (ieee_signbit(dx1)) stop 5
+  dx1 = 0
+  if (ieee_signbit(dx1)) stop 6
+  dx1 = ieee_value(dx1, ieee_quiet_nan)
+  if (ieee_signbit(dx1)) stop 7
+
+  dx1 = -1.3
+  if (.not. ieee_signbit(dx1)) stop 8
+  dx1 = -huge(dx1)
+  if (.not. ieee_signbit(dx1)) stop 9
+  dx1 = -ieee_value(dx1, ieee_positive_inf)
+  if (.not. ieee_signbit(dx1)) stop 10
+  dx1 = -tiny(dx1)
+  if (.not. ieee_signbit(dx1)) stop 11
+  dx1 = -tiny(dx1)
+  dx1 = dx1 / 101
+  if (.not. ieee_signbit(dx1)) stop 12
+  dx1 = 0
+  dx1 = -dx1
+  if (.not. ieee_signbit(dx1)) stop 13
+  dx1 = ieee_value(dx1, ieee_quiet_nan)
+  dx1 = -dx1
+  if (.not. ieee_signbit(dx1)) stop 14
+
+  ! Large kind 1
+
+  xk1 = 1.3
+  if (ieee_signbit(xk1)) stop 1
+  xk1 = huge(xk1)
+  if (ieee_signbit(xk1)) stop 2
+  xk1 = ieee_value(xk1, ieee_positive_inf)
+  if (ieee_signbit(xk1)) stop 3
+  xk1 = tiny(xk1)
+  if (ieee_signbit(xk1)) stop 4
+  xk1 = tiny(xk1)
+  xk1 = xk1 / 101
+  if (ieee_signbit(xk1)) stop 5
+  xk1 = 0
+  if (ieee_signbit(xk1)) stop 6
+  xk1 = ieee_value(xk1, ieee_quiet_nan)
+  if (ieee_signbit(xk1)) stop 7
+
+  xk1 = -1.3
+  if (.not. ieee_signbit(xk1)) stop 8
+  xk1 = -huge(xk1)
+  if (.not. ieee_signbit(xk1)) stop 9
+  xk1 = -ieee_value(xk1, ieee_positive_inf)
+  if (.not. ieee_signbit(xk1)) stop 10
+  xk1 = -tiny(xk1)
+  if (.not. ieee_signbit(xk1)) stop 11
+  xk1 = -tiny(xk1)
+  xk1 = xk1 / 101
+  if (.not. ieee_signbit(xk1)) stop 12
+  xk1 = 0
+  xk1 = -xk1
+  if (.not. ieee_signbit(xk1)) stop 13
+  xk1 = ieee_value(xk1, ieee_quiet_nan)
+  xk1 = -xk1
+  if (.not. ieee_signbit(xk1)) stop 14
+
+  ! Large kind 2
+
+  xk2 = 1.3
+  if (ieee_signbit(xk2)) stop 1
+  xk2 = huge(xk2)
+  if (ieee_signbit(xk2)) stop 2
+  xk2 = ieee_value(xk2, ieee_positive_inf)
+  if (ieee_signbit(xk2)) stop 3
+  xk2 = tiny(xk2)
+  if (ieee_signbit(xk2)) stop 4
+  xk2 = tiny(xk2)
+  xk2 = xk2 / 101
+  if (ieee_signbit(xk2)) stop 5
+  xk2 = 0
+  if (ieee_signbit(xk2)) stop 6
+  xk2 = ieee_value(xk2, ieee_quiet_nan)
+  if (ieee_signbit(xk2)) stop 7
+
+  xk2 = -1.3
+  if (.not. ieee_signbit(xk2)) stop 8
+  xk2 = -huge(xk2)
+  if (.not. ieee_signbit(xk2)) stop 9
+  xk2 = -ieee_value(xk2, ieee_positive_inf)
+  if (.not. ieee_signbit(xk2)) stop 10
+  xk2 = -tiny(xk2)
+  if (.not. ieee_signbit(xk2)) stop 11
+  xk2 = -tiny(xk2)
+  xk2 = xk2 / 101
+  if (.not. ieee_signbit(xk2)) stop 12
+  xk2 = 0
+  xk2 = -xk2
+  if (.not. ieee_signbit(xk2)) stop 13
+  xk2 = ieee_value(xk2, ieee_quiet_nan)
+  xk2 = -xk2
+  if (.not. ieee_signbit(xk2)) stop 14
+
+end
diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90
index c8ef3e2faeb..4e01aa5504c 100644
--- a/libgfortran/ieee/ieee_arithmetic.F90
+++ b/libgfortran/ieee/ieee_arithmetic.F90
@@ -343,6 +343,39 @@ UNORDERED_MACRO(4,4)
   end interface
   public :: IEEE_UNORDERED
 
+  ! IEEE_FMA
+
+  interface
+    elemental real(kind=4) function _gfortran_ieee_fma_4 (A, B, C)
+      real(kind=4), intent(in) :: A, B, C
+    end function
+    elemental real(kind=8) function _gfortran_ieee_fma_8 (A, B, C)
+      real(kind=8), intent(in) :: A, B, C
+    end function
+#ifdef HAVE_GFC_REAL_10
+    elemental real(kind=10) function _gfortran_ieee_fma_10 (A, B, C)
+      real(kind=10), intent(in) :: A, B, C
+    end function
+#endif
+#ifdef HAVE_GFC_REAL_16
+    elemental real(kind=16) function _gfortran_ieee_fma_16 (A, B, C)
+      real(kind=16), intent(in) :: A, B, C
+    end function
+#endif
+  end interface
+
+  interface IEEE_FMA
+    procedure &
+#ifdef HAVE_GFC_REAL_16
+      _gfortran_ieee_fma_16, &
+#endif
+#ifdef HAVE_GFC_REAL_10
+      _gfortran_ieee_fma_10, &
+#endif
+      _gfortran_ieee_fma_8, _gfortran_ieee_fma_4
+  end interface
+  public :: IEEE_FMA
+
   ! IEEE_LOGB
 
   interface
@@ -702,6 +735,39 @@ REM_MACRO(4,4,4)
   end interface
   public :: IEEE_SCALB
 
+  ! IEEE_SIGNBIT
+
+  interface
+    elemental logical function _gfortran_ieee_signbit_4 (X)
+      real(kind=4), intent(in) :: X
+    end function
+    elemental logical function _gfortran_ieee_signbit_8 (X)
+      real(kind=8), intent(in) :: X
+    end function
+#ifdef HAVE_GFC_REAL_10
+    elemental logical function _gfortran_ieee_signbit_10 (X)
+      real(kind=10), intent(in) :: X
+    end function
+#endif
+#ifdef HAVE_GFC_REAL_16
+    elemental logical function _gfortran_ieee_signbit_16 (X)
+      real(kind=16), intent(in) :: X
+    end function
+#endif
+  end interface
+
+  interface IEEE_SIGNBIT
+    procedure &
+#ifdef HAVE_GFC_REAL_16
+      _gfortran_ieee_signbit_16, &
+#endif
+#ifdef HAVE_GFC_REAL_10
+      _gfortran_ieee_signbit_10, &
+#endif
+      _gfortran_ieee_signbit_8, _gfortran_ieee_signbit_4
+  end interface
+  public :: IEEE_SIGNBIT
+
   ! IEEE_VALUE
 
   interface IEEE_VALUE
-- 
2.25.1


^ permalink raw reply	[flat|nested] 10+ messages in thread

* Re: [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions
  2022-08-31 13:46 [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions FX
@ 2022-08-31 14:22 ` FX
  2022-09-06 13:26   ` FX
  0 siblings, 1 reply; 10+ messages in thread
From: FX @ 2022-08-31 14:22 UTC (permalink / raw)
  To: fortran; +Cc: gcc-patches

[-- Attachment #1: Type: text/plain, Size: 330 bytes --]

Hum, slightly amended patch, after checking 32-bit results on another linux machine.
The test for FMA has been made a bit less strict, because otherwise we have surprised on 387 arithmetic due to excess precision.

Final patch is attached. Regression-tested on x86_64-pc-linux-gnu, both 32- and 64-bit.
OK to commit?

FX


[-- Attachment #2: 0001-fortran-Add-IEEE_SIGNBIT-and-IEEE_FMA-functions.patch --]
[-- Type: application/octet-stream, Size: 17950 bytes --]

From 315046830a1b52ac1ed89b1469558c992febcc0c Mon Sep 17 00:00:00 2001
From: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Date: Wed, 31 Aug 2022 15:22:50 +0200
Subject: [PATCH] fortran: Add IEEE_SIGNBIT and IEEE_FMA functions

The functions are added to the IEEE_ARITHMETIC module, but
are entirely expanded in the front-end, using GCC built-ins.

2022-08-31  Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>

	PR fortran/95644

gcc/fortran/
	* f95-lang.cc (gfc_init_builtin_functions): Declare FMA
	built-ins.
	* mathbuiltins.def: Declare FMA built-ins.
	* trans-intrinsic.cc (conv_intrinsic_ieee_fma): New function.
	(conv_intrinsic_ieee_signbit): New function.
	(gfc_build_intrinsic_lib_fndecls): Add cases for FMA and
	SIGNBIT.

gcc/testsuite/
	* gfortran.dg/ieee/fma_1.f90: New test.
	* gfortran.dg/ieee/signbit_1.f90: New test.

libgfortran/
	* ieee/ieee_arithmetic.F90: Add IEEE_SIGNBIT and IEEE_FMA.
---
 gcc/fortran/f95-lang.cc                      |  16 ++
 gcc/fortran/mathbuiltins.def                 |   1 +
 gcc/fortran/trans-intrinsic.cc               |  51 +++++-
 gcc/testsuite/gfortran.dg/ieee/fma_1.f90     | 100 +++++++++++
 gcc/testsuite/gfortran.dg/ieee/signbit_1.f90 | 166 +++++++++++++++++++
 libgfortran/ieee/ieee_arithmetic.F90         |  66 ++++++++
 6 files changed, 398 insertions(+), 2 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/ieee/fma_1.f90
 create mode 100644 gcc/testsuite/gfortran.dg/ieee/signbit_1.f90

diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 10ac8a95b87..ff4bf800e49 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -1281,6 +1281,22 @@ gfc_init_builtin_functions (void)
 		      "__builtin_assume_aligned",
 		      ATTR_CONST_NOTHROW_LEAF_LIST);
 
+  ftype = build_function_type_list (long_double_type_node, long_double_type_node,
+				    long_double_type_node, long_double_type_node,
+				    NULL_TREE);
+  gfc_define_builtin ("__builtin_fmal", ftype, BUILT_IN_FMAL,
+		      "fmal", ATTR_CONST_NOTHROW_LEAF_LIST);
+  ftype = build_function_type_list (double_type_node, double_type_node,
+				    double_type_node, double_type_node,
+				    NULL_TREE);
+  gfc_define_builtin ("__builtin_fma", ftype, BUILT_IN_FMA,
+		      "fma", ATTR_CONST_NOTHROW_LEAF_LIST);
+  ftype = build_function_type_list (float_type_node, float_type_node,
+				    float_type_node, float_type_node,
+				    NULL_TREE);
+  gfc_define_builtin ("__builtin_fmaf", ftype, BUILT_IN_FMAF,
+		      "fmaf", ATTR_CONST_NOTHROW_LEAF_LIST);
+
   gfc_define_builtin ("__emutls_get_address",
 		      builtin_types[BT_FN_PTR_PTR],
 		      BUILT_IN_EMUTLS_GET_ADDRESS,
diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def
index 615214ebcd6..9d55c34cda8 100644
--- a/gcc/fortran/mathbuiltins.def
+++ b/gcc/fortran/mathbuiltins.def
@@ -60,6 +60,7 @@ OTHER_BUILTIN (CABS,      "cabs",      cabs,    true)
 OTHER_BUILTIN (COPYSIGN,  "copysign",  2,       true)
 OTHER_BUILTIN (CPOW,      "cpow",      cpow,    true)
 OTHER_BUILTIN (FABS,      "fabs",      1,       true)
+OTHER_BUILTIN (FMA,       "fma",       3,       true)
 OTHER_BUILTIN (FMOD,      "fmod",      2,       true)
 OTHER_BUILTIN (FREXP,     "frexp",     frexp,   false)
 OTHER_BUILTIN (LOGB,      "logb",      1,       true)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index ec116fff26e..bb938026828 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -695,7 +695,7 @@ gfc_build_intrinsic_lib_fndecls (void)
        C99-like library functions.  For now, we only handle _Float128
        q-suffixed or IEC 60559 f128-suffixed functions.  */
 
-    tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
+    tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
     tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
 
     memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
@@ -715,6 +715,8 @@ gfc_build_intrinsic_lib_fndecls (void)
 					     type, NULL_TREE);
     /* type (*) (type, type) */
     func_2 = build_function_type_list (type, type, type, NULL_TREE);
+    /* type (*) (type, type, type) */
+    func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
     /* type (*) (type, &int) */
     func_frexp
       = build_function_type_list (type,
@@ -9781,7 +9783,7 @@ conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
 }
 
 
-/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
+/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
    and IEEE_UNORDERED, which translate directly to GCC type-generic
    built-ins.  */
 
@@ -9801,6 +9803,23 @@ conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
 }
 
 
+/* Generate code for intrinsics IEEE_SIGNBIT.  */
+
+static void
+conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
+{
+  tree arg, signbit;
+
+  conv_ieee_function_args (se, expr, &arg, 1);
+  signbit = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_SIGNBIT),
+				 1, arg);
+  signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			     signbit, integer_zero_node);
+  se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
+}
+
+
 /* Generate code for IEEE_IS_NORMAL intrinsic:
      IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0)  */
 
@@ -10207,6 +10226,30 @@ conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
 }
 
 
+/* Generate code for IEEE_FMA.  */
+
+static void
+conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
+{
+  tree args[3], decl, call;
+  int argprec;
+
+  conv_ieee_function_args (se, expr, args, 3);
+
+  /* All three arguments should have the same type.  */
+  gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
+  gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
+
+  /* Call the type-generic FMA built-in.  */
+  argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
+  decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
+  call = build_call_expr_loc_array (input_location, decl, 3, args);
+
+  /* Convert to the final type.  */
+  se->expr = fold_convert (TREE_TYPE (args[0]), call);
+}
+
+
 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
    module.  */
 
@@ -10221,6 +10264,8 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
     conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
   else if (startswith (name, "_gfortran_ieee_unordered"))
     conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
+  else if (startswith (name, "_gfortran_ieee_signbit"))
+    conv_intrinsic_ieee_signbit (se, expr);
   else if (startswith (name, "_gfortran_ieee_is_normal"))
     conv_intrinsic_ieee_is_normal (se, expr);
   else if (startswith (name, "_gfortran_ieee_is_negative"))
@@ -10241,6 +10286,8 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
     conv_intrinsic_ieee_class (se, expr);
   else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
     conv_intrinsic_ieee_value (se, expr);
+  else if (startswith (name, "_gfortran_ieee_fma"))
+    conv_intrinsic_ieee_fma (se, expr);
   else
     /* It is not among the functions we translate directly.  We return
        false, so a library function call is emitted.  */
diff --git a/gcc/testsuite/gfortran.dg/ieee/fma_1.f90 b/gcc/testsuite/gfortran.dg/ieee/fma_1.f90
new file mode 100644
index 00000000000..34636426c98
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/fma_1.f90
@@ -0,0 +1,100 @@
+! Test IEEE_FMA
+! { dg-do run }
+
+  use, intrinsic :: ieee_features
+  use, intrinsic :: ieee_exceptions
+  use, intrinsic :: ieee_arithmetic
+  implicit none
+
+  integer :: ex
+
+  real :: sx1, sx2, sx3
+  double precision :: dx1, dx2, dx3
+
+  ! k1 and k2 will be large real kinds, if supported, and single/double
+  ! otherwise
+  integer, parameter :: k1 = &
+    max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.))
+  integer, parameter :: k2 = &
+    max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0))
+
+  real(kind=k1) :: lx1, lx2, lx3
+  real(kind=k2) :: wx1, wx2, wx3
+
+  ! Float
+
+  sx1 = 3 ; sx2 = 2 ; sx3 = 1
+  if (ieee_fma(sx1, sx2, sx3) /= 7) stop 1
+  sx1 = 0 ; sx2 = 2 ; sx3 = 1
+  if (ieee_fma(sx1, sx2, sx3) /= 1) stop 2
+  sx1 = 3 ; sx2 = 2 ; sx3 = 0
+  if (ieee_fma(sx1, sx2, sx3) /= 6) stop 3
+
+  ex = int(log(rrspacing(real(1, kind(sx1)))) / log(real(2, kind(sx1)))) - 1
+  sx1 = 1 + spacing(real(1, kind(sx1)))
+  sx2 = 2 ; sx2 = sx2 ** ex ; sx2 = sx2 * 3
+  sx3 = -sx2
+
+  print *, sx1 * sx2 + sx3
+  print *, ieee_fma(sx1, sx2, sx3)
+  if (ieee_fma(sx1, sx2, sx3) /= real(3, kind(sx1)) / 2) stop 4
+  !if (ieee_fma(sx1, sx2, sx3) == sx1 * sx2 + sx3) stop 5
+
+  ! Double
+
+  dx1 = 3 ; dx2 = 2 ; dx3 = 1
+  if (ieee_fma(dx1, dx2, dx3) /= 7) stop 1
+  dx1 = 0 ; dx2 = 2 ; dx3 = 1
+  if (ieee_fma(dx1, dx2, dx3) /= 1) stop 2
+  dx1 = 3 ; dx2 = 2 ; dx3 = 0
+  if (ieee_fma(dx1, dx2, dx3) /= 6) stop 3
+
+  ex = int(log(rrspacing(real(1, kind(dx1)))) / log(real(2, kind(dx1)))) - 1
+  dx1 = 1 + spacing(real(1, kind(dx1)))
+  dx2 = 2 ; dx2 = dx2 ** ex ; dx2 = dx2 * 3
+  dx3 = -dx2
+
+  print *, dx1 * dx2 + dx3
+  print *, ieee_fma(dx1, dx2, dx3)
+  if (ieee_fma(dx1, dx2, dx3) /= real(3, kind(dx1)) / 2) stop 4
+  !if (ieee_fma(dx1, dx2, dx3) == dx1 * dx2 + dx3) stop 5
+
+  ! Large kind 1
+
+  lx1 = 3 ; lx2 = 2 ; lx3 = 1
+  if (ieee_fma(lx1, lx2, lx3) /= 7) stop 1
+  lx1 = 0 ; lx2 = 2 ; lx3 = 1
+  if (ieee_fma(lx1, lx2, lx3) /= 1) stop 2
+  lx1 = 3 ; lx2 = 2 ; lx3 = 0
+  if (ieee_fma(lx1, lx2, lx3) /= 6) stop 3
+
+  ex = int(log(rrspacing(real(1, kind(lx1)))) / log(real(2, kind(lx1)))) - 1
+  lx1 = 1 + spacing(real(1, kind(lx1)))
+  lx2 = 2 ; lx2 = lx2 ** ex ; lx2 = lx2 * 3
+  lx3 = -lx2
+
+  print *, lx1 * lx2 + lx3
+  print *, ieee_fma(lx1, lx2, lx3)
+  if (ieee_fma(lx1, lx2, lx3) /= real(3, kind(lx1)) / 2) stop 4
+  if (ieee_fma(lx1, lx2, lx3) == lx1 * lx2 + lx3) stop 5
+
+  ! Large kind 2
+
+  wx1 = 3 ; wx2 = 2 ; wx3 = 1
+  if (ieee_fma(wx1, wx2, wx3) /= 7) stop 1
+  wx1 = 0 ; wx2 = 2 ; wx3 = 1
+  if (ieee_fma(wx1, wx2, wx3) /= 1) stop 2
+  wx1 = 3 ; wx2 = 2 ; wx3 = 0
+  if (ieee_fma(wx1, wx2, wx3) /= 6) stop 3
+
+  ex = int(log(rrspacing(real(1, kind(wx1)))) / log(real(2, kind(wx1)))) - 1
+  wx1 = 1 + spacing(real(1, kind(wx1)))
+  wx2 = 2 ; wx2 = wx2 ** ex ; wx2 = wx2 * 3
+  wx3 = -wx2
+
+  print *, wx1 * wx2 + wx3
+  print *, ieee_fma(wx1, wx2, wx3)
+  if (ieee_fma(wx1, wx2, wx3) /= real(3, kind(wx1)) / 2) stop 4
+  if (ieee_fma(wx1, wx2, wx3) == wx1 * wx2 + wx3) stop 5
+
+end
diff --git a/gcc/testsuite/gfortran.dg/ieee/signbit_1.f90 b/gcc/testsuite/gfortran.dg/ieee/signbit_1.f90
new file mode 100644
index 00000000000..5d6e41de739
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/signbit_1.f90
@@ -0,0 +1,166 @@
+! Test IEEE_SIGNBIT
+! { dg-do run }
+
+  use, intrinsic :: ieee_features
+  use, intrinsic :: ieee_exceptions
+  use, intrinsic :: ieee_arithmetic
+  implicit none
+
+  real :: sx1
+  double precision :: dx1
+
+  ! k1 and k2 will be large real kinds, if supported, and single/double
+  ! otherwise
+  integer, parameter :: k1 = &
+    max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.))
+  integer, parameter :: k2 = &
+    max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0))
+
+  real(kind=k1) :: xk1
+  real(kind=k2) :: xk2
+
+  ! Float
+
+  sx1 = 1.3
+  if (ieee_signbit(sx1)) stop 1
+  sx1 = huge(sx1)
+  if (ieee_signbit(sx1)) stop 2
+  sx1 = ieee_value(sx1, ieee_positive_inf)
+  if (ieee_signbit(sx1)) stop 3
+  sx1 = tiny(sx1)
+  if (ieee_signbit(sx1)) stop 4
+  sx1 = tiny(sx1)
+  sx1 = sx1 / 101
+  if (ieee_signbit(sx1)) stop 5
+  sx1 = 0
+  if (ieee_signbit(sx1)) stop 6
+  sx1 = ieee_value(sx1, ieee_quiet_nan)
+  if (ieee_signbit(sx1)) stop 7
+
+  sx1 = -1.3
+  if (.not. ieee_signbit(sx1)) stop 8
+  sx1 = -huge(sx1)
+  if (.not. ieee_signbit(sx1)) stop 9
+  sx1 = -ieee_value(sx1, ieee_positive_inf)
+  if (.not. ieee_signbit(sx1)) stop 10
+  sx1 = -tiny(sx1)
+  if (.not. ieee_signbit(sx1)) stop 11
+  sx1 = -tiny(sx1)
+  sx1 = sx1 / 101
+  if (.not. ieee_signbit(sx1)) stop 12
+  sx1 = 0
+  sx1 = -sx1
+  if (.not. ieee_signbit(sx1)) stop 13
+  sx1 = ieee_value(sx1, ieee_quiet_nan)
+  sx1 = -sx1
+  if (.not. ieee_signbit(sx1)) stop 14
+
+  ! Double
+
+  dx1 = 1.3
+  if (ieee_signbit(dx1)) stop 1
+  dx1 = huge(dx1)
+  if (ieee_signbit(dx1)) stop 2
+  dx1 = ieee_value(dx1, ieee_positive_inf)
+  if (ieee_signbit(dx1)) stop 3
+  dx1 = tiny(dx1)
+  if (ieee_signbit(dx1)) stop 4
+  dx1 = tiny(dx1)
+  dx1 = dx1 / 101
+  if (ieee_signbit(dx1)) stop 5
+  dx1 = 0
+  if (ieee_signbit(dx1)) stop 6
+  dx1 = ieee_value(dx1, ieee_quiet_nan)
+  if (ieee_signbit(dx1)) stop 7
+
+  dx1 = -1.3
+  if (.not. ieee_signbit(dx1)) stop 8
+  dx1 = -huge(dx1)
+  if (.not. ieee_signbit(dx1)) stop 9
+  dx1 = -ieee_value(dx1, ieee_positive_inf)
+  if (.not. ieee_signbit(dx1)) stop 10
+  dx1 = -tiny(dx1)
+  if (.not. ieee_signbit(dx1)) stop 11
+  dx1 = -tiny(dx1)
+  dx1 = dx1 / 101
+  if (.not. ieee_signbit(dx1)) stop 12
+  dx1 = 0
+  dx1 = -dx1
+  if (.not. ieee_signbit(dx1)) stop 13
+  dx1 = ieee_value(dx1, ieee_quiet_nan)
+  dx1 = -dx1
+  if (.not. ieee_signbit(dx1)) stop 14
+
+  ! Large kind 1
+
+  xk1 = 1.3
+  if (ieee_signbit(xk1)) stop 1
+  xk1 = huge(xk1)
+  if (ieee_signbit(xk1)) stop 2
+  xk1 = ieee_value(xk1, ieee_positive_inf)
+  if (ieee_signbit(xk1)) stop 3
+  xk1 = tiny(xk1)
+  if (ieee_signbit(xk1)) stop 4
+  xk1 = tiny(xk1)
+  xk1 = xk1 / 101
+  if (ieee_signbit(xk1)) stop 5
+  xk1 = 0
+  if (ieee_signbit(xk1)) stop 6
+  xk1 = ieee_value(xk1, ieee_quiet_nan)
+  if (ieee_signbit(xk1)) stop 7
+
+  xk1 = -1.3
+  if (.not. ieee_signbit(xk1)) stop 8
+  xk1 = -huge(xk1)
+  if (.not. ieee_signbit(xk1)) stop 9
+  xk1 = -ieee_value(xk1, ieee_positive_inf)
+  if (.not. ieee_signbit(xk1)) stop 10
+  xk1 = -tiny(xk1)
+  if (.not. ieee_signbit(xk1)) stop 11
+  xk1 = -tiny(xk1)
+  xk1 = xk1 / 101
+  if (.not. ieee_signbit(xk1)) stop 12
+  xk1 = 0
+  xk1 = -xk1
+  if (.not. ieee_signbit(xk1)) stop 13
+  xk1 = ieee_value(xk1, ieee_quiet_nan)
+  xk1 = -xk1
+  if (.not. ieee_signbit(xk1)) stop 14
+
+  ! Large kind 2
+
+  xk2 = 1.3
+  if (ieee_signbit(xk2)) stop 1
+  xk2 = huge(xk2)
+  if (ieee_signbit(xk2)) stop 2
+  xk2 = ieee_value(xk2, ieee_positive_inf)
+  if (ieee_signbit(xk2)) stop 3
+  xk2 = tiny(xk2)
+  if (ieee_signbit(xk2)) stop 4
+  xk2 = tiny(xk2)
+  xk2 = xk2 / 101
+  if (ieee_signbit(xk2)) stop 5
+  xk2 = 0
+  if (ieee_signbit(xk2)) stop 6
+  xk2 = ieee_value(xk2, ieee_quiet_nan)
+  if (ieee_signbit(xk2)) stop 7
+
+  xk2 = -1.3
+  if (.not. ieee_signbit(xk2)) stop 8
+  xk2 = -huge(xk2)
+  if (.not. ieee_signbit(xk2)) stop 9
+  xk2 = -ieee_value(xk2, ieee_positive_inf)
+  if (.not. ieee_signbit(xk2)) stop 10
+  xk2 = -tiny(xk2)
+  if (.not. ieee_signbit(xk2)) stop 11
+  xk2 = -tiny(xk2)
+  xk2 = xk2 / 101
+  if (.not. ieee_signbit(xk2)) stop 12
+  xk2 = 0
+  xk2 = -xk2
+  if (.not. ieee_signbit(xk2)) stop 13
+  xk2 = ieee_value(xk2, ieee_quiet_nan)
+  xk2 = -xk2
+  if (.not. ieee_signbit(xk2)) stop 14
+
+end
diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90
index c8ef3e2faeb..4e01aa5504c 100644
--- a/libgfortran/ieee/ieee_arithmetic.F90
+++ b/libgfortran/ieee/ieee_arithmetic.F90
@@ -343,6 +343,39 @@ UNORDERED_MACRO(4,4)
   end interface
   public :: IEEE_UNORDERED
 
+  ! IEEE_FMA
+
+  interface
+    elemental real(kind=4) function _gfortran_ieee_fma_4 (A, B, C)
+      real(kind=4), intent(in) :: A, B, C
+    end function
+    elemental real(kind=8) function _gfortran_ieee_fma_8 (A, B, C)
+      real(kind=8), intent(in) :: A, B, C
+    end function
+#ifdef HAVE_GFC_REAL_10
+    elemental real(kind=10) function _gfortran_ieee_fma_10 (A, B, C)
+      real(kind=10), intent(in) :: A, B, C
+    end function
+#endif
+#ifdef HAVE_GFC_REAL_16
+    elemental real(kind=16) function _gfortran_ieee_fma_16 (A, B, C)
+      real(kind=16), intent(in) :: A, B, C
+    end function
+#endif
+  end interface
+
+  interface IEEE_FMA
+    procedure &
+#ifdef HAVE_GFC_REAL_16
+      _gfortran_ieee_fma_16, &
+#endif
+#ifdef HAVE_GFC_REAL_10
+      _gfortran_ieee_fma_10, &
+#endif
+      _gfortran_ieee_fma_8, _gfortran_ieee_fma_4
+  end interface
+  public :: IEEE_FMA
+
   ! IEEE_LOGB
 
   interface
@@ -702,6 +735,39 @@ REM_MACRO(4,4,4)
   end interface
   public :: IEEE_SCALB
 
+  ! IEEE_SIGNBIT
+
+  interface
+    elemental logical function _gfortran_ieee_signbit_4 (X)
+      real(kind=4), intent(in) :: X
+    end function
+    elemental logical function _gfortran_ieee_signbit_8 (X)
+      real(kind=8), intent(in) :: X
+    end function
+#ifdef HAVE_GFC_REAL_10
+    elemental logical function _gfortran_ieee_signbit_10 (X)
+      real(kind=10), intent(in) :: X
+    end function
+#endif
+#ifdef HAVE_GFC_REAL_16
+    elemental logical function _gfortran_ieee_signbit_16 (X)
+      real(kind=16), intent(in) :: X
+    end function
+#endif
+  end interface
+
+  interface IEEE_SIGNBIT
+    procedure &
+#ifdef HAVE_GFC_REAL_16
+      _gfortran_ieee_signbit_16, &
+#endif
+#ifdef HAVE_GFC_REAL_10
+      _gfortran_ieee_signbit_10, &
+#endif
+      _gfortran_ieee_signbit_8, _gfortran_ieee_signbit_4
+  end interface
+  public :: IEEE_SIGNBIT
+
   ! IEEE_VALUE
 
   interface IEEE_VALUE
-- 
2.25.1


^ permalink raw reply	[flat|nested] 10+ messages in thread

* Re: [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions
  2022-08-31 14:22 ` FX
@ 2022-09-06 13:26   ` FX
  2022-09-07  5:43     ` Thomas Koenig
  0 siblings, 1 reply; 10+ messages in thread
From: FX @ 2022-09-06 13:26 UTC (permalink / raw)
  To: FX via Fortran; +Cc: gcc-patches

ping on that patch from last week

Maybe the ping is a bit early, as you know I’m not very active anymore, so I do not know what are the current policies. In particular, how much leeway do I have to commit the patch if there is no comment from another maintainer?

I am fairly confident about the code, because I wrote the original IEEE implementation so I know it very well. I believe it would probably be better to commit this and have it tested on mainline, that wait for too long. I intend to submit further patches and improvements in this area, once those are merged.

Best,
FX



> Le 31 août 2022 à 16:22, FX <fxcoudert@gmail.com> a écrit :
> 
> Hum, slightly amended patch, after checking 32-bit results on another linux machine.
> The test for FMA has been made a bit less strict, because otherwise we have surprised on 387 arithmetic due to excess precision.
> 
> Final patch is attached. Regression-tested on x86_64-pc-linux-gnu, both 32- and 64-bit.
> OK to commit?
> 
> FX
> 
> <0001-fortran-Add-IEEE_SIGNBIT-and-IEEE_FMA-functions.patch>


^ permalink raw reply	[flat|nested] 10+ messages in thread

* Re: [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions
  2022-09-06 13:26   ` FX
@ 2022-09-07  5:43     ` Thomas Koenig
  2022-09-07 18:57       ` FX
  0 siblings, 1 reply; 10+ messages in thread
From: Thomas Koenig @ 2022-09-07  5:43 UTC (permalink / raw)
  To: FX, FX via Fortran; +Cc: gcc-patches

Hi FX,

> Maybe the ping is a bit early, as you know I’m not very active anymore, so I do not know what are the current policies. In particular, how much leeway do I have to commit the patch if there is no comment from another maintainer?
> 
> I am fairly confident about the code, because I wrote the original IEEE implementation so I know it very well. I believe it would probably be better to commit this and have it tested on mainline, that wait for too long. I intend to submit further patches and improvements in this area, once those are merged.


Looks good in principle.

Just a couple of remarks:

Both of these functions are new with Fortran 2018, could you add
a standards version check?

And, more general: I don't think we document which part of the IEEE
arithmetic we support. It might be a good idea to add that to the manual
(but not for this patch).

So, OK with the version check.

Best regards

	Thomas

^ permalink raw reply	[flat|nested] 10+ messages in thread

* Re: [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions
  2022-09-07  5:43     ` Thomas Koenig
@ 2022-09-07 18:57       ` FX
  2022-09-09 17:50         ` FX
  0 siblings, 1 reply; 10+ messages in thread
From: FX @ 2022-09-07 18:57 UTC (permalink / raw)
  To: Thomas Koenig; +Cc: FX via Fortran, gcc-patches

Hi,

> Both of these functions are new with Fortran 2018, could you add
> a standards version check?

Thanks Thomas, I will do that and post here the commit diff. The check will not be perfect, though, because the warning/error cannot be emitted when loading the module (because it’s in an external file), but will have to be when the call is actually emitted. This means that loading a symbol and not using it will not trigger the error it should, but we cannot do better in the current scheme.

IEEE modules will need to be fully moved to the front-end at some point, bécause F2018 added two procedures that cannot be described in a Fortran module (functions whose return kind is described by an optional KIND argument).

 - IEEE_INT (A, ROUND [, KIND])
 - IEEE_REAL (A [, KIND])

But emitting all the symbols in the front-end is a huge work, and there are some cases I do not know how to handle.

FX

^ permalink raw reply	[flat|nested] 10+ messages in thread

* Re: [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions
  2022-09-07 18:57       ` FX
@ 2022-09-09 17:50         ` FX
  2022-09-10 10:14           ` FX
  0 siblings, 1 reply; 10+ messages in thread
From: FX @ 2022-09-09 17:50 UTC (permalink / raw)
  To: Thomas Koenig; +Cc: FX via Fortran, gcc-patches

Hi Thomas,

>> Both of these functions are new with Fortran 2018, could you add
>> a standards version check?
> 
> Thanks Thomas, I will do that and post here the commit diff. The check will not be perfect, though, because the warning/error cannot be emitted when loading the module (because it’s in an external file), but will have to be when the call is actually emitted.

Actuelly, that does not work. gfc_notify_std() should not be used at code-generation time, but in matching or setting-up symbols. It is never used in trans-* files, so I do not think I should introduce it now.

Any hard objection to committing as it is? In the middle term, I intend to revamp this part anyway, as I said in my previous email.

Thanks,
FX

^ permalink raw reply	[flat|nested] 10+ messages in thread

* Re: [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions
  2022-09-09 17:50         ` FX
@ 2022-09-10 10:14           ` FX
  2022-09-11  9:49             ` Mikael Morin
  0 siblings, 1 reply; 10+ messages in thread
From: FX @ 2022-09-10 10:14 UTC (permalink / raw)
  To: Thomas Koenig; +Cc: FX via Fortran, gcc-patches

> Actuelly, that does not work. gfc_notify_std() should not be used at code-generation time, but in matching or setting-up symbols. It is never used in trans-* files, so I do not think I should introduce it now.
> 
> Any hard objection to committing as it is? In the middle term, I intend to revamp this part anyway, as I said in my previous email.

I’ve committed: https://gcc.gnu.org/git/?p=gcc.git;a=commit;h=7c4c65d11469d29403d5a88316445ec95cd3c3f8
If you have a solution for the standards checking, I’ll add it.

I will finish my series of IEEE-related patches, then intend to document the current state of things once the dust has settled.

FX

^ permalink raw reply	[flat|nested] 10+ messages in thread

* Re: [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions
  2022-09-10 10:14           ` FX
@ 2022-09-11  9:49             ` Mikael Morin
  2022-09-11  9:57               ` FX
  0 siblings, 1 reply; 10+ messages in thread
From: Mikael Morin @ 2022-09-11  9:49 UTC (permalink / raw)
  To: FX, Thomas Koenig; +Cc: gcc-patches, FX via Fortran

Le 10/09/2022 à 12:14, FX via Fortran a écrit :
> If you have a solution for the standards checking, I’ll add it.
> 
As a first step, one could check the use rename lists; what's done for 
iso_fortran_env can be used as an example.

To diagnose the other usages, the check could be put in resolve_symbol 
but it would diagnose it even if not used, so one can add a check on 
attr.referenced (I hope it can be relied upon).
Another possibility is mimicking or modifying gfc_resolve_intrinsic, 
which already does a similar job for intrinsic procedures.

I hope this helps.

^ permalink raw reply	[flat|nested] 10+ messages in thread

* Re: [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions
  2022-09-11  9:49             ` Mikael Morin
@ 2022-09-11  9:57               ` FX
  2022-09-11 10:23                 ` Mikael Morin
  0 siblings, 1 reply; 10+ messages in thread
From: FX @ 2022-09-11  9:57 UTC (permalink / raw)
  To: Mikael Morin; +Cc: Thomas Koenig, gcc-patches, FX via Fortran

Hi Mikael,

> As a first step, one could check the use rename lists; what's done for iso_fortran_env can be used as an example.

Yes, but iso_fortran_env is handled entirely in front-end, not through external files.
This is what I plan to do when migrating the IEEE modules to front-end, but it is a big task.


> Another possibility is mimicking or modifying gfc_resolve_intrinsic, which already does a similar job for intrinsic procedures.

That’s probably the best place to put it for now, indeed. Thanks for the advice.

FX

^ permalink raw reply	[flat|nested] 10+ messages in thread

* Re: [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions
  2022-09-11  9:57               ` FX
@ 2022-09-11 10:23                 ` Mikael Morin
  0 siblings, 0 replies; 10+ messages in thread
From: Mikael Morin @ 2022-09-11 10:23 UTC (permalink / raw)
  To: FX; +Cc: Thomas Koenig, gcc-patches, FX via Fortran

Le 11/09/2022 à 11:57, FX a écrit :
>> As a first step, one could check the use rename lists; what's done for iso_fortran_env can be used as an example.
> 
> Yes, but iso_fortran_env is handled entirely in front-end, not through external files.
> 
That's true, but the standard check doesn't really depend on that.
It only needs the u->use_name for each use rename u.


^ permalink raw reply	[flat|nested] 10+ messages in thread

end of thread, other threads:[~2022-09-11 10:23 UTC | newest]

Thread overview: 10+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-08-31 13:46 [PATCH] Fortran: Add IEEE_SIGNBIT and IEEE_FMA functions FX
2022-08-31 14:22 ` FX
2022-09-06 13:26   ` FX
2022-09-07  5:43     ` Thomas Koenig
2022-09-07 18:57       ` FX
2022-09-09 17:50         ` FX
2022-09-10 10:14           ` FX
2022-09-11  9:49             ` Mikael Morin
2022-09-11  9:57               ` FX
2022-09-11 10:23                 ` Mikael Morin

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).