From patchwork Fri Dec 2 12:28:40 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 86290 Delivered-To: patch@linaro.org Received: by 10.140.20.101 with SMTP id 92csp230684qgi; Fri, 2 Dec 2016 04:29:15 -0800 (PST) X-Received: by 10.99.142.201 with SMTP id k192mr77192770pge.174.1480681754980; Fri, 02 Dec 2016 04:29:14 -0800 (PST) Return-Path: Received: from sourceware.org (server1.sourceware.org. [209.132.180.131]) by mx.google.com with ESMTPS id j130si4905884pgc.309.2016.12.02.04.29.14 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Fri, 02 Dec 2016 04:29:14 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-return-443315-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) client-ip=209.132.180.131; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org; spf=pass (google.com: domain of gcc-patches-return-443315-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) smtp.mailfrom=gcc-patches-return-443315-patch=linaro.org@gcc.gnu.org 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:subject:message-id:mime-version:content-type; q=dns; s= default; b=Cuh8NhX3cVibW4n8MxI3wQzkydjXayy2PnyU4HM0OO8NKfO1LUYxj 6hPWKcX3iRrJm30W+WVwo6zAFzsBxBKXeTs54FpwwCQGvEdaAHRmpjGTB/wThRKK kMU9JI94tW4KwnbULz4rVquEyx2tNjD2P3isuYNDGo6vPq/xwgmPo4= 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:subject:message-id:mime-version:content-type; s= default; bh=OdOVQD+gzJ8rq5Sp9SXmTqDg/qQ=; b=xSi/s+3LqxhJxZ7STO07 XPGufF12kTvlRaP8QjwXgzsa212xb8+6YRo0Ye55u5KEyNWt9b3eK02FSA0QvqwU QWuvzV12DFSpuRbpX6JKhr55Gnk8QAf6Sg2Zx5rSVVSqep0NlOxSR8OHWbO3SVNw mZlAqbwNs4zh1Y06FAJYdjc= Received: (qmail 11669 invoked by alias); 2 Dec 2016 12:28:56 -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 11644 invoked by uid 89); 2 Dec 2016 12:28:55 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.0 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, RCVD_IN_SORBS_SPAM, SPF_PASS autolearn=ham version=3.3.2 spammy=trusted, UD:f08, transh, UD:trans.h X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.15.19) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 02 Dec 2016 12:28:45 +0000 Received: from vepi2 ([92.76.205.227]) by mail.gmx.com (mrgmx003 [212.227.17.190]) with ESMTPSA (Nemesis) id 0M08eS-1cXkcH0AJA-00uKo8; Fri, 02 Dec 2016 13:28:41 +0100 Date: Fri, 2 Dec 2016 13:28:40 +0100 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Subject: [PATCH, Fortran, v1] Fix deallocation of nested derived typed components Message-ID: <20161202132840.1ca6be4b@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:QlcYbdrdtqQ=:SPdwpY/T9t+lob+yobEMb/ XVKdmhC0zEymx6dN0852YvEo5z5X17lvNedAfuK9P+wzb58yZtQGxR/svHXOntxxJ/+n7KSWt 18BhmGjiJObxyXXwijW6RqGrLq8rg8NHGSOgBX6Mal/P/nTPF0fKLPm74MFKzXEis3MWlEVvt JLYDSxHkAYqMu9sfbd1TeMVt9tSagGa4QdU14XteWGYN21p48OlVpH9iFe4y5HwD+0SPY62jG VfVjY7jZBZhBC9mxX5IpXQroxiEXxajLRxxVM8BGoZZAjjLnZY2AJ+SRXjlnCEX+nRmZOQO28 MwUfvVXY7h+nvIbZxgGClyUURdrfM/1djdJojBAKoZVx3HrwBdSt0vqnUQR/y16QijKoJb1ie pe+podSeDuCcbYlrDJDXTfTxLXPgxzZ2f5x/WVvheEoyq4zvxLZC7KcnivnPnSt7A+aCLHSWx RJ+FNtS4iU5+kxfrfrLuFBKZ8pBmVMTpLq/jUqPcy+XWhIucibnMPoMJjSi/dgMyKx6OAbQ4s TKZleFV89QVD2ydNGtIdupuYUdCJbhxtPTB3U5XjFJzGQXzwo18GTmiUihuYOuQYTt2Lx9V2m AuyLt/fsxiGpBU7YbfXLnZEqBGL73d+oVWZtgHCJeT1kNfYYPb9u/4HNuHFXiunmzAk7cOUHi 7uunVdyUcj+XeuVpGPvSd4mlkflZws9M3GbPu1kJCyVlAVWFoBt5v4LJ2fvTb2z4j5jFPjkXv xeinJ+uAMLDBTuvYcQmh1zzkUhP45aUb+439oiy0zGb3+Lcd1s5+sjm/Apo= 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 -- Andre Vehreschild * Email: vehre ad gmx dot de gcc/fortran/ChangeLog: 2016-12-02 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. * 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-02 Andre Vehreschild * gfortran.dg/coarray_alloc_comp_3.f08: New test. * gfortran.dg/finalize_18.f90: Add count for additional guard against accessing null-pointer. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ac90a4b..a5deb42 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,120 @@ 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); - 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); + 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)); - } + /* Shortcut to get the attributes of the component. */ + if (c->ts.type == BT_CLASS) + attr = &CLASS_DATA (c)->attr; else - comp = NULL_TREE; + attr = &c->attr; - 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)))) - { - /* Allocatable arrays or coarray'ed components (scalar or - array). */ - int caf_dereg_mode - = (caf_in_coarray (caf_mode) || c->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->ts.type == BT_DERIVED && !c->attr.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; - if (c->attr.dimension || c->attr.codimension) - /* Deallocate array. */ - tmp = gfc_trans_dealloc_allocated (comp, NULL, caf_dereg_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 { - /* 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)); + rank = c->as ? c->as->rank : 0; + add_when_allocated = structure_alloc_comps (c->ts.u.derived, + comp, NULL_TREE, + rank, purpose, + caf_mode); } - - gfc_add_expr_to_block (&tmpblock, tmp); } - else if (c->attr.allocatable && !c->attr.codimension && !same_type) + + if (attr->allocatable && !attr->proc_pointer && !same_type + && (!c->attr.codimension + || (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) != 0)) { - /* Allocatable scalar components. */ - if (comp == NULL_TREE) - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); + /* 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_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0 + || attr->codimension) + ? ((caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) != 0 + ? GFC_CAF_COARRAY_DEALLOCATE_ONLY + : GFC_CAF_COARRAY_DEREGISTER) + : GFC_CAF_COARRAY_NOCOARRAY; - 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; + caf_token = NULL_TREE; + /* Coarray components are handled directly by + deallocate_with_status. */ + if (!attr->codimension + && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY) + { + 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) + caf_token = gfc_conv_descriptor_token (comp); + } + if (attr->dimension && !attr->codimension) + /* 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); + + 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 { @@ -8406,11 +8418,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_index_zero_node, ubound); if (c->attr.dimension) - data = gfc_conv_descriptor_data_get (comp); - else - data = comp; + 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 +8430,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 +8448,21 @@ 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_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) == 0)) { - /* 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 +8489,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..a16bf92 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,7 +1531,7 @@ 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) + 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); @@ -1573,7 +1588,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..4e9effd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! 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/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" } }