Fix PR61831: Side-effect variable component deallocation

gcc/fortran/
2015-07-17  Mikael Morin  <mikael@gcc.gnu.org>
	    Dominique d'Humieres  <dominiq@lps.ens.fr>

	PR fortran/61831
	* trans-array.c (gfc_conv_array_parameter): Guard allocatable
	component deallocation code generation with descriptorless
	calling convention flag.
	* trans-expr.c (gfc_conv_expr_reference): Remove allocatable
	component deallocation code generation from revision 212329.
	(expr_may_alias_variables): New function.
	(gfc_conv_procedure_call): New boolean elemental_proc to factor
	check for procedure elemental-ness.  Rename boolean f to nodesc_arg
	and declare it in the outer scope.  Use expr_may_alias_variables,
	elemental_proc and nodesc_arg to decide whether generate allocatable
	component deallocation code.
	(gfc_trans_subarray_assign): Set deep copy flag.

gcc/testsuite/
2015-07-17  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/61831
	* gfortran.dg/alloc_comp_auto_array_3.f90: Count the number
	of generated while loops in the tree dump.
	* gfortran.dg/derived_constructor_comps_6.f90: New file.


Co-Authored-By: Dominique d'Humieres <dominiq@lps.ens.fr>

From-SVN: r225926

gcc/fortran/ChangeLog

+2015-07-17  Mikael Morin  <mikael@gcc.gnu.org>
+	    Dominique d'Humieres  <dominiq@lps.ens.fr>
+
+	PR fortran/61831
+	* trans-array.c (gfc_conv_array_parameter): Guard allocatable
+	component deallocation code generation with descriptorless
+	calling convention flag.
+	* trans-expr.c (gfc_conv_expr_reference): Remove allocatable
+	component deallocation code generation from revision 212329.
+	(expr_may_alias_variables): New function.
+	(gfc_conv_procedure_call): New boolean elemental_proc to factor
+	check for procedure elemental-ness.  Rename boolean f to nodesc_arg
+	and declare it in the outer scope.  Use expr_may_alias_variables,
+	elemental_proc and nodesc_arg to decide whether generate allocatable
+	component deallocation code.
+	(gfc_trans_subarray_assign): Set deep copy flag.
+
 2015-07-16  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/66724

gcc/fortran/trans-array.c

@@ -7395,10 +7395,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
     }
 
   /* Deallocate the allocatable components of structures that are
-     not variable.  */
-  if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
-	&& expr->ts.u.derived->attr.alloc_comp
-	&& expr->expr_type != EXPR_VARIABLE)
+     not variable, for descriptorless arguments.
+     Arguments with a descriptor are handled in gfc_conv_procedure_call.  */
+  if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+	  && expr->ts.u.derived->attr.alloc_comp
+	  && expr->expr_type != EXPR_VARIABLE)
     {
       tmp = build_fold_indirect_ref_loc (input_location, se->expr);
       tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);

gcc/fortran/trans-expr.c

@@ -4528,6 +4528,62 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
 }
 
 
+/* This function tells whether the middle-end representation of the expression
+   E given as input may point to data otherwise accessible through a variable
+   (sub-)reference.
+   It is assumed that the only expressions that may alias are variables,
+   and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
+   may alias.
+   This function is used to decide whether freeing an expression's allocatable
+   components is safe or should be avoided.
+
+   If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
+   its elements are copied from a variable.  This ARRAY_MAY_ALIAS trick
+   is necessary because for array constructors, aliasing depends on how
+   the array is used:
+    - If E is an array constructor used as argument to an elemental procedure,
+      the array, which is generated through shallow copy by the scalarizer,
+      is used directly and can alias the expressions it was copied from.
+    - If E is an array constructor used as argument to a non-elemental
+      procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
+      the array as in the previous case, but then that array is used
+      to initialize a new descriptor through deep copy.  There is no alias
+      possible in that case.
+   Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
+   above.  */
+
+static bool
+expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
+{
+  gfc_constructor *c;
+
+  if (e->expr_type == EXPR_VARIABLE)
+    return true;
+  else if (e->expr_type == EXPR_FUNCTION)
+    {
+      gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
+
+      if ((proc_ifc->result->ts.type == BT_CLASS
+	   && proc_ifc->result->ts.u.derived->attr.is_class
+	   && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
+	  || proc_ifc->result->attr.pointer)
+	return true;
+      else
+	return false;
+    }
+  else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
+    return false;
+
+  for (c = gfc_constructor_first (e->value.constructor);
+       c; c = gfc_constructor_next (c))
+    if (c->expr
+	&& expr_may_alias_variables (c->expr, array_may_alias))
+      return true;
+
+  return false;
+}
+
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.
@@ -4580,9 +4636,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
   comp = gfc_get_proc_ptr_comp (expr);
 
+  bool elemental_proc = (comp
+			 && comp->ts.interface
+			 && comp->ts.interface->attr.elemental)
+			|| (comp && comp->attr.elemental)
+			|| sym->attr.elemental;
+
   if (se->ss != NULL)
     {
-      if (!sym->attr.elemental && !(comp && comp->attr.elemental))
+      if (!elemental_proc)
 	{
 	  gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
 	  if (se->ss->info->useflags)
@@ -4639,6 +4701,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
 
+      /* If the procedure requires an explicit interface, the actual
+	 argument is passed according to the corresponding formal
+	 argument.  If the corresponding formal argument is a POINTER,
+	 ALLOCATABLE or assumed shape, we do not use g77's calling
+	 convention, and pass the address of the array descriptor
+	 instead.  Otherwise we use g77's calling convention, in other words
+	 pass the array data pointer without descriptor.  */
+      bool nodesc_arg = fsym != NULL
+			&& !(fsym->attr.pointer || fsym->attr.allocatable)
+			&& fsym->as
+			&& fsym->as->type != AS_ASSUMED_SHAPE
+			&& fsym->as->type != AS_ASSUMED_RANK;
+      if (comp)
+	nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
+      else
+	nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
+
       /* Class array expressions are sometimes coming completely unadorned
 	 with either arrayspec or _data component.  Correct that here.
 	 OOP-TODO: Move this to the frontend.  */
@@ -5165,22 +5244,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    }
 	  else
 	    {
-              /* If the procedure requires an explicit interface, the actual
-                 argument is passed according to the corresponding formal
-                 argument.  If the corresponding formal argument is a POINTER,
-                 ALLOCATABLE or assumed shape, we do not use g77's calling
-                 convention, and pass the address of the array descriptor
-                 instead. Otherwise we use g77's calling convention.  */
-	      bool f;
-	      f = (fsym != NULL)
-		  && !(fsym->attr.pointer || fsym->attr.allocatable)
-		  && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE
-		  && fsym->as->type != AS_ASSUMED_RANK;
-	      if (comp)
-		f = f || !comp->attr.always_explicit;
-	      else
-		f = f || !sym->attr.always_explicit;
-
 	      /* If the argument is a function call that may not create
 		 a temporary for the result, we have to check that we
 		 can do it, i.e. that there is no alias between this
@@ -5225,7 +5288,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		   array of derived types.  In this case, the argument
 		   is converted to a temporary, which is passed and then
 		   written back after the procedure call.  */
-		gfc_conv_subref_array_arg (&parmse, e, f,
+		gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
 				fsym ? fsym->attr.intent : INTENT_INOUT,
 				fsym && fsym->attr.pointer);
 	      else if (gfc_is_class_array_ref (e, NULL)
@@ -5237,7 +5300,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		   OOP-TODO: Insert code so that if the dynamic type is
 		   the same as the declared type, copy-in/copy-out does
 		   not occur.  */
-		gfc_conv_subref_array_arg (&parmse, e, f,
+		gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
 				fsym ? fsym->attr.intent : INTENT_INOUT,
 				fsym && fsym->attr.pointer);
 
@@ -5248,12 +5311,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		   intent in.  */
 		{
 		  e->must_finalize = 1;
-		  gfc_conv_subref_array_arg (&parmse, e, f,
+		  gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
 					     INTENT_IN,
 					     fsym && fsym->attr.pointer);
 		}
 	      else
-	        gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL);
+		gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
+					  sym->name, NULL);
 
 	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
 		 allocated on entry, it must be deallocated.  */
@@ -5295,7 +5359,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	     but do not always set fsym.  */
 	  if (e->expr_type == EXPR_VARIABLE
 	      && e->symtree->n.sym->attr.optional
-	      && ((e->rank != 0 && sym->attr.elemental)
+	      && ((e->rank != 0 && elemental_proc)
 		  || e->representation.length || e->ts.type == BT_CHARACTER
 		  || (e->rank != 0
 		      && (fsym == NULL
@@ -5330,13 +5394,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       gfc_add_block_to_block (&post, &parmse.post);
 
       /* Allocated allocatable components of derived types must be
-	 deallocated for non-variable scalars.  Non-variable arrays are
-	 dealt with in trans-array.c(gfc_conv_array_parameter).  */
+	 deallocated for non-variable scalars, array arguments to elemental
+	 procedures, and array arguments with descriptor to non-elemental
+	 procedures.  As bounds information for descriptorless arrays is no
+	 longer available here, they are dealt with in trans-array.c
+	 (gfc_conv_array_parameter).  */
       if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
 	    && e->ts.u.derived->attr.alloc_comp
-	    && !(e->symtree && e->symtree->n.sym->attr.pointer)
-	    && e->expr_type != EXPR_VARIABLE && !e->rank)
-        {
+	    && (e->rank == 0 || elemental_proc || !nodesc_arg)
+	    && !expr_may_alias_variables (e, elemental_proc))
+	{
 	  int parm_rank;
 	  /* It is known the e returns a structure type with at least one
 	     allocatable component.  When e is a function, ensure that the
@@ -6674,7 +6741,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 
   gfc_conv_expr (&rse, expr);
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
+  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, true, true);
   gfc_add_expr_to_block (&body, tmp);
 
   gcc_assert (rse.ss == gfc_ss_terminator);
@@ -7545,20 +7612,6 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
 
   /* Take the address of that value.  */
   se->expr = gfc_build_addr_expr (NULL_TREE, var);
-  if (expr->ts.type == BT_DERIVED && expr->rank
-      && !gfc_is_finalizable (expr->ts.u.derived, NULL)
-      && expr->ts.u.derived->attr.alloc_comp
-      && expr->expr_type != EXPR_VARIABLE)
-    {
-      tree tmp;
-
-      tmp = build_fold_indirect_ref_loc (input_location, se->expr);
-      tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
-
-      /* The components shall be deallocated before
-         their containing entity.  */
-      gfc_prepend_expr_to_block (&se->post, tmp);
-    }
 }
 
 

gcc/testsuite/ChangeLog

+2015-07-17  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/61831
+	* gfortran.dg/alloc_comp_auto_array_3.f90: Count the number
+	of generated while loops in the tree dump.
+	* gfortran.dg/derived_constructor_components_6.f90: New file.
+
 2015-07-17  Yuri Rumyantsev  <ysrumyan@gmail.com>
 
 	* gcc.dg/vect/vect-outer-simd-2.c: New test.

gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90

@@ -27,3 +27,4 @@ contains
 end
 ! { dg-final { scan-tree-dump-times "builtin_malloc" 3 "original" } }
 ! { dg-final { scan-tree-dump-times "builtin_free" 4 "original" } }
+! { dg-final { scan-tree-dump-times "while \\(1\\)" 4 "original" } }

gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90

+! { dg-do run }
+! { dg-additional-options "-fsanitize=address -fdump-tree-original"
+!
+! PR fortran/61831
+! The deallocation of components of array constructor elements
+! used to have the side effect of also deallocating some other
+! variable's components from which they were copied.
+
+program main
+  implicit none
+
+  integer, parameter :: n = 2
+
+  type :: string_t
+     character(LEN=1), dimension(:), allocatable :: chars
+  end type string_t
+
+  type :: string_container_t
+     type(string_t) :: comp
+  end type string_container_t
+
+  type :: string_array_container_t
+     type(string_t) :: comp(n)
+  end type string_array_container_t
+
+  type(string_t) :: prt_in, tmp, tmpa(n)
+  type(string_container_t) :: tmpc, tmpca(n)
+  type(string_array_container_t) :: tmpac, tmpaca(n)
+  integer :: i, j, k
+
+  do i=1,16
+
+     ! Test without intermediary function
+     prt_in = string_t(["A"])
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "A")) call abort
+     deallocate (prt_in%chars)
+
+     ! scalar elemental function
+     prt_in = string_t(["B"])
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "B")) call abort
+     tmp = new_prt_spec (prt_in)
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "B")) call abort
+     deallocate (prt_in%chars)
+     deallocate (tmp%chars)
+
+     ! array elemental function with array constructor
+     prt_in = string_t(["C"])
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "C")) call abort
+     tmpa = new_prt_spec ([(prt_in, i=1,2)])
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "C")) call abort
+     deallocate (prt_in%chars)
+     do j=1,n
+        deallocate (tmpa(j)%chars)
+     end do
+
+     ! scalar elemental function with structure constructor
+     prt_in = string_t(["D"])
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "D")) call abort
+     tmpc = new_prt_spec2 (string_container_t(prt_in))
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "D")) call abort
+     deallocate (prt_in%chars)
+     deallocate(tmpc%comp%chars)
+
+     ! array elemental function of an array constructor of structure constructors
+     prt_in = string_t(["E"])
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "E")) call abort
+     tmpca = new_prt_spec2 ([ (string_container_t(prt_in), i=1,2) ])
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "E")) call abort
+     deallocate (prt_in%chars)
+     do j=1,n
+        deallocate (tmpca(j)%comp%chars)
+     end do
+
+     ! scalar elemental function with a structure constructor and a nested array constructor
+     prt_in = string_t(["F"])
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "F")) call abort
+     tmpac = new_prt_spec3 (string_array_container_t([ (prt_in, i=1,2) ]))
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "F")) call abort
+     deallocate (prt_in%chars)
+     do j=1,n
+        deallocate (tmpac%comp(j)%chars)
+     end do
+
+     ! array elemental function with an array constructor nested inside
+     ! a structure constructor nested inside  an array constructor
+     prt_in = string_t(["G"])
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "G")) call abort
+     tmpaca = new_prt_spec3 ([ (string_array_container_t([ (prt_in, i=1,2) ]), j=1,2) ])
+     if (.not. allocated(prt_in%chars)) call abort
+     if (any(prt_in%chars .ne. "G")) call abort
+     deallocate (prt_in%chars)
+     do j=1,n
+        do k=1,n
+           deallocate (tmpaca(j)%comp(k)%chars)
+        end do
+     end do
+
+  end do
+
+contains
+
+  elemental function new_prt_spec (name) result (prt_spec)
+    type(string_t), intent(in) :: name
+    type(string_t) :: prt_spec
+    prt_spec = name
+  end function new_prt_spec
+
+  elemental function new_prt_spec2 (name) result (prt_spec)
+    type(string_container_t), intent(in) :: name
+    type(string_container_t) :: prt_spec
+    prt_spec = name
+  end function new_prt_spec2
+
+  elemental function new_prt_spec3 (name) result (prt_spec)
+    type(string_array_container_t), intent(in) :: name
+    type(string_array_container_t) :: prt_spec
+    prt_spec = name
+  end function new_prt_spec3
+end program main
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 15 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 33 "original" } }