* Re: [PATCH, Fortran, v3] Fix deallocation of nested derived typed components
2016-12-03 23:59 ` Dominique d'Humières
@ 2016-12-05 13:32 ` Andre Vehreschild
0 siblings, 0 replies; 5+ messages in thread
From: Andre Vehreschild @ 2016-12-05 13:32 UTC (permalink / raw)
To: Dominique d'Humières; +Cc: Fortran List, GCC-Patches-ML
[-- Attachment #1: Type: text/plain, Size: 2466 bytes --]
Hi Dominique, hi all,
@Dominique: Thanks for testing. I have extended my usual testcycle to add the
libgomp.fortran tests.
I could fix the errors below by calling deallocate_with_status directly from
the trans_omp_*-routines instead of using the gfc_array_deallocate wrapper.
While being at it, I made deallocate_with_status almighty when freeing memory.
gfc_deallocate_with_status now frees memory of scalars or arrays, coarrayed
scalars or coarrayed arrays without having to massage the inputs of the
routine. The benefit of this is, that instead of having four routines that are
able to deallocate a special kind of allocated object, there now are only two
(gfc_deallocate_scalar_with_status can be removed, too, but means changes in
many places which would enlarge this patch even more. Therefore I have not yet
done it.). I.e. no longer guessing which routine to call for freeing an
allocatable object -> hand it to deallocate_with_status and be done.
Bootstraps and regtests ok on x86_64-linux/F23. Ok for trunk?
Regards,
Andre
On Sun, 4 Dec 2016 00:59:00 +0100
Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> Hi Andre,
>
> I fear the patch is causing another set of failures with -fopenmp:
>
> FAIL: libgomp.fortran/allocatable11.f90 -O0 (internal compiler error)
> …
> FAIL: libgomp.fortran/allocatable8.f90 -g -flto (test for excess errors)
>
> of the kind
>
> collect2: error: ld returned 1 exit status
> [Book15] f90/bug%
> gfc /opt/gcc/work/libgomp/testsuite/libgomp.fortran/allocatable2.f90
> -fopenmp /opt/gcc/work/libgomp/testsuite/libgomp.fortran/allocatable2.f90:46:0:
>
> if (l.or.allocated (a)) call abort
>
> Error: incorrect sharing of tree nodes
> a.data
> a.data = 0B;
> /opt/gcc/work/libgomp/testsuite/libgomp.fortran/allocatable2.f90:46:0:
> internal compiler error: verify_gimple failed
>
> Dominique
>
> > Le 3 déc. 2016 à 19:51, Andre Vehreschild <vehre@gmx.de> a écrit :
> >
> > Hi all,
> >
> > @Dominique: Thanks for checking. And also for pointing out that the initial
> > version of the patch ICEd on some already closed PRs. The objective of those
> > PRs does not seem to be covered by the current testsuite. I therefore
> > additionally propose to add attached testcase. Ok for trunk?
> >
> > Of course with appropriate Changelog-entry.
> >
> > Regards,
> > Andre
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: dealloc_comps_fix_v3.clog --]
[-- Type: text/plain, Size: 1496 bytes --]
gcc/fortran/ChangeLog:
2016-12-05 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-05 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.
[-- Attachment #3: dealloc_comps_fix_v3.patch --]
[-- Type: text/x-patch, Size: 34990 bytes --]
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);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 0a6621b..ab0a6de 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -18,9 +18,6 @@ You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
-/* Generate code to free an array. */
-tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*, int c = -2);
-
/* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
@@ -41,8 +38,6 @@ void gfc_trans_auto_array_allocation (tree, gfc_symbol *, gfc_wrapped_block *);
void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
/* Generate entry and exit code for g77 calling convention arrays. */
void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
-/* Generate code to deallocate an array, if it is allocated. */
-tree gfc_trans_dealloc_allocated (tree, gfc_expr *, int);
tree gfc_full_array_size (stmtblock_t *, tree, int);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 78bff87..8d7e881 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5441,8 +5441,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr);
- tmp = gfc_trans_dealloc_allocated (tmp, e,
- GFC_CAF_COARRAY_NOCOARRAY);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, true,
+ e,
+ GFC_CAF_COARRAY_NOCOARRAY);
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index d460048..6bc2dcd 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -420,8 +420,11 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var,
if (GFC_DESCRIPTOR_TYPE_P (ftype)
&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
{
- tem = gfc_trans_dealloc_allocated (unshare_expr (declf), NULL,
- GFC_CAF_COARRAY_NOCOARRAY);
+ tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
+ tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, true,
+ NULL,
+ GFC_CAF_COARRAY_NOCOARRAY);
gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
}
else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
@@ -810,10 +813,13 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
{
gfc_init_block (&cond_block);
if (GFC_DESCRIPTOR_TYPE_P (type))
- gfc_add_expr_to_block (&cond_block,
- gfc_trans_dealloc_allocated (unshare_expr (dest),
- NULL,
- GFC_CAF_COARRAY_NOCOARRAY));
+ {
+ tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest));
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, true, NULL,
+ GFC_CAF_COARRAY_NOCOARRAY);
+ gfc_add_expr_to_block (&cond_block, tmp);
+ }
else
{
destptr = gfc_evaluate_now (destptr, &cond_block);
@@ -987,9 +993,14 @@ gfc_omp_clause_dtor (tree clause, tree decl)
}
if (GFC_DESCRIPTOR_TYPE_P (type))
- /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
- to be deallocated if they were allocated. */
- tem = gfc_trans_dealloc_allocated (decl, NULL, GFC_CAF_COARRAY_NOCOARRAY);
+ {
+ /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
+ to be deallocated if they were allocated. */
+ tem = gfc_conv_descriptor_data_get (decl);
+ tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE,
+ NULL_TREE, true, NULL,
+ GFC_CAF_COARRAY_NOCOARRAY);
+ }
else
tem = gfc_call_free (decl);
tem = gfc_omp_unshare_expr (tem);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 514db28..5ca716b 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -6489,8 +6489,9 @@ gfc_trans_deallocate (gfc_code *code)
: GFC_CAF_COARRAY_DEREGISTER;
else
caf_dtype = GFC_CAF_COARRAY_NOCOARRAY;
- tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
- label_finish, expr, caf_dtype);
+ tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen,
+ label_finish, false, expr,
+ caf_dtype);
gfc_add_expr_to_block (&se.pre, tmp);
}
else if (TREE_CODE (se.expr) == COMPONENT_REF
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 6a1d481..e5dd986 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1281,31 +1281,58 @@ tree
gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
tree errlen, tree label_finish,
bool can_fail, gfc_expr* expr,
- int coarray_dealloc_mode)
+ int coarray_dealloc_mode, tree add_when_allocated,
+ tree caf_token)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
tree status_type = NULL_TREE;
- tree caf_decl = NULL_TREE;
+ tree token = NULL_TREE;
gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
{
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
- caf_decl = pointer;
- pointer = gfc_conv_descriptor_data_get (caf_decl);
- STRIP_NOPS (pointer);
- if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
+ if (flag_coarray == GFC_FCOARRAY_LIB)
{
- bool comp_ref;
- if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
- && comp_ref)
- caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
- // else do a deregister as set by default.
+ if (caf_token)
+ token = caf_token;
+ else
+ {
+ tree caf_type, caf_decl = pointer;
+ pointer = gfc_conv_descriptor_data_get (caf_decl);
+ caf_type = TREE_TYPE (caf_decl);
+ STRIP_NOPS (pointer);
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ token = gfc_conv_descriptor_token (caf_decl);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+ token = GFC_DECL_TOKEN (caf_decl);
+ else
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
+ != NULL_TREE);
+ token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+ }
+ }
+
+ if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
+ {
+ bool comp_ref;
+ if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
+ && comp_ref)
+ caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
+ // else do a deregister as set by default.
+ }
+ else
+ caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
}
- else
- caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
+ else if (flag_coarray == GFC_FCOARRAY_SINGLE)
+ pointer = gfc_conv_descriptor_data_get (pointer);
}
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
+ pointer = gfc_conv_descriptor_data_get (pointer);
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
build_int_cst (TREE_TYPE (pointer), 0));
@@ -1348,6 +1375,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
+ if (add_when_allocated)
+ gfc_add_expr_to_block (&non_null, add_when_allocated);
gfc_add_finalizer_call (&non_null, expr);
if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
|| flag_coarray != GFC_FCOARRAY_LIB)
@@ -1356,6 +1385,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
builtin_decl_explicit (BUILT_IN_FREE), 1,
fold_convert (pvoid_type_node, pointer));
gfc_add_expr_to_block (&non_null, tmp);
+ gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
+ 0));
if (status != NULL_TREE && !integer_zerop (status))
{
@@ -1378,8 +1409,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
}
else
{
- tree caf_type, token, cond2;
- tree pstat = null_pointer_node;
+ tree cond2, pstat = null_pointer_node;
if (errmsg == NULL_TREE)
{
@@ -1394,27 +1424,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
}
- caf_type = TREE_TYPE (caf_decl);
-
if (status != NULL_TREE && !integer_zerop (status))
{
gcc_assert (status_type == integer_type_node);
pstat = status;
}
- if (GFC_DESCRIPTOR_TYPE_P (caf_type)
- && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
- token = gfc_conv_descriptor_token (caf_decl);
- else if (DECL_LANG_SPECIFIC (caf_decl)
- && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
- token = GFC_DECL_TOKEN (caf_decl);
- else
- {
- gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
- && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
- token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
- }
-
token = gfc_build_addr_expr (NULL_TREE, token);
gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
tmp = build_call_expr_loc (input_location,
@@ -1435,6 +1450,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
if (status != NULL_TREE)
{
tree stat = build_fold_indirect_ref_loc (input_location, status);
+ tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, pointer,
+ build_int_cst (TREE_TYPE (pointer),
+ 0));
TREE_USED (label_finish) = 1;
tmp = build1_v (GOTO_EXPR, label_finish);
@@ -1442,9 +1461,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
stat, build_zero_cst (TREE_TYPE (stat)));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
- tmp, build_empty_stmt (input_location));
+ tmp, nullify);
gfc_add_expr_to_block (&non_null, tmp);
}
+ else
+ gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
+ 0));
}
return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
@@ -1516,11 +1538,17 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
finalizable = gfc_add_finalizer_call (&non_null, expr);
if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
- if (coarray)
+ int caf_mode = coarray
+ ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY
+ ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0)
+ | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
+ | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
+ : 0;
+ if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
tmp = gfc_conv_descriptor_data_get (pointer);
else
tmp = build_fold_indirect_ref_loc (input_location, pointer);
- tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
+ tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode);
gfc_add_expr_to_block (&non_null, tmp);
}
@@ -1573,7 +1601,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
gfc_add_expr_to_block (&non_null, tmp);
/* It guarantees memory consistency within the same segment. */
- tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
+ tmp = gfc_build_string_const (strlen ("memory")+1, "memory");
tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index ae1f156..bfc2a24 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -719,7 +719,8 @@ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
/* Generate code to deallocate an array. */
tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool,
- gfc_expr *, int);
+ gfc_expr *, int, tree a = NULL_TREE,
+ tree c = NULL_TREE);
tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*,
gfc_typespec, bool c = false);
diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08
new file mode 100644
index 0000000..8d2e793
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08
@@ -0,0 +1,51 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
+!
+! Contributed by Andre Vehreschild
+! Check that manually freeing components does not lead to a runtime crash,
+! when the auto-deallocation is taking care.
+
+program coarray_alloc_comp_3
+ implicit none
+
+ type dt
+ integer, allocatable :: i
+ end type dt
+
+ type linktype
+ type(dt), allocatable :: link
+ end type linktype
+
+ type(linktype), allocatable :: obj[:]
+
+ allocate(obj[*])
+ allocate(obj%link)
+
+ if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated."
+ if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+ if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated."
+
+ allocate(obj%link%i, source = 42)
+
+ if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated."
+ if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+ if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated."
+ if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42."
+
+ deallocate(obj%link%i)
+
+ if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated."
+ if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated."
+ if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated."
+
+ ! Freeing this object, lead to crash with older gfortran...
+ deallocate(obj%link)
+
+ if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated."
+ if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated."
+
+ ! ... when auto-deallocating the allocated components.
+ deallocate(obj)
+
+ if (allocated(obj)) error stop "Test failed. 'obj' still allocated."
+end program
diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08
new file mode 100644
index 0000000..517bb18
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08
@@ -0,0 +1,44 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Contributed by Andre Vehreschild
+! Check that sub-components are caf_deregistered and not freed.
+
+program coarray_alloc_comp_3
+ implicit none
+
+ type dt
+ integer, allocatable :: i
+ end type dt
+
+ type linktype
+ type(dt), allocatable :: link
+ end type linktype
+
+ type(linktype) :: obj[*]
+
+ allocate(obj%link)
+
+ if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+ if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated."
+
+ allocate(obj%link%i, source = 42)
+
+ if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+ if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated."
+ if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42."
+
+ deallocate(obj%link%i)
+
+ if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated."
+ if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated."
+
+ ! Freeing this object, lead to crash with older gfortran...
+ deallocate(obj%link)
+
+ if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated."
+end program
+! Ensure, that three calls to deregister are present.
+! { dg-final { scan-tree-dump-times "_caf_deregister" 3 "original" } }
+! And ensure that no calls to builtin_free are made.
+! { dg-final { scan-tree-dump-not "_builtin_free" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/finalize_18.f90 b/gcc/testsuite/gfortran.dg/finalize_18.f90
index c8b4afc..3e64332 100644
--- a/gcc/testsuite/gfortran.dg/finalize_18.f90
+++ b/gcc/testsuite/gfortran.dg/finalize_18.f90
@@ -33,8 +33,8 @@ end
! { dg-final { scan-tree-dump-times "if \\(y.aa != 0B\\)" 2 "original" } }
! { dg-final { scan-tree-dump-times "if \\(y.cc._data != 0B\\)" 2 "original" } }
-! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 2 "original" } }
! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.aa;" 1 "original" } }
! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.cc._data;" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90
new file mode 100644
index 0000000..1d52100
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+
+MODULE distribution_types
+ ABSTRACT INTERFACE
+ FUNCTION dist_map_blk_to_proc_func ( row, col, nrow_tot, ncol_tot, proc_grid ) RESULT( reslt )
+ INTEGER, INTENT( IN ) :: row, col, nrow_tot, ncol_tot
+ INTEGER, DIMENSION( : ), INTENT( IN ) :: proc_grid
+ INTEGER, DIMENSION( : ), ALLOCATABLE :: reslt
+ END FUNCTION dist_map_blk_to_proc_func
+ END INTERFACE
+ TYPE, PUBLIC :: dist_type
+ INTEGER, DIMENSION( : ), ALLOCATABLE :: task_coords
+ PROCEDURE( dist_map_blk_to_proc_func ), NOPASS, POINTER :: map_blk_to_proc => NULL( )
+ END TYPE dist_type
+END MODULE distribution_types
+
+MODULE sparse_matrix_types
+ USE distribution_types, ONLY : dist_type
+ TYPE, PUBLIC :: sm_type
+ TYPE( dist_type ) :: dist
+ END TYPE sm_type
+END MODULE sparse_matrix_types
+
+PROGRAM comp_proc_ptr_test
+ USE sparse_matrix_types, ONLY : sm_type
+
+ call sm_multiply_a ()
+CONTAINS
+ SUBROUTINE sm_multiply_a ( )
+ INTEGER :: n_push_tot, istat
+ TYPE( sm_type ), DIMENSION( : ), ALLOCATABLE :: matrices_a, matrices_b
+ n_push_tot =2
+ ALLOCATE( matrices_a( n_push_tot + 1 ), matrices_b( n_push_tot + 1), STAT=istat )
+ if (istat /= 0) call abort()
+ if (.not. allocated(matrices_a)) call abort()
+ if (.not. allocated(matrices_b)) call abort()
+ if (associated(matrices_a(1)%dist%map_blk_to_proc)) call abort()
+ END SUBROUTINE sm_multiply_a
+END PROGRAM comp_proc_ptr_test
+
^ permalink raw reply [flat|nested] 5+ messages in thread