Hi all,
attached patch improves analysis of cycles in derived types, i.e. type
dependencies ala:
type(T)
type(T2), allocatable :: c
end type
type(T2)
type(T), allocatable :: t
end type
are now detected and deallocating an object that is of any of the types
now no longer crashes the compiler because of an endless recursion. To
accomplish this, I stored the symbols of the types seen in a C++ set
and checked if a component's type is already present in there. When a
type has such an indirect self-reference, it gets marked by setting its
symbol_attribute::recursive flag. Later steps then can make use of it.
Furthermore are _deallocate members of the vtab populated when a type
has the recursive and the alloc_comp flag set.
Bootstraps and regtests ok on x86_64-pc-linux-gnu / F41. Ok for
mainline?
Note: The patch was developed on top of my coarray patch, but should
apply with delta on a regular trunk w/o issues.
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gcc dot gnu dot org
From e1f0294f19a10164e932b697e8e2f7f3f59c85f7 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Mon, 9 Dec 2024 14:56:27 +0100
Subject: [PATCH] Fortran: Extend cylic type detection for deallocate
[PR116669]
Using cycles in derived/class types lead to the compiler doing a endless
recursion in several locations, when the cycle was not immediate.
An immediate cyclic dependency is present in, for example T T::comp.
Cylcic dependencies of the form T T2::comp; T2 T::comp2; are now
detected and the recursive bit in the derived type's attr is set.
gcc/fortran/ChangeLog:
PR fortran/116669
* class.cc (gfc_find_derived_vtab): Use attr to determine cyclic
type dependendies.
* expr.cc (gfc_has_default_initializer): Prevent endless
recursion by storing already visited derived types.
* resolve.cc (resolve_cyclic_derived_type): Determine if a type
is used in its hierarchy in a cyclic way.
(resolve_fl_derived0): Call resolve_cyclic_derived_type.
(resolve_fl_derived): Ensure vtab is generated when cyclic
derived types have allocatable components.
* trans-array.cc (structure_alloc_comps): Prevent endless loop
for derived type cycles.
* trans-expr.cc (gfc_get_ultimate_alloc_ptr_comps_caf_token):
Off topic, just prevent memory leaks.
gcc/testsuite/ChangeLog:
* gfortran.dg/class_array_15.f03: Freeing more memory.
* gfortran.dg/recursive_alloc_comp_6.f90: New test.
---
gcc/fortran/class.cc | 19 +-----
gcc/fortran/expr.cc | 40 +++++++++----
gcc/fortran/resolve.cc | 60 +++++++++++++++++--
gcc/fortran/trans-array.cc | 29 ++++++---
gcc/fortran/trans-expr.cc | 10 +++-
gcc/testsuite/gfortran.dg/class_array_15.f03 | 2 +-
.../gfortran.dg/recursive_alloc_comp_6.f90 | 28 +++++++++
7 files changed, 144 insertions(+), 44 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/recursive_alloc_comp_6.f90
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 64a0e726eeb..5017ee973e0 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -2507,20 +2507,6 @@ gfc_find_derived_vtab (gfc_symbol *derived)
{
gfc_component *c;
gfc_symbol *parent = NULL, *parent_vtab = NULL;
- bool rdt = false;
-
- /* Is this a derived type with recursive allocatable
- components? */
- c = (derived->attr.unlimited_polymorphic
- || derived->attr.abstract) ?
- NULL : derived->components;
- for (; c; c= c->next)
- if (c->ts.type == BT_DERIVED
- && c->ts.u.derived == derived)
- {
- rdt = true;
- break;
- }
gfc_get_symbol (name, ns, &vtype);
if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
@@ -2703,9 +2689,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
c->attr.access = ACCESS_PRIVATE;
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
- if (derived->attr.unlimited_polymorphic
- || derived->attr.abstract
- || !rdt)
+ if (derived->attr.unlimited_polymorphic || derived->attr.abstract
+ || !derived->attr.recursive)
c->initializer = gfc_get_null_expr (NULL);
else
{
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index a997bdae726..148f5f90a43 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see
#include "constructor.h"
#include "tree.h"
+#include <set>
/* The following set of functions provide access to gfc_expr* of
various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
@@ -5009,28 +5010,45 @@ is_non_empty_structure_constructor (gfc_expr * e)
bool
gfc_has_default_initializer (gfc_symbol *der)
{
+ static std::set<gfc_symbol *> seen_derived_types;
gfc_component *c;
+ /* The rewrite to a result variable and breaks is only needed, because
+ there is no scope_guard in C++ yet. */
+ bool result = false;
gcc_assert (gfc_fl_struct (der->attr.flavor));
+ seen_derived_types.insert (der);
for (c = der->components; c; c = c->next)
- if (gfc_bt_struct (c->ts.type))
+ if (gfc_bt_struct (c->ts.type)
+ && seen_derived_types.find (c->ts.u.derived)
+ == seen_derived_types.cend ())
{
- if (!c->attr.pointer && !c->attr.proc_pointer
- && !(c->attr.allocatable && der == c->ts.u.derived)
- && ((c->initializer
- && is_non_empty_structure_constructor (c->initializer))
- || gfc_has_default_initializer (c->ts.u.derived)))
- return true;
+ if (!c->attr.pointer && !c->attr.proc_pointer
+ && !(c->attr.allocatable && der == c->ts.u.derived)
+ && ((c->initializer
+ && is_non_empty_structure_constructor (c->initializer))
+ || gfc_has_default_initializer (c->ts.u.derived)))
+ {
+ result = true;
+ break;
+ }
if (c->attr.pointer && c->initializer)
- return true;
+ {
+ result = true;
+ break;
+ }
}
else
{
- if (c->initializer)
- return true;
+ if (c->initializer)
+ {
+ result = true;
+ break;
+ }
}
- return false;
+ seen_derived_types.erase (der);
+ return result;
}
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 47d42f64b32..4e5e64cd842 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -30,6 +30,8 @@ along with GCC; see the file COPYING3. If not see
#include "target-memory.h" /* for gfc_simplify_transfer */
#include "constructor.h"
+#include <set>
+
/* Types used in equivalence statements. */
enum seq_type
@@ -16757,6 +16759,53 @@ resolve_fl_struct (gfc_symbol *sym)
return true;
}
+/* Figure if the derived type is using itself directly in one of its components
+ or through referencing other derived types. The information is required to
+ generate the __deallocate and __final type bound procedures to ensure
+ freeing larger hierarchies of derived types with allocatable objects. */
+
+static void
+resolve_cyclic_derived_type (gfc_symbol *derived)
+{
+ std::set<gfc_symbol *> seen, to_examin;
+ gfc_component *c;
+ seen.insert (derived);
+ to_examin.insert (derived);
+ while (!to_examin.empty ())
+ {
+ gfc_symbol *cand = *to_examin.begin ();
+ to_examin.erase (cand);
+ for (c = cand->components; c; c = c->next)
+ if (c->ts.type == BT_DERIVED)
+ {
+ if (c->ts.u.derived == derived)
+ {
+ derived->attr.recursive = 1;
+ return;
+ }
+ else if (seen.find (c->ts.u.derived) == seen.cend ())
+ {
+ seen.insert (c->ts.u.derived);
+ to_examin.insert (c->ts.u.derived);
+ }
+ }
+ else if (c->ts.type == BT_CLASS)
+ {
+ if (!c->attr.class_ok)
+ continue;
+ if (CLASS_DATA (c)->ts.u.derived == derived)
+ {
+ derived->attr.recursive = 1;
+ return;
+ }
+ else if (seen.find (CLASS_DATA (c)->ts.u.derived) == seen.cend ())
+ {
+ seen.insert (CLASS_DATA (c)->ts.u.derived);
+ to_examin.insert (CLASS_DATA (c)->ts.u.derived);
+ }
+ }
+ }
+}
/* Resolve the components of a derived type. This does not have to wait until
resolution stage, but can be done as soon as the dt declaration has been
@@ -16796,6 +16845,10 @@ resolve_fl_derived0 (gfc_symbol *sym)
return false;
}
+ /* Resolving components below, may create vtabs for which the cyclic type
+ information needs to be present. */
+ resolve_cyclic_derived_type (sym);
+
c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
: sym->components;
@@ -16870,7 +16923,6 @@ resolve_fl_derived0 (gfc_symbol *sym)
return true;
}
-
/* The following procedure does the full resolution of a derived type,
including resolution of all type-bound procedures (if present). In contrast
to 'resolve_fl_derived0' this can only be done after the module has been
@@ -16945,9 +16997,9 @@ resolve_fl_derived (gfc_symbol *sym)
being vtables or pdt templates. If this is not done class declarations
in external procedures wind up with their own version and so SELECT TYPE
fails because the vptrs do not have the same address. */
- if (gfc_option.allow_std & GFC_STD_F2003
- && sym->ns->proc_name
- && sym->ns->proc_name->attr.flavor == FL_MODULE
+ if (gfc_option.allow_std & GFC_STD_F2003 && sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || (sym->attr.recursive && sym->attr.alloc_comp))
&& sym->attr.access != ACCESS_PRIVATE
&& !(sym->attr.vtype || sym->attr.pdt_template))
{
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2f239285c13..366127d5651 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -93,6 +93,8 @@ along with GCC; see the file COPYING3. If not see
#include "trans-const.h"
#include "dependency.h"
+#include <set>
+
static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
/* The contents of this structure aren't actually used, just the address. */
@@ -9779,6 +9781,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
int caf_dereg_mode;
symbol_attribute *attr;
bool deallocate_called;
+ static std::set<gfc_symbol *> seen_derived_types;
gfc_init_block (&fnblock);
@@ -9901,13 +9904,19 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
}
/* Otherwise, act on the components or recursively call self to
act on a chain of components. */
+ seen_derived_types.insert (der_type);
for (c = der_type->components; c; c = c->next)
{
bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
|| c->ts.type == BT_CLASS)
&& c->ts.u.derived->attr.alloc_comp;
- bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
- || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
+ bool same_type
+ = (c->ts.type == BT_DERIVED
+ && seen_derived_types.find (c->ts.u.derived)
+ != seen_derived_types.cend ())
+ || (c->ts.type == BT_CLASS
+ && seen_derived_types.find (CLASS_DATA (c)->ts.u.derived)
+ != seen_derived_types.cend ());
bool is_pdt_type = c->ts.type == BT_DERIVED
&& c->ts.u.derived->attr.pdt_type;
@@ -10072,7 +10081,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
if (c->ts.type == BT_CLASS)
{
attr = &CLASS_DATA (c)->attr;
- if (attr->class_pointer)
+ if (attr->class_pointer || c->attr.proc_pointer)
continue;
}
else
@@ -10130,12 +10139,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
/* Handle all types of components besides components of the
same_type as the current one, because those would create an
endless loop. */
- caf_dereg_mode
- = (caf_in_coarray (caf_mode) || attr->codimension)
- ? (gfc_caf_is_dealloc_only (caf_mode)
- ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
- : GFC_CAF_COARRAY_DEREGISTER)
- : GFC_CAF_COARRAY_NOCOARRAY;
+ caf_dereg_mode = (caf_in_coarray (caf_mode)
+ && (attr->dimension || c->caf_token))
+ || attr->codimension
+ ? (gfc_caf_is_dealloc_only (caf_mode)
+ ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
+ : GFC_CAF_COARRAY_DEREGISTER)
+ : GFC_CAF_COARRAY_NOCOARRAY;
caf_token = NULL_TREE;
/* Coarray components are handled directly by
@@ -10917,6 +10927,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
break;
}
}
+ seen_derived_types.erase (der_type);
return gfc_finish_block (&fnblock);
}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6e7874811b1..20f60e6587f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -165,7 +165,10 @@ gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
}
if (last_caf_ref == NULL)
- return NULL_TREE;
+ {
+ gfc_free_expr (caf_expr);
+ return NULL_TREE;
+ }
tree comp = last_caf_ref->u.c.component->caf_token
? gfc_comp_caf_token (last_caf_ref->u.c.component)
@@ -174,7 +177,10 @@ gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
gfc_se se;
bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
if (comp == NULL_TREE && comp_ref)
- return NULL_TREE;
+ {
+ gfc_free_expr (caf_expr);
+ return NULL_TREE;
+ }
gfc_init_se (&se, outerse);
gfc_free_ref_list (last_caf_ref->next);
last_caf_ref->next = NULL;
diff --git a/gcc/testsuite/gfortran.dg/class_array_15.f03 b/gcc/testsuite/gfortran.dg/class_array_15.f03
index 4e4c0a64ded..332b39833eb 100644
--- a/gcc/testsuite/gfortran.dg/class_array_15.f03
+++ b/gcc/testsuite/gfortran.dg/class_array_15.f03
@@ -115,4 +115,4 @@ subroutine pr54992 ! This test remains as the original.
bh => bhGet(b,instance=2)
if (loc (b) .ne. loc(bh%hostNode)) STOP 8
end
-! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 16 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/recursive_alloc_comp_6.f90 b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_6.f90
new file mode 100644
index 00000000000..e491b7a6030
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_6.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+!
+! Check that PR116669 is fixed now.
+! Contributed by Dominik Gronkiewicz <gro...@gmail.com>
+
+program pr116669
+
+ implicit none (type, external)
+
+ type ast_expr_t
+ type(ast_opcall_t), allocatable :: op_call
+ end type
+
+ type ast_opcall_t
+ type(ast_expr_t), allocatable :: args(:)
+ end type
+
+ type(ast_opcall_t) :: o
+
+ allocate(o%args(2))
+ allocate(o%args(2)%op_call)
+ allocate(o%args(2)%op_call%args(3))
+
+ if (.NOT. allocated(o%args(2)%op_call%args)) stop 1
+
+ deallocate(o%args)
+end program
+
--
2.47.1
