re PR fortran/56872 (Incorrect SUM evaluation, involving implied-do loop, with -ffron...

2013-04-19  Thomas Koenig  <tkoenig@gcc.gnu.org>
	    Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/56872
	* frontend-passes.c (copy_walk_reduction_arg): Change argument type
	to gfc_constructor.  If it has an iterator, wrap the copy of its
	expression in an array constructor with that iterator.  Don't special
	case function expressions.
	(callback_reduction): Update caller.  Don't return early if there is
	an iterator.

2013-04-19  Thomas Koenig  <tkoenig@gcc.gnu.org>
	    Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/56872
	* gfortran.dg/array_constructor_45.f90:  New test.
	* gfortran.dg/array_constructor_46.f90:  New test.
	* gfortran.dg/array_constructor_47.f90:  New test.
	* gfortran.dg/array_constructor_40.f90:  Adjust number of
	while loops.

Co-Authored-By: Mikael Morin <mikael@gcc.gnu.org>
From-SVN: r198086

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2f2d5ee440de9eaaaec263a7180cbfcd04599bdd..9323af9b8c6818102c5098a000eaabc7c680f375 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2013-04-19  Thomas Koenig  <tkoenig@gcc.gnu.org>
+           Mikael Morin  <mikael@gcc.gnu.org>
+
+       PR fortran/56872
+       * frontend-passes.c (copy_walk_reduction_arg): Change argument type
+       to gfc_constructor.  If it has an iterator, wrap the copy of its
+       expression in an array constructor with that iterator.  Don't special
+       case function expressions.
+       (callback_reduction): Update caller.  Don't return early if there is
+       an iterator.
+
 2013-04-18  Tobias Burnus  <burnus@net-b.de>
 
        * expr.c (find_array_element): Don't copy expr.

diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 68e7e053056eb350bb2d57c89dbef5e29f8685ae..0618aed895a30717b39c0063fc56791d964354ab 100644 (file)
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -192,37 +192,49 @@ optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    old one can be freed.  */
 
 static gfc_expr *
-copy_walk_reduction_arg (gfc_expr *e, gfc_expr *fn)
+copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
 {
-  gfc_expr *fcn;
-  gfc_isym_id id;
+  gfc_expr *fcn, *e = c->expr;
 
-  if (e->rank == 0 || e->expr_type == EXPR_FUNCTION)
-    fcn = gfc_copy_expr (e);
-  else
+  fcn = gfc_copy_expr (e);
+  if (c->iterator)
+    {
+      gfc_constructor_base newbase;
+      gfc_expr *new_expr;
+      gfc_constructor *new_c;
+
+      newbase = NULL;
+      new_expr = gfc_get_expr ();
+      new_expr->expr_type = EXPR_ARRAY;
+      new_expr->ts = e->ts;
+      new_expr->where = e->where;
+      new_expr->rank = 1;
+      new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
+      new_c->iterator = c->iterator;
+      new_expr->value.constructor = newbase;
+      c->iterator = NULL;
+
+      fcn = new_expr;
+    }
+
+  if (fcn->rank != 0)
     {
-      id = fn->value.function.isym->id;
+      gfc_isym_id id = fn->value.function.isym->id;
 
       if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
-       fcn = gfc_build_intrinsic_call (current_ns,
-                                       fn->value.function.isym->id,
+       fcn = gfc_build_intrinsic_call (current_ns, id,
                                        fn->value.function.isym->name,
-                                       fn->where, 3, gfc_copy_expr (e),
-                                       NULL, NULL);
+                                       fn->where, 3, fcn, NULL, NULL);
       else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
-       fcn = gfc_build_intrinsic_call (current_ns,
-                                       fn->value.function.isym->id,
+       fcn = gfc_build_intrinsic_call (current_ns, id,
                                        fn->value.function.isym->name,
-                                       fn->where, 2, gfc_copy_expr (e),
-                                       NULL);
+                                       fn->where, 2, fcn, NULL);
       else
        gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
 
       fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
     }
 
-  (void) gfc_expr_walker (&fcn, callback_reduction, NULL);
-
   return fcn;
 }
 
@@ -305,10 +317,10 @@ callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
      - only have a single element in the array which contains an
      iterator.  */
 
-  if (c == NULL || (c->iterator != NULL && gfc_constructor_next (c) == NULL))
+  if (c == NULL)
     return 0;
 
-  res = copy_walk_reduction_arg (c->expr, fn);
+  res = copy_walk_reduction_arg (c, fn);
 
   c = gfc_constructor_next (c);
   while (c)
@@ -320,7 +332,7 @@ callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
       new_expr->where = fn->where;
       new_expr->value.op.op = op;
       new_expr->value.op.op1 = res;
-      new_expr->value.op.op2 = copy_walk_reduction_arg (c->expr, fn);
+      new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
       res = new_expr;
       c = gfc_constructor_next (c);
     }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7532b5abff1787ebe1834e5ac7bddabe677ffa30..930fb254e01c1c16ac9f0ade74befd88519e98a5 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,13 @@
+2013-04-19  Thomas Koenig  <tkoenig@gcc.gnu.org>
+           Mikael Morin  <mikael@gcc.gnu.org>
+
+       PR fortran/56872
+       * gfortran.dg/array_constructor_45.f90:  New test.
+       * gfortran.dg/array_constructor_46.f90:  New test.
+       * gfortran.dg/array_constructor_47.f90:  New test.
+       * gfortran.dg/array_constructor_40.f90:  Adjust number of
+       while loops.
+
 2013-04-18  Jakub Jelinek  <jakub@redhat.com>
 
        PR rtl-optimization/56999

diff --git a/gcc/testsuite/gfortran.dg/array_constructor_40.f90 b/gcc/testsuite/gfortran.dg/array_constructor_40.f90
index ca91d5eacda858daffe048f23723f9e86199119f..424f6f4fe75684ffb4d28618a6a33e75c782994c 100644 (file)
--- a/gcc/testsuite/gfortran.dg/array_constructor_40.f90
+++ b/gcc/testsuite/gfortran.dg/array_constructor_40.f90
@@ -48,5 +48,5 @@ program main
   call baz(a,b,res);
   if (abs(res - 8.1) > 1e-5) call abort
 end program main
-! { dg-final { scan-tree-dump-times "while" 3 "original" } }
+! { dg-final { scan-tree-dump-times "while" 5 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }

diff --git a/gcc/testsuite/gfortran.dg/array_constructor_45.f90 b/gcc/testsuite/gfortran.dg/array_constructor_45.f90
new file mode 100644 (file)
index 0000000..fdf049c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_constructor_45.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+! PR PR 56872 - wrong front-end optimization with a
+! single array constructor and another value.
+program main
+  real    :: s
+  integer :: m
+  integer :: k
+  real :: res
+
+  m = 2
+  s = 1000.
+
+  res = SUM([3.0,(s**(REAL(k-1)/REAL(m-1)),k=1,m),17.])
+  if (abs(res - 1021.)>1e-4) call abort
+end

diff --git a/gcc/testsuite/gfortran.dg/array_constructor_46.f90 b/gcc/testsuite/gfortran.dg/array_constructor_46.f90
new file mode 100644 (file)
index 0000000..471c6a8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_constructor_46.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+! { dg-options "-ffrontend-optimize -fdump-tree-original" }
+! Test that nested array constructors are optimized.
+program main
+  implicit none
+  integer, parameter :: dp=selected_real_kind(15)
+  real(kind=dp), dimension(2,2) :: a
+  real(kind=dp) thirteen
+
+  data a /2._dp,3._dp,5._dp,7._dp/
+  thirteen = 13._dp
+  if (abs (product([[11._dp, thirteen], a]) - 30030._dp) > 1e-8) call abort
+end program main
+! { dg-final { scan-tree-dump-times "while" 2 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

diff --git a/gcc/testsuite/gfortran.dg/array_constructor_47.f90 b/gcc/testsuite/gfortran.dg/array_constructor_47.f90
new file mode 100644 (file)
index 0000000..2ad85be
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_constructor_47.f90
@@ -0,0 +1,24 @@
+! { dg-do run }
+! { dg-options "-ffrontend-optimize -fdump-tree-original" }
+! Test that reduction optimization doesn't break with a function expression
+! in an array constructor. 
+program main
+  implicit none
+  integer, parameter :: dp=selected_real_kind(15)
+  real(kind=dp), dimension(2,2) :: a
+  real(kind=dp) thirteen
+
+  data a /2._dp,3._dp,5._dp,7._dp/
+  thirteen = 13._dp
+  if (abs (product([[sum([eleven_ones()]), thirteen], a]) - 30030._dp) > 1e-8) call abort
+ contains
+  function eleven_ones()
+    real(kind=dp) :: eleven_ones(11)
+    integer       :: i
+
+    eleven_ones = [ (1._dp, i=1,11) ]
+  end function eleven_ones
+end program main
+! { dg-final { scan-tree-dump-times "while" 4 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+