From patchwork Fri Dec 9 12:33:07 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 704443 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3tZs8z2h17z9vF6 for ; Fri, 9 Dec 2016 23:33:39 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="fF9+o6qG"; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; q=dns; s=default; b=vXAKN1ut2KS6FTCZ DcgrgMg8jRpxIlyxs4vf3K4dznXNNWPkqydD4K7WyCOapVvuW6F2P2/DOWw1EKQe KoE/xGou0jUmw+tCBY8392cx6xZH0vS+wMBPj77svr5hPzWBKGljYid6vpC31GX2 k6yvnCrCuvi2imHt9I+ZvCPFnbc= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; s=default; bh=fBYr5dUYo7hyFibf3CQQYC wGq7k=; b=fF9+o6qGAMxoyS5xsU6gh7mSnjHTy3v9edYUNYv8u0HNcX5/eVppuF /G9Ww3dVpeF9duGckm699FaQKhSN728z/D7kfD9GRBk5ErVSYPHhG7hKjukaIPyZ 34/i5WKjswgW/qKrLXNGdSTw7CbYCyA31rgQsag8nTVcmYYfjj3Tg= Received: (qmail 483 invoked by alias); 9 Dec 2016 12:33:24 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 457 invoked by uid 89); 9 Dec 2016 12:33:23 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.1 required=5.0 tests=AWL, BAYES_05, FREEMAIL_FROM, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_LOW, RCVD_IN_SORBS_SPAM, SPF_PASS autolearn=no version=3.3.2 spammy=nicht, vehregccgnuorg, vehre@gcc.gnu.org, row 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; Fri, 09 Dec 2016 12:33:13 +0000 Received: from vepi2 ([92.76.205.227]) by mail.gmx.com (mrgmx102 [212.227.17.168]) with ESMTPSA (Nemesis) id 0LpPg1-1cuAxV3piv-00f6sa; Fri, 09 Dec 2016 13:33:09 +0100 Date: Fri, 9 Dec 2016 13:33:07 +0100 From: Andre Vehreschild To: Jerry DeLisle Cc: fortran@gcc.gnu.org, GCC-Patches-ML Subject: Re: Ping [PATCH, Fortran, v1] Fix deallocation of nested derived typed components Message-ID: <20161209133307.3f302b58@vepi2> In-Reply-To: <3374a802-109d-b316-4da2-b535d619c6e5@charter.net> References: <20161202132840.1ca6be4b@vepi2> <20161208144217.413c39d6@vepi2> <3374a802-109d-b316-4da2-b535d619c6e5@charter.net> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:rRLwDgVZcdM=:kTGw/9yeQZgxXapzr0LY9W e4Um17fdY7owtIiaTZL5UFlgn6N65sOdR8R/i1F9tNGgcGJ7F0xPRztGWjJUAMUFfgKWdMaEQ sLvsM3qnjKYOLhsVSruZpG+ecAU7ZLNyaJp+2GsDW78ylFeUbOimMaOWmdUTkcGPL3DpVYjcI C5bwmL1lrYA5A5pLkyRjZppF9xZD1Oc2ZiHHXxaQD/k1cej4kC/P8xJzF0htU0xFSl+vc6uid DYoSbIHaqh95tjGVc/U1+tGEFxamZevv1r8PqP1+ENbQTJ6Hga9XUlvgXUahk4UlOdfgbzrgW 6yT/pSCMvceH3oHjL8IXkHSF0ivSYV5FFCGcgSXXPqH0ls/yTUIe0+ecAVn+OJpMESCbYJWLg Z7C0vvQOjhZWSsJZM4aPyD8017mh7xlxLZ7LuxXt6B4qMnSnysXqoLr8l6tIf15T5jBPNe7Yk yO2WwW1YRvi9AwxCz1qtp5msrGsXwSas9LTSGApHPRUzYfrlEGFTz4+hxxjKO7bhOzjBHDgRc igeyu+1bHB3ganroFJxFI1OGQiOUGCE9nl5cqvVnhcgNzXgP4XmmPriKnOPbU9ddBumIniL0A uUkjCUndDqagE0C7FnvgbP0L7+jHqsF2pZP+fRVa8GKwtd9Jdf/F/2o8JQ2c5Q6Jlnq7lqrqg j3f0lumFovPCBRFjaqkrUNmqjj/bJpgb4LdF+OUaCApqLlv7QccKli9JDhdHV8NxF2p3Fq+XN qab04PNhtmvCHJwXDsz8irS5uJ166cT7hcyo+nhzZU0UMgMrzjF2K0aHWU4= Hi Jerry, thanks for the review. Committed as r243480. Regards, Andre On Thu, 8 Dec 2016 12:10:55 -0800 Jerry DeLisle wrote: > On 12/08/2016 05:42 AM, Andre Vehreschild wrote: > > Ping! > > > > On Fri, 2 Dec 2016 13:28:40 +0100 > > Andre Vehreschild wrote: > > > >> Hi all, > >> > >> attached patch fixes on ICE, when freeing a scalar allocatable component > >> in a derived typed coarray. > >> > >> Furthermore does it fix freeing of nested derived typed allocatable > >> components. A simple code explains the bug that is solved by the patch: > >> > >> type inner > >> integer, allocatable :: i > >> end type > >> type outer > >> type(inner), allocatable :: link > >> end type > >> > >> type(outer), allocatable :: obj > >> > >> allocate(obj) > >> allocate(obj%link) > >> allocate(obj%link%i) > >> > >> deallocate(obj%link) > >> deallocate(obj) ! <- this will generate pseudo-pseudo-code of the kind: > >> > >> if (obj.link.i != 0) // But link is already NULL, i.e. a crash occurs. > >> free(obj.link.i) > >> > >> The patch fixes this by moving the code for freeing link.i into the check > >> if link is allocated, i.e.: > >> > >> if (obj.link != 0) { > >> if (obj.link.i != 0) { > >> free (obj.link.i); > >> obj.link.i = 0; > >> } > >> free (obj.link); > >> obj.link = 0; > >> } > >> > >> Furthermore does the patch ensure that the handle of an allocatable > >> component is set to 0. > >> > >> Bootstraped and regtested ok on x86_64-linux/F23. Ok for trunk? > >> > >> Regards, > >> Andre > > > > > > I think OK. > > Jerry Index: gcc/fortran/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 243479) +++ gcc/fortran/ChangeLog (Arbeitskopie) @@ -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 Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (Revision 243479) +++ gcc/fortran/trans-array.c (Arbeitskopie) @@ -5652,53 +5652,6 @@ } -/* 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 @@ } -/* 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 @@ 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 @@ 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 @@ { 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)) + || (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); + + add_when_allocated = NULL_TREE; + if (cmp_has_alloc_comps + && !c->attr.pointer && !c->attr.proc_pointer + && !same_type + && !deallocate_called) { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - /* 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 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_with_status (comp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + NULL, caf_dereg_mode, + add_when_allocated, caf_token); - 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 = 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 @@ 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 @@ 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,42 +8366,13 @@ 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. @@ -8480,7 +8379,7 @@ 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 @@ } } - 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_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); Index: gcc/fortran/trans-array.h =================================================================== --- gcc/fortran/trans-array.h (Revision 243479) +++ gcc/fortran/trans-array.h (Arbeitskopie) @@ -18,9 +18,6 @@ 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_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); Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 243479) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -5451,8 +5451,12 @@ { 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) Index: gcc/fortran/trans-openmp.c =================================================================== --- gcc/fortran/trans-openmp.c (Revision 243479) +++ gcc/fortran/trans-openmp.c (Arbeitskopie) @@ -420,8 +420,11 @@ 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_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 @@ } 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); Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 243479) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -6489,8 +6489,9 @@ : 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 Index: gcc/fortran/trans.c =================================================================== --- gcc/fortran/trans.c (Revision 243479) +++ gcc/fortran/trans.c (Arbeitskopie) @@ -1281,31 +1281,58 @@ 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 @@ /* 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 @@ 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 @@ } else { - tree caf_type, token, cond2; - tree pstat = null_pointer_node; + tree cond2, pstat = null_pointer_node; if (errmsg == NULL_TREE) { @@ -1394,8 +1424,6 @@ 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); @@ -1402,19 +1430,6 @@ 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 @@ 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 @@ 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 @@ 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_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); Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (Revision 243479) +++ gcc/fortran/trans.h (Arbeitskopie) @@ -719,7 +719,8 @@ /* 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); Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 243479) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -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 Index: gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 =================================================================== --- gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 (nicht existent) +++ gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 (Arbeitskopie) @@ -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 Index: gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08 =================================================================== --- gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08 (nicht existent) +++ gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08 (Arbeitskopie) @@ -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" } } Index: gcc/testsuite/gfortran.dg/finalize_18.f90 =================================================================== --- gcc/testsuite/gfortran.dg/finalize_18.f90 (Revision 243479) +++ gcc/testsuite/gfortran.dg/finalize_18.f90 (Arbeitskopie) @@ -33,8 +33,8 @@ ! { 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" } } Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90 =================================================================== --- gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90 (nicht existent) +++ gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90 (Arbeitskopie) @@ -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 +