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. */
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);
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. */
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
}
}
+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
--- /dev/null
+! { 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" } }
projects / platform / upstream / gcc.git / commitdiff