re PR fortran/55806 (Missed optimization with ANY or ALL)

2013-01-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/55806
	* frontend-passes.c (optimize_reduction):  New function,
	including prototype.
	(callback_reduction):  Likewise.
	(gfc_run_passes):  Also run optimize_reduction.
	(copy_walk_reduction_arg):  New function.
	(dummy_code_callback):  New function.

2013-01-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/55806
	* gfortran.dg/array_constructor_40.f90:  New test.

From-SVN: r195179

gcc/fortran/ChangeLog

+2013-01-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/55806
+	* frontend-passes.c (optimize_reduction):  New function,
+	including prototype.
+	(callback_reduction):  Likewise.
+	(gfc_run_passes):  Also run optimize_reduction.
+	(copy_walk_reduction_arg):  New function.
+	(dummy_code_callback):  New function.
+
 2013-01-13  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/55935

gcc/fortran/frontend-passes.c

@@ -40,6 +40,8 @@ static bool optimize_lexical_comparison (gfc_expr *);
 static void optimize_minmaxloc (gfc_expr **);
 static bool is_empty_string (gfc_expr *e);
 static void doloop_warn (gfc_namespace *);
+static void optimize_reduction (gfc_namespace *);
+static int callback_reduction (gfc_expr **, int *, void *);
 
 /* How deep we are inside an argument list.  */
 
@@ -107,6 +109,7 @@ gfc_run_passes (gfc_namespace *ns)
       expr_array = XNEWVEC(gfc_expr **, expr_size);
 
       optimize_namespace (ns);
+      optimize_reduction (ns);
       if (gfc_option.dump_fortran_optimized)
 	gfc_dump_parse_tree (ns, stdout);
 
@@ -180,6 +183,145 @@ optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
   return 0;
 }
 
+/* Auxiliary function to handle the arguments to reduction intrnisics.  If the
+   function is a scalar, just copy it; otherwise returns the new element, the
+   old one can be freed.  */
+
+static gfc_expr *
+copy_walk_reduction_arg (gfc_expr *e, gfc_expr *fn)
+{
+  gfc_expr *fcn;
+  gfc_isym_id id;
+
+  if (e->rank == 0 || e->expr_type == EXPR_FUNCTION)
+    fcn = gfc_copy_expr (e);
+  else
+    {
+      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,
+					fn->value.function.isym->name,
+					fn->where, 3, gfc_copy_expr (e),
+					NULL, NULL);
+      else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
+	fcn = gfc_build_intrinsic_call (current_ns,
+					fn->value.function.isym->id,
+					fn->value.function.isym->name,
+					fn->where, 2, gfc_copy_expr (e),
+					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;
+}
+
+/* Callback function for optimzation of reductions to scalars.  Transform ANY
+   ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
+   correspondingly.  Handly only the simple cases without MASK and DIM.  */
+
+static int
+callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+		    void *data ATTRIBUTE_UNUSED)
+{
+  gfc_expr *fn, *arg;
+  gfc_intrinsic_op op;
+  gfc_isym_id id;
+  gfc_actual_arglist *a;
+  gfc_actual_arglist *dim;
+  gfc_constructor *c;
+  gfc_expr *res, *new_expr;
+  gfc_actual_arglist *mask;
+
+  fn = *e;
+
+  if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
+      || fn->value.function.isym == NULL)
+    return 0;
+
+  id = fn->value.function.isym->id;
+
+  if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
+      && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
+    return 0;
+
+  a = fn->value.function.actual;
+
+  /* Don't handle MASK or DIM.  */
+
+  dim = a->next;
+
+  if (dim->expr != NULL)
+    return 0;
+
+  if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
+    {
+      mask = dim->next;
+      if ( mask->expr != NULL)
+	return 0;
+    }
+
+  arg = a->expr;
+
+  if (arg->expr_type != EXPR_ARRAY)
+    return 0;
+
+  switch (id)
+    {
+    case GFC_ISYM_SUM:
+      op = INTRINSIC_PLUS;
+      break;
+
+    case GFC_ISYM_PRODUCT:
+      op = INTRINSIC_TIMES;
+      break;
+
+    case GFC_ISYM_ANY:
+      op = INTRINSIC_OR;
+      break;
+
+    case GFC_ISYM_ALL:
+      op = INTRINSIC_AND;
+      break;
+
+    default:
+      return 0;
+    }
+
+  c = gfc_constructor_first (arg->value.constructor);
+
+  if (c == NULL)
+    return 0;
+
+  res = copy_walk_reduction_arg (c->expr, fn);
+
+  c = gfc_constructor_next (c);
+  while (c)
+    {
+      new_expr = gfc_get_expr ();
+      new_expr->ts = fn->ts;
+      new_expr->expr_type = EXPR_OP;
+      new_expr->rank = fn->rank;
+      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);
+      res = new_expr;
+      c = gfc_constructor_next (c);
+    }
+
+  gfc_simplify_expr (res, 0);
+  *e = res;
+  gfc_free_expr (fn);
+
+  return 0;
+}
 
 /* Callback function for common function elimination, called from cfe_expr_0.
    Put all eligible function expressions into expr_array.  */
@@ -484,6 +626,16 @@ dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
   return 0;
 }
 
+/* Dummy function for code callback, for use when we really
+   don't want to do anything.  */
+static int
+dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
+		     int *walk_subtrees ATTRIBUTE_UNUSED,
+		     void *data ATTRIBUTE_UNUSED)
+{
+  return 0;
+}
+
 /* Code callback function for converting
    do while(a)
    end do
@@ -639,6 +791,20 @@ optimize_namespace (gfc_namespace *ns)
     }
 }
 
+static void
+optimize_reduction (gfc_namespace *ns)
+{
+  current_ns = ns;
+  gfc_code_walker (&ns->code, dummy_code_callback, callback_reduction, NULL);
+
+/* BLOCKs are handled in the expression walker below.  */
+  for (ns = ns->contained; ns; ns = ns->sibling)
+    {
+      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+	optimize_reduction (ns);
+    }
+}
+
 /* Replace code like
    a = matmul(b,c) + d
    with

gcc/testsuite/ChangeLog

+2013-01-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/55806
+	* gfortran.dg/array_constructor_40.f90:  New test.
+
 2013-01-14  Richard Sandiford  <rdsandiford@googlemail.com>
 
 	* gcc.dg/tree-ssa/slsr-8.c: Allow widening multiplications.

gcc/testsuite/gfortran.dg/array_constructor_40.f90

+! { dg-do run }
+! { dg-options "-ffrontend-optimize -fdump-tree-original" }
+! PR 55806 - replace ANY intrinsic for array
+! constructor with .or.
+
+module mymod
+  implicit none
+contains
+  subroutine bar(a,b,c, lo)
+    real, dimension(3,3), intent(in) :: a,b
+    logical, dimension(3,3), intent(in) :: lo
+    integer, intent(out) :: c
+    real, parameter :: acc = 1e-4
+    integer :: i,j
+    
+    c = 0
+    do i=1,3
+       if (any([abs(a(i,1) - b(i,1)) > acc,  &
+            (j==i+1,j=3,8)])) cycle
+       if (any([abs(a(i,2) - b(i,2)) > acc, &
+            abs(a(i,3) - b(i,3)) > acc, lo(i,:)])) cycle
+       c = c + i
+    end do
+  end subroutine bar
+
+  subroutine baz(a, b, c)
+    real, dimension(3,3), intent(in) :: a,b
+    real, intent(out) :: c
+    c = sum([a(1,1),a(2,2),a(3,3),b(:,1)])
+  end subroutine baz
+end module mymod
+
+program main
+  use mymod
+  implicit none
+  real, dimension(3,3) :: a,b
+  real :: res
+  integer :: c
+  logical lo(3,3)
+  data a/1.1, 1.2, 1.3, 1.4, 1.5, 1.6, 1.7, 1.8, 1.9/
+
+  b = a
+  b(2,2) = a(2,2) + 0.2
+  lo = .false.
+  lo(3,3) = .true.
+  call bar(a,b,c,lo)
+  if (c /= 1) call abort
+  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 { cleanup-tree-dump "original" } }