Re: [Patch, fortran] PR61831 side-effect deallocation of variable components

[Mikael Morin <mikael dot morin at sfr dot fr>]

Le 16/05/2015 18:43, Mikael Morin a Ãcrit :
> Hello,
> 
> this is about PR61831 where in code like:
> 	
> 	type :: string_t
> 	   character(LEN=1), dimension(:), allocatable :: chars
> 	end type string_t
> 	type(string_t) :: prt_in
> 	(...)
> 	tmp = new_prt_spec ([prt_in])
> 	
> the deallocation of the argument's allocatable components after the
> procedure call (to new_prt_spec) has the side effect of freeing prt_in's
> allocatable components, as the array constructor temporary for [prt_in]
> is a shallow copy of prt_in.
> 
> This bug is a regression caused by the Dominique's PR41936 memory leak
> fix, itself based on a patch originally from me.
> 
> The attached patch is basically a revert of that fix.  It avoids the
> problem by not deallocating allocatable components in the problematic
> case, at the price of a (possible) memory leak.  A new function is
> introduced telling whether there is aliasing, so that we don't regress
> on PR41936's memory leak when there is no aliasing, and we don't free
> components when there is aliasing.
> The possible remaining memory leak case is the case of a "mixed" array
> constructor with some parts aliasing variables, and some non-aliasing parts.
> 
> The patch takes also the opportunity to reassemble the scattered
> procedure argument deallocation code into a single place.
> 
> The test needs pr65792's fix (thanks Paul), so for the 4.9 branch I
> propose commenting the parts that depend on PR65792 in the test.
> 
> Regression tested on x86_64-linux. OK for 6/5/4.9 ?

Hello,

I would like to come back to the patch:
https://gcc.gnu.org/ml/gcc-patches/2015-05/msg01491.html

PR66082 made me notice one bug in that patch:
for descriptorless arrays, the patch was deallocating only the first
element's allocatable components.
As gfc_conv_array_parameter returns the array data only, the bounds are
lost and it is not possible to loop through all the elements.

With the attached patch, the deallocation code is kept in
gfc_conv_array_parameter where the bounds of descriptorless arrays are
known.
To test this fixes the bug, I have added a count of while (1) loops in
the dump of pr66082's test.  I'm open to better ideas to properly test this.

For arrays with descriptors, I have decided to not handle them in
gfc_conv_array_parameter, because in some cases gfc_conv_expr_descriptor
is called directly from gfc_conv_procedure_call, without passing through
gfc_conv_array_parameter.
To be able to select everything but descriptorless arrays for
allocatable component deallocation, the flags are moved around somewhat.
The rest is as in the previous patch.

The test provided is basically unchanged, thus not suitable for the
branches without pr65792.
We can decide what to do with it later (backport pr65792 or disable
parts of the test), I would like to have the fix in mainline first.
It has been fortran-tested on x86_64-linux, OK for trunk?

Mikael

Attachment: pr61831_v7.CL
Description: Text document

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index fece3ab..bda887c 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7386,10 +7386,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);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 5d6555b..583e692 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4529,6 +4529,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.
@@ -4581,9 +4637,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)
@@ -4640,6 +4702,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.  */
@@ -5166,22 +5245,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
@@ -5226,7 +5289,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)
@@ -5238,7 +5301,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);
 
@@ -5249,12 +5312,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.  */
@@ -5296,7 +5360,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
@@ -5331,13 +5395,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;
 	  tmp = build_fold_indirect_ref_loc (input_location,
 					 parmse.expr);
@@ -6664,7 +6731,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);
@@ -7535,20 +7602,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);
-    }
 }
 
 
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90
index eaeaf54..b135d3d 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90
+++ b/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" } }
diff --git a/gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 b/gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90
new file mode 100644
index 0000000..f9fbcb1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90
@@ -0,0 +1,133 @@
+! { 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" } }