Hi Paul,
On Mon, 24 Oct 2016 14:42:42 +0200
Paul Richard Thomas <paul.richard.tho...@gmail.com> wrote:
> Dear All,
>
> Please find attached the patch for allocatable components of recursive
> type. The patch is pretty straightforward in that for the main part
> they are treated exactly as their pointer equivalents. The exception
> to this is the automatic deallocation of allocatable components. I
> tried to use the vtable finalization wrapper to do this but found it
> impossible to prevent the compilation going into an infinite loop on
> trying to build the automatic deallocation code. I therefore added a
> new field to the vtable that points to a component that does nothing
> more than deallocate the component. This function takes a rank 1
> array, which can be done safely for automatic deallocation of an
> allocatable component.
>
> The testcases indicate some of the possibilities for these components,
> which provide the benefit of automatic garbage collection. As the
> comment in the fourth testcase says, array components are fiendishly
> difficult to use and, I suspect, will find very little application.
See my comments inline.
> Index: gcc/fortran/class.c
> ===================================================================
> *** gcc/fortran/class.c (revision 241467)
> --- gcc/fortran/class.c (working copy)
<snip>
> *************** gfc_find_derived_vtab (gfc_symbol *deriv
> *** 2255,2260 ****
> --- 2256,2275 ----
> {
> 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;
> + }
So recursive types are defined to be simple recursive, i.e., not transitive?
type A == uses => type B == uses => type A
>
> gfc_get_symbol (name, ns, &vtype);
> if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
> *************** gfc_find_derived_vtab (gfc_symbol *deriv
> *** 2427,2432 ****
> --- 2442,2507 ----
> c->tb->ppc = 1;
> generate_finalization_wrapper (derived, ns, tname, c);
>
> + /* Add component _deallocate. */
> + if (!gfc_add_component (vtype, "_deallocate", &c))
> + 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.unlimited_polymorphic
> + || derived->attr.abstract
> + || !rdt)
When unlimited or abstract rdt can never be true. This is redundant here, isn't
it?
<snip>
> Index: gcc/fortran/expr.c
> ===================================================================
> *** gcc/fortran/expr.c (revision 241467)
> --- gcc/fortran/expr.c (working copy)
> *************** gfc_has_default_initializer (gfc_symbol
> *** 4144,4149 ****
> --- 4144,4150 ----
> if (gfc_bt_struct (c->ts.type))
> {
> if (!c->attr.pointer && !c->attr.proc_pointer
> + && !(c->attr.allocatable && (der == c->ts.u.derived))
The inner most pair of parentheses is unnecessary here.
> && gfc_has_default_initializer (c->ts.u.derived))
> return true;
> if (c->attr.pointer && c->initializer)
> Index: gcc/fortran/resolve.c
> ===================================================================
> *** gcc/fortran/resolve.c (revision 241467)
> --- gcc/fortran/resolve.c (working copy)
> *************** resolve_component (gfc_component *c, gfc
> *** 13493,13498 ****
> --- 13493,13505 ----
> return false;
> }
>
> + /* If an allocatable component derived type is of the same type as
component's
> + the enclosing derived type, we need a vtable generating so that
generated
> + the __deallocate procedure is created. */
> + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
> + && c->ts.u.derived == sym && c->attr.allocatable == 1)
> + gfc_find_vtab (&c->ts);
> +
The indentation of the whole block above is wrong. The comment has 6 spaces
while it should have 2 only.
> /* Ensure that all the derived type components are put on the
> derived type list; even in formal namespaces, where derived type
> pointer components might not have been declared. */
> Index: gcc/fortran/trans-array.c
> ===================================================================
> *** gcc/fortran/trans-array.c (revision 241467)
> --- gcc/fortran/trans-array.c (working copy)
> *************** structure_alloc_comps (gfc_symbol * der_
> *** 7976,7982 ****
> --- 7976,7984 ----
> tree vref, dref;
> tree null_cond = NULL_TREE;
> tree add_when_allocated;
> + tree dealloc_fndecl;
> bool called_dealloc_with_status;
> + gfc_symbol *vtab;
>
> gfc_init_block (&fnblock);
>
> *************** structure_alloc_comps (gfc_symbol * der_
> *** 8112,8118 ****
> if (c->attr.allocatable && !c->attr.proc_pointer
> && (c->attr.dimension
> || (c->attr.codimension
> ! && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF)))
> {
> if (comp == NULL_TREE)
> comp = fold_build3_loc (input_location, COMPONENT_REF,
> ctype, --- 8114,8121 ----
> if (c->attr.allocatable && !c->attr.proc_pointer
> && (c->attr.dimension
> || (c->attr.codimension
> ! && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
> ! && !(c->ts.type == BT_DERIVED && der_type == c->ts.u.derived))
How about adding a "talking boolean" before the if, like:
is_derived_type = c->ts.type == BT_DERIVED && der_type == c->ts.u.derived;
and using that instead of repeatedly evaluating the expression?
<snip>
> *************** structure_alloc_comps (gfc_symbol * der_
> *** 8137,8142 ****
> --- 8141,8222 ----
> build_int_cst (TREE_TYPE (comp), 0));
> gfc_add_expr_to_block (&tmpblock, tmp);
> }
> + else if (c->attr.allocatable && !c->attr.codimension)
> + {
How about putting also the creation of the descriptor into the body that is
guarded by the is_allocated, i.e. in pseudo-code make:
while (1)
{
if (S.0 > D.3472) goto L.1;
cdesc.1.dtype = 601;
cdesc.1.dim[0].lbound = 1;
cdesc.1.dim[0].stride = 1;
cdesc.1.dim[0].ubound = 1;
cdesc.1.data = (void *) (*(struct stack[0:] * restrict)
arg->data)[S.0].next; if ((struct stack *[1] *) cdesc.1.data != 0B)
{
__vtab_m_Stack._deallocate (&cdesc.1);
}
(*(struct stack[0:] * restrict) arg->data)[S.0].next = 0B;
S.0 = S.0 + 1;
}
become
while (1)
{
if (S.0 > D.3472) goto L.1;
if ((struct stack *[1] *) cdesc.1.data != 0B)
{
cdesc.1.dtype = 601;
cdesc.1.dim[0].lbound = 1;
cdesc.1.dim[0].stride = 1;
cdesc.1.dim[0].ubound = 1;
cdesc.1.data = (void *) (*(struct stack[0:] * restrict)
arg->data)[S.0].next;
__vtab_m_Stack._deallocate (&cdesc.1);
}
(*(struct stack[0:] * restrict) arg->data)[S.0].next = 0B;
S.0 = S.0 + 1;
}
Sorry for the ill-alignment. My mailer is breaking lines.
Furthermore, why are you always using an array? We do now at code-generation
time whether the argument is a scalar or an array, don't we? This is more for my
understanding, then an actual comment.
> /* The size field is returned as an array index type. Therefore treat
> Index: gcc/fortran/trans-types.c
> ===================================================================
> *** gcc/fortran/trans-types.c (revision 241467)
> --- gcc/fortran/trans-types.c (working copy)
> *************** gfc_get_derived_type (gfc_symbol * deriv
> *** 2524,2530 ****
> non-procedure pointer components have no backend_decl. */
> for (c = derived->components; c; c = c->next)
> {
> ! if (!c->attr.proc_pointer && c->backend_decl == NULL)
> break;
> else if (c->next == NULL)
> return derived->backend_decl;
> --- 2524,2532 ----
> non-procedure pointer components have no backend_decl. */
> for (c = derived->components; c; c = c->next)
> {
> ! if (!c->attr.proc_pointer
> ! && !(c->attr.allocatable && (derived == c->ts.u.derived))
Spare parentheses above (derived == ..)
> ! && c->backend_decl == NULL)
> break;
> else if (c->next == NULL)
> return derived->backend_decl;
> *************** gfc_get_derived_type (gfc_symbol * deriv
> *** 2562,2568 ****
> if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
> continue;
>
> ! if ((!c->attr.pointer && !c->attr.proc_pointer)
> || c->ts.u.derived->backend_decl == NULL)
> c->ts.u.derived->backend_decl = gfc_get_derived_type
> (c->ts.u.derived, in_coarray
> --- 2564,2571 ----
> if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
> continue;
>
> ! if ((!c->attr.pointer && !c->attr.proc_pointer
> ! && !(c->attr.allocatable && (derived == c->ts.u.derived)))
and here
> || c->ts.u.derived->backend_decl == NULL)
> c->ts.u.derived->backend_decl = gfc_get_derived_type
> (c->ts.u.derived, in_coarray
> *************** gfc_get_derived_type (gfc_symbol * deriv
> *** 2656,2662 ****
> && !(unlimited_entity && c == derived->components))
> field_type = build_pointer_type (field_type);
>
> ! if (c->attr.pointer)
> field_type = gfc_nonrestricted_type (field_type);
>
> /* vtype fields can point to different types to the base type. */
> --- 2659,2665 ----
> && !(unlimited_entity && c == derived->components))
> field_type = build_pointer_type (field_type);
>
> ! if (c->attr.pointer || (c->attr.allocatable && (derived ==
> c->ts.u.derived))) field_type = gfc_nonrestricted_type (field_type);
and here.
>
> /* vtype fields can point to different types to the base type. */
<snipp>
> Index: gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08
> ===================================================================
> *** gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08 (revision 0)
> --- gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08 (working copy)
> ***************
> *** 0 ****
> --- 1,59 ----
> + ! { dg-do run }
> + !
> + ! Tests functionality of recursive allocatable derived types.
> + !
> + module m
> + type :: stack
> + real :: value
> + integer :: index
> + type(stack), allocatable :: next
> + end type stack
> + end module
> +
> + use m
> + ! Here is how to add a new entry at the top of the stack:
> + type (stack), allocatable :: top, temp, dum
> +
> + call poke (1.0)
> + call poke (2.0)
> + call poke (3.0)
> + call output (top)
> + call pop
> + call output (top)
> + deallocate (top)
> + contains
> + subroutine output (arg)
> + type(stack), target, allocatable :: arg
> + type(stack), pointer :: ptr
> +
> + if (.not.allocated (arg)) then
> + print *, "empty stack"
> + return
> + end if
> +
> + print *, " idx value"
> + ptr => arg
> + do while (associated (ptr))
> + print *, ptr%index, " ", ptr%value
> + ptr => ptr%next
> + end do
> + end subroutine
> + subroutine poke(arg)
> + real :: arg
> + integer :: idx
> + if (allocated (top)) then
> + idx = top%index + 1
> + else
> + idx = 1
> + end if
> + allocate (temp)
> + temp%value = arg
> + temp%index = idx
> + call move_alloc(top,temp%next)
> + call move_alloc(temp,top)
> + end subroutine
> + subroutine pop
> + call move_alloc(top%next,temp)
> + call move_alloc(temp,top)
> + end subroutine
> + end
This testcase fails only on segfaults, but never on wrong data. Can you enhance
it to e.g. make output() check that it is seeing 3.0 on the top before the pop
and 2.0 after?
So patch looks beside the mentioned small nits ok to me. Would love to see it
in trunk.
Thanks for the work.
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
