[patch, fortran] PR32382 missed optimization in internal read - updated

[Jerry DeLisle <jvdelisle at verizon dot net>]

Hi folks,

This is an updated patch that handles the general case of implied do loops.  The 
attached example test case is modified to include nested implied do loops in the 
read.

(First patch (ignore) was here:
	http://gcc.gnu.org/ml/fortran/2010-02/msg00091.html )

Without the patch: using 4.4.3

real	1m20.369s
user	1m20.289s
sys	0m0.016s

With the patch: using trunk

real	0m0.013s
user	0m0.003s
sys	0m0.001s

This problem manifests with both internal and external units.

The revised patch modifies gfc_trans_code to accept a condition parameter.  This 
parameter is then passed into gfc_trans_do (and gfc_trans_simple_do).  In all 
calls to gfc_trans_code accept inside build_dt, the condition is set to 
NULL_TREE.  When non NULL_TREE is passed into gfc_trans_do, code is built to 
test the iostat conditions of the IO data transfers. The loops exit on EOR, END, 
and ERR.

Regression tested on X86_64.  No new test case needed.

OK for trunk?

2010-02-13  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/32382
	* trans-stmt.h: Update function prototype for gfc_trans_code and
	gfc_trans_do, adding condition tree argument.
	* trans-openmp.c (gfc_trans_omp_code, gfc_trans_omp_critical,
	gfc_trans_omp_flush, gfc_trans_omp_master): Pass NULL_TREE for new
	argument of gfc_trans_code.
	* trans-decl.c (gfc_generate_function_code): Likewise.
	* trans-stmt.c (gfc_trans_if_1, gfc_trans_block_construct,
	gfc_trans_integer_select, gfc_trans_logical_select,
	gfc_trans_logical_select, gfc_trans_character_select): Likewise.
	(gfc_trans_simple_do): Add optional argument to pass in a
	loop exit condition.  Build the loop exit code if present.
	(gfc_trans_do): Likewise.
	* trans.c (gfc_trans_code): Add tree cond to argument list. Use
	NULL_TREE for exit condition in call to gfc_trans_do.
	* trans-io.c (build_dt): Build an exit condition to allow checking IO
	result status bits in the dtparm structure. Use this condition in call
	to gfc_trans_code, adding a runtime error check inside implied do loops.

C234567
      program internalread
      implicit none
      integer m
CC      parameter(m=1000000)
      parameter(m=10000)
      character value*10
      integer i,j,k,iv(m,3)

      DO j=1,100
        write(value,'(i3,a5)') j," 5 69"
        write(*,*) value
        read(value,*,end=20,err=20)((iv(i,k),i=1,m),k=1,m)
20      write(*,*) j
      ENDDO
      end program internalread

Index: trans-openmp.c
===================================================================
--- trans-openmp.c	(revision 156750)
+++ trans-openmp.c	(working copy)
@@ -919,7 +919,7 @@ gfc_trans_omp_code (gfc_code *code, bool force_emp
   tree stmt;
 
   pushlevel (0);
-  stmt = gfc_trans_code (code);
+  stmt = gfc_trans_code (code, NULL_TREE);
   if (TREE_CODE (stmt) != BIND_EXPR)
     {
       if (!IS_EMPTY_STMT (stmt) || force_empty)
@@ -1119,7 +1119,7 @@ gfc_trans_omp_critical (gfc_code *code)
   tree name = NULL_TREE, stmt;
   if (code->ext.omp_name != NULL)
     name = get_identifier (code->ext.omp_name);
-  stmt = gfc_trans_code (code->block->next);
+  stmt = gfc_trans_code (code->block->next, NULL_TREE);
   return build2 (OMP_CRITICAL, void_type_node, stmt, name);
 }
 
@@ -1372,7 +1372,7 @@ gfc_trans_omp_flush (void)
 static tree
 gfc_trans_omp_master (gfc_code *code)
 {
-  tree stmt = gfc_trans_code (code->block->next);
+  tree stmt = gfc_trans_code (code->block->next, NULL_TREE);
   if (IS_EMPTY_STMT (stmt))
     return stmt;
   return build1_v (OMP_MASTER, stmt);
@@ -1381,7 +1381,7 @@ gfc_trans_omp_master (gfc_code *code)
 static tree
 gfc_trans_omp_ordered (gfc_code *code)
 {
-  return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
+  return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next, NULL_TREE));
 }
 
 static tree
Index: trans-stmt.c
===================================================================
--- trans-stmt.c	(revision 156750)
+++ trans-stmt.c	(working copy)
@@ -657,7 +657,7 @@ gfc_trans_if_1 (gfc_code * code)
 
   /* Check for an unconditional ELSE clause.  */
   if (!code->expr1)
-    return gfc_trans_code (code->next);
+    return gfc_trans_code (code->next, NULL_TREE);
 
   /* Initialize a statement builder for each block. Puts in NULL_TREEs.  */
   gfc_init_se (&if_se, NULL);
@@ -667,7 +667,7 @@ gfc_trans_if_1 (gfc_code * code)
   gfc_conv_expr_val (&if_se, code->expr1);
 
   /* Translate the THEN clause.  */
-  stmt = gfc_trans_code (code->next);
+  stmt = gfc_trans_code (code->next, NULL_TREE);
 
   /* Translate the ELSE clause.  */
   if (code->block)
@@ -791,7 +791,7 @@ gfc_trans_block_construct (gfc_code* code)
   gfc_start_block (&body);
   gfc_process_block_locals (ns);
 
-  tmp = gfc_trans_code (ns->code);
+  tmp = gfc_trans_code (ns->code, NULL_TREE);
   tmp = gfc_trans_deferred_vars (sym, tmp);
 
   gfc_add_expr_to_block (&body, tmp);
@@ -831,7 +831,7 @@ gfc_trans_block_construct (gfc_code* code)
 
 static tree
 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
-		     tree from, tree to, tree step)
+		     tree from, tree to, tree step, tree exit_cond)
 {
   stmtblock_t body;
   tree type;
@@ -864,7 +864,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t
   gfc_start_block (&body);
 
   /* Main loop body.  */
-  tmp = gfc_trans_code (code->block->next);
+  tmp = gfc_trans_code (code->block->next, exit_cond);
   gfc_add_expr_to_block (&body, tmp);
 
   /* Label for cycle statements (if needed).  */
@@ -882,6 +882,15 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t
 			       "Loop variable has been modified");
     }
 
+  /* Exit the loop if there is an I/O result condition or error.  */
+  if (exit_cond)
+    {
+      tmp = build1_v (GOTO_EXPR, exit_label);
+      tmp = fold_build3 (COND_EXPR, void_type_node, exit_cond, tmp,
+			 build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
   /* Evaluate the loop condition.  */
   cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to);
   cond = gfc_evaluate_now (cond, &body);
@@ -955,7 +964,7 @@ exit_label:
    because the loop count itself can overflow.  */
 
 tree
-gfc_trans_do (gfc_code * code)
+gfc_trans_do (gfc_code * code, tree exit_cond)
 {
   gfc_se se;
   tree dovar;
@@ -1010,7 +1019,7 @@ tree
   if (TREE_CODE (type) == INTEGER_TYPE
       && (integer_onep (step)
 	|| tree_int_cst_equal (step, integer_minus_one_node)))
-    return gfc_trans_simple_do (code, &block, dovar, from, to, step);
+    return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
 
   pos_step = fold_build2 (GT_EXPR, boolean_type_node, step,
 			  fold_convert (type, integer_zero_node));
@@ -1125,7 +1134,7 @@ tree
   code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
 
   /* Main loop body.  */
-  tmp = gfc_trans_code (code->block->next);
+  tmp = gfc_trans_code (code->block->next, exit_cond);
   gfc_add_expr_to_block (&body, tmp);
 
   /* Label for cycle statements (if needed).  */
@@ -1143,6 +1152,15 @@ tree
 			       "Loop variable has been modified");
     }
 
+  /* Exit the loop if there is an I/O result condition or error.  */
+  if (exit_cond)
+    {
+      tmp = build1_v (GOTO_EXPR, exit_label);
+      tmp = fold_build3 (COND_EXPR, void_type_node, exit_cond, tmp,
+			 build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
   /* Increment the loop variable.  */
   tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
   gfc_add_modify (&body, dovar, tmp);
@@ -1233,7 +1251,7 @@ gfc_trans_do_while (gfc_code * code)
   gfc_add_expr_to_block (&block, tmp);
 
   /* The main body of the loop.  */
-  tmp = gfc_trans_code (code->block->next);
+  tmp = gfc_trans_code (code->block->next, NULL_TREE);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Label for cycle statements (if needed).  */
@@ -1388,7 +1406,7 @@ gfc_trans_integer_select (gfc_code * code)
 	}
 
       /* Add the statements for this case.  */
-      tmp = gfc_trans_code (c->next);
+      tmp = gfc_trans_code (c->next, NULL_TREE);
       gfc_add_expr_to_block (&body, tmp);
 
       /* Break to the end of the construct.  */
@@ -1468,7 +1486,7 @@ gfc_trans_logical_select (gfc_code * code)
       /* Cases for .TRUE. and .FALSE. are in the same block.  Just
          translate the code for these cases, append it to the current
          block.  */
-      gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
+      gfc_add_expr_to_block (&block, gfc_trans_code (t->next, NULL_TREE));
     }
   else
     {
@@ -1493,10 +1511,10 @@ gfc_trans_logical_select (gfc_code * code)
       /* Translate the code for each of these blocks, and append it to
          the current block.  */
       if (t != NULL)
-        true_tree = gfc_trans_code (t->next);
+        true_tree = gfc_trans_code (t->next, NULL_TREE);
 
       if (f != NULL)
-	false_tree = gfc_trans_code (f->next);
+	false_tree = gfc_trans_code (f->next, NULL_TREE);
 
       stmt = fold_build3 (COND_EXPR, void_type_node, se.expr,
 			  true_tree, false_tree);
@@ -1596,7 +1614,7 @@ gfc_trans_character_select (gfc_code *code)
           gfc_add_expr_to_block (&body, tmp);
         }
 
-      tmp = gfc_trans_code (c->next);
+      tmp = gfc_trans_code (c->next, NULL_TREE);
       gfc_add_expr_to_block (&body, tmp);
 
       tmp = build1_v (GOTO_EXPR, end_label);
Index: trans-stmt.h
===================================================================
--- trans-stmt.h	(revision 156750)
+++ trans-stmt.h	(working copy)
@@ -21,7 +21,7 @@ along with GCC; see the file COPYING3.  If not see
 
 /* Statement translators (gfc_trans_*) return a fully translated tree.
    Calls gfc_trans_*.  */
-tree gfc_trans_code (gfc_code *);
+tree gfc_trans_code (gfc_code *, tree);
 
 /* All other gfc_trans_* should only need be called by gfc_trans_code */
 
@@ -45,7 +45,7 @@ tree gfc_trans_return (gfc_code *);
 tree gfc_trans_if (gfc_code *);
 tree gfc_trans_arithmetic_if (gfc_code *);
 tree gfc_trans_block_construct (gfc_code *);
-tree gfc_trans_do (gfc_code *);
+tree gfc_trans_do (gfc_code *, tree);
 tree gfc_trans_do_while (gfc_code *);
 tree gfc_trans_select (gfc_code *);
 tree gfc_trans_forall (gfc_code *);
Index: trans.c
===================================================================
--- trans.c	(revision 156750)
+++ trans.c	(working copy)
@@ -1051,7 +1051,7 @@ gfc_set_backend_locus (locus * loc)
 /* Translate an executable statement.  */
 
 tree
-gfc_trans_code (gfc_code * code)
+gfc_trans_code (gfc_code * code, tree cond)
 {
   stmtblock_t block;
   tree res;
@@ -1172,7 +1172,7 @@ tree
 	  break;
 
 	case EXEC_DO:
-	  res = gfc_trans_do (code);
+	  res = gfc_trans_do (code, cond);
 	  break;
 
 	case EXEC_DO_WHILE:
Index: trans-io.c
===================================================================
--- trans-io.c	(revision 156750)
+++ trans-io.c	(working copy)
@@ -1811,8 +1811,24 @@ build_dt (tree function, gfc_code * code)
   dt_parm = var;
   dt_post_end_block = &post_end_block;
 
-  gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
+  /* Set implied do loop exit condition.  */
+  if (last_dt == READ || last_dt == WRITE)
+    {
+      gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
 
+      tmp = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+			 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), NULL_TREE);
+      tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
+			  tmp, p->field, NULL_TREE);
+      tmp = fold_build2 (BIT_AND_EXPR, TREE_TYPE (tmp),
+			  tmp, build_int_cst (TREE_TYPE (tmp),
+			  IOPARM_common_libreturn_mask));
+    }
+  else /* IOLENGTH */
+    tmp = NULL_TREE;
+
+  gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next, tmp));
+
   gfc_add_block_to_block (&block, &post_iu_block);
 
   dt_parm = NULL;
Index: trans-decl.c
===================================================================
--- trans-decl.c	(revision 156750)
+++ trans-decl.c	(working copy)
@@ -4370,7 +4370,7 @@ gfc_generate_function_code (gfc_namespace * ns)
   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
     add_argument_checking (&body, sym);
 
-  tmp = gfc_trans_code (ns->code);
+  tmp = gfc_trans_code (ns->code, NULL_TREE);
   gfc_add_expr_to_block (&body, tmp);
 
   /* Add a return label if needed.  */