From 39da58667d94ab210cb6918fb8f528aa6aabfbb2 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Fri, 9 Dec 2016 13:32:50 +0100 Subject: [PATCH] trans-array.c (gfc_array_deallocate): Remove wrapper. gcc/fortran/ChangeLog: 2016-12-09 Andre Vehreschild * 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 * 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/ChangeLog | 24 ++ gcc/fortran/trans-array.c | 322 ++++++------------ gcc/fortran/trans-array.h | 5 - gcc/fortran/trans-expr.c | 8 +- gcc/fortran/trans-openmp.c | 29 +- gcc/fortran/trans-stmt.c | 5 +- gcc/fortran/trans.c | 98 ++++-- gcc/fortran/trans.h | 3 +- gcc/testsuite/ChangeLog | 8 + .../gfortran.dg/coarray_alloc_comp_3.f08 | 51 +++ .../gfortran.dg/coarray_alloc_comp_4.f08 | 44 +++ gcc/testsuite/gfortran.dg/finalize_18.f90 | 4 +- .../gfortran.dg/proc_ptr_comp_47.f90 | 40 +++ 13 files changed, 366 insertions(+), 275 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 create mode 100644 gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08 create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b27c1e36787..fe68bf45cfb 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2016-12-09 Andre Vehreschild + + * 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. + 2016-12-09 Paul Thomas PR fortran/44265 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ac90a4ba188..8753cbf4660 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 0a6621b0a63..ab0a6dee972 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 . */ -/* 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 8cb0f1c7129..cbfad0babd9 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5451,8 +5451,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 d460048d20d..6bc2dcdbaeb 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 514db287478..5ca716bebeb 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 6a1d4819ca6..e5dd98695fe 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 ae1f15651ef..bfc2a24d0fa 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/ChangeLog b/gcc/testsuite/ChangeLog index 2f15e89d456..33e5b378800 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2016-12-09 Andre Vehreschild + + * 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. + 2016-12-09 Nathan Sidwell PR c++/78550 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 00000000000..8d2e7939b6e --- /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 00000000000..517bb188733 --- /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 c8b4afcff50..3e643327628 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 00000000000..1d5210019ff --- /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 + -- 2.30.2