Re: [Patch, Fortran, F03] PR 55603: Memory leak with scalar allocatable function result

[Tobias Burnus <burnus at net-b dot de>]

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;
     }