From 39da58667d94ab210cb6918fb8f528aa6aabfbb2 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Fri, 9 Dec 2016 13:32:50 +0100
Subject: trans-array.c (gfc_array_deallocate): Remove wrapper.
gcc/fortran/ChangeLog:
2016-12-09 Andre Vehreschild <vehre@gcc.gnu.org>
* trans-array.c (gfc_array_deallocate): Remove wrapper.
(gfc_trans_dealloc_allocated): Same.
(structure_alloc_comps): Restructure deallocation of (nested)
allocatable components. Insert dealloc of sub-component into the block
guarded by the if != NULL for the component.
(gfc_trans_deferred_array): Use the almightly deallocate_with_status.
* trans-array.h: Remove prototypes.
* trans-expr.c (gfc_conv_procedure_call): Use the almighty deallocate_
with_status.
* trans-openmp.c (gfc_walk_alloc_comps): Likewise.
(gfc_omp_clause_assign_op): Likewise.
(gfc_omp_clause_dtor): Likewise.
* trans-stmt.c (gfc_trans_deallocate): Likewise.
* trans.c (gfc_deallocate_with_status): Allow deallocation of scalar
and arrays as well as coarrays.
(gfc_deallocate_scalar_with_status): Get the data member for coarrays
only when freeing an array with descriptor. And set correct caf_mode
when freeing components of coarrays.
* trans.h: Change prototype of gfc_deallocate_with_status to allow
adding statements into the block guarded by the if (pointer != 0) and
supply a coarray handle.
gcc/testsuite/ChangeLog:
2016-12-09 Andre Vehreschild <vehre@gcc.gnu.org>
* gfortran.dg/coarray_alloc_comp_3.f08: New test.
* gfortran.dg/coarray_alloc_comp_4.f08: New test.
* gfortran.dg/finalize_18.f90: Add count for additional guard against
accessing null-pointer.
* gfortran.dg/proc_ptr_comp_47.f90: New test.
From-SVN: r243480
---
gcc/fortran/trans-array.c | 322 +++++++++++++++-------------------------------
1 file changed, 103 insertions(+), 219 deletions(-)
(limited to 'gcc/fortran/trans-array.c')
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index ac90a4b..8753cbf 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5652,53 +5652,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
}
-/* Deallocate an array variable. Also used when an allocated variable goes
- out of scope. */
-/*GCC ARRAYS*/
-
-tree
-gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
- tree label_finish, gfc_expr* expr,
- int coarray_dealloc_mode)
-{
- tree var;
- tree tmp;
- stmtblock_t block;
- bool coarray = coarray_dealloc_mode != GFC_CAF_COARRAY_NOCOARRAY;
-
- gfc_start_block (&block);
-
- /* Get a pointer to the data. */
- var = gfc_conv_descriptor_data_get (descriptor);
- STRIP_NOPS (var);
-
- /* Parameter is the address of the data component. */
- tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
- errlen, label_finish, false, expr,
- coarray_dealloc_mode);
- gfc_add_expr_to_block (&block, tmp);
-
- /* Zero the data pointer; only for coarrays an error can occur and then
- the allocation status may not be changed. */
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- var, build_int_cst (TREE_TYPE (var), 0));
- if (pstat != NULL_TREE && coarray && flag_coarray == GFC_FCOARRAY_LIB)
- {
- tree cond;
- tree stat = build_fold_indirect_ref_loc (input_location, pstat);
-
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- stat, build_int_cst (TREE_TYPE (stat), 0));
- 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);
-
- return gfc_finish_block (&block);
-}
-
-
/* Create an array constructor from an initialization expression.
We assume the frontend already did any expansions and conversions. */
@@ -7806,39 +7759,6 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
}
-/* Generate code to deallocate an array, if it is allocated. */
-
-tree
-gfc_trans_dealloc_allocated (tree descriptor, gfc_expr *expr,
- int coarray_dealloc_mode)
-{
- tree tmp;
- tree var;
- stmtblock_t block;
- bool coarray = coarray_dealloc_mode != GFC_CAF_COARRAY_NOCOARRAY;
-
- gfc_start_block (&block);
-
- var = gfc_conv_descriptor_data_get (descriptor);
- STRIP_NOPS (var);
-
- /* Call array_deallocate with an int * present in the second argument.
- Although it is ignored here, it's presence ensures that arrays that
- are already deallocated are ignored. */
- tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
- NULL_TREE, NULL_TREE, NULL_TREE, true, expr,
- coarray_dealloc_mode);
- gfc_add_expr_to_block (&block, tmp);
-
- /* Zero the data pointer. */
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- var, build_int_cst (TREE_TYPE (var), 0));
- gfc_add_expr_to_block (&block, tmp);
-
- return gfc_finish_block (&block);
-}
-
-
/* This helper function calculates the size in words of a full array. */
tree
@@ -8157,8 +8077,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tree null_cond = NULL_TREE;
tree add_when_allocated;
tree dealloc_fndecl;
- bool called_dealloc_with_status;
+ tree caf_token;
gfc_symbol *vtab;
+ int caf_dereg_mode;
+ symbol_attribute *attr;
+ bool deallocate_called;
gfc_init_block (&fnblock);
@@ -8265,7 +8188,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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;
+ 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);
cdecl = c->backend_decl;
ctype = TREE_TYPE (cdecl);
@@ -8274,112 +8198,118 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
{
case DEALLOCATE_ALLOC_COMP:
- /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
- (i.e. this function) so generate all the calls and suppress the
- recursion from here, if necessary. */
- called_dealloc_with_status = false;
gfc_init_block (&tmpblock);
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+
+ /* Shortcut to get the attributes of the component. */
+ if (c->ts.type == BT_CLASS)
+ attr = &CLASS_DATA (c)->attr;
+ else
+ attr = &c->attr;
+
if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
- || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
- {
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
+ || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+ /* Call the finalizer, which will free the memory and nullify the
+ pointer of an array. */
+ deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
+ caf_enabled (caf_mode))
+ && attr->dimension;
+ else
+ deallocate_called = false;
+
+ /* Add the _class ref for classes. */
+ if (c->ts.type == BT_CLASS && attr->allocatable)
+ comp = gfc_class_data_get (comp);
- /* The finalizer frees allocatable components. */
- called_dealloc_with_status
- = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
- purpose == DEALLOCATE_ALLOC_COMP
- && caf_enabled (caf_mode));
+ add_when_allocated = NULL_TREE;
+ if (cmp_has_alloc_comps
+ && !c->attr.pointer && !c->attr.proc_pointer
+ && !same_type
+ && !deallocate_called)
+ {
+ /* Add checked deallocation of the components. This code is
+ obviously added because the finalizer is not trusted to free
+ all memory. */
+ if (c->ts.type == BT_CLASS)
+ {
+ rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
+ add_when_allocated
+ = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
+ comp, NULL_TREE, rank, purpose,
+ caf_mode);
+ }
+ else
+ {
+ rank = c->as ? c->as->rank : 0;
+ add_when_allocated = structure_alloc_comps (c->ts.u.derived,
+ comp, NULL_TREE,
+ rank, purpose,
+ caf_mode);
+ }
}
- else
- comp = NULL_TREE;
- if (c->attr.allocatable && !c->attr.proc_pointer && !same_type
- && (c->attr.dimension
- || (caf_enabled (caf_mode)
- && (caf_in_coarray (caf_mode) || c->attr.codimension))))
+ if (attr->allocatable && !same_type
+ && (!attr->codimension || caf_enabled (caf_mode)))
{
- /* Allocatable arrays or coarray'ed components (scalar or
- array). */
- int caf_dereg_mode
- = (caf_in_coarray (caf_mode) || c->attr.codimension)
+ /* 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;
- if (comp == NULL_TREE)
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
- if (c->attr.dimension || c->attr.codimension)
- /* Deallocate array. */
- tmp = gfc_trans_dealloc_allocated (comp, NULL, caf_dereg_mode);
- else
+ caf_token = NULL_TREE;
+ /* Coarray components are handled directly by
+ deallocate_with_status. */
+ if (!attr->codimension
+ && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
{
- /* Deallocate scalar. */
- tree cond = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, comp,
- build_int_cst (TREE_TYPE (comp),
- 0));
-
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- pvoid_type_node, decl, c->caf_token,
- NULL_TREE);
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_deregister, 5,
- gfc_build_addr_expr (NULL_TREE,
- tmp),
- build_int_cst (integer_type_node,
- caf_dereg_mode),
- null_pointer_node,
- null_pointer_node,
- integer_zero_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node, cond, tmp,
- build_empty_stmt (input_location));
+ if (c->caf_token)
+ caf_token = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (c->caf_token),
+ decl, c->caf_token, NULL_TREE);
+ else if (attr->dimension && !attr->proc_pointer)
+ caf_token = gfc_conv_descriptor_token (comp);
}
+ if (attr->dimension && !attr->codimension && !attr->proc_pointer)
+ /* When this is an array but not in conjunction with a coarray
+ then add the data-ref. For coarray'ed arrays the data-ref
+ is added by deallocate_with_status. */
+ comp = gfc_conv_descriptor_data_get (comp);
- gfc_add_expr_to_block (&tmpblock, tmp);
- }
- else if (c->attr.allocatable && !c->attr.codimension && !same_type)
- {
- /* Allocatable scalar components. */
- if (comp == NULL_TREE)
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
-
- tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE,
- NULL_TREE, true, NULL,
- c->ts);
- gfc_add_expr_to_block (&tmpblock, tmp);
- called_dealloc_with_status = true;
+ tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, true,
+ NULL, caf_dereg_mode,
+ add_when_allocated, caf_token);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, comp,
- build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&tmpblock, tmp);
}
- else if (c->attr.allocatable && !c->attr.codimension)
+ else if (attr->allocatable && !attr->codimension
+ && !deallocate_called)
{
/* Case of recursive allocatable derived types. */
tree is_allocated;
tree ubound;
tree cdesc;
- tree data;
stmtblock_t dealloc_block;
gfc_init_block (&dealloc_block);
+ if (add_when_allocated)
+ gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
/* Convert the component into a rank 1 descriptor type. */
- if (comp == NULL_TREE)
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
-
- if (c->attr.dimension)
+ if (attr->dimension)
{
tmp = gfc_get_element_type (TREE_TYPE (comp));
- ubound = gfc_full_array_size (&dealloc_block, comp, c->as->rank);
+ ubound = gfc_full_array_size (&dealloc_block, comp,
+ c->ts.type == BT_CLASS
+ ? CLASS_DATA (c)->as->rank
+ : c->as->rank);
}
else
{
@@ -8405,12 +8335,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
gfc_index_zero_node, ubound);
- if (c->attr.dimension)
- data = gfc_conv_descriptor_data_get (comp);
- else
- data = comp;
+ if (attr->dimension)
+ comp = gfc_conv_descriptor_data_get (comp);
- gfc_conv_descriptor_data_set (&dealloc_block, cdesc, data);
+ gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
/* Now call the deallocator. */
vtab = gfc_find_vtab (&c->ts);
@@ -8420,10 +8348,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
dealloc_fndecl);
- tmp = build_int_cst (TREE_TYPE (data), 0);
+ tmp = build_int_cst (TREE_TYPE (comp), 0);
is_allocated = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tmp,
- data);
+ comp);
cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
tmp = build_call_expr_loc (input_location,
@@ -8438,49 +8366,20 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&tmpblock, tmp);
-
- gfc_add_modify (&tmpblock, data,
- build_int_cst (TREE_TYPE (data), 0));
}
+ else if (add_when_allocated)
+ gfc_add_expr_to_block (&tmpblock, add_when_allocated);
- else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable
- && (!CLASS_DATA (c)->attr.codimension
- || !caf_enabled (caf_mode)))
+ if (c->ts.type == BT_CLASS && attr->allocatable
+ && (!attr->codimension || !caf_enabled (caf_mode)))
{
- /* Allocatable CLASS components. */
-
- /* Add reference to '_data' component. */
- tmp = CLASS_DATA (c)->backend_decl;
- comp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (tmp), comp, tmp, NULL_TREE);
-
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
- tmp = gfc_trans_dealloc_allocated (comp, NULL,
- CLASS_DATA (c)->attr.codimension
- ? GFC_CAF_COARRAY_DEREGISTER
- : GFC_CAF_COARRAY_NOCOARRAY);
- else
- {
- tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE,
- NULL_TREE, true,
- NULL,
- CLASS_DATA (c)->ts);
- gfc_add_expr_to_block (&tmpblock, tmp);
- called_dealloc_with_status = true;
-
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, comp,
- build_int_cst (TREE_TYPE (comp), 0));
- }
- gfc_add_expr_to_block (&tmpblock, tmp);
-
/* Finally, reset the vptr to the declared type vtable and, if
necessary reset the _len field.
First recover the reference to the component and obtain
the vptr. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
+ decl, cdecl, NULL_TREE);
tmp = gfc_class_vptr_get (comp);
if (UNLIMITED_POLY (c))
@@ -8507,22 +8406,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
}
}
- if (cmp_has_alloc_comps
- && !c->attr.pointer && !c->attr.proc_pointer
- && !same_type
- && !called_dealloc_with_status)
- {
- /* Do not deallocate the components of ultimate pointer
- components or iteratively call self if call has been made
- to gfc_trans_dealloc_allocated */
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
- decl, cdecl, NULL_TREE);
- rank = c->as ? c->as->rank : 0;
- tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
- rank, purpose, caf_mode);
- gfc_add_expr_to_block (&fnblock, tmp);
- }
-
/* Now add the deallocation of this component. */
gfc_add_block_to_block (&fnblock, &tmpblock);
break;
@@ -9723,10 +9606,11 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
{
gfc_expr *e;
e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
- tmp = gfc_trans_dealloc_allocated (sym->backend_decl, e,
- sym->attr.codimension
- ? GFC_CAF_COARRAY_DEREGISTER
- : GFC_CAF_COARRAY_NOCOARRAY);
+ tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, true, e,
+ sym->attr.codimension
+ ? GFC_CAF_COARRAY_DEREGISTER
+ : GFC_CAF_COARRAY_NOCOARRAY);
if (e)
gfc_free_expr (e);
gfc_add_expr_to_block (&cleanup, tmp);
--
cgit v1.1