Dear Mikael,
I have gathered together the applicable patches to fix this PR on
5-branch. In so doing, the testcase for PR66082 was added
(alloc_comp_auto_array_3.f90), since a change was made for this PR. I
found that this leaked memory, of course, and so I have added the fix
for PR66082. I have checked that all the memory leaks mentioned in the
PR comments are fixed. The change in allocate_with_source_14.f03 is a
bit mysterious but I checked that it doesn't lose memory, so no harm
is done.
Bootstrapped and regtested on FC21/x86_64 - OK for 5-branch? (I
thought to commit it today, if that is OK?)
Cheers
Paul
2016-01-17 Mikael Morin <mik...@gcc.gnu.org>
Backport from trunk.
PR fortran/61831
* gfortran.dg/derived_constructor_components_6.f90: New file.
* gfortran.dg/allocate_with_source_14.f03: Change count of
__builtin_malloc from 21 to 23.
2016-01-17 Paul Thomas <pa...@gcc.gnu.org>
Backport from trunk.
PR fortran/66082
* gfortran.dg/alloc_comp_auto_array_3.f90: New file. Count of
__builtin_malloc increased from 3 to 4, relative to trunk.
2016-01-17 Mikael Morin <mik...@gcc.gnu.org>
Dominique d'Humieres <domi...@lps.ens.fr>
Backport from trunk.
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.
2016-01-17 Paul Thomas <pa...@gcc.gnu.org>
Backport from trunk.
PR fortran/66082
* trans-array.c (gfc_conv_array_parameter): Ensure that all
non-variable arrays with allocatable components have the
components deallocated after the procedure call.
--
The difference between genius and stupidity is; genius has its limits.
Albert Einstein
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 232481)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 7192,7197 ****
--- 7192,7208 ----
if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
{
gfc_conv_expr_descriptor (se, expr);
+ /* 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)
+ {
+ tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr,
expr->rank);
+
+ /* The components shall be deallocated before their containing
entity. */
+ gfc_prepend_expr_to_block (&se->post, tmp);
+ }
if (expr->ts.type == BT_CHARACTER)
se->string_length = expr->ts.u.cl->backend_decl;
if (size)
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 7227,7236 ****
}
/* 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)
{
tmp = build_fold_indirect_ref_loc (input_location, se->expr);
tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
--- 7238,7248 ----
}
/* Deallocate the allocatable components of structures that are
! 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);
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 232481)
--- gcc/fortran/trans-expr.c (working copy)
*************** conv_arglist_function (gfc_se *se, gfc_e
*** 4398,4403 ****
--- 4398,4459 ----
}
+ /* 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.
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 4448,4456 ****
comp = gfc_get_proc_ptr_comp (expr);
if (se->ss != NULL)
{
! if (!sym->attr.elemental && !(comp && comp->attr.elemental))
{
gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
if (se->ss->info->useflags)
--- 4504,4518 ----
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 (!elemental_proc)
{
gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
if (se->ss->info->useflags)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 4501,4506 ****
--- 4563,4585 ----
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. */
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5020,5041 ****
}
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
--- 5099,5104 ----
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5080,5086 ****
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,
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
else if (gfc_is_class_array_ref (e, NULL)
--- 5143,5149 ----
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, nodesc_arg,
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
else if (gfc_is_class_array_ref (e, NULL)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5092,5098 ****
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,
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
--- 5155,5161 ----
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, nodesc_arg,
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5103,5114 ****
intent in. */
{
e->must_finalize = 1;
! gfc_conv_subref_array_arg (&parmse, e, f,
INTENT_IN,
fsym && fsym->attr.pointer);
}
else
! gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
--- 5166,5178 ----
intent in. */
{
e->must_finalize = 1;
! gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
INTENT_IN,
fsym && fsym->attr.pointer);
}
else
! 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. */
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5150,5156 ****
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->representation.length || e->ts.type == BT_CHARACTER
|| (e->rank != 0
&& (fsym == NULL
--- 5214,5220 ----
but do not always set fsym. */
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional
! && ((e->rank != 0 && elemental_proc)
|| e->representation.length || e->ts.type == BT_CHARACTER
|| (e->rank != 0
&& (fsym == NULL
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5184,5197 ****
gfc_add_block_to_block (&se->pre, &parmse.pre);
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). */
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))
! {
int parm_rank;
tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr);
--- 5248,5264 ----
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&post, &parmse.post);
! /* Allocated allocatable components of derived types must be
! 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->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);
*************** gfc_trans_subarray_assign (tree dest, gf
*** 6519,6525 ****
gfc_conv_expr (&rse, expr);
! tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
--- 6586,6592 ----
gfc_conv_expr (&rse, expr);
! 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);
*************** gfc_conv_expr_reference (gfc_se * se, gf
*** 7404,7423 ****
/* 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);
- }
}
--- 7471,7476 ----
Index: gcc/testsuite/gfortran.dg/allocate_with_source_14.f03
===================================================================
*** gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 (revision
232481)
--- gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 (working copy)
*************** program main
*** 210,214 ****
call v%free()
deallocate(av)
end program
! ! { dg-final { scan-tree-dump-times "__builtin_malloc" 21 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } }
--- 210,214 ----
call v%free()
deallocate(av)
end program
! ! { dg-final { scan-tree-dump-times "__builtin_malloc" 23 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } }
Index: gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 (working copy)
***************
*** 0 ****
--- 1,133 ----
+ ! { dg-do run }
+ ! { dg-additional-options "-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" } }
Index: gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 (working copy)
***************
*** 0 ****
--- 1,31 ----
+ ! { dg-do compile }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Test the fix for PR66082. The original problem was with the first
+ ! call foo_1d.
+ !
+ ! Reported by Damian Rouson <dam...@sourceryinstitute.org>
+ !
+ type foo_t
+ real, allocatable :: bigarr
+ end type
+ block
+ type(foo_t) :: foo
+ allocate(foo%bigarr)
+ call foo_1d (1,[foo]) ! wasy lost
+ call foo_1d (1,bar_1d()) ! Check that this is OK
+ deallocate(foo_t)
+ end block
+ contains
+ subroutine foo_1d (n,foo)
+ integer n
+ type(foo_t) :: foo(n)
+ end subroutine
+ function bar_1d () result (array)
+ type(foo_t) :: array(1)
+ allocate (array(1)%bigarr)
+ end function
+ end
+ ! { dg-final { scan-tree-dump-times "builtin_malloc" 4 "original" } }
+ ! { dg-final { scan-tree-dump-times "builtin_free" 4 "original" } }
+ ! { dg-final { scan-tree-dump-times "while \\(1\\)" 4 "original" } }
