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

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

[Dominique d'Humières]

Hi Nicolas,

Updating gfortran with your patch fails with

../../work/gcc/fortran/frontend-passes.c: In function 'bool traverse_io_block(gfc_code*, bool*, gfc_code*)':
../../work/gcc/fortran/frontend-passes.c:1067:20: error: expected unqualified-id before '(' token
 #define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
                    ^
../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro 'swap'
          std::swap(start->value.op.op1, start->value.op.op2);
               ^~~~
../../work/gcc/fortran/frontend-passes.c:1067:36: error: invalid operands of types 'gfc_expr*' and 'gfc_expr*' to binary 'operator^'
 #define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
                                ~~~~^~~~~~
../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro 'swap'
          std::swap(start->value.op.op1, start->value.op.op2);
               ^~~~
../../work/gcc/fortran/frontend-passes.c:1067:41: error:   in evaluation of 'operator^=(struct gfc_expr*, struct gfc_expr*)'
 #define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
                                         ^
../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro 'swap'
          std::swap(start->value.op.op1, start->value.op.op2);
               ^~~~
../../work/gcc/fortran/frontend-passes.c:1067:48: error: invalid operands of types 'gfc_expr*' and 'gfc_expr*' to binary 'operator^'
 #define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
                                            ~~~~^~~~~~
../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro 'swap'
          std::swap(start->value.op.op1, start->value.op.op2);
               ^~~~
../../work/gcc/fortran/frontend-passes.c:1067:53: error:   in evaluation of 'operator^=(struct gfc_expr*, struct gfc_expr*)'
 #define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
                                                     ^
../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro 'swap'
          std::swap(start->value.op.op1, start->value.op.op2);
               ^~~~

TIA

Dominique

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

[Nicolas Koenig]

[-- Attachment #1: Type: text/plain, Size: 2465 bytes --]

Hello Dominique,

mea culpa, their was a bit confusion with the file being open in emacs
and vi at the same time. Attached is the new patch with the #define removed.

Nicolas


On 05/29/2017 05:32 PM, Dominique d'Humières wrote:
> Hi Nicolas,
>
> Updating gfortran with your patch fails with
>
> ../../work/gcc/fortran/frontend-passes.c: In function 'bool traverse_io_block(gfc_code*, bool*, gfc_code*)':
> ../../work/gcc/fortran/frontend-passes.c:1067:20: error: expected unqualified-id before '(' token
>   #define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
>                      ^
> ../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro 'swap'
>            std::swap(start->value.op.op1, start->value.op.op2);
>                 ^~~~
> ../../work/gcc/fortran/frontend-passes.c:1067:36: error: invalid operands of types 'gfc_expr*' and 'gfc_expr*' to binary 'operator^'
>   #define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
>                                  ~~~~^~~~~~
> ../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro 'swap'
>            std::swap(start->value.op.op1, start->value.op.op2);
>                 ^~~~
> ../../work/gcc/fortran/frontend-passes.c:1067:41: error:   in evaluation of 'operator^=(struct gfc_expr*, struct gfc_expr*)'
>   #define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
>                                           ^
> ../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro 'swap'
>            std::swap(start->value.op.op1, start->value.op.op2);
>                 ^~~~
> ../../work/gcc/fortran/frontend-passes.c:1067:48: error: invalid operands of types 'gfc_expr*' and 'gfc_expr*' to binary 'operator^'
>   #define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
>                                              ~~~~^~~~~~
> ../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro 'swap'
>            std::swap(start->value.op.op1, start->value.op.op2);
>                 ^~~~
> ../../work/gcc/fortran/frontend-passes.c:1067:53: error:   in evaluation of 'operator^=(struct gfc_expr*, struct gfc_expr*)'
>   #define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
>                                                       ^
> ../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro 'swap'
>            std::swap(start->value.op.op1, start->value.op.op2);
>                 ^~~~
>
> TIA
>
> Dominique
>


[-- Attachment #2: p5.diff --]
[-- Type: text/x-patch, Size: 7600 bytes --]

Index: frontend-passes.c
===================================================================
--- frontend-passes.c	(revision 248539)
+++ frontend-passes.c	(working copy)
@@ -1060,6 +1060,256 @@ 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;
+
+/* Recursivly traverse the block of a WRITE or READ statement, and, can it be
+   optimized, do so. It optimizes it 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];
+
+  /* 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);
+
+  if (curr->expr1->symtree->n.sym->attr.allocatable)
+    return false;
+
+  ref = curr->expr1->ref;
+  if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0)
+    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);
+	    __attribute__((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;
+	  expr = gfc_copy_expr(start);
+	  expr->value.op.op1 = gfc_copy_expr(iters[i]->end);
+	  new_e->ref->u.ar.end[i] = expr;
+	  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;
+	      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
@@ -1073,6 +1323,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);

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

[Dominique d'Humières]

> Le 29 mai 2017 à 17:49, Nicolas Koenig <koenigni@student.ethz.ch> a écrit :
> 
> Hello Dominique,
> 
> mea culpa, their was a bit confusion with the file being open in emacs
> and vi at the same time. Attached is the new patch with the #define removed.
> 
> Nicolas
> 

Thanks for the quick fix!

Testing in progress

Dominique

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

[Bernhard Reutner-Fischer]

On 29 May 2017 17:49:30 CEST, Nicolas Koenig <koenigni@student.ethz.ch> wrote:
>Hello Dominique,
>
>mea culpa, their was a bit confusion with the file being open in emacs
>and vi at the same time. Attached is the new patch with the #define
>removed.


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

It seems indentation is off above.
thanks,

+	  traverse_io_block((*curr)->block->next, &b, prev);
+	  stack_top = NULL;
+        }
+      prev = *curr;
+    }
+  return 0;
+}

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

[Dominique d'Humières]

If I am not mistaken, compiling the following code with the patch applied

program test_ivs
  use iso_varying_string
  implicit none

  type(varying_string),dimension(:,:),allocatable :: array2d
  type(varying_string) :: extra
  integer :: i,j

  allocate(array2d(2,3))

  extra = "four"

  array2d(:,:) = reshape((/ var_str("1"), &
       var_str("2"), var_str("3"), &
       extra, var_str("5"), &
       var_str("six") /), (/ 2, 3 /))


  print *,"array2d second ",ubound(array2d),(("'"//char(array2d(i,j))//"' ",i=1,size(array2d,1)),j=1,size(array2d,2))

end program test_ivs

gives an ICE.

TIA

Dominique

> Le 31 mai 2017 à 08:16, Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> a écrit :
> 
> On 29 May 2017 17:49:30 CEST, Nicolas Koenig <koenigni@student.ethz.ch> wrote:
>> Hello Dominique,
>> 
>> mea culpa, their was a bit confusion with the file being open in emacs
>> and vi at the same time. Attached is the new patch with the #define
>> removed.

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

[Dominique d'Humières]

> Le 31 mai 2017 à 17:40, Dominique d'Humières <dominiq@lps.ens.fr> a écrit :
> 
> If I am not mistaken, compiling the following code with the patch applied

simpler test

  print *,(huge(0),i=1,6)
!  print*,(i,i=1,6)
!  print*,(i,i=10000,60000,10000)
  end

> 
> gives an ICE.
> 
> TIA
> 
> Dominique

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

[Nicolas Koenig]

[-- Attachment #1: Type: text/plain, Size: 1029 bytes --]

Hello Dominique,

attached is the next try, this time without stupidities (I hope). Both 
test cases you posted don't ICE anymore.

Ok for trunk?

Nicolas

Regression tested for x86_64-pc-linux-gnu.

Changelog (still the same):
2017-05-27  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-05-27  Nicolas Koenig  <koenigni@student.ethz.ch>

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

On 05/31/2017 05:49 PM, Dominique d'Humières wrote:
>> Le 31 mai 2017 à 17:40, Dominique d'Humières <dominiq@lps.ens.fr> a écrit :
>>
>> If I am not mistaken, compiling the following code with the patch applied
> simpler test
>
>    print *,(huge(0),i=1,6)
> !  print*,(i,i=1,6)
> !  print*,(i,i=10000,60000,10000)
>    end
>
>> gives an ICE.
>>
>> TIA
>>
>> Dominique


[-- Attachment #2: p8.diff --]
[-- Type: text/x-patch, Size: 7691 bytes --]

Index: frontend-passes.c
===================================================================
--- frontend-passes.c	(revision 248539)
+++ frontend-passes.c	(working copy)
@@ -1060,6 +1060,257 @@ 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;
+
+/* Recursivly traverse the block of a WRITE or READ statement, and, can it be
+   optimized, do so. It optimizes it 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];
+
+  /* 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);
+
+  ref = curr->expr1->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
@@ -1073,6 +1324,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);

[-- Attachment #3: implied_do_io_1.f90 --]
[-- Type: text/x-fortran, Size: 1744 bytes --]

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

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

[Bernhard Reutner-Fischer]

On 31 May 2017 at 21:03, Nicolas Koenig <koenigni@student.ethz.ch> wrote:
> Hello Dominique,
>
> attached is the next try, this time without stupidities (I hope). Both test
> cases you posted don't ICE anymore.
>
> Ok for trunk?

Please check contrib/check_GNU_style.sh /tmp/p8.diff
and let me point you to contrib/vimrc

Furthermore:

+/* Recursivly traverse the block of a WRITE or READ statement, and, can it be
+   optimized, do so. It optimizes it by replacing do loops with their analog
+   array slices. For example:

s/Recursivly/Recursively

Maybe:
Recursively traverse the block of a WRITE or READ statement and maybe
optimize it by ...

+  if (curr->expr1->shape)
+    {
+      new_e->shape = gfc_get_shape(new_e->rank);
+    }
+
+
No curly braces around single stmt if-bodies.
Excess vertical space.

+  if (!(*code)->block || ((*code)->block->op != EXEC_WRITE
+                          && (*code)->block->op != EXEC_READ))

break line on ||
  if (!(*code)->block
      || ((*code)->block->op != EXEC_WRITE
          && (*code)->block->op != EXEC_READ))

thanks,

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

[Dominique d'Humières]

> Le 31 mai 2017 à 21:03, Nicolas Koenig <koenigni@student.ethz.ch> a écrit :
> 
> Hello Dominique,
> 
> attached is the next try, this time without stupidities (I hope). Both test cases you posted don't ICE anymore.
> 
> Ok for trunk?
> 
> Nicolas
> 

Preliminary tests look OK, full testing in progress.

Thanks,

Dominique

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

[Dominique d'Humières]

> Le 1 juin 2017 à 11:30, Dominique d'Humières <dominiq@lps.ens.fr> a écrit :
> 
> 
>> Le 31 mai 2017 à 21:03, Nicolas Koenig <koenigni@student.ethz.ch> a écrit :
>> 
>> Hello Dominique,
>> 
>> attached is the next try, this time without stupidities (I hope). Both test cases you posted don't ICE anymore.
>> 
>> Ok for trunk?
>> 
>> Nicolas
>> 
> 
> Preliminary tests look OK, full testing in progress.
> 
> Thanks,
> 
> Dominique
> 

I see

FAIL: gfortran.dg/deferred_character_2.f90   -O1  execution test
FAIL: gfortran.dg/deferred_character_2.f90   -O2  execution test
FAIL: gfortran.dg/deferred_character_2.f90   -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions  execution test
FAIL: gfortran.dg/deferred_character_2.f90   -O3 -g  execution test
FAIL: gfortran.dg/deferred_character_2.f90   -Os  execution test

Dominique

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

[Dominique d'Humières]

> Le 1 juin 2017 à 16:19, Dominique d'Humières <dominiq@lps.ens.fr> a écrit :
> 
> I see
> 
> FAIL: gfortran.dg/deferred_character_2.f90   -O1  execution test
> FAIL: gfortran.dg/deferred_character_2.f90   -O2  execution test
> FAIL: gfortran.dg/deferred_character_2.f90   -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions  execution test
> FAIL: gfortran.dg/deferred_character_2.f90   -O3 -g  execution test
> FAIL: gfortran.dg/deferred_character_2.f90   -Os  execution test
> 
> Dominique

Reduced test

PROGRAM hello

    IMPLICIT NONE

    CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_lineas
    CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_copia
    character (3), dimension (2) :: array_fijo = ["abc","def"]
    character (100) :: buffer
    INTEGER :: largo , cant_lineas , i

    write (buffer, "(2a3)") array_fijo

    largo = LEN (array_fijo)

    cant_lineas = size (array_fijo, 1)

    ALLOCATE(CHARACTER(LEN=largo) :: array_lineas(cant_lineas))

    READ(buffer,"(2a3)") (array_lineas(i),i=1,cant_lineas)

    print *, array_lineas
    print *, array_fijo
     if (any (array_lineas .ne. array_fijo)) call abort

END PROGRAM

Dominique

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

[Nicolas Koenig]

[-- Attachment #1: Type: text/plain, Size: 738 bytes --]

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.



[-- Attachment #2: p9.diff --]
[-- Type: text/x-patch, Size: 9861 bytes --]

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

[-- Attachment #3: implied_do_io_1.f90 --]
[-- Type: text/x-fortran, Size: 1743 bytes --]

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

[-- Attachment #4: implied_do_io_2.f90 --]
[-- Type: text/x-fortran, Size: 615 bytes --]

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

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

[Jerry DeLisle]

On 06/03/2017 06:48 AM, Nicolas Koenig wrote:
> 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?
> 

Yes, OK.

Thanks for the work.

Jerry

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

[Bernhard Reutner-Fischer]

On Sat, Jun 03, 2017 at 09:25:31AM -0700, Jerry DeLisle wrote:
> On 06/03/2017 06:48 AM, Nicolas Koenig wrote:
> > 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?
> > 
> 
> Yes, OK.

There still are plenty of coding-style issues (see below).
Can you please rectify them before committing?

Also you change gfc-internals.texi without a ChangeLog entry. I guess
this was an accident?

thanks,

$ contrib/check_GNU_style.sh /tmp/p9.diff 

Blocks of 8 spaces should be replaced with tabs.
40:+        break;
55:+        return false;
61:+        {
64:+              curr->block->next = NULL;
65:+              gfc_free_statements(curr);
70:+        }
92:+          || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
93:+        return false;
98:+        {
111:+              iters[i] = stack_top->iter;
116:+        case EXPR_CONSTANT:
120:+          switch (start->value.op.op)
125:+	        std::swap(start->value.op.op1, start->value.op.op2);
130:+	          || start->value.op.op1->ref)
131:+	        return false;
132:+              if (!stack_top || !stack_top->iter 
135:+	        return false;
146:+        }
160:+        continue;
163:+        {
174:+          break;
214:+        {
215:+          curr->next = prev->next->next;
216:+          prev->next = curr;
219:+        {
220:+          curr->next = stack_top->code->block->next->next->next;
253:+        {
254:+          first.prev = &write;
260:+        }

Trailing whitespace.
18:+   
20:+     
22:+     
25:+static bool 
28:+  gfc_code *curr; 
44:+       
94:+      
106:+	  if (!stack_top || !stack_top->iter 
108:+	    iters[i] = NULL; 
128:+	      if ((start->value.op.op1->expr_type!= EXPR_VARIABLE 
132:+              if (!stack_top || !stack_top->iter 
133:+		  || stack_top->iter->var->symtree 
136:+	      iters[i] = stack_top->iter; 
152:+  new_e->rank = future_rank; 
176:+	  new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE; 
218:+      else 
244:+  
249:+  

Dot, space, space, new sentence.
17:+   optimize by replacing do loops with their analog array slices. For example:

There should be exactly one space between function name and parenthesis.
26:+traverse_io_block(gfc_code *code, bool *has_reached, gfc_code *prev)
60:+      if (traverse_io_block(curr->block->next, has_reached, prev))
65:+              gfc_free_statements(curr);
74:+  gcc_assert(curr->op == EXEC_TRANSFER);
96:+      gfc_simplify_expr(start, 0);
125:+	        std::swap(start->value.op.op1, start->value.op.op2);
126:+	      gcc_fallthrough();
150:+  new_e = gfc_copy_expr(curr->expr1);
154:+    new_e->shape = gfc_get_shape(new_e->rank);
165:+	  gfc_internal_error("bad expression");
170:+	  gfc_free_expr(new_e->ref->u.ar.start[i]);
171:+	  new_e->ref->u.ar.start[i] = gfc_copy_expr(iters[i]->start);
172:+	  new_e->ref->u.ar.end[i] = gfc_copy_expr(iters[i]->end);
173:+	  new_e->ref->u.ar.stride[i] = gfc_copy_expr(iters[i]->step);
178:+	  gfc_free_expr(new_e->ref->u.ar.start[i]);
179:+	  expr = gfc_copy_expr(start);
180:+	  expr->value.op.op1 = gfc_copy_expr(iters[i]->start);
182:+	  gfc_simplify_expr(new_e->ref->u.ar.start[i], 0);
183:+	  expr = gfc_copy_expr(start);
184:+	  expr->value.op.op1 = gfc_copy_expr(iters[i]->end);
186:+	  gfc_simplify_expr(new_e->ref->u.ar.end[i], 0);
187:+	  switch(start->value.op.op)
191:+	      new_e->ref->u.ar.stride[i] = gfc_copy_expr(iters[i]->step);
194:+	      expr = gfc_copy_expr(start);
195:+	      expr->value.op.op1 = gfc_copy_expr(iters[i]->step);
197:+	      gfc_simplify_expr(new_e->ref->u.ar.stride[i], 0);
200:+	      gfc_internal_error("bad op");
204:+	  gfc_internal_error("bad expression");
258:+	  traverse_io_block((*curr)->block->next, &b, prev);

> 
> Thanks for the work.
> 
> Jerry

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

[Nicolas Koenig]

With all the style fixes committed as r248877.

Thanks for the review.

Nicolas


On 06/03/2017 06:25 PM, Jerry DeLisle wrote:
> On 06/03/2017 06:48 AM, Nicolas Koenig wrote:
>> 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?
>>
> Yes, OK.
>
> Thanks for the work.
>
> Jerry

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

[Markus Trippelsdorf]

On 2017.06.05 at 22:39 +0200, Nicolas Koenig wrote:
> With all the style fixes committed as r248877.

171_swim fails now. I didn't bisect, but I suspect your revision.

-- 
Markus

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

[Renlin Li]

171.swim fails on aarch64-linux as well. I dis a bisect and confirm it's r248877 causing 
the miscompare.

Regards,
Renlin

On 06/06/17 12:05, Markus Trippelsdorf wrote:
> On 2017.06.05 at 22:39 +0200, Nicolas Koenig wrote:
>> With all the style fixes committed as r248877.
>
> 171_swim fails now. I didn't bisect, but I suspect your revision.
>

[testsuite, committed] Fix scan pattern in gfortran.dg/implied_do_io_1.f90

[Tom de Vries]

[-- Attachment #1: Type: text/plain, Size: 474 bytes --]

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

On 06/03/2017 03:48 PM, Nicolas Koenig wrote:
> ! { dg-final { scan-tree-dump-times "while" 7 "original" } }


Hi,

I build and tested gcc in a directory with "while" in the path. That 
made this scan fail (with 25 matches, instead of 7), because the dump 
contains lines with <parm>.common.filename = &"<path>".

Fixed by making the scan more precise.

Committed as obvious.

Thanks,
- Tom

[-- Attachment #2: 0001-Fix-scan-pattern-in-gfortran.dg-implied_do_io_1.f90.patch --]
[-- Type: text/x-patch, Size: 738 bytes --]

Fix scan pattern in gfortran.dg/implied_do_io_1.f90

2017-11-02  Tom de Vries  <tom@codesourcery.com>

	* gfortran.dg/implied_do_io_1.f90: Fix scan-tree-dump-times pattern.

---
 gcc/testsuite/gfortran.dg/implied_do_io_1.f90 | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gcc/testsuite/gfortran.dg/implied_do_io_1.f90 b/gcc/testsuite/gfortran.dg/implied_do_io_1.f90
index e4a6d6b..aef36af 100644
--- a/gcc/testsuite/gfortran.dg/implied_do_io_1.f90
+++ b/gcc/testsuite/gfortran.dg/implied_do_io_1.f90
@@ -56,4 +56,4 @@ program main
 1000 format (A2,100I4)
 end program main
 
-! { dg-final { scan-tree-dump-times "while" 7 "original" } }
+! { dg-final { scan-tree-dump-times "(?n)^\\s*while \\(1\\)$" 7 "original" } }

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

[Jerry DeLisle]

On 05/27/2017 12:49 PM, Nicolas Koenig wrote:
> Hello everyone,
> 
> attached is a patch to simplify implied do loops in io statements by replacing 
> them with their respective array slices. For example "WRITE (*,*) (a(i), 
> i=1,4,2)" becomes "WRITE (*,*) a(1:4:2)".
> 
> Ok for trunk?
> 

Thanks for patch. Could you do some timing performance tests with and without 
the patch on large arrays and see if we gain anything?

Also, we should expand the test case to include implied do loops in read 
statements. You could probably just rewind the file, copy down the WRITEs and 
change them to READs or similar and check results.

While doing some checks myself I noticed some odd behavior and found PR53029. I 
posted a patch, but what caught my attention was the implied do version was 
faster than the array version. (about .89 sec vs 6 sec)

So with my patch there I am now getting (.89 sec vs .007 sec)

This prompted me to have you check some performance cases.

Thanks for additional feedback,

Jerry

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

[Nicolas Koenig]

[-- Attachment #1: Type: text/plain, Size: 712 bytes --]

Hello everyone,

attached is a patch to simplify implied do loops in io statements by 
replacing them with their respective array slices. For example "WRITE 
(*,*) (a(i), i=1,4,2)" becomes "WRITE (*,*) a(1:4:2)".

Ok for trunk?

Nicolas

Regression tested for x85_64-pc-linux-gnu.

Changelog:
2017-05-27  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-05-27  Nicolas Koenig  <koenigni@student.ethz.ch>

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


[-- Attachment #2: p4.diff --]
[-- Type: text/x-patch, Size: 7658 bytes --]

Index: frontend-passes.c
===================================================================
--- frontend-passes.c	(revision 248539)
+++ frontend-passes.c	(working copy)
@@ -1060,6 +1060,258 @@ convert_elseif (gfc_code **c, int *walk_subtrees A
   return 0;
 }
 
+#define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
+
+struct do_stack
+{
+  struct do_stack *prev;
+  gfc_iterator *iter;
+  gfc_code *code;
+} *stack_top;
+
+/* Recursivly traverse the block of a WRITE or READ statement, and, can it be
+   optimized, do so. It optimizes it 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];
+
+  /* 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);
+
+  if (curr->expr1->symtree->n.sym->attr.allocatable)
+    return false;
+
+  ref = curr->expr1->ref;
+  if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0)
+    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);
+	    __attribute__((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;
+	  expr = gfc_copy_expr(start);
+	  expr->value.op.op1 = gfc_copy_expr(iters[i]->end);
+	  new_e->ref->u.ar.end[i] = expr;
+	  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;
+	      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
@@ -1073,6 +1325,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);

[-- Attachment #3: implied_do_io_1.f90 --]
[-- Type: text/x-fortran, Size: 1449 bytes --]

! { 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
  integer, parameter:: k = 2, linenum = 11
  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
  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'/

  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)
  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" 5 "original" } }