[patch, fortran] Simplify (-1.0)**i

[Thomas Koenig <tkoenig at netcologne dot de>]

Hello world,

the attached patch replaces (-1.0)**i with (in C language)
(i & 1) == 0 ? 1.0 : 1.0, see PR 57073.

I tried doing it in the middle end, see the PR of where these
approaches failed.  So, rather than not doing the optimization
at all, I would rather do it in the Fortran front end.

If somebody jumps in with a middle-end solution that works, I
would withdraw this patch.

Regression-tested on trunk.  OK?

	Thomas

2013-05-19  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/57073
        * trans-expr.c:  Simplify (-1.0)**i to (i & 1) == 0 ? 1.0 : -1.0.

2013-05-19  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/57073
        * gfortran.dg/power_6.f90:  New test.

Index: trans-expr.c
===================================================================
--- trans-expr.c	(Revision 199050)
+++ trans-expr.c	(Arbeitskopie)
@@ -2110,18 +2110,41 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
   gfc_se lse;
   gfc_se rse;
   tree fndecl = NULL;
+  gfc_expr *op1, *op2;
 
+  op1 = expr->value.op.op1;
+  op2 = expr->value.op.op2;
+
   gfc_init_se (&lse, se);
-  gfc_conv_expr_val (&lse, expr->value.op.op1);
+  gfc_conv_expr_val (&lse, op1);
   lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
   gfc_add_block_to_block (&se->pre, &lse.pre);
 
   gfc_init_se (&rse, se);
-  gfc_conv_expr_val (&rse, expr->value.op.op2);
+  gfc_conv_expr_val (&rse, op2);
   gfc_add_block_to_block (&se->pre, &rse.pre);
 
-  if (expr->value.op.op2->ts.type == BT_INTEGER
-      && expr->value.op.op2->expr_type == EXPR_CONSTANT)
+  if (op1->ts.type == BT_REAL && op1->expr_type == EXPR_CONSTANT
+      && op2->expr_type != EXPR_CONSTANT
+      && mpfr_cmp_si (op1->value.real, -1L) == 0)
+    {
+      tree tmp, type_op1, type_op2;
+
+      type_op1 = TREE_TYPE (lse.expr);
+      type_op2 = TREE_TYPE (rse.expr);
+
+      tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type_op2,
+			     rse.expr, build_int_cst (type_op2, 1));
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			     tmp, build_int_cst (type_op2, 0));
+      se->expr = fold_build3_loc (input_location, COND_EXPR, type_op1, tmp,
+				  build_real (type_op1, dconst1),
+				  build_real (type_op1, dconstm1));
+      return;
+    }
+
+  if (op2->ts.type == BT_INTEGER
+      && op2->expr_type == EXPR_CONSTANT)
     if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
       return;
 
@@ -2134,11 +2157,11 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
   res_ikind_1 = -1;
   res_ikind_2 = -1;
 
-  kind = expr->value.op.op1->ts.kind;
-  switch (expr->value.op.op2->ts.type)
+  kind = op1->ts.kind;
+  switch (op2->ts.type)
     {
     case BT_INTEGER:
-      ikind = expr->value.op.op2->ts.kind;
+      ikind = op2->ts.kind;
       switch (ikind)
 	{
 	case 1:
@@ -2166,7 +2189,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
 	{
 	case 1:
 	case 2:
-	  if (expr->value.op.op1->ts.type == BT_INTEGER)
+	  if (op1->ts.type == BT_INTEGER)
 	    {
 	      lse.expr = convert (gfc_int4_type_node, lse.expr);
 	      res_ikind_1 = kind;
@@ -2195,7 +2218,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
 	  gcc_unreachable ();
 	}
 
-      switch (expr->value.op.op1->ts.type)
+      switch (op1->ts.type)
 	{
 	case BT_INTEGER:
 	  if (kind == 3) /* Case 16 was not handled properly above.  */

! { dg-do run }
! { dg-options "-fdump-tree-original" }
! PR 57073 - test that (-1.0)**n is transormed into n & 1 == 0 ? 1.0 : -1.0
program main
  integer :: i
  character(len=10) :: c
  real(8) :: a
  c = '-1.0'
  read (unit=c,fmt=*) a
  do i=-3,3
     if ((-1.0_8)**i /= a**i) call abort
  end do
end program main
! { dg-final { scan-tree-dump-times "__builtin_powi" 1 "original" } }
! { dg-final { scan-tree-dump-times "i & 1" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }