re PR fortran/50069 (FORALL fails on a character array)

2017-01-18  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/50069
	PR fortran/55086
	* gfortran.dg/pr50069_1.f90: New test.
	* gfortran.dg/pr50069_2.f90: New test.
	* gfortran.dg/pr55086_1.f90: New test.
	* gfortran.dg/pr55086_1_tfat.f90: New test.
	* gfortran.dg/pr55086_2.f90: New test.
	* gfortran.dg/pr55086_2_tfat.f90: New test.
	* gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90: New test.

2017-01-18  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/50069
	PR fortran/55086
	* trans-expr.c (gfc_conv_variable): Don't treat temporary variables
	as function arguments.
	* trans-stmt.c (forall_make_variable_temp,
	generate_loop_for_temp_to_lhs, gfc_trans_assign_need_temp,
	gfc_trans_forall_1): Don't adjust offset of forall temporary
	for array sections, make forall temporaries work for substring
	expressions, improve test coverage by adding -ftest-forall-temp
	option to request usage of temporary array in forall code.
	* lang.opt: Add -ftest-forall-temp option.
	* invoke.texi: Add -ftest-forall-temp option.

From-SVN: r244601

5 files changed, 134 insertions, 94 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0c59ced..17c419f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2017-01-18  Louis Krupp  <louis.krupp@zoho.com>
+
+	PR fortran/50069
+	PR fortran/55086
+	* trans-expr.c (gfc_conv_variable): Don't treat temporary variables
+	as function arguments.
+	* trans-stmt.c (forall_make_variable_temp,
+	generate_loop_for_temp_to_lhs, gfc_trans_assign_need_temp,
+	gfc_trans_forall_1): Don't adjust offset of forall temporary
+	for array sections, make forall temporaries work for substring
+	expressions, improve test coverage by adding -ftest-forall-temp
+	option to request usage of temporary array in forall code.
+	* lang.opt: Add -ftest-forall-temp option.
+	* invoke.texi: Add -ftest-forall-temp option.
+
 2017-01-18  Andre Vehreschild  <vehre@gcc.gnu.org>
 
 	* primary.c (caf_variable_attr): Improve figuring whether the current
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index e0abbf8..2a89647 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -124,6 +124,7 @@ by type.  Explanations are in the following sections.
 -fmax-identifier-length -fmodule-private -ffixed-form -fno-range-check @gol
 -fopenacc -fopenmp -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 @gol
 -freal-8-real-10 -freal-8-real-16 -freal-8-real-4 -std=@var{std}
+-ftest-forall-temp
 }
 
 @item Preprocessing Options
@@ -459,6 +460,10 @@ allows the Fortran 2008 standard including the additions of the
 Technical Specification (TS) 29113 on Further Interoperability of Fortran
 with C and TS 18508 on Additional Parallel Features in Fortran.
 
+@item -ftest-forall-temp
+@opindex @code{ftest-forall-temp}
+Enhance test coverage by forcing most forall assignments to use temporary.
+
 @end table
 
 @node Preprocessing Options
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 9670bf7..bdc621b 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -488,6 +488,10 @@ ffixed-form
 Fortran RejectNegative
 Assume that the source file is fixed form.
 
+ftest-forall-temp
+Fortran Var(flag_test_forall_temp) Init(0)
+Force creation of temporary to test infrequently-executed forall code
+
 finteger-4-integer-8
 Fortran RejectNegative Var(flag_integer4_kind,8)
 Interpret any INTEGER(4) as an INTEGER(8).
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index ee8e15d..138af56 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2544,8 +2544,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       if (se_expr)
 	se->expr = se_expr;
 
-      /* Procedure actual arguments.  */
-      else if (sym->attr.flavor == FL_PROCEDURE
+      /* Procedure actual arguments.  Look out for temporary variables
+	 with the same attributes as function values.  */
+      else if (!sym->attr.temporary
+	       && sym->attr.flavor == FL_PROCEDURE
 	       && se->expr != current_function_decl)
 	{
 	  if (!sym->attr.dummy && !sym->attr.proc_pointer)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 63f3304..113545b 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -3196,7 +3196,7 @@ forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
       gfc_add_block_to_block (post, &tse.post);
       tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
 
-      if (e->ts.type != BT_CHARACTER)
+      if (c->expr1->ref->u.ar.type != AR_SECTION)
 	{
 	  /* Use the variable offset for the temporary.  */
 	  tmp = gfc_conv_array_offset (old_sym->backend_decl);
@@ -3526,114 +3526,103 @@ gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
 
 static tree
 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
-			       tree count1, tree wheremask, bool invert)
+			       tree count1,
+			       gfc_ss *lss, gfc_ss *rss,
+			       tree wheremask, bool invert)
 {
-  gfc_ss *lss;
-  gfc_se lse, rse;
-  stmtblock_t block, body;
-  gfc_loopinfo loop1;
+  stmtblock_t block, body1;
+  gfc_loopinfo loop;
+  gfc_se lse;
+  gfc_se rse;
   tree tmp;
   tree wheremaskexpr;
 
-  /* Walk the lhs.  */
-  lss = gfc_walk_expr (expr);
+  (void) rss; /* TODO: unused.  */
 
-  if (lss == gfc_ss_terminator)
-    {
-      gfc_start_block (&block);
+  gfc_start_block (&block);
 
-      gfc_init_se (&lse, NULL);
+  gfc_init_se (&rse, NULL);
+  gfc_init_se (&lse, NULL);
 
-      /* Translate the expression.  */
+  if (lss == gfc_ss_terminator)
+    {
+      gfc_init_block (&body1);
       gfc_conv_expr (&lse, expr);
-
-      /* Form the expression for the temporary.  */
-      tmp = gfc_build_array_ref (tmp1, count1, NULL);
-
-      /* Use the scalar assignment as is.  */
-      gfc_add_block_to_block (&block, &lse.pre);
-      gfc_add_modify (&block, lse.expr, tmp);
-      gfc_add_block_to_block (&block, &lse.post);
-
-      /* Increment the count1.  */
-      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
-			     count1, gfc_index_one_node);
-      gfc_add_modify (&block, count1, tmp);
-
-      tmp = gfc_finish_block (&block);
+      rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
     }
   else
     {
-      gfc_start_block (&block);
-
-      gfc_init_loopinfo (&loop1);
-      gfc_init_se (&rse, NULL);
-      gfc_init_se (&lse, NULL);
+      /* Initialize the loop.  */
+      gfc_init_loopinfo (&loop);
 
-      /* Associate the lss with the loop.  */
-      gfc_add_ss_to_loop (&loop1, lss);
+      /* We may need LSS to determine the shape of the expression.  */
+      gfc_add_ss_to_loop (&loop, lss);
 
-      /* Calculate the bounds of the scalarization.  */
-      gfc_conv_ss_startstride (&loop1);
-      /* Setup the scalarizing loops.  */
-      gfc_conv_loop_setup (&loop1, &expr->where);
+      gfc_conv_ss_startstride (&loop);
+      gfc_conv_loop_setup (&loop, &expr->where);
 
       gfc_mark_ss_chain_used (lss, 1);
+      /* Start the loop body.  */
+      gfc_start_scalarized_body (&loop, &body1);
 
-      /* Start the scalarized loop body.  */
-      gfc_start_scalarized_body (&loop1, &body);
-
-      /* Setup the gfc_se structures.  */
-      gfc_copy_loopinfo_to_se (&lse, &loop1);
+      /* Translate the expression.  */
+      gfc_copy_loopinfo_to_se (&lse, &loop);
       lse.ss = lss;
+      gfc_conv_expr (&lse, expr);
 
       /* Form the expression of the temporary.  */
-      if (lss != gfc_ss_terminator)
-	rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
-      /* Translate expr.  */
-      gfc_conv_expr (&lse, expr);
+      rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
+    }
 
-      /* Use the scalar assignment.  */
-      rse.string_length = lse.string_length;
-      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, true);
+  /* Use the scalar assignment.  */
+  rse.string_length = lse.string_length;
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
+				 expr->expr_type == EXPR_VARIABLE, false);
 
-      /* Form the mask expression according to the mask tree list.  */
-      if (wheremask)
-	{
-	  wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
-	  if (invert)
-	    wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
-					     TREE_TYPE (wheremaskexpr),
-					     wheremaskexpr);
-	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-				 wheremaskexpr, tmp,
-				 build_empty_stmt (input_location));
-       }
+  /* Form the mask expression according to the mask tree list.  */
+  if (wheremask)
+    {
+      wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
+      if (invert)
+	wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
+					 TREE_TYPE (wheremaskexpr),
+					 wheremaskexpr);
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     wheremaskexpr, tmp,
+			     build_empty_stmt (input_location));
+    }
 
-      gfc_add_expr_to_block (&body, tmp);
+  gfc_add_expr_to_block (&body1, tmp);
 
-      /* Increment count1.  */
-      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-			     count1, gfc_index_one_node);
-      gfc_add_modify (&body, count1, tmp);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
+			 count1, gfc_index_one_node);
+  gfc_add_modify (&body1, count1, tmp);
 
+  if (lss == gfc_ss_terminator)
+      gfc_add_block_to_block (&block, &body1);
+  else
+    {
       /* Increment count3.  */
       if (count3)
 	{
 	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
-				 gfc_array_index_type, count3,
-				 gfc_index_one_node);
-	  gfc_add_modify (&body, count3, tmp);
+				 gfc_array_index_type,
+				 count3, gfc_index_one_node);
+	  gfc_add_modify (&body1, count3, tmp);
 	}
 
       /* Generate the copying loops.  */
-      gfc_trans_scalarizing_loops (&loop1, &body);
-      gfc_add_block_to_block (&block, &loop1.pre);
-      gfc_add_block_to_block (&block, &loop1.post);
-      gfc_cleanup_loop (&loop1);
+      gfc_trans_scalarizing_loops (&loop, &body1);
+
+      gfc_add_block_to_block (&block, &loop.pre);
+      gfc_add_block_to_block (&block, &loop.post);
 
-      tmp = gfc_finish_block (&block);
+      gfc_cleanup_loop (&loop);
+      /* TODO: Reuse lss and rss when copying temp->lhs.  Need to be careful
+	 as tree nodes in SS may not be valid in different scope.  */
     }
+
+  tmp = gfc_finish_block (&block);
   return tmp;
 }
 
@@ -3989,26 +3978,39 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
 
   /* Calculate the size of temporary needed in the assignment. Return loop, lss
      and rss which are used in function generate_loop_for_rhs_to_temp().  */
-  gfc_init_block (&inner_size_body);
-  inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
-					&lss, &rss);
-
   /* The type of LHS. Used in function allocate_temp_for_forall_nest */
-  if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
+  if (expr1->ts.type == BT_CHARACTER)
     {
-      if (!expr1->ts.u.cl->backend_decl)
+      type = NULL;
+      if (expr1->ref && expr1->ref->type == REF_SUBSTRING)
 	{
-	  gfc_se tse;
-	  gfc_init_se (&tse, NULL);
-	  gfc_conv_expr (&tse, expr1->ts.u.cl->length);
-	  expr1->ts.u.cl->backend_decl = tse.expr;
+	  gfc_se ssse;
+	  gfc_init_se (&ssse, NULL);
+	  gfc_conv_expr (&ssse, expr1);
+	  type = gfc_get_character_type_len (gfc_default_character_kind,
+					     ssse.string_length);
+	}
+      else
+	{
+	  if (!expr1->ts.u.cl->backend_decl)
+	    {
+	      gfc_se tse;
+	      gcc_assert (expr1->ts.u.cl->length);
+	      gfc_init_se (&tse, NULL);
+	      gfc_conv_expr (&tse, expr1->ts.u.cl->length);
+	      expr1->ts.u.cl->backend_decl = tse.expr;
+	    }
+	  type = gfc_get_character_type_len (gfc_default_character_kind,
+					     expr1->ts.u.cl->backend_decl);
 	}
-      type = gfc_get_character_type_len (gfc_default_character_kind,
-				         expr1->ts.u.cl->backend_decl);
     }
   else
     type = gfc_typenode_for_spec (&expr1->ts);
 
+  gfc_init_block (&inner_size_body);
+  inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
+					&lss, &rss);
+
   /* Allocate temporary for nested forall construct according to the
      information in nested_forall_info and inner_size.  */
   tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
@@ -4030,8 +4032,14 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
   if (wheremask)
     gfc_add_modify (block, count, gfc_index_zero_node);
 
+  /* TODO: Second call to compute_inner_temp_size to initialize lss and
+     rss;  there must be a better way.  */
+  inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
+					&lss, &rss);
+
   /* Generate codes to copy the temporary to lhs.  */
   tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
+				       lss, rss,
 				       wheremask, invert);
 
   /* Generate body and loops according to the information in
@@ -4488,8 +4496,8 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
 
           /* Temporaries due to array assignment data dependencies introduce
              no end of problems.  */
-	  if (need_temp)
-            gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
+	  if (need_temp || flag_test_forall_temp)
+	    gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
                                         nested_forall_info, &block);
           else
             {
@@ -4517,7 +4525,12 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
         /* Pointer assignment inside FORALL.  */
 	case EXEC_POINTER_ASSIGN:
           need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
-          if (need_temp)
+	  /* Avoid cases where a temporary would never be needed and where
+	     the temp code is guaranteed to fail.  */
+	  if (need_temp
+	      || (flag_test_forall_temp
+		  && c->expr2->expr_type != EXPR_CONSTANT
+		  && c->expr2->expr_type != EXPR_NULL))
             gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
                                                 nested_forall_info, &block);
           else
@@ -5125,7 +5138,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
               if (nested_forall_info != NULL)
                 {
                   need_temp = gfc_check_dependency (expr1, expr2, 0);
-                  if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
+		  if ((need_temp || flag_test_forall_temp)
+		    && cnext->op != EXEC_ASSIGN_CALL)
                     gfc_trans_assign_need_temp (expr1, expr2,
 						cmask, invert,
                                                 nested_forall_info, block);