Am 27.08.2013 15:09, schrieb Janus Weil:
here is a patch for PR 55603, which plugs a memory leak with scalar
allocatable function results.
To accomplish this, several things are done:
1) Allocatable scalar function results are passed as argument now and
returned by reference (just like array or character results, cf.
gfc_return_by_reference).
[...]
In fact the patch is just a first step and does not handle more
advanced cases yet (like polymorphic allocatable scalar results,
finalization, etc).
Hooray an ABI breakage! (On the other hand, the finalizer already causes
some breakage - but this is worse as with an interface, one can override
the .mod-version check.)
In my attempts to get this working, I kept the current version - but
handled derived types and non-derived types separately. The reason was
that functions can occur everywhere but DT/CLASS can only occur at some
places. On the other hand, DT/CLASS can have allocatable components and
all other kind of nasty things - and se->post comes too early for that.
For some reasons, it seems to work if there are no allocatable
components and other nastiness.
I am not sure which approach is better. In any case, here is my current
draft - completely unclean and not touched for about a month. And of
course not ready/fully working. (Otherwise, I had posted a patch.)
I have not yet looked at your patch - and I will first look through the
backlog of gfortran emails/patches before returning to this one.
Tobias
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 74e95b0..96de076 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4226,6 +4226,51 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else
gfc_conv_expr_reference (&parmse, e);
+#if 0
+ /* Finalize function results after their use as
+ actual argument. */
+ // FIXME: Cleanup of constructors
+ if (e->expr_type == EXPR_FUNCTION && fsym
+ && (fsym->ts.type == BT_CLASS
+ || (fsym->ts.type == BT_DERIVED
+ && gfc_is_finalizable (e->ts.u.derived, NULL))))
+ {
+ tree final_fndecl, size, array;
+ gfc_expr *final_expr;
+
+ if (fsym->ts.type == BT_CLASS)
+ {
+ gfc_is_finalizable (CLASS_DATA (e)->ts.u.derived,
+ &final_expr);
+ final_fndecl = gfc_vtable_final_get (parmse.expr);
+ size = gfc_vtable_size_get (parmse.expr);
+ array = gfc_class_data_get (parmse.expr);
+ }
+ else
+ {
+ gfc_se fse;
+ gfc_is_finalizable (e->ts.u.derived, &final_expr);
+ gfc_init_se (&fse, NULL);
+ gfc_conv_expr (&fse, final_expr);
+ final_fndecl = fse.expr;
+ size = gfc_typenode_for_spec (&e->ts);
+ size = TYPE_SIZE_UNIT (size);
+ size = fold_convert (gfc_array_index_type, size);
+ array = parmse.expr;
+ }
+ if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
+ final_fndecl
+ = build_fold_indirect_ref_loc (input_location,
+ final_fndecl);
+ array = gfc_conv_scalar_to_descriptor (&parmse, array,
+ fsym->attr);
+ array = gfc_build_addr_expr (NULL_TREE, array);
+ tmp = build_call_expr_loc (input_location,
+ final_fndecl, 3, array,
+ size, boolean_false_node);
+ gfc_add_expr_to_block (&parmse.post, tmp);
+ }
+#endif
/* Catch base objects that are not variables. */
if (e->ts.type == BT_CLASS
@@ -5562,6 +5607,29 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
NULL);
+ /* Ensure that allocatable scalars get deallocated; we only handle
+ nonderived types as for TYPE/CLASS one runs into ordering problems
+ with allocatable components. On the other hand, TYPE and CLASS
+ can only occur with assignment and as actual argument, contrary to
+ intrinsic types. */
+ if (sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
+ && ((sym->result && !sym->result->as && sym->result->attr.allocatable)
+ || (!sym->result && !sym->as && sym->attr.allocatable)))
+ {
+ tree tmp;
+ bool undo_deref = !POINTER_TYPE_P (TREE_TYPE (se->expr));
+
+ if (undo_deref)
+ se->expr = gfc_build_addr_expr (NULL, se->expr);
+
+ tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
+ gfc_add_modify (&se->pre, tmp, se->expr);
+
+ se->expr = tmp;
+ if (undo_deref)
+ se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+ gfc_add_expr_to_block (&se->post, gfc_call_free (tmp));
+ }
}
@@ -5665,7 +5733,18 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
else if (pointer || procptr)
{
if (!expr || expr->expr_type == EXPR_NULL)
- return fold_convert (type, null_pointer_node);
+ {
+ if (ts->type == BT_CLASS)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_structure (&se, gfc_class_null_initializer(ts, expr), 1);
+ gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
+ TREE_STATIC (se.expr) = 1;
+ return se.expr;
+ }
+ else
+ return fold_convert (type, null_pointer_node);
+ }
else
{
gfc_init_se (&se, NULL);
@@ -7591,9 +7670,15 @@ is_scalar_reallocatable_lhs (gfc_expr *expr)
{
gfc_ref * ref;
+#if 0
+/* FIXME: Do we need to handle _data? */
+ if (expr->ts.type == BT_CLASS && CLASS_DATA (expr)->attr.allocatable)
+ return true;
+#endif
+
/* An allocatable variable with no reference. */
if (expr->symtree->n.sym->attr.allocatable
- && !expr->ref)
+ && !expr->ref)
return true;
/* All that can be left are allocatable components. */
@@ -7615,12 +7700,13 @@ is_scalar_reallocatable_lhs (gfc_expr *expr)
/* Allocate or reallocate scalar lhs, as necessary. */
+/* FIXME: If the RHS ise CLASS, we need the _size of the RHS and a temporary + we need to handle CLASS(*) on the LHS, including CLASS(*) = char and CLASS(*) = CLASS(*). */
+
static void
alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
tree string_length,
gfc_expr *expr1,
gfc_expr *expr2)
-
{
tree cond;
tree tmp;
@@ -7644,6 +7730,11 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
+#if 0
+ if (expr1->ts.type == BT_CLASS)
+ lse.expr = gfc_class_data_get (lse.expr);
+#endif
+
jump_label1 = gfc_build_label_decl (NULL_TREE);
jump_label2 = gfc_build_label_decl (NULL_TREE);
@@ -7660,7 +7751,9 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
{
/* Use the rhs string length and the lhs element size. */
size = string_length;
- tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
+ tmp = TREE_TYPE (gfc_typenode_for_spec (/*expr1->ts.type == BT_CLASS
+ ? &CLASS_DATA (expr1)->ts
+ :*/ &expr1->ts));
tmp = TYPE_SIZE_UNIT (tmp);
size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), tmp,
@@ -7669,7 +7762,8 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
else
{
/* Otherwise use the length in bytes of the rhs. */
- size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
+ size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (/*expr1->ts.type == BT_CLASS
+ ? &CLASS_DATA (expr1)->ts :*/ &expr1->ts));
size_in_bytes = size;
}
