From 7b3ee9c97d7eb8eedf46ec04e85dc02fb5161f75 Mon Sep 17 00:00:00 2001 From: Nicolas Koenig Date: Mon, 5 Jun 2017 14:35:11 +0200 Subject: [PATCH] re PR fortran/35339 (Improve translation of implied do loop in transfer) 2017-06-05 Nicolas Koenig 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-05 Nicolas Koenig PR fortran/35339 * gfortran.dg/implied_do_io_1.f90: New Test. * gfortran.dg/implied_do_io_2.f90: New Test. From-SVN: r248877 --- gcc/fortran/ChangeLog | 8 + gcc/fortran/frontend-passes.c | 259 ++++++++++++++++++ gcc/testsuite/ChangeLog | 6 + gcc/testsuite/gfortran.dg/implied_do_io_1.f90 | 59 ++++ gcc/testsuite/gfortran.dg/implied_do_io_2.f90 | 23 ++ 5 files changed, 355 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/implied_do_io_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/implied_do_io_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f95fef0580d..7b61cc4fce5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2017-06-05 Nicolas Koenig + + 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-02 Jakub Jelinek PR fortran/80918 diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index be02dce05ea..8fa1de12acc 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -1064,6 +1064,264 @@ convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 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 +1335,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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 34bbae7a135..bed2af7c5c1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2017-06-05 Nicolas Koenig + + PR fortran/35339 + * gfortran.dg/implied_do_io_1.f90: New Test. + * gfortran.dg/implied_do_io_2.f90: New Test. + 2017-06-05 Renlin Li * c-c++-common/Wfloat-conversion.c: Add large_long_double target diff --git a/gcc/testsuite/gfortran.dg/implied_do_io_1.f90 b/gcc/testsuite/gfortran.dg/implied_do_io_1.f90 new file mode 100644 index 00000000000..e4a6d6b37b3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/implied_do_io_1.f90 @@ -0,0 +1,59 @@ +! { 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" } } diff --git a/gcc/testsuite/gfortran.dg/implied_do_io_2.f90 b/gcc/testsuite/gfortran.dg/implied_do_io_2.f90 new file mode 100644 index 00000000000..52edde54329 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/implied_do_io_2.f90 @@ -0,0 +1,23 @@ +! { 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 + -- 2.30.2