Re: [Patch, fortran] PR35339 Optimize implied do loops in io statements

[Nicolas Koenig <koenigni at student dot ethz dot ch>]

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  <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-03  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.


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