Hello world,
this patch moves expressions which do not depend on the
index variable(s) from FORALL headers (which also includes
DO CONCURRENT).
For the test case in do_concurrent_4.f90,
do concurrent(i=1:n, a(i)>sum(a)/n)
a(i) = a(i) * 0.5
end do
Without the patch, this gets translated in a
straightforward manner to
DO CONCURRENT main:i 1:10:1(> main:a(main:i) (/
_gfortran_sum_r4[[((main:a(FULL)) ((arg not-present)) ((arg
not-present)))]] 1.00000000e1))
ASSIGN main:a(main:i) (* main:a(main:i) 5.00000000e-1) END DO
With the patch and with front-end optimization on, this becomes
ASSIGN block@7:__var_1 (/ _gfortran_sum_r4[[((main:a(FULL)) ((arg
not-present)) ((arg not-present)))]] 1.00000000e1)
DO CONCURRENT main:i 1:10:1(> main:a(main:i) block@7:__var_1)
ASSIGN main:a(main:i) (* main:a(main:i) 5.00000000e-1) END DO
There is one fine point regarding the part of the patch used to check
if an expression is identical to the loop variable:
+ se = (*e)->symtree;
+
+ if (se == NULL)
+ return 0;
+
+ for (fa = (*current_code)->ext.forall_iterator; fa;
+ fa = fa->next)
+ {
+ if (se == fa->var->symtree)
+ return 1;
+ }
+ return 0;
Originally, this was
+ se = (*e)->symtree->n.sym;
+
+ for (fa = (*current_code)->ext.forall_iterator; fa; fa = fa->next)
+ {
+ si = fa->var->symtree->n.sym;
+ if (si == se)
+ return 1;
+ }
+
but this caused a regression in forall_5.f90 when
fa->var->symtree held the address 0x04 (which only
occurred when running the test suite). I could not
figure out where this strange value was being generated,
so I setteled for comparing the symtree address instead
(and adding a NULL check just in case :-)
Regression-tested. OK for trunk?
Regards
Thomas
2014-08-17 Thomas Koenig <[email protected]>
PR fortran/60661
* frontend-passes.c (optimize_forall_header): Add prototype,
new function.
(optimize_code): Call optimize_forall_header.
(concurrent_iterator_check): New function.
(forall_header_varmove): New function.
2014-08-17 Thomas Koenig <[email protected]>
PR fortran/60661
* gfortran.dg/do_concurrent_4.f90: New test.
* gfortran.dg/do_concurrent_5.f90: New test.
Index: frontend-passes.c
===================================================================
--- frontend-passes.c (Revision 214061)
+++ frontend-passes.c (Arbeitskopie)
@@ -33,6 +33,7 @@ along with GCC; see the file COPYING3. If not see
static void strip_function_call (gfc_expr *);
static void optimize_namespace (gfc_namespace *);
static void optimize_assignment (gfc_code *);
+static void optimize_forall_header (gfc_code *);
static bool optimize_op (gfc_expr *);
static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
static bool optimize_trim (gfc_expr *);
@@ -145,6 +146,10 @@ optimize_code (gfc_code **c, int *walk_subtrees AT
if (op == EXEC_ASSIGN)
optimize_assignment (*c);
+
+ if (op == EXEC_DO_CONCURRENT || op == EXEC_FORALL)
+ optimize_forall_header (*c);
+
return 0;
}
@@ -980,6 +985,70 @@ remove_trim (gfc_expr *rhs)
return ret;
}
+/* Callback function to check if there is a reference
+ to one of the concurrent iterators in the expression. */
+
+static int
+concurrent_iterator_check (gfc_expr **e,
+ int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_symtree *se;
+ gfc_forall_iterator *fa;
+
+ if ((*e)->expr_type != EXPR_VARIABLE)
+ return 0;
+
+ se = (*e)->symtree;
+
+ if (se == NULL)
+ return 0;
+
+ for (fa = (*current_code)->ext.forall_iterator; fa;
+ fa = fa->next)
+ {
+ if (se == fa->var->symtree)
+ return 1;
+ }
+ return 0;
+}
+
+/* Callback helper function for optimizing the header of
+ FORALL and DO CONCURRENT. */
+
+static int
+forall_header_varmove (gfc_expr **e,
+ int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ if ((*e)->expr_type == EXPR_VARIABLE && (*e)->ref == NULL)
+ return 0;
+
+ if ((*e)->expr_type == EXPR_CONSTANT)
+ return 0;
+
+ if (gfc_expr_walker (e, concurrent_iterator_check, NULL) == 0)
+ {
+ gfc_expr *ex;
+
+ ex = create_var (*e);
+ (*e) = ex;
+ *walk_subtrees = 1;
+ }
+ return 0;
+}
+
+/* Optimization for FORALL and DO CONCURRENT masks. */
+
+static void
+optimize_forall_header (gfc_code *c)
+{
+ if (c->expr1 == NULL)
+ return;
+
+ gfc_expr_walker (&(c->expr1), forall_header_varmove, NULL);
+}
+
/* Optimizations for an assignment. */
static void
! { dg-do run }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }
! Test movement of expressions not involving the index variable
program main
implicit none
integer, parameter :: n = 10
real, dimension(n) :: a,res
integer :: i
data a/0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9/
data res /0.0, 0.1, 0.2, 0.3, 0.4, 0.25, 0.3, 0.35, 0.4, 0.45/
do concurrent(i=1:n, a(i)>sum(a)/n)
a(i) = a(i) * 0.5
end do
if (any(abs(a-res) > 1e-6)) call abort
end
! { dg-final { scan-tree-dump-times "__var" 3 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-do run }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }
! Check no movment of expressions which involve the index variable
program main
implicit none
integer, parameter :: n = 10
real, dimension(n) :: a, res
integer :: i
data a/0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9/
data res /0.0, 0.1, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45/
do concurrent(i=1:n, sum(a(1:i)) > (i/2)/6.0)
a(i) = a(i) * 0.5
end do
if (any(abs(a-res) > 1e-6)) call abort
end
! { dg-final { scan-tree-dump-times "__var" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
