[Fortran, gcc-5, patch, pr69268, v1] [5 Regression] Sourced allocation calls function twice

[Andre Vehreschild <vehre at gmx dot de>]

Hi all,

please find attached a patch to solve the issue of evaluating a source=
expression of an allocate() twice in gcc-5. The patch is a combination
and partial back port of several prs of the mainline (namely, but not
the complete list: pr44672, pr65548).

The patch needed the counts of builtin_mallocs/frees in
allocatable_scalar_13 to be adapted. There are now fewer calls to the
memory management routines. Valgrind does not report any memory issues
in the modified code, but that does not mean there aren't any. I am
happy to hear about any issue, this patch causes (still having issues
getting the sanitizer to work).

Bootstrapped and regtested on x86_64-linux-gnu/F23.

Ok, for gcc-5-branch?

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de

Attachment: pr69268_1.txt
Description: Text document

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 68601f6..0be92cd 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5108,7 +5108,7 @@ tree
 gfc_trans_allocate (gfc_code * code)
 {
   gfc_alloc *al;
-  gfc_expr *expr;
+  gfc_expr *expr, *e3rhs = NULL;
   gfc_se se, se_sz;
   tree tmp;
   tree parm;
@@ -5130,6 +5130,7 @@ gfc_trans_allocate (gfc_code * code)
   stmtblock_t post;
   tree nelems;
   bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set;
+  gfc_symtree *newsym = NULL;
 
   if (!code->ext.alloc.list)
     return NULL_TREE;
@@ -5239,16 +5240,28 @@ gfc_trans_allocate (gfc_code * code)
 					 false, false);
 	      gfc_add_block_to_block (&block, &se.pre);
 	      gfc_add_block_to_block (&post, &se.post);
-	      /* Prevent aliasing, i.e., se.expr may be already a
-		 variable declaration.  */
+
 	      if (!VAR_P (se.expr))
 		{
+		  tree var;
+
 		  tmp = build_fold_indirect_ref_loc (input_location,
 						     se.expr);
-		  tmp = gfc_evaluate_now (tmp, &block);
+
+		  /* We need a regular (non-UID) symbol here, therefore give a
+		     prefix.  */
+		  var = gfc_create_var (TREE_TYPE (tmp), "source");
+		  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+		    {
+		      gfc_allocate_lang_decl (var);
+		      GFC_DECL_SAVED_DESCRIPTOR (var) = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+		    }
+		  gfc_add_modify_loc (input_location, &block, var, tmp);
+		  tmp = var;
 		}
 	      else
 		tmp = se.expr;
+
 	      if (!code->expr3->mold)
 		expr3 = tmp;
 	      else
@@ -5357,6 +5370,71 @@ gfc_trans_allocate (gfc_code * code)
 	  else
 	    expr3_esize = TYPE_SIZE_UNIT (
 		  gfc_typenode_for_spec (&code->expr3->ts));
+
+	  /* The routine gfc_trans_assignment () already implements all
+	     techniques needed.  Unfortunately we may have a temporary
+	     variable for the source= expression here.  When that is the
+	     case convert this variable into a temporary gfc_expr of type
+	     EXPR_VARIABLE and used it as rhs for the assignment.  The
+	     advantage is, that we get scalarizer support for free,
+	     don't have to take care about scalar to array treatment and
+	     will benefit of every enhancements gfc_trans_assignment ()
+	     gets.
+	     Exclude variables since the following block does not handle
+	     array sections.  In any case, there is no harm in sending
+	     variables to gfc_trans_assignment because there is no
+	     evaluation of variables.  */
+	  if (code->expr3->expr_type != EXPR_VARIABLE
+	      && code->expr3->mold != 1 && expr3 != NULL_TREE
+	      && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+	    {
+	      /* Build a temporary symtree and symbol.  Do not add it to
+		 the current namespace to prevent accidently modifying
+		 a colliding symbol's as.  */
+	      newsym = XCNEW (gfc_symtree);
+	      /* The name of the symtree should be unique, because
+		 gfc_create_var () took care about generating the
+		 identifier.  */
+	      newsym->name = gfc_get_string (IDENTIFIER_POINTER (
+					       DECL_NAME (expr3)));
+	      newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
+	      /* The backend_decl is known.  It is expr3, which is inserted
+		 here.  */
+	      newsym->n.sym->backend_decl = expr3;
+	      e3rhs = gfc_get_expr ();
+	      e3rhs->ts = code->expr3->ts;
+	      e3rhs->rank = code->expr3->rank;
+	      e3rhs->symtree = newsym;
+	      /* Mark the symbol referenced or gfc_trans_assignment will
+		 bug.  */
+	      newsym->n.sym->attr.referenced = 1;
+	      e3rhs->expr_type = EXPR_VARIABLE;
+	      e3rhs->where = code->expr3->where;
+	      /* Set the symbols type, upto it was BT_UNKNOWN.  */
+	      newsym->n.sym->ts = e3rhs->ts;
+	      /* Check whether the expr3 is array valued.  */
+	      if (e3rhs->rank)
+		{
+		  gfc_array_spec *arr;
+		  arr = gfc_get_array_spec ();
+		  arr->rank = e3rhs->rank;
+		  arr->type = AS_DEFERRED;
+		  /* Set the dimension and pointer attribute for arrays
+		     to be on the safe side.  */
+		  newsym->n.sym->attr.dimension = 1;
+		  newsym->n.sym->attr.pointer = 1;
+		  newsym->n.sym->as = arr;
+		  gfc_add_full_array_ref (e3rhs, arr);
+		}
+	      else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
+		newsym->n.sym->attr.pointer = 1;
+	      /* The string length is known to.  Set it for char arrays.  */
+	      if (e3rhs->ts.type == BT_CHARACTER)
+		newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
+	      gfc_commit_symbol (newsym->n.sym);
+	    }
+	  else
+	    e3rhs = gfc_copy_expr (code->expr3);
 	}
       gcc_assert (expr3_esize);
       expr3_esize = fold_convert (sizetype, expr3_esize);
@@ -5674,7 +5752,6 @@ gfc_trans_allocate (gfc_code * code)
 	{
 	  /* Initialization via SOURCE block
 	     (or static default initializer).  */
-	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
 	  if (expr3 != NULL_TREE
 	      && ((POINTER_TYPE_P (TREE_TYPE (expr3))
 		   && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
@@ -5688,25 +5765,13 @@ gfc_trans_allocate (gfc_code * code)
 	      tmp = gfc_copy_class_to_class (expr3, to,
 					     nelems, upoly_expr);
 	    }
-	  else if (code->expr3->ts.type == BT_CHARACTER
-		   && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
-	    {
-	      tmp = INDIRECT_REF_P (se.expr) ?
-			se.expr :
-			build_fold_indirect_ref_loc (input_location,
-						     se.expr);
-	      gfc_trans_string_copy (&block, al_len, tmp,
-				     code->expr3->ts.kind,
-				     expr3_len, expr3,
-				     code->expr3->ts.kind);
-	      tmp = NULL_TREE;
-	    }
 	  else if (al->expr->ts.type == BT_CLASS)
 	    {
 	      gfc_actual_arglist *actual, *last_arg;
 	      gfc_expr *ppc;
 	      gfc_code *ppc_code;
 	      gfc_ref *ref, *dataref;
+	      gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
 
 	      /* Do a polymorphic deep copy.  */
 	      actual = gfc_get_actual_arglist ();
@@ -5818,6 +5883,8 @@ gfc_trans_allocate (gfc_code * code)
 					 void_type_node, tmp, extcopy, stdcopy);
 		}
 	      gfc_free_statements (ppc_code);
+	      if (rhs != e3rhs)
+		gfc_free_expr (rhs);
 	    }
 	  else
 	    {
@@ -5826,10 +5893,9 @@ gfc_trans_allocate (gfc_code * code)
 	      int realloc_lhs = flag_realloc_lhs;
 	      flag_realloc_lhs = 0;
 	      tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
-					  rhs, false, false);
+					  e3rhs, false, false);
 	      flag_realloc_lhs = realloc_lhs;
 	    }
-	  gfc_free_expr (rhs);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
      else if (code->expr3 && code->expr3->mold
@@ -5847,6 +5913,15 @@ gfc_trans_allocate (gfc_code * code)
        gfc_free_expr (expr);
     } // for-loop
 
+  if (e3rhs)
+    {
+      if (newsym)
+	{
+	  gfc_free_symbol (newsym->n.sym);
+	  XDELETE (newsym);
+	}
+      gfc_free_expr (e3rhs);
+    }
   /* STAT.  */
   if (code->expr1)
     {
diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90
index 532f364..1d60154 100644
--- a/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90
@@ -67,6 +67,6 @@ contains
 !    allocate(res, source = arg) ! Caused an ICE
 !  end subroutine
 end
-! { dg-final { scan-tree-dump-times "builtin_malloc" 15 "original" } }
-! { dg-final { scan-tree-dump-times "builtin_free" 17 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_malloc" 16 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 16 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
new file mode 100644
index 0000000..977202d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
@@ -0,0 +1,26 @@
+!{ dg-do compile }
+! PR69268
+!
+! Contributed by Rich Townsend  <townsend@astro.wisc.edu>
+
+program test_sourced_alloc
+
+  implicit none
+ 
+  type :: foo_t
+  end type foo_t
+
+  class(foo_t), allocatable :: f
+
+  allocate(f, SOURCE=f_func())
+
+contains
+
+  function f_func () result (f)
+    type(foo_t) :: f
+    integer, save :: c = 0
+    c = c + 1
+    if (c .gt. 1) call abort()
+  end function f_func
+
+end program test_sourced_alloc