From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 24144 invoked by alias); 3 Dec 2016 11:51:52 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 24106 invoked by uid 89); 3 Dec 2016 11:51:50 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.5 required=5.0 tests=AWL,BAYES_00,FREEMAIL_FROM,RCVD_IN_DNSWL_LOW,SPF_PASS autolearn=ham version=3.3.2 spammy=vehregccgnuorg, vehre@gcc.gnu.org, suppress, transarrayc X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sat, 03 Dec 2016 11:51:40 +0000 Received: from vepi2 ([92.76.205.227]) by mail.gmx.com (mrgmx102 [212.227.17.168]) with ESMTPSA (Nemesis) id 0Lxdfb-1cjkmE33CV-017HEd; Sat, 03 Dec 2016 12:51:34 +0100 Date: Sat, 03 Dec 2016 11:51:00 -0000 From: Andre Vehreschild To: Dominique =?UTF-8?B?ZCdIdW1pw6hyZXM=?= Cc: Fortran List , GCC-Patches-ML Subject: Re: [PATCH, Fortran, v2] Fix deallocation of nested derived typed components Message-ID: <20161203125132.3a0e6995@vepi2> In-Reply-To: <5B28CFDC-65D8-4FD1-8588-1100E1997FD9@lps.ens.fr> References: <5B28CFDC-65D8-4FD1-8588-1100E1997FD9@lps.ens.fr> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/bvb4B32WR0sl7CaXbIlwSn7" X-UI-Out-Filterresults: notjunk:1;V01:K0:AA33Tmd87+Q=:NmI1J1BjgEFD1wTD1e7xr1 uInuLY0mSUcDTawFN6hq0I3/KieiuD0X0nUp3cUf1JgBzMV0FJcvm671WSru8Zja7m9pgEqfj NXUDrV67TLZdFDLqzWe7BeD+2UXe9XFfTcZF4xmeJEB5gGXMPNY8aWItOy8W6CLQLZqPtl/P8 rlNLgGs1pluq3DPzkA6HPs+P8/IZxCQtsE7IarH1O0fVNPDf6eMeD5Uf9oaXktO7VVhZYO/8U pqDfNjHn2SQRyY8GaKqzv42gPz51RjQVq2A3ZZwdgbQWRNi20LrpyzqSnhBLs7eo5bf5NtWXg 6IAg1NS+vWStDG8jo6eUjHSPqOaosbgcYNK3vnvbFnEe6YIFH5sbtmEd1IVfz2l7O1Fsggvr2 egIo61/ay8wq3Hhfb1mZWpRwAgfkZQ7bRKJM1sRhOBjtRFlK+VasBCkZ8AoqRoio4pH/eRbqk fLD2eFA9H5isuR/zwLR+wdVbpEHGizN8w5ArdhRv3DHPsp835R9dlkQv0gx4FTh6H66t1MPrl 8NRCQdZPu3cSj70payseHUaSjvutAtR+DO3PPcRcC9JFFMMgNgHBrSQw3bADjAHutHPuLSkI7 rZtXzI4QMp33UrZtRM0J16CD2EHRfIeOsZTXxMU99x6mKrMNFycisn4GCQ9X2i2FcKo8QEA0v lEFVylnbtNUyok9FVxLfaFsnRLHSvZB24iCZDBDA7tfmsW3SFPDZZKDPS2Eu6BXNG3LeeeLEf DwEeS7wV002oc75pHjGKFnSVx6J+fmi5RetMUyk5+a4SvtCaCLXZiizW8Xc= X-SW-Source: 2016-12/txt/msg00271.txt.bz2 --MP_/bvb4B32WR0sl7CaXbIlwSn7 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Content-Disposition: inline Content-length: 1101 Hi Dominique, thanks for immediately finding the issues. Please find an updated and exten= ded patch. This time trunk w/o this patch ICEs on compiling the _4-testcase and accesses freed memory for the _3-testcase. Furthermore are now components of derived-typed coarrays deregistered correctly instead of being freed as tru= nk did. I also have addressed the ICEs with proc_pointer components. Bootstraps and regtests ok on x86_64-linux/F23. Ok for trunk? Regards, Andre On Sat, 3 Dec 2016 02:17:30 +0100 Dominique d'Humi=C3=A8res wrote: > Dear Andre, >=20 > After having applied the patch to my working tree, compiling the tests in > pr61952 or pr64381 gives the ICE >=20 > END SUBROUTINE sm_multiply >=20=20 > internal compiler error: in gfc_get_element_type, at > fortran/trans-types.c:1185 >=20 > Also the name coarray_alloc_comp_3.f08 does not seem right as there is no > carry involved. Note that the test compiles and executes with at least a > clean trunk and 6.2.0. >=20 > Cheers, >=20 > Dominique >=20 --=20 Andre Vehreschild * Email: vehre ad gmx dot de=20 --MP_/bvb4B32WR0sl7CaXbIlwSn7 Content-Type: text/plain Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=dealloc_comps_fix_v2.clog Content-length: 1001 gcc/fortran/ChangeLog: 2016-12-03 Andre Vehreschild * trans-array.c (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. * 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-03 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. --MP_/bvb4B32WR0sl7CaXbIlwSn7 Content-Type: text/x-patch Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=dealloc_comps_fix_v2.patch Content-length: 24022 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ac90a4b..1d48c63 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -8157,8 +8157,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 +8268,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 +8278,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; - /* 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 the _class ref for classes. */ + if (c->ts.type == BT_CLASS && attr->allocatable) + comp = gfc_class_data_get (comp); + + 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 && /*!attr->proc_pointer && */!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 +8415,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 +8428,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 +8446,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 +8486,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; diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 6a1d481..9053c9e 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1281,30 +1281,55 @@ 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); } cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, @@ -1348,6 +1373,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 +1383,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 +1407,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 +1422,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, @@ -1431,6 +1444,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); ASM_VOLATILE_P (tmp) = 1; 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) { @@ -1516,11 +1531,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 +1594,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" } } --MP_/bvb4B32WR0sl7CaXbIlwSn7--