Patchwork [Fortran,DRAFT] PR 46321 - [OOP] Polymorphic deallocation

login
register
mail settings
Submitter Tobias Burnus
Date June 10, 2012, 2:09 p.m.
Message ID <4FD4AA8E.3070707@net-b.de>
Download mbox | patch
Permalink /patch/164000/
State New
Headers show

Comments

Tobias Burnus - June 10, 2012, 2:09 p.m.
Alessandro Fanfarillo wrote:
> with the priceless support of Tobias I've almost realized the patch
> for this PR. In attachment there's the second draft. During the
> regression test I have only one error with select_type_4.f90. The
> problem is in the destroy_list subroutine when it checks
> associated(node) after the first deallocate(node).

I'd prefer:

gfc_expr *ppc = NULL;
...
if (expr->ts.type == BT_CLASS)
   ppc = gfc_copy_expr (expr);
...
if (ppc)
   ...

Namely: Only copy the expression if needed.

Additionally, the check "if (expr->symtree->n.sym->ts.type == BT_CLASS)" 
is wrong. For instance, for
   type(t) :: x
   deallocate(x%class)
it won't trigger, but it should.

Actually, I think a cleaner version would be:

if (al->expr->ts.type == BT_CLASS)
   {
     gfc_expr *ppc;
     ppc = gfc_copy_expr (al->expr);

  * * *

Furthermore, I think you call _free + free for the same component for:

type t
    integer, allocatable :: x
end type t
class(t), allocatable :: y
...
deallocate (y)

* * *

Regarding your code: You assume that "al->expr" points to an allocated 
variable, that's not the always the case - hence, select_type_4.f90 fails.

* * *

You always create a _free function; I wonder whether it makes sense to 
use _vtab->free with NULL in case that no _free is needed.

  * * *

Attached an updated version, which does that all. No guarantee that it 
works correctly, but it should at least fix select_type_4.f90.

Tobias
Alessandro Fanfarillo - June 11, 2012, 9:24 a.m.
Thank you for the review, with this patch I get some ICEs during the
regstest with:

gfortran.dg/coarray/poly_run_3.f90
gfortran.dg/elemental_optional_args_5.f03
gfortran.dg/select_type_26.f03
gfortran.dg/select_type_27.f03
gfortran.dg/class_48.f90
gfortran.dg/class_allocate_10.f03
gfortran.dg/class_allocate_8.f03
gfortran.dg/class_array_1.f03
gfortran.dg/class_array_2.f03
gfortran.dg/assumed_type_2.f90
gfortran.dg/class_array_9.f03
gfortran.dg/coarray_lib_alloc_2.f90

I've debugged only the first 2 and the problem seems to be related
with "tmp =  fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); "
in trans-stmt.c at line 5376. The ICE message is the following:

$ gcc/bin/gfortran -c elemental_optional_args_5.f03
elemental_optional_args_5.f03: In function ‘MAIN__’:
elemental_optional_args_5.f03:220:0: internal compiler error: in
build_int_cst_wide, at tree.c:1219
 deallocate (taa, tpa, caa, cpa)
 ^
Please submit a full bug report,
with preprocessed source if appropriate.
See <http://gcc.gnu.org/bugs.html> for instructions.



2012/6/10 Tobias Burnus <burnus@net-b.de>:
> Alessandro Fanfarillo wrote:
>>
>> with the priceless support of Tobias I've almost realized the patch
>> for this PR. In attachment there's the second draft. During the
>> regression test I have only one error with select_type_4.f90. The
>> problem is in the destroy_list subroutine when it checks
>> associated(node) after the first deallocate(node).
>
>
> --- gcc/fortran/trans-stmt.c    (revisione 188002)
> +++ gcc/fortran/trans-stmt.c    (copia locale)
> @@ -5341,7 +5341,12 @@ gfc_trans_deallocate (gfc_code *code)
>    for (al = code->ext.alloc.list; al != NULL; al = al->next)
>     {
> -      gfc_expr *expr = gfc_copy_expr (al->expr);
> +      gfc_expr *expr;
> +      gfc_expr *ppc;
> +      gfc_code *ppc_code;
> +      gfc_actual_arglist *actual;
> +      expr = gfc_copy_expr (al->expr);
> +      ppc = gfc_copy_expr (expr);
> ...
> +      if (expr->symtree->n.sym->ts.type == BT_CLASS)
>
>
> I'd prefer:
>
> gfc_expr *ppc = NULL;
> ...
> if (expr->ts.type == BT_CLASS)
>  ppc = gfc_copy_expr (expr);
> ...
> if (ppc)
>  ...
>
> Namely: Only copy the expression if needed.
>
> Additionally, the check "if (expr->symtree->n.sym->ts.type == BT_CLASS)" is
> wrong. For instance, for
>  type(t) :: x
>  deallocate(x%class)
> it won't trigger, but it should.
>
> Actually, I think a cleaner version would be:
>
> if (al->expr->ts.type == BT_CLASS)
>  {
>    gfc_expr *ppc;
>    ppc = gfc_copy_expr (al->expr);
>
>  * * *
>
> Furthermore, I think you call _free + free for the same component for:
>
> type t
>   integer, allocatable :: x
> end type t
> class(t), allocatable :: y
> ...
> deallocate (y)
>
> * * *
>
> Regarding your code: You assume that "al->expr" points to an allocated
> variable, that's not the always the case - hence, select_type_4.f90 fails.
>
> * * *
>
> You always create a _free function; I wonder whether it makes sense to use
> _vtab->free with NULL in case that no _free is needed.
>
>  * * *
>
> Attached an updated version, which does that all. No guarantee that it works
> correctly, but it should at least fix select_type_4.f90.
>
> Tobias
Tobias Burnus - June 11, 2012, 10:13 a.m.
On 06/11/2012 11:24 AM, Alessandro Fanfarillo wrote:
> gfortran.dg/coarray/poly_run_3.f90

That one fails because I for forgot that se.expr in gfc_trans_deallocate 
contains the descriptor and not the pointer to the data. That's fixed by:

           tmp = se.expr;
           if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
             {
               tmp = gfc_conv_descriptor_data_get (tmp);
               STRIP_NOPS (tmp);
             }
           tmp =  fold_build2_loc (input_location, NE_EXPR, 
boolean_type_node,
                                   tmp, build_int_cst (TREE_TYPE (tmp), 0));

However, it still fails for the

type t
   integer, allocatable :: comp
end type t
contains
   subroutine foo(x)
     class(t), allocatable, intent(out) :: x(:)
   end subroutine
end

(The intent(out) causes automatic deallocation.) The backtrace does not 
really point to some code which the patch touched; it shouldn't be 
affected by the class.c changes and gfc_trans_deallocate does not seem 
to be entered.

While I do not immediately see why it fails, I wonder whether it is due 
to the removed "else if ... BT_CLASS)" case in 
gfc_deallocate_scalar_with_status. In any case, the change to 
gfc_trans_deallocate might be also needed for 
gfc_deallocate_scalar_with_status. At least, automatic deallocation 
(with intent(out) or when leaving the scope) does not seem to go through 
gfc_trans_deallocate but only through gfc_deallocate_scalar_with_status.

Tobias
Alessandro Fanfarillo - June 12, 2012, 7:57 a.m.
I don't know if there's already a PR but I get an ICE compiling this
with a non-patched version. If x is not an array everything goes ok.

2012/6/11 Tobias Burnus <burnus@net-b.de>:
> On 06/11/2012 11:24 AM, Alessandro Fanfarillo wrote:
>>
>> gfortran.dg/coarray/poly_run_3.f90
>
>
> That one fails because I for forgot that se.expr in gfc_trans_deallocate
> contains the descriptor and not the pointer to the data. That's fixed by:
>
>          tmp = se.expr;
>          if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
>            {
>              tmp = gfc_conv_descriptor_data_get (tmp);
>              STRIP_NOPS (tmp);
>
>            }
>          tmp =  fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
>                                  tmp, build_int_cst (TREE_TYPE (tmp), 0));
>
> However, it still fails for the
>
> type t
>  integer, allocatable :: comp
> end type t
> contains
>  subroutine foo(x)
>    class(t), allocatable, intent(out) :: x(:)
>  end subroutine
> end
>
> (The intent(out) causes automatic deallocation.) The backtrace does not
> really point to some code which the patch touched; it shouldn't be affected
> by the class.c changes and gfc_trans_deallocate does not seem to be entered.
>
> While I do not immediately see why it fails, I wonder whether it is due to
> the removed "else if ... BT_CLASS)" case in
> gfc_deallocate_scalar_with_status. In any case, the change to
> gfc_trans_deallocate might be also needed for
> gfc_deallocate_scalar_with_status. At least, automatic deallocation (with
> intent(out) or when leaving the scope) does not seem to go through
> gfc_trans_deallocate but only through gfc_deallocate_scalar_with_status.
>
> Tobias

Patch

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index c71aa4a..8224f45 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -42,6 +42,7 @@  along with GCC; see the file COPYING3.  If not see
     * _extends:  A pointer to the vtable entry of the parent derived type.
     * _def_init: A pointer to a default initialized variable of this type.
     * _copy:     A procedure pointer to a copying procedure.
+    * _free:     A procedure pointer to a free procedure.
    After these follow procedure pointer components for the specific
    type-bound procedures.  */
 
@@ -717,6 +718,9 @@  gfc_find_derived_vtab (gfc_symbol *derived)
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
+  gfc_symbol *free = NULL, *tofree = NULL;
+  gfc_component *temp = NULL;
+  bool comp_alloc;
 
   /* Find the top-level namespace (MODULE or PROGRAM).  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)
@@ -907,6 +911,101 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 		  c->ts.interface = copy;
 		}
 
+	      /* Add component _free.  */
+	      comp_alloc = false;
+
+	      for (temp = derived->components; temp; temp = temp->next)
+		{
+		  if (temp == derived->components && derived->attr.extension)
+		    continue;
+
+		  if (temp->ts.type != BT_CLASS
+		      && !temp->attr.pointer
+		      && (temp->attr.alloc_comp || temp->attr.allocatable))
+		    comp_alloc = true;
+		  else if (temp->ts.type == BT_CLASS
+			   && CLASS_DATA (temp)
+			   && CLASS_DATA (temp)->attr.allocatable)
+		    comp_alloc = true;
+		}
+
+	      if (gfc_add_component (vtype, "_free", &c) == FAILURE)
+		goto cleanup;
+	      c->attr.proc_pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->tb = XCNEW (gfc_typebound_proc);
+	      c->tb->ppc = 1;
+
+	      if (!derived->attr.alloc_comp || derived->attr.abstract)
+		c->initializer = gfc_get_null_expr (NULL);
+	      else if (derived->attr.extension && !comp_alloc
+		       && !derived->components->attr.abstract)
+		{
+		  /* No new allocatable components: Link to the parent's _free.  */
+		  gfc_component *parent = derived->components;
+		  gfc_component *free_proc = NULL;
+		  gfc_symbol *vtab2 = NULL;
+		  vtab2 = gfc_find_derived_vtab (parent->ts.u.derived);
+
+		  for (free_proc = vtab2->ts.u.derived->components;
+		       free_proc; free_proc = free_proc->next)
+		    if (free_proc->name[0] == '_'
+			&& free_proc->name[1] == 'f')
+		      break;
+		  gcc_assert (free_proc);
+
+		  c->initializer = gfc_copy_expr (free_proc->initializer);
+		  c->ts.interface = free_proc->ts.interface;
+		}
+	      else
+		{
+		  gfc_alloc *head = NULL;
+
+		  /* Create _free function. Set up its namespace.  */
+		  gfc_namespace *sub_ns2 = gfc_get_namespace (ns, 0);
+		  sub_ns2->sibling = ns->contained;
+		  ns->contained = sub_ns2;
+		  sub_ns2->resolved = 1;
+
+		  /* Set up procedure symbol.  */
+		  sprintf (name, "__free_%s", tname);
+		  gfc_get_symbol (name, sub_ns2, &free);
+		  sub_ns2->proc_name = free;
+		  free->attr.flavor = FL_PROCEDURE;
+		  free->attr.subroutine = 1;
+		  free->attr.if_source = IFSRC_DECL;
+
+		  /* This is elemental so that arrays are automatically
+		  treated correctly by the scalarizer.  */
+		  free->attr.elemental = 1;
+		  free->attr.pure = 1;
+		  if (ns->proc_name->attr.flavor == FL_MODULE)
+		    free->module = ns->proc_name->name;
+		  gfc_set_sym_referenced (free);
+
+		  /* Set up formal arguments.  */
+		  gfc_get_symbol ("tofree", sub_ns2, &tofree);
+		  tofree->ts.type = BT_DERIVED;
+		  tofree->ts.u.derived = derived;
+		  tofree->attr.flavor = FL_VARIABLE;
+		  tofree->attr.dummy = 1;
+		  tofree->attr.intent = INTENT_OUT;
+		  gfc_set_sym_referenced (tofree);
+		  free->formal = gfc_get_formal_arglist ();
+		  free->formal->sym = tofree;
+
+		  /* Set up code.  */
+		  sub_ns2->code = gfc_get_code ();
+		  sub_ns2->code->op = EXEC_NOP;
+		  head = gfc_get_alloc ();
+		  head->expr = gfc_lval_expr_from_sym (tofree);
+		  sub_ns2->code->ext.alloc.list = head;
+
+		  /* Set initializer.  */
+		  c->initializer = gfc_lval_expr_from_sym (free);
+		  c->ts.interface = free;
+		}
+
 	      /* Add procedure pointers for type-bound procedures.  */
 	      add_procs_to_declared_vtab (derived, vtype);
 	    }
@@ -935,6 +1034,10 @@  cleanup:
 	gfc_commit_symbol (src);
       if (dst)
 	gfc_commit_symbol (dst);
+      if (free)
+	gfc_commit_symbol (free);
+      if (tofree)
+	gfc_commit_symbol (tofree);
     }
   else
     gfc_undo_symbols ();
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 323fca3..e2faeb9 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5341,7 +5341,8 @@  gfc_trans_deallocate (gfc_code *code)
 
   for (al = code->ext.alloc.list; al != NULL; al = al->next)
     {
-      gfc_expr *expr = gfc_copy_expr (al->expr);
+      gfc_expr *expr;
+      expr = gfc_copy_expr (al->expr);
       gcc_assert (expr->expr_type == EXPR_VARIABLE);
 
       if (expr->ts.type == BT_CLASS)
@@ -5354,9 +5355,50 @@  gfc_trans_deallocate (gfc_code *code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
+      if (al->expr->ts.type == BT_CLASS)
+	{
+	  gfc_expr *ppc;
+	  gfc_code *ppc_code;
+	  gfc_actual_arglist *actual;
+          tree cond;
+	  gfc_se free_se;
+
+	  ppc = gfc_copy_expr (al->expr);
+	  gfc_add_vptr_component (ppc);
+	  gfc_add_component_ref (ppc, "_free");
+
+	  gfc_init_se (&free_se, NULL);
+	  free_se.want_pointer = 1;
+	  gfc_conv_expr (&free_se, ppc);
+	  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				  free_se.expr,
+				  build_int_cst (TREE_TYPE (free_se.expr), 0));
+	  tmp =  fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				  se.expr,
+				  build_int_cst (TREE_TYPE (se.expr), 0));
+	  cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				  boolean_type_node, cond, tmp);
+
+	  actual = gfc_get_actual_arglist ();
+	  actual->expr = gfc_copy_expr (expr);
+
+	  ppc_code = gfc_get_code ();
+	  ppc_code->resolved_sym = ppc->symtree->n.sym;
+	  ppc_code->resolved_sym->attr.elemental = 1;
+	  ppc_code->ext.actual = actual;
+	  ppc_code->expr1 = ppc;
+	  ppc_code->op = EXEC_CALL;
+	  tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
+
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+                              cond, tmp, build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&block, tmp);
+	  gfc_free_statements (ppc_code);
+	}
+
       if (expr->rank || gfc_is_coarray (expr))
 	{
-	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
+	  if (al->expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
 	    {
 	      gfc_ref *ref;
 	      gfc_ref *last = NULL;
@@ -5381,7 +5423,7 @@  gfc_trans_deallocate (gfc_code *code)
       else
 	{
 	  tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
-						   expr, expr->ts);
+						   expr, al->expr->ts);
 	  gfc_add_expr_to_block (&se.pre, tmp);
 
 	  /* Set to zero after deallocation.  */
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 3313be9..9320f39 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1083,14 +1083,6 @@  gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
       tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
       gfc_add_expr_to_block (&non_null, tmp);
     }
-  else if (ts.type == BT_CLASS
-	   && ts.u.derived->components->ts.u.derived->attr.alloc_comp)
-    {
-      tmp = build_fold_indirect_ref_loc (input_location, pointer);
-      tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
-				       tmp, 0);
-      gfc_add_expr_to_block (&non_null, tmp);
-    }
   
   tmp = build_call_expr_loc (input_location,
 			     builtin_decl_explicit (BUILT_IN_FREE), 1,