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

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

gcc/fortran/ChangeLog

+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

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

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/implied_do_io_1.f90

+! { 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" } }

gcc/testsuite/gfortran.dg/implied_do_io_2.f90

+! { 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
+