diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3e16d4c8b2a9..0b738bac2dbd 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2007-01-20 Roger Sayle + + * 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 * gfortran.h (gfc_options_t): Add flag_allow_leading_underscore. diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 2c031748966b..6c321f1c6093 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1,5 +1,6 @@ /* 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 and Steven Bosscher @@ -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)); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e9f9c9f125aa..d1b2ddb65337 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2007-01-20 Roger Sayle + Brooks Moses + Francois-Xavier Coudert + + * gfortran.dg/intrinsic_sign_1.f90: New test case. + * gfortran.dg/intrinsic_sign_2.f90: Likewise. + 2007-01-19 Kaveh R. Ghazi * gcc.dg/torture/builtin-math-3.c: Test fdim. diff --git a/gcc/testsuite/gfortran.dg/intrinsic_sign_1.f90 b/gcc/testsuite/gfortran.dg/intrinsic_sign_1.f90 new file mode 100644 index 000000000000..03addde78c40 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsic_sign_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! At one point, SIGN() evaluated its first argument twice. +! Contributed by Brooks Moses +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 diff --git a/gcc/testsuite/gfortran.dg/intrinsic_sign_2.f90 b/gcc/testsuite/gfortran.dg/intrinsic_sign_2.f90 new file mode 100755 index 000000000000..0bc9b07b87c6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsic_sign_2.f90 @@ -0,0 +1,69 @@ +! { 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 +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