trans-intrinsic.c (gfc_conv_intrinsic_sign): New branchless implementation for…

trans-intrinsic.c (gfc_conv_intrinsic_sign): New branchless implementation for the SIGN intrinsic with integral operands.


	* trans-intrinsic.c (gfc_conv_intrinsic_sign): New branchless
	implementation for the SIGN intrinsic with integral operands.
	(gfc_conv_intrinsic_minmax): Fix whitespace.

	* gfortran.dg/intrinsic_sign_1.f90: New test case.
	* gfortran.dg/intrinsic_sign_2.f90: Likewise.


Co-Authored-By: Brooks Moses <brooks.moses@codesourcery.com>
Co-Authored-By: Francois-Xavier Coudert <coudert@clipper.ens.fr>

From-SVN: r121009

gcc/fortran/ChangeLog

+2007-01-20  Roger Sayle  <roger@eyesopen.com>
+
+	* trans-intrinsic.c (gfc_conv_intrinsic_sign): New branchless
+	implementation for the SIGN intrinsic with integral operands.
+	(gfc_conv_intrinsic_minmax): Fix whitespace.
+
 2007-01-20  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	* gfortran.h (gfc_options_t): Add flag_allow_leading_underscore.

gcc/fortran/trans-intrinsic.c

 /* Intrinsic translation
-   Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+   Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
@@ -1130,7 +1131,7 @@ gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 /* SIGN(A, B) is absolute value of A times sign of B.
    The real value versions use library functions to ensure the correct
    handling of negative zero.  Integer case implemented as:
-   SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
+   SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
   */
 
 static void
@@ -1140,10 +1141,6 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
   tree arg;
   tree arg2;
   tree type;
-  tree zero;
-  tree testa;
-  tree testb;
-
 
   arg = gfc_conv_intrinsic_function_args (se, expr);
   if (expr->ts.type == BT_REAL)
@@ -1167,16 +1164,27 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
       return;
     }
 
+  /* Having excluded floating point types, we know we are now dealing
+     with signed integer types.  */
   arg2 = TREE_VALUE (TREE_CHAIN (arg));
   arg = TREE_VALUE (arg);
   type = TREE_TYPE (arg);
-  zero = gfc_build_const (type, integer_zero_node);
 
-  testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
-  testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);
-  tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb);
-  se->expr = fold_build3 (COND_EXPR, type, tmp,
-			  build1 (NEGATE_EXPR, type, arg), arg);
+  /* Arg is used multiple times below.  */
+  arg = gfc_evaluate_now (arg, &se->pre);
+
+  /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
+     the signs of A and B are the same, and of all ones if they differ.  */
+  tmp = fold_build2 (BIT_XOR_EXPR, type, arg, arg2);
+  tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
+		     build_int_cst (type, TYPE_PRECISION (type) - 1));
+  tmp = gfc_evaluate_now (tmp, &se->pre);
+
+  /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
+     is all ones (i.e. -1).  */
+  se->expr = fold_build2 (BIT_XOR_EXPR, type,
+			  fold_build2 (PLUS_EXPR, type, arg, tmp),
+			  tmp);
 }
 
 
@@ -1385,7 +1393,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
     limit = convert (type, limit);
   /* Only evaluate the argument once.  */
   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
-    limit = gfc_evaluate_now(limit, &se->pre);
+    limit = gfc_evaluate_now (limit, &se->pre);
 
   mvar = gfc_create_var (type, "M");
   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
@@ -1397,7 +1405,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
 
       /* Only evaluate the argument once.  */
       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
-        val = gfc_evaluate_now(val, &se->pre);
+        val = gfc_evaluate_now (val, &se->pre);
 
       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
 

gcc/testsuite/ChangeLog

+2007-01-20  Roger Sayle  <roger@eyesopen.com>
+	    Brooks Moses  <brooks.moses@codesourcery.com>
+	    Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* gfortran.dg/intrinsic_sign_1.f90: New test case.
+	* gfortran.dg/intrinsic_sign_2.f90: Likewise.
+
 2007-01-19  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
 
 	* gcc.dg/torture/builtin-math-3.c: Test fdim.

gcc/testsuite/gfortran.dg/intrinsic_sign_1.f90

+! { dg-do run }
+! At one point, SIGN() evaluated its first argument twice.
+! Contributed by Brooks Moses <brooks.moses@codesourcery.com>
+program sign1
+  integer :: i
+  i = 1
+  if (sign(foo(i), 1) /= 1) call abort
+  i = 1
+  if (sign(foo(i), -1) /= -1) call abort
+contains
+  integer function foo(i)
+    integer :: i
+    foo = i
+    i = i + 1
+  end function
+end

gcc/testsuite/gfortran.dg/intrinsic_sign_2.f90

+! { dg-do run }
+! Testcase for SIGN() with integer arguments
+! Check that:
+!   + SIGN() evaluates its arguments only once
+!   + SIGN() works on large values
+!   + SIGN() works with parameter arguments
+! Contributed by FX Coudert <fxcoudert@gmail.com>
+program sign1
+  implicit none
+  integer(kind=1), parameter :: one1 = 1_1, mone1 = -1_1
+  integer(kind=2), parameter :: one2 = 1_2, mone2 = -1_2
+  integer(kind=4), parameter :: one4 = 1_4, mone4 = -1_4
+  integer(kind=8), parameter :: one8 = 1_8, mone8 = -1_8
+  integer(kind=1) :: i1, j1
+  integer(kind=2) :: i2, j2
+  integer(kind=4) :: i4, j4
+  integer(kind=8) :: i8, j8
+  integer :: i = 1
+
+  i1 = huge(0_1) ; j1 = -huge(0_1)
+  if (sign(i1, j1) /= j1) call abort()
+  if (sign(j1, i1) /= i1) call abort()
+  if (sign(i1,one1) /= i1 .or. sign(j1,one1) /= i1) call abort()
+  if (sign(i1,mone1) /= j1 .or. sign(j1,mone1) /= j1) call abort()
+
+  i2 = huge(0_2) ; j2 = -huge(0_2)
+  if (sign(i2, j2) /= j2) call abort()
+  if (sign(j2, i2) /= i2) call abort()
+  if (sign(i2,one2) /= i2 .or. sign(j2,one2) /= i2) call abort()
+  if (sign(i2,mone2) /= j2 .or. sign(j2,mone2) /= j2) call abort()
+
+  i4 = huge(0_4) ; j4 = -huge(0_4)
+  if (sign(i4, j4) /= j4) call abort()
+  if (sign(j4, i4) /= i4) call abort()
+  if (sign(i4,one4) /= i4 .or. sign(j4,one4) /= i4) call abort()
+  if (sign(i4,mone4) /= j4 .or. sign(j4,mone4) /= j4) call abort()
+
+  i8 = huge(0_8) ; j8 = -huge(0_8)
+  if (sign(i8, j8) /= j8) call abort()
+  if (sign(j8, i8) /= i8) call abort()
+  if (sign(i8,one8) /= i8 .or. sign(j8,one8) /= i8) call abort()
+  if (sign(i8,mone8) /= j8 .or. sign(j8,mone8) /= j8) call abort()
+
+  if (sign(foo(i), 1) /= 1) call abort
+  if (sign(foo(i), -1) /= -2) call abort
+  if (sign(42, foo(i)) /= 42) call abort
+  if (sign(42, -foo(i)) /= -42) call abort
+  if (i /= 5) call abort
+
+  if (sign(bar(), 1) /= 1) call abort
+  if (sign(bar(), -1) /= -2) call abort
+  if (sign(17, bar()) /= 17) call abort
+  if (sign(17, -bar()) /= -17) call abort
+  if (bar() /= 5) call abort
+
+contains
+
+  integer function foo(i)
+    integer :: i
+    foo = i
+    i = i + 1
+  end function
+
+  integer function bar()
+    integer, save :: i = 0
+    i = i + 1
+    bar = i
+  end function
+end