Hello everyone,
here is a version of the patch that includes a workaround for PR 80960.
I have also included a separate test case for the failure that Dominique
detected. The style issues should be fixed.
Regression-tested. OK for trunk?
Nicolas
Changelog:
2017-06-03 Nicolas Koenig <koeni...@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-06-03 Nicolas Koenig <koeni...@student.ethz.ch>
PR fortran/35339
* gfortran.dg/implied_do_io_1.f90: New Test.
* gfortran.dg/implied_do_io_2.f90: New Test.
Index: frontend-passes.c
===================================================================
--- frontend-passes.c (Revision 248553)
+++ frontend-passes.c (Arbeitskopie)
@@ -1064,6 +1064,263 @@ 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;
+
+/* Recursively traverse the block of a WRITE or READ statement, and maybe
+ optimize 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];
+ gfc_expr *e;
+
+ /* 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);
+
+ /* FIXME: Workaround for PR 80945 - array slices with deferred character
+ lenghts do not work. Remove this section when the PR is fixed. */
+ e = curr->expr1;
+ if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
+ && e->ts.deferred)
+ return false;
+ /* End of section to be removed. */
+
+ ref = e->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
@@ -1077,6 +1334,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);
Index: gfc-internals.texi
===================================================================
--- gfc-internals.texi (Revision 248467)
+++ gfc-internals.texi (Arbeitskopie)
@@ -115,6 +115,7 @@ not accurately reflect the status of the most rece
@comment
@menu
* Introduction:: About this manual.
+* Main structure:: Main structure of the compiler
* User Interface:: Code that Interacts with the User.
* Frontend Data Structures::
Data structures used by the frontend
@@ -153,7 +154,43 @@ guide; in the interim, GNU Fortran developers are
contribute to it as a way of keeping notes while working on the
compiler.
+@c ---------------------------------------------------------------------
+@c Main structure of the compiler
+@c ---------------------------------------------------------------------
+@node Main structure
+@chapter Main structure of the compiler
+
+Operation of the compiler can be structured into the main phases
+initialization, parsing, resolution, front-end passes and translations.
+
+The main entry point of the Fortran compiler is
+@code{gfc_be_parse_file} in @file{f95-lang.c}.
+
+@menu
+* Initialization:: Initializing the internal data stuctures.
+* Parsing:: Parsing the user's input.
+* Resolution:: Completing information in the syntax tree.
+* Front-end passes:: Manipulating the syntax tree
+* Translation:: Translating the syntax tree to the middle-end representation
+@end menu
+
+@node Initialization
+@section Initialization
+
+@node Parsing
+@section Parsing
+
+The main entry for parsing is
+@node Resolution
+@section Resolution
+
+@node Front-end passes
+@section Front-end passes
+
+@node Translation
+@section Translation
+
@c ---------------------------------------------------------------------
@c Code that Interacts with the User
@c ---------------------------------------------------------------------
! { 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" } }
! { dg-do run }
! Test that allocatable characters with deferred length
! are written correctly
program main
implicit none
integer:: i
integer, parameter:: N = 10
character(len=:), dimension(:),allocatable:: ca
character(len=50):: buffer, line
allocate(character(len=N):: ca(3))
buffer = "foo bar xyzzy"
ca(1) = "foo"
ca(2) = "bar"
ca(3) = "xyzzy"
write (unit=line, fmt='(3A5)') (ca(i),i=1,3)
if (line /= buffer) call abort
ca(1) = ""
ca(2) = ""
ca(3) = ""
read (unit=line, fmt='(3A5)') (ca(i),i=1,3)
if (line /= buffer) call abort
end program
