https://gcc.gnu.org/g:d897090949086d1a094429f043a4dcb7bbc74448
commit r15-6615-gd897090949086d1a094429f043a4dcb7bbc74448 Author: Andre Vehreschild <ve...@gcc.gnu.org> Date: Mon Dec 9 14:56:27 2024 +0100 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. Diff: --- gcc/fortran/class.cc | 19 +------ gcc/fortran/expr.cc | 38 ++++++++++---- gcc/fortran/resolve.cc | 58 ++++++++++++++++++++-- gcc/fortran/trans-array.cc | 25 ++++++---- 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, 136 insertions(+), 44 deletions(-) diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index e0dd571cd68b..3e0dce1b54d8 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 0b8d69436761..0e40b2493a5c 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -5017,28 +5017,44 @@ is_non_empty_structure_constructor (gfc_expr * e) bool gfc_has_default_initializer (gfc_symbol *der) { + static hash_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.add (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.contains (c->ts.u.derived)) { - 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.remove (der); + return result; } diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 4f7fe8b6a4bd..6dcda70679f2 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -16752,6 +16752,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) +{ + hash_set<gfc_symbol *> seen, to_examin; + gfc_component *c; + seen.add (derived); + to_examin.add (derived); + while (!to_examin.is_empty ()) + { + gfc_symbol *cand = *to_examin.begin (); + to_examin.remove (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.contains (c->ts.u.derived)) + { + seen.add (c->ts.u.derived); + to_examin.add (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.contains (CLASS_DATA (c)->ts.u.derived)) + { + seen.add (CLASS_DATA (c)->ts.u.derived); + to_examin.add (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 @@ -16791,6 +16838,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; @@ -16865,7 +16916,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 @@ -16940,9 +16990,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 e2b82c1df8b6..057f6a63fdf5 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -9784,6 +9784,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, int caf_dereg_mode; symbol_attribute *attr; bool deallocate_called; + static hash_set<gfc_symbol *> seen_derived_types; gfc_init_block (&fnblock); @@ -9906,13 +9907,17 @@ 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.add (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.contains (c->ts.u.derived)) + || (c->ts.type == BT_CLASS + && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived)); bool is_pdt_type = c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type; @@ -10077,7 +10082,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 @@ -10135,12 +10140,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 @@ -10922,6 +10928,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, break; } } + seen_derived_types.remove (der_type); return gfc_finish_block (&fnblock); } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index bc24105ce329..bef49d32a589 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 4e4c0a64dedb..332b39833ebf 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 000000000000..e491b7a60300 --- /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 +