This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, fortran] PR35339 Optimize implied do loops in io statements
Hello Dominique,
attached is the next try, this time without stupidities (I hope). Both
test cases you posted don't ICE anymore.
Ok for trunk?
Nicolas
Regression tested for x86_64-pc-linux-gnu.
Changelog (still the same):
2017-05-27 Nicolas Koenig <koenigni@student.ethz.ch>
PR fortran/35339
* frontend-passes.c (traverse_io_block): New function.
(simplify_io_impl_do): New function.
(optimize_namespace): Invoke gfc_code_walker with
simplify_io_impl_do.
2017-05-27 Nicolas Koenig <koenigni@student.ethz.ch>
PR fortran/35339
* gfortran.dg/implied_do_io_1.f90: New Test.
On 05/31/2017 05:49 PM, Dominique d'Humières wrote:
Le 31 mai 2017 à 17:40, Dominique d'Humières <dominiq@lps.ens.fr> a écrit :
If I am not mistaken, compiling the following code with the patch applied
simpler test
print *,(huge(0),i=1,6)
! print*,(i,i=1,6)
! print*,(i,i=10000,60000,10000)
end
gives an ICE.
TIA
Dominique
Index: frontend-passes.c
===================================================================
--- frontend-passes.c (revision 248539)
+++ frontend-passes.c (working copy)
@@ -1060,6 +1060,257 @@ convert_elseif (gfc_code **c, int *walk_subtrees A
return 0;
}
+struct do_stack
+{
+ struct do_stack *prev;
+ gfc_iterator *iter;
+ gfc_code *code;
+} *stack_top;
+
+/* Recursivly traverse the block of a WRITE or READ statement, and, can it be
+ optimized, do so. It optimizes it by replacing do loops with their analog
+ array slices. For example:
+
+ write (*,*) (a(i), i=1,4)
+
+ is replaced with
+
+ write (*,*) a(1:4:1) . */
+
+static bool
+traverse_io_block(gfc_code *code, bool *has_reached, gfc_code *prev)
+{
+ gfc_code *curr;
+ gfc_expr *new_e, *expr, *start;
+ gfc_ref *ref;
+ struct do_stack ds_push;
+ int i, future_rank = 0;
+ gfc_iterator *iters[GFC_MAX_DIMENSIONS];
+
+ /* Find the first transfer/do statement. */
+ for (curr = code; curr; curr = curr->next)
+ {
+ if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER)
+ break;
+ }
+
+ /* Ensure it is the only transfer/do statement because cases like
+
+ write (*,*) (a(i), b(i), i=1,4)
+
+ cannot be optimized. */
+
+ if (!curr || curr->next)
+ return false;
+
+ if (curr->op == EXEC_DO)
+ {
+ if (curr->ext.iterator->var->ref)
+ return false;
+ ds_push.prev = stack_top;
+ ds_push.iter = curr->ext.iterator;
+ ds_push.code = curr;
+ stack_top = &ds_push;
+ if (traverse_io_block(curr->block->next, has_reached, prev))
+ {
+ if (curr != stack_top->code && !*has_reached)
+ {
+ curr->block->next = NULL;
+ gfc_free_statements(curr);
+ }
+ else
+ *has_reached = true;
+ return true;
+ }
+ return false;
+ }
+
+ gcc_assert(curr->op == EXEC_TRANSFER);
+
+ ref = curr->expr1->ref;
+ if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next)
+ return false;
+
+ /* Find the iterators belonging to each variable and check conditions. */
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref
+ || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
+ return false;
+
+ start = ref->u.ar.start[i];
+ gfc_simplify_expr(start, 0);
+ switch (start->expr_type)
+ {
+ case EXPR_VARIABLE:
+
+ /* write (*,*) (a(i), i=a%b,1) not handled yet. */
+ if (start->ref)
+ return false;
+
+ /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
+ if (!stack_top || !stack_top->iter
+ || stack_top->iter->var->symtree != start->symtree)
+ iters[i] = NULL;
+ else
+ {
+ iters[i] = stack_top->iter;
+ stack_top = stack_top->prev;
+ future_rank++;
+ }
+ break;
+ case EXPR_CONSTANT:
+ iters[i] = NULL;
+ break;
+ case EXPR_OP:
+ switch (start->value.op.op)
+ {
+ case INTRINSIC_PLUS:
+ case INTRINSIC_TIMES:
+ if (start->value.op.op1->expr_type != EXPR_VARIABLE)
+ std::swap(start->value.op.op1, start->value.op.op2);
+ gcc_fallthrough();
+ case INTRINSIC_MINUS:
+ if ((start->value.op.op1->expr_type!= EXPR_VARIABLE
+ && start->value.op.op2->expr_type != EXPR_CONSTANT)
+ || start->value.op.op1->ref)
+ return false;
+ if (!stack_top || !stack_top->iter
+ || stack_top->iter->var->symtree
+ != start->value.op.op1->symtree)
+ return false;
+ iters[i] = stack_top->iter;
+ stack_top = stack_top->prev;
+ break;
+ default:
+ return false;
+ }
+ future_rank++;
+ break;
+ default:
+ return false;
+ }
+ }
+
+ /* Create new expr. */
+ new_e = gfc_copy_expr(curr->expr1);
+ new_e->expr_type = EXPR_VARIABLE;
+ new_e->rank = future_rank;
+ if (curr->expr1->shape)
+ {
+ new_e->shape = gfc_get_shape(new_e->rank);
+ }
+
+
+ /* Assign new starts, ends and strides if necessary. */
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ if (!iters[i])
+ continue;
+ start = ref->u.ar.start[i];
+ switch (start->expr_type)
+ {
+ case EXPR_CONSTANT:
+ gfc_internal_error("bad expression");
+ break;
+ case EXPR_VARIABLE:
+ new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
+ new_e->ref->u.ar.type = AR_SECTION;
+ gfc_free_expr(new_e->ref->u.ar.start[i]);
+ new_e->ref->u.ar.start[i] = gfc_copy_expr(iters[i]->start);
+ new_e->ref->u.ar.end[i] = gfc_copy_expr(iters[i]->end);
+ new_e->ref->u.ar.stride[i] = gfc_copy_expr(iters[i]->step);
+ break;
+ case EXPR_OP:
+ new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
+ new_e->ref->u.ar.type = AR_SECTION;
+ gfc_free_expr(new_e->ref->u.ar.start[i]);
+ expr = gfc_copy_expr(start);
+ expr->value.op.op1 = gfc_copy_expr(iters[i]->start);
+ new_e->ref->u.ar.start[i] = expr;
+ gfc_simplify_expr(new_e->ref->u.ar.start[i], 0);
+ expr = gfc_copy_expr(start);
+ expr->value.op.op1 = gfc_copy_expr(iters[i]->end);
+ new_e->ref->u.ar.end[i] = expr;
+ gfc_simplify_expr(new_e->ref->u.ar.end[i], 0);
+ switch(start->value.op.op)
+ {
+ case INTRINSIC_MINUS:
+ case INTRINSIC_PLUS:
+ new_e->ref->u.ar.stride[i] = gfc_copy_expr(iters[i]->step);
+ break;
+ case INTRINSIC_TIMES:
+ expr = gfc_copy_expr(start);
+ expr->value.op.op1 = gfc_copy_expr(iters[i]->step);
+ new_e->ref->u.ar.stride[i] = expr;
+ gfc_simplify_expr(new_e->ref->u.ar.stride[i], 0);
+ break;
+ default:
+ gfc_internal_error("bad op");
+ }
+ break;
+ default:
+ gfc_internal_error("bad expression");
+ }
+ }
+ curr->expr1 = new_e;
+
+ /* Insert modified statement. Check whether the statement needs to be
+ inserted at the lowest level. */
+ if (!stack_top->iter)
+ {
+ if (prev)
+ {
+ curr->next = prev->next->next;
+ prev->next = curr;
+ }
+ else
+ {
+ curr->next = stack_top->code->block->next->next->next;
+ stack_top->code->block->next = curr;
+ }
+ }
+ else
+ stack_top->code->block->next = curr;
+ return true;
+}
+
+/* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
+ tries to optimize its block. */
+
+static int
+simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code **curr, *prev = NULL;
+ struct do_stack write, first;
+ bool b = false;
+ *walk_subtrees = 1;
+ if (!(*code)->block || ((*code)->block->op != EXEC_WRITE
+ && (*code)->block->op != EXEC_READ))
+ return 0;
+
+ *walk_subtrees = 0;
+ write.prev = NULL;
+ write.iter = NULL;
+ write.code = *code;
+
+ for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
+ {
+ if ((*curr)->op == EXEC_DO)
+ {
+ first.prev = &write;
+ first.iter = (*curr)->ext.iterator;
+ first.code = *curr;
+ stack_top = &first;
+ traverse_io_block((*curr)->block->next, &b, prev);
+ stack_top = NULL;
+ }
+ prev = *curr;
+ }
+ return 0;
+}
+
/* Optimize a namespace, including all contained namespaces. */
static void
@@ -1073,6 +1324,7 @@ optimize_namespace (gfc_namespace *ns)
in_assoc_list = false;
in_omp_workshare = false;
+ gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
! { dg-do run }
! { dg-options "-O -fdump-tree-original" }
! PR/35339
! This test ensures optimization of implied do loops in io statements
program main
implicit none
integer:: i, j, square
integer, parameter:: k = 2, linenum = 14
integer, dimension(2):: a = [(i, i=1,2)]
integer, dimension(2,2):: b = reshape([1, 2, 3, 4], shape(b))
character (len=30), dimension(linenum) :: res
character (len=30) :: line
type tp
integer, dimension(2):: i
end type
type(tp), dimension(2):: t = [tp([1, 2]), tp([1, 2])]
data res / &
' a 2 2', &
' b 1 2', &
' c 1 2', &
' d 1 2', &
' e 1 2 1 2', &
' f 1 2 1 1 2 2', &
' g 1 2 3 4', &
' h 1 3 2 4', &
' i 2', &
' j 2', &
' k 1 2 1 2', &
' l 1', &
' m 1 1', &
' n 1 2'/
open(10,file="test.dat")
write (10,1000) 'a', (a(k), i=1,2)
write (10,1000) 'b', (b(i, 1), i=1,2)
write (10,1000) 'c', b(1:2:1, 1)
write (10,1000) 'd', (a(i), i=1,2)
write (10,1000) 'e', ((a(i), i=1,2), j=1,2)
write (10,1000) 'f', (a, b(i, 1), i = 1,2)
write (10,1000) 'g', ((b(i, j), i=1,2),j=1,2)
write (10,1000) 'h', ((b(j, i), i=1,2),j=1,2)
write (10,1000) 'i', (a(i+1), i=1,1)
write (10,1000) 'j', (a(i*2), i=1,1)
write (10,1000) 'k', (a(i), i=1,2), (a(i), i=1,2)
write (10,1000) 'l', (a(i), i=1,1)
write (10,1000) 'm', (1, i=1,2)
write (10,1000) 'n', (t(i)%i(i), i=1,2)
rewind (10)
do i=1,linenum
read (10,'(A)') line
if (line .ne. res(i)) call abort
end do
close(10,status="delete")
1000 format (A2,100I4)
end program main
! { dg-final { scan-tree-dump-times "while" 7 "original" } }