[patch, Fortran] PR 55806 - Inefficient ANY with array constructors

[patch, Fortran] PR 55806 - Inefficient ANY with array constructors

[Thomas Koenig]

[-- Attachment #1: Type: text/plain, Size: 745 bytes --]

Hello world,

the attached patch replaces ANY(a, b, c) with a .or. b .or c,
leading to reduced execution time.  It also handles ALL, PRODUCT
and SUM.

This fixes a bug noted by Michael Metcalf.

Regression-tested.  OK for trunk?

	Thomas

2013-01-01  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-01  Thomas Koenig  <tkoenig@gcc.gnu.org>

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

[-- Attachment #2: array_constructor_40.f90 --]
[-- Type: text/x-fortran, Size: 1053 bytes --]

! { 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,  &
            abs(a(i,2) - b(i,2)) > acc, &
            abs(a(i,3) - b(i,3)) > acc, lo(i,:), &
            (j==i+1,j=3,8)])) cycle
       c = c + i
    end do
  end subroutine bar
end module mymod

program main
  use mymod
  implicit none
  real, dimension(3,3) :: a,b
  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
end program main
! { dg-final { scan-tree-dump-times "while" 2 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

[-- Attachment #3: p3.diff --]
[-- Type: text/x-patch, Size: 5937 bytes --]

Index: frontend-passes.c
===================================================================
--- frontend-passes.c	(Revision 194760)
+++ frontend-passes.c	(Arbeitskopie)
@@ -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,7 +183,172 @@ optimize_expr (gfc_expr **e, int *walk_subtrees AT
   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;
+  const char *new_name;
+  gfc_actual_arglist *actual_arglist;
+
+  if (e->rank == 0 || e->expr_type == EXPR_FUNCTION)
+    fcn = gfc_copy_expr (e);
+  else
+    {
+      fcn = gfc_get_expr ();
+      fcn->expr_type = EXPR_FUNCTION;
+      fcn->value.function.isym = fn->value.function.isym;
+      actual_arglist = gfc_get_actual_arglist ();
+      actual_arglist->expr = gfc_copy_expr (e);
+      actual_arglist->next = gfc_get_actual_arglist ();
+      fcn->value.function.actual = actual_arglist;
+      fcn->ts = fn->ts;
+
+      switch (fn->value.function.isym->id)
+	{
+	case GFC_ISYM_SUM:
+	  new_name = "__internal_sum";
+	  break;
+	  
+	case GFC_ISYM_PRODUCT:
+	  new_name = "__internal_product";
+	  break;
+	  
+	case GFC_ISYM_ANY:
+	  new_name = "__internal_any";
+	  break;
+
+	case GFC_ISYM_ALL:
+	  new_name = "__internal_all";
+	  break;
+
+	default:
+	  abort ();
+	}
+
+      gfc_get_sym_tree (new_name, current_ns, &fcn->symtree, false);
+      fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+      fcn->symtree->n.sym->attr.function = 1;
+      fcn->symtree->n.sym->attr.elemental = 1;
+      fcn->symtree->n.sym->attr.referenced = 1;
+      fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+      gfc_commit_symbol (fcn->symtree->n.sym);
+    }
+
+  (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;
+
+  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 != NULL)
+    {
+      gfc_actual_arglist *mask;
+
+      if (dim->expr != NULL)
+	return 0;
+      
+      mask = dim->next;
+      if (mask != NULL)
+	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);
+
+  /* We changed things from under the expression walker.  Walking the
+     old tree would mess up things, so let's not do that.  */
+  return 1;
+}
+
 /* Callback function for common function elimination, called from cfe_expr_0.
    Put all eligible function expressions into expr_array.  */
 
@@ -484,6 +652,16 @@ dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED
   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 +817,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

Re: [patch, Fortran] PR 55806 - Inefficient ANY with array constructors

[Thomas Koenig]

Ping?


http://gcc.gnu.org/ml/fortran/2013-01/msg00000.html

> Hello world,
>
> the attached patch replaces ANY(a, b, c) with a .or. b .or c,
> leading to reduced execution time.  It also handles ALL, PRODUCT
> and SUM.
>
> This fixes a bug noted by Michael Metcalf.
>
> Regression-tested.  OK for trunk?

*ping* [patch, Fortran] PR 55806 - Inefficient ANY with array constructors

[Thomas Koenig]

Ping**2?

This was submitted before the review, so I think it should still be OK.

> Ping?
>
>
> http://gcc.gnu.org/ml/fortran/2013-01/msg00000.html
>
>> Hello world,
>>
>> the attached patch replaces ANY(a, b, c) with a .or. b .or c,
>> leading to reduced execution time.  It also handles ALL, PRODUCT
>> and SUM.
>>
>> This fixes a bug noted by Michael Metcalf.
>>
>> Regression-tested.  OK for trunk?
>
>

Re: [patch, Fortran] PR 55806 - Inefficient ANY with array constructors

[Mikael Morin]

Le 01/01/2013 21:18, Thomas Koenig a écrit :
> Hello world,
>
> the attached patch replaces ANY(a, b, c) with a .or. b .or c,
> leading to reduced execution time. It also handles ALL, PRODUCT
> and SUM.
>
> This fixes a bug noted by Michael Metcalf.
>
> Regression-tested. OK for trunk?
>
A few comments below.

Mikael

> Index: frontend-passes.c
> ===================================================================
> --- frontend-passes.c	(Revision 194760)
> +++ frontend-passes.c	(Arbeitskopie)
> @@ -180,7 +183,172 @@ optimize_expr (gfc_expr **e, int *walk_subtrees AT
>    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;
> +  const char *new_name;
> +  gfc_actual_arglist *actual_arglist;
> +
> +  if (e->rank == 0 || e->expr_type == EXPR_FUNCTION)
> +    fcn = gfc_copy_expr (e);
> +  else
> +    {
> +      fcn = gfc_get_expr ();
> +      fcn->expr_type = EXPR_FUNCTION;
> +      fcn->value.function.isym = fn->value.function.isym;
> +      actual_arglist = gfc_get_actual_arglist ();
> +      actual_arglist->expr = gfc_copy_expr (e);
> +      actual_arglist->next = gfc_get_actual_arglist ();
Another one is needed.  I get a segmentation fault with SUM.

[...]
> +
> +/* 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;
> +
> +  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 != NULL)
> +    {
Minor, but I think you can assume dim != NULL.  Same for mask.

> +      gfc_actual_arglist *mask;
> +
> +      if (dim->expr != NULL)
> +	return 0;
> +
> +      mask = dim->next;
> +      if (mask != NULL)
> +	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);
> +
> +  /* We changed things from under the expression walker.  Walking the
> +     old tree would mess up things, so let's not do that.  */
> +  return 1;
I think this prevents any further reduction optimization. The following 
variant of your test case doesn't avoid the temporary:

     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

Re: [patch, Fortran] PR 55806 - Inefficient ANY with array constructors

[Thomas Koenig]

[-- Attachment #1: Type: text/plain, Size: 1637 bytes --]

Hi Mikael,

thanks a lot for your comments!

>> +      actual_arglist->expr = gfc_copy_expr (e);
>> +      actual_arglist->next = gfc_get_actual_arglist ();
> Another one is needed.  I get a segmentation fault with SUM.

Fixed by using gfc_build_intrisic_call.  I have also put SUM
into the test case.


>> +  if (dim != NULL)
>> +    {
> Minor, but I think you can assume dim != NULL.  Same for mask.

Fixed.

>> +  /* We changed things from under the expression walker.  Walking the
>> +     old tree would mess up things, so let's not do that.  */
>> +  return 1;
> I think this prevents any further reduction optimization. The following
> variant of your test case doesn't avoid the temporary:

You're right; I also could not come up with a test case where this
didn't work.

I have put this

>      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

into the test case.

Updated test case and patch attached.

OK for trunk?

	Thomas

2013-01-13  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  Thomas Koenig  <tkoenig@gcc.gnu.org>

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


[-- Attachment #2: p5.diff --]
[-- Type: text/x-patch, Size: 5242 bytes --]

Index: frontend-passes.c
===================================================================
--- frontend-passes.c	(Revision 195136)
+++ frontend-passes.c	(Arbeitskopie)
@@ -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,7 +183,144 @@ optimize_expr (gfc_expr **e, int *walk_subtrees AT
   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_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;
+      
+  mask = dim->next;
+  if (mask != NULL)
+    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 +624,16 @@ dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED
   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 +789,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

[-- Attachment #3: array_constructor_40.f90 --]
[-- Type: text/x-fortran, Size: 1300 bytes --]

! { 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" } }

Re: [patch, Fortran] PR 55806 - Inefficient ANY with array constructors

[Mikael Morin]

Le 13/01/2013 23:14, Thomas Koenig a écrit :
> Hi Mikael,
>
> thanks a lot for your comments!
>
>>> + actual_arglist->expr = gfc_copy_expr (e); +
>>> actual_arglist->next = gfc_get_actual_arglist ();
>> Another one is needed. I get a segmentation fault with SUM.
>
> Fixed by using gfc_build_intrisic_call.
Nice.


>
> Updated test case and patch attached.
> Index: frontend-passes.c
> ===================================================================
> --- frontend-passes.c	(Revision 195136)
> +++ frontend-passes.c	(Arbeitskopie)
[...]
> +      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_error ("Illegal id in copy_walk_reduction_arg");

This is not very useful for a user.  It should be an internal error (or 
gcc_unreachable would do as well).


> +
> +/* 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;
> +
Trailing whitespace.

> +  mask = dim->next;
> +  if (mask != NULL)
> +    if ( mask->expr != NULL)
> +      return 0;
This is a bit confusing as mask is the first argument in the ANY/ALL 
case.  You can use something like this instead:
if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
   {
     mask = dim->next;
     if (mask->expr != NULL)
       return 0;
   }



>
> OK for trunk?
>
OK with the changes suggested above. Thanks.

Mikael

Re: [patch, Fortran] PR 55806 - Inefficient ANY with array constructors

[Thomas Koenig]

Am 14.01.2013 14:29, schrieb Mikael Morin:
> Le 13/01/2013 23:14, Thomas Koenig a écrit :

>> OK for trunk?
>>
> OK with the changes suggested above. Thanks.

Committed as rev. 195179 with your changes.

Thanks a lot for the thorough review!

	Thomas

Re: [patch, Fortran] PR 55806 - Inefficient ANY with array constructors

[Bernhard Reutner-Fischer]

On Mon, Jan 14, 2013 at 10:51:25PM +0100, Thomas Koenig wrote:
> Am 14.01.2013 14:29, schrieb Mikael Morin:
> > Le 13/01/2013 23:14, Thomas Koenig a écrit :
> 
> > > OK for trunk?
> > > 
> > OK with the changes suggested above. Thanks.
> 
> Committed as rev. 195179 with your changes.

s/intrnisics/intrinsics/; # in a comment

And in r232774 this found it's way into a runtime error:
s/intrnisic/intrinsic/g
( gfortran.dg/matmul_bounds_9.f90 needs adjustment)

TIA,