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

[Mikael Morin <mikael.morin@sfr.fr>]

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