OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/35339 (Improve translation of implied do loop in transfer)

Browse Source 
2017-06-05  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-06-05  Nicolas Koenig  <koenigni@student.ethz.ch>

	PR fortran/35339
	* gfortran.dg/implied_do_io_1.f90: New Test.
	* gfortran.dg/implied_do_io_2.f90: New Test.

From-SVN: r248877
This commit is contained in:
Nicolas Koenig 2017-06-05 14:35:11 +02:00 committed by Nicolas Koenig
parent e4d1c5c438
commit 7b3ee9c97d
5 changed files with 355 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2017-06-05 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-06-02 Jakub Jelinek <jakub@redhat.com>
PR fortran/80918

259
gcc/fortran/frontend-passes.c
View File

@ -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);

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2017-06-05 Nicolas Koenig <koenigni@student.ethz.ch>
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 <renlin.li@arm.com>
* c-c++-common/Wfloat-conversion.c: Add large_long_double target

59
gcc/testsuite/gfortran.dg/implied_do_io_1.f90 Normal file
View File

@ -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" } }

23
gcc/testsuite/gfortran.dg/implied_do_io_2.f90 Normal file
View File

@ -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