Hi All, This PR was largely fixed by preceding patches, insofar as it ran and produced the expected output, apart from the explicit initialization expressions for the PDT entities. However, the testcase leaked memory like a sieve and it has taken a while to sort out a satisfactory fix.
The chunks in trans-decl.cc implement the fix for the explicit initialization of PDT entities. This part is straightforward. The rest of the patch is devoted to fixing the memory leaks triggered by the new testcase. The problem was associated with pdt_arrays embedded in PDT structure constructors, which themselves were embedded in array constructors that were part of a PDT constructor.... if you see what I mean :-) The original pdt_arrays are copied into a destination array, which is implicitly allocated by gfc_duplicate_allocatable. The allocated memory was being lost in the subsequent copy of the enclosing array constructor. Rescuing and freeing the memory is accomplished using the finalization block, which is then executed after the copy of the array constructor. Note that these frees are not guarded. I don't believe that there is any circumstance where this will be an issue but, if required, it would be easily implemented. The chunks in trans-stmt.cc pick up memory leaks in allocation and deallocation. As a side effect, the leak in pdt_3.f03 is fixed. PR121972 will be updated accordingly, since pdt_39/70/77.f03 still leak memory. Regtests on FC43/x86_64. OK for mainline Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0b0d50263e9..46b5c0f7726 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -2248,6 +2248,11 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock,
{
/* Scalar values. */
gfc_init_se (&se, NULL);
+ if (c->expr->ts.type == BT_DERIVED
+ && c->expr->ts.u.derived->attr.pdt_type
+ && c->expr->expr_type == EXPR_STRUCTURE)
+ c->expr->must_finalize = 1;
+
gfc_trans_array_ctor_element (&body, desc, *poffset,
&se, c->expr);
@@ -3088,6 +3093,10 @@ trans_array_constructor (gfc_ss * ss, locus * where)
finalize_required = expr->must_finalize;
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
finalize_required = true;
+
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.pdt_type)
+ finalize_required = true;
+
gfc_trans_array_constructor_value (&outer_loop->pre,
finalize_required ? &finalblock : NULL,
type, desc, c, &offset, &offsetvar,
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index d7189f48c6b..8f6819d2f77 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1711,12 +1711,16 @@ gfc_get_symbol_decl (gfc_symbol * sym)
declaration of the entity and memory allocated/deallocated. */
if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
&& sym->param_list != NULL
- && gfc_current_ns == sym->ns
+ && (gfc_current_ns == sym->ns
+ || (gfc_current_ns == sym->ns->parent
+ && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
&& !(sym->attr.use_assoc || sym->attr.dummy))
gfc_defer_symbol_init (sym);
if ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_comp)
- && gfc_current_ns == sym->ns
+ && (gfc_current_ns == sym->ns
+ || (gfc_current_ns == sym->ns->parent
+ && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
&& !(sym->attr.use_assoc || sym->attr.dummy))
gfc_defer_symbol_init (sym);
@@ -4596,25 +4600,37 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc,
}
-/* Initialize a PDT, when all the components have an initializer. */
-static void
-gfc_init_default_pdt (gfc_symbol *sym, stmtblock_t *block, bool dealloc)
+/* Initialize a PDT, either when the symbol has a value or when all the
+ components have an initializer. */
+static tree
+gfc_init_default_pdt (gfc_symbol *sym, bool dealloc)
{
- /* Allowed in the case where all the components have initializers and
- there are no LEN components. */
- if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
+ stmtblock_t block;
+ tree tmp;
+ gfc_component *c;
+
+ if (sym->value && sym->value->symtree
+ && sym->value->symtree->n.sym
+ && !sym->value->symtree->n.sym->attr.artificial)
{
- gfc_component *c = sym->ts.u.derived->components;
- if (!dealloc || !sym->value || sym->value->expr_type != EXPR_STRUCTURE)
- return;
- for (; c; c = c->next)
- if (c->attr.pdt_len || !c->initializer)
- return;
+ tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym),
+ sym->value, false, false, true);
+ return tmp;
}
- else
- return;
- gfc_init_default_dt (sym, block, dealloc, true);
- return;
+
+ if (!dealloc || !sym->value)
+ return NULL_TREE;
+
+ /* Allowed in the case where all the components have initializers and
+ there are no LEN components. */
+ c = sym->ts.u.derived->components;
+ for (; c; c = c->next)
+ if (c->attr.pdt_len || !c->initializer)
+ return NULL_TREE;
+
+ gfc_init_block (&block);
+ gfc_init_default_dt (sym, &block, dealloc, true);
+ return gfc_finish_block (&block);
}
@@ -4998,9 +5014,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
{
is_pdt_type = true;
gfc_init_block (&tmpblock);
+
if (!sym->attr.dummy && !sym->attr.pointer)
{
- if (!sym->attr.allocatable)
+ tmp = gfc_init_default_pdt (sym, true);
+ if (!sym->attr.allocatable && tmp == NULL_TREE)
{
tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
sym->backend_decl,
@@ -5008,9 +5026,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
sym->param_list);
gfc_add_expr_to_block (&tmpblock, tmp);
}
-
- if (is_pdt_type)
- gfc_init_default_pdt (sym, &tmpblock, true);
+ else if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&tmpblock, tmp);
if (!sym->attr.result && !sym->ts.u.derived->attr.alloc_comp)
tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6ed34619c32..fc82ac11234 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9609,6 +9609,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
}
+static stmtblock_t *final_block;
static tree
gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_expr * expr)
@@ -9680,6 +9681,13 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
+ if (final_block && expr->expr_type == EXPR_ARRAY)
+ {
+ tree data_ptr;
+ data_ptr = gfc_conv_descriptor_data_get (dest);
+ gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
+ }
+
if (expr->expr_type != EXPR_VARIABLE)
gfc_conv_descriptor_data_set (&block, se.expr,
null_pointer_node);
@@ -10385,6 +10393,10 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
if (!init)
{
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.pdt_type
+ && expr->must_finalize)
+ final_block = &se->finalblock;
+
/* Create a temporary variable and fill it in. */
se->expr = gfc_create_var (type, expr->ts.u.derived->name);
/* The symtree in expr is NULL, if the code to generate is for
@@ -10392,6 +10404,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
se->want_coarray);
gfc_add_expr_to_block (&se->pre, tmp);
+ final_block = NULL;
return;
}
@@ -13291,6 +13304,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
/* Deallocate the lhs parameterized components if required. */
if (dealloc
&& !expr1->symtree->n.sym->attr.associate_var
+ && expr2->expr_type != EXPR_ARRAY
&& ((expr1->ts.type == BT_DERIVED
&& expr1->ts.u.derived
&& expr1->ts.u.derived->attr.pdt_type)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 42606845cc7..3433738c373 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6926,7 +6926,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
if ((code->expr3->ts.type == BT_DERIVED
|| code->expr3->ts.type == BT_CLASS)
&& (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
- && code->expr3->ts.u.derived->attr.alloc_comp
+ && (code->expr3->ts.u.derived->attr.alloc_comp
+ || code->expr3->ts.u.derived->attr.pdt_type)
&& !code->expr3->must_finalize
&& !code->ext.alloc.expr3_not_explicit)
{
@@ -7975,7 +7976,7 @@ gfc_trans_deallocate (gfc_code *code)
se.expr, expr->rank);
if (tmp)
- gfc_add_expr_to_block (&block, tmp);
+ gfc_add_expr_to_block (&se.pre, tmp);
if (flag_coarray == GFC_FCOARRAY_LIB
|| flag_coarray == GFC_FCOARRAY_SINGLE)
diff --git a/gcc/testsuite/gfortran.dg/pdt_79.f03 b/gcc/testsuite/gfortran.dg/pdt_79.f03
index 84d74f8eae5..16b40fe6576 100644
--- a/gcc/testsuite/gfortran.dg/pdt_79.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_79.f03
@@ -54,8 +54,8 @@ contains
if (mt%k /= 4) stop 3
if (mt%j /= 42) stop 4
end associate
- end subroutine
+ end subroutine ! { dg-warning ".mapped_tensor. is used uninitialized" }
end
-! { dg-final { scan-tree-dump-times "mapped_tensor.j = 42" 1 "original" } }
+! { dg-final { scan-tree-dump-times "Pdttensor_t_4.2.j = 42" 1 "original" } }
! { dg-final { scan-tree-dump-times "struct Pdttensor_t_4 mt" 1 "original" } }
