From patchwork Mon Nov 28 18:33:30 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 700102 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 3tSFh463Wrz9tlW for ; Tue, 29 Nov 2016 05:34:12 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="BQt6AzTx"; 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:subject:message-id:in-reply-to:references:mime-version :content-type; q=dns; s=default; b=LMG32Qrcz8fTiQertrnXBfY6PQO8F Zye1NPg7QkBs0rq12DlzRFDZADwc2mxsVKx9NZNhx5veyyWq2jD/lzKZ4a4SWw27 wUq/SMw6I5A0KOHQKx7YJ5uMd4UkuuerxBdv5j0e6GGpoANXpTX61/ZMRuEr/+FV ihNciiavcA3Lb0= 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:in-reply-to:references:mime-version :content-type; s=default; bh=1CPTJrLvR7/02bbIsvcWASJRcH8=; b=BQt 6AzTxUXLglghR1W0znNXLHIbEdPGx9T3lUvH2sOagSxcxq7ggUdMGtoVjUNJ9s5F TFzNwR0oyBSmICZs18H780XGe3c850Asdagt5GjfgtecAx2192jNIKzEhKFwvuQZ pHE/lMTqFM6aH6lg1La5eY7M0ONx2dVNKFsj/Hks= Received: (qmail 11723 invoked by alias); 28 Nov 2016 18:33:49 -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 11691 invoked by uid 89); 28 Nov 2016 18:33:48 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=0.0 required=5.0 tests=AWL, BAYES_50, FREEMAIL_FROM, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 spammy=cm, parm, adhere, sk:gfc_res 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; Mon, 28 Nov 2016 18:33:37 +0000 Received: from vepi2 ([92.76.205.227]) by mail.gmx.com (mrgmx101 [212.227.17.168]) with ESMTPSA (Nemesis) id 0MAloF-1c1DSS3O7n-00BtHW; Mon, 28 Nov 2016 19:33:33 +0100 Date: Mon, 28 Nov 2016 19:33:30 +0100 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Subject: Re: PING! [PATCH, Fortran, accaf, v1] Add caf-API-calls to asynchronously handle allocatable components in derived type coarrays. Message-ID: <20161128193330.55c0802a@vepi2> In-Reply-To: <20161122204650.03893214@vepi2> References: <20161122204650.03893214@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:eq1sBTutIUs=:/DlMqNhFeY0FJAf2E6gvL2 YiVld+LWfLsYILKP4/4CWv77/y/6hgl11bj38/kAhB1ZqCvvymO/YuxZh1l7eppVexezfmkE5 cL4nw73mtFR/5ZIzAG+dduQ++wiY3DDxco4eQ3c+6OCVBCG8S0fs1CQ8SsyG3uDI6WvbXgyyq TIXd92UaiseCK2KnvCc7UegbMBr8jujQxSwsSudgvkzV8JMLYLaY9KPCxIB+MOEcCoM0oQ7yu qqqrkj55R7eAPunJ1Ucf1UoB1v2/od9W51eJSJaQwEEF+AS17uUygsMdYJxfW8zc1LBAK6u87 vteMlfF8t9PUcGm9SJP1GWqMHilbWX/Bt6Qw0XA0Y4iW05ZFZ8sQP7sjm7hw1a3bAqVsxcRUi vZbVnTncs+e2DHslsvPqIeTxHhh6iaSNlio8WyOCbF2e9DOxQb/2mU43znr443BDl3q3KqG2l KPnMwqnTzQq3YHj5V9KmiFQrNYvOZo38fWjVAHaqN+y1CMLpJC96nwl90YZOSfr+tyE27TB/B PbyerrX+ySQJ/6Mpak6pvwC8Wtwyx5tqljjVW4XShow0hQBOq0v1Cqmp8BXje3Vi4wYsNDwfn YNgmIKieRw6nS5Cqr6EDcB0KfjZOuaRd/Hlm7z5H2wJSp3Zxa66wc6MOKpx9xkFT1nc8eKV01 SER/mS/OLS3Sz+PA+x7YQwIGUWHEU2hvmaSFtOTrI8BoGOHsYDwVAewpIqE4TYpcOk6vjxp3y XI5SrhmDwsoLUHHgg7DulngQWCN4RQpwzd6cy0j7Tqqb17KcQZ+ilkys5EU= PING! I know it's a lengthy patch, but comments would be nice anyway. - Andre On Tue, 22 Nov 2016 20:46:50 +0100 Andre Vehreschild wrote: > Hi all, > > attached patch addresses the need of extending the API of the caf-libs to > enable allocatable components asynchronous allocation. Allocatable components > in derived type coarrays are different from regular coarrays or coarrayed > components. The latter have to be allocated on all images or on none. > Furthermore is the allocation a point of synchronisation. > > For allocatable components the F2008 allows to have some allocated on some > images and on others not. Furthermore is the registration with the caf-lib, > that an allocatable component is present in a derived type coarray no longer a > synchronisation point. To implement these features two new types of coarray > registration have been introduced. The first one just registering the > component with the caf-lib and the latter doing the allocate. Furthermore has > the caf-API been extended to provide a query function to learn about the > allocation status of a component on a remote image. > > Sorry, that the patch is rather lengthy. Most of this is due to the > structure_alloc_comps' signature change. The routine and its wrappers are used > rather often which needed the appropriate changes. > > I know I left two or three TODOs in the patch to remind me of things I have to > investigate further. For the current state these TODOs are no reason to hold > back the patch. The third party library opencoarrays implements the mpi-part > of the caf-model and will change in sync. It would of course be advantageous > to just have to say: With gcc-7 gfortran implements allocatable components in > derived coarrays nearly completely. > > I know we are in stage 3. But the patch bootstraps and regtests ok on > x86_64-linux/F23. So, is it ok for trunk or shall it go to 7.2? > > Regards, > Andre diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 265fe22..3b80156 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -851,6 +851,17 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) bool gfc_check_allocated (gfc_expr *array) { + /* Tests on allocated components of coarrays need to detour the check to + argument of the _caf_get. */ + if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION + && array->value.function.isym + && array->value.function.isym->id == GFC_ISYM_CAF_GET) + { + array = array->value.function.actual->expr; + if (!array->ref) + return false; + } + if (!variable_check (array, 0, false)) return false; if (!allocatable_check (array, 0)) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 7956630..370b2a0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3274,7 +3274,7 @@ const char *gfc_dt_upper_string (const char *); /* primary.c */ symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *); symbol_attribute gfc_expr_attr (gfc_expr *); -symbol_attribute gfc_caf_attr (gfc_expr *, bool in_allocate = false); +symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL); match gfc_match_rvalue (gfc_expr **); match gfc_match_varspec (gfc_expr*, int, bool, bool); int gfc_check_digit (char, int); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 6d8805c..5e2a750 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -3871,6 +3871,7 @@ of such a type @menu * caf_token_t:: * caf_register_t:: +* caf_deregister_t:: * caf_reference_t:: @end menu @@ -3893,11 +3894,39 @@ typedef enum caf_register_t { CAF_REGTYPE_LOCK_ALLOC, CAF_REGTYPE_CRITICAL, CAF_REGTYPE_EVENT_STATIC, - CAF_REGTYPE_EVENT_ALLOC + CAF_REGTYPE_EVENT_ALLOC, + CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY, + CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY } caf_register_t; @end verbatim +The values @code{CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY} and +@code{CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY} are for allocatable components +in derived type coarrays only. The first one sets up the token without +allocating memory for allocatable component. The latter one only allocates the +memory for an allocatable component in a derived type coarray. The token +needs to be setup previously by the REGISTER_ONLY. This allows to have +allocatable components un-allocated on some images. The status whether an +allocatable component is allocated on a remote image can be queried by +@code{_caf_is_present} which used internally by the @code{ALLOCATED} +intrinsic. + +@node caf_deregister_t +@subsection @code{caf_deregister_t} + +@verbatim +typedef enum caf_deregister_t { + CAF_DEREGTYPE_COARRAY_DEREGISTER, + CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY +} +caf_deregister_t; +@end verbatim + +Allows to specifiy the type of deregistration of a coarray object. The +@code{CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY} flag is only allowed for +allocatable components in derived type coarrays. + @node caf_reference_t @subsection @code{caf_reference_t} @@ -4017,6 +4046,7 @@ descriptor-less arrays. The library caf_single has untested support for it. * _gfortran_caf_num_images:: Querying the maximal number of images * _gfortran_caf_register:: Registering coarrays * _gfortran_caf_deregister:: Deregistering coarrays +* _gfortran_caf_is_present:: Query whether an allocatable component in a derived type coarray is allocated * _gfortran_caf_send:: Sending data from a local image to a remote image * _gfortran_caf_get:: Getting data from a remote image * _gfortran_caf_sendget:: Sending data between remote images @@ -4218,6 +4248,7 @@ section) such as the value false; for event types, the initial state should be no event, e.g. zero. @end table + @node _gfortran_caf_deregister @subsection @code{_gfortran_caf_deregister} --- Deregistering coarrays @cindex Coarray, _gfortran_caf_deregister @@ -4231,12 +4262,16 @@ library is only expected to free memory it allocated itself during a call to @code{_gfortran_caf_register}. @item @emph{Syntax}: -@code{void caf_deregister (caf_token_t *token, int *stat, char *errmsg, -int errmsg_len)} +@code{void caf_deregister (caf_token_t *token, caf_deregister_t type, +int *stat, char *errmsg, int errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{token} @tab the token to free. +@item @var{type} @tab the type of action to take for the coarray. A +@code{CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY} is allowed only for allocatable +components of derived type coarrays. The action only deallocates the local +memory without deleting the token. @item @var{stat} @tab intent(out) Stores the STAT=; may be NULL @item @var{errmsg} @tab intent(out) When an error occurs, this will be set to an error message; may be NULL @@ -4250,6 +4285,31 @@ and via destructors. @end table +@node _gfortran_caf_is_present +@subsection @code{_gfortran_caf_is_present} --- Query whether an allocatable component in a derived type coarray is allocated +@cindex Coarray, _gfortran_caf_is_present + +@table @asis +@item @emph{Description}: +Used to query the coarray library whether an allocatable component in a derived +type coarray is allocated on a remote image. + +@item @emph{Syntax}: +@code{void _gfortran_caf_is_present (caf_token_t token, int image_index, +gfc_reference_t *ref)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{token} @tab An opaque pointer identifying the coarray. +@item @var{image_index} @tab The ID of the remote image; must be a positive +number. +@item @var{ref} @tab A chain of references to address the allocatable component +in the derived type coarray. The object reffed needs to be a scalar or a full +array ref, respectively. +@end multitable + +@end table + @node _gfortran_caf_send @subsection @code{_gfortran_caf_send} --- Sending data from a local image to a remote image @cindex Coarray, _gfortran_caf_send diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 50d7072..c287e44 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2418,10 +2418,15 @@ gfc_expr_attr (gfc_expr *e) attribute is. This routine is similar to gfc_variable_attr with parts of gfc_expr_attr, but focuses more on the needs of coarrays. For coarrays a codimension attribute is kind of - "infectious" being propagated once set and never cleared. */ + "infectious" being propagated once set and never cleared. + The coarray_comp is only set, when the expression refs a coarray + component. REFS_COMP is set when present to true only, when this EXPR + refs a (non-_data) component. To check whether EXPR refs an allocatable + component in a derived type coarray *refs_comp needs to be set and + coarray_comp has to false. */ static symbol_attribute -caf_variable_attr (gfc_expr *expr, bool in_allocate) +caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp) { int dimension, codimension, pointer, allocatable, target, coarray_comp, alloc_comp; @@ -2436,13 +2441,15 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate) sym = expr->symtree->n.sym; gfc_clear_attr (&attr); + if (refs_comp) + *refs_comp = 0; + if (sym->ts.type == BT_CLASS && sym->attr.class_ok) { dimension = CLASS_DATA (sym)->attr.dimension; codimension = CLASS_DATA (sym)->attr.codimension; pointer = CLASS_DATA (sym)->attr.class_pointer; allocatable = CLASS_DATA (sym)->attr.allocatable; - coarray_comp = CLASS_DATA (sym)->attr.coarray_comp; alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp; } else @@ -2451,12 +2458,11 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate) codimension = sym->attr.codimension; pointer = sym->attr.pointer; allocatable = sym->attr.allocatable; - coarray_comp = sym->attr.coarray_comp; alloc_comp = sym->ts.type == BT_DERIVED ? sym->ts.u.derived->attr.alloc_comp : 0; } - target = attr.target; + target = coarray_comp = 0; if (pointer || attr.proc_pointer) target = 1; @@ -2494,19 +2500,26 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate) if (comp->ts.type == BT_CLASS) { + /* Set coarray_comp only, when this component introduces the + coarray. */ + coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension; codimension |= CLASS_DATA (comp)->attr.codimension; pointer = CLASS_DATA (comp)->attr.class_pointer; allocatable = CLASS_DATA (comp)->attr.allocatable; - coarray_comp |= CLASS_DATA (comp)->attr.coarray_comp; } else { + /* Set coarray_comp only, when this component introduces the + coarray. */ + coarray_comp = !codimension && comp->attr.codimension; codimension |= comp->attr.codimension; pointer = comp->attr.pointer; allocatable = comp->attr.allocatable; - coarray_comp |= comp->attr.coarray_comp; } + if (refs_comp && strcmp (comp->name, "_data") != 0) + *refs_comp = 1; + if (pointer || attr.proc_pointer) target = 1; @@ -2531,14 +2544,14 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate) symbol_attribute -gfc_caf_attr (gfc_expr *e, bool in_allocate) +gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp) { symbol_attribute attr; switch (e->expr_type) { case EXPR_VARIABLE: - attr = caf_variable_attr (e, in_allocate); + attr = caf_variable_attr (e, in_allocate, refs_comp); break; case EXPR_FUNCTION: @@ -2557,7 +2570,7 @@ gfc_caf_attr (gfc_expr *e, bool in_allocate) } } else if (e->symtree) - attr = caf_variable_attr (e, in_allocate); + attr = caf_variable_attr (e, in_allocate, refs_comp); else gfc_clear_attr (&attr); break; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 1708f7c..45e1369 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5633,12 +5633,13 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen, - tree label_finish, gfc_expr* expr) + tree label_finish, gfc_expr* expr, + int coarray_dealloc_mode) { tree var; tree tmp; stmtblock_t block; - bool coarray = gfc_caf_attr (expr).codimension; + bool coarray = coarray_dealloc_mode != GFC_CAF_COARRAY_NOCOARRAY; gfc_start_block (&block); @@ -5648,7 +5649,8 @@ gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen, /* Parameter is the address of the data component. */ tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg, - errlen, label_finish, false, expr, coarray); + 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 @@ -7782,11 +7784,13 @@ 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, bool coarray, gfc_expr *expr) +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); @@ -7797,8 +7801,8 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr) 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); + NULL_TREE, NULL_TREE, NULL_TREE, true, expr, + coarray_dealloc_mode); gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ @@ -7967,17 +7967,119 @@ gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank) } +static tree +duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, + tree type, int rank) +{ + tree tmp; + tree size; + tree nelems; + tree null_cond; + tree null_data; + stmtblock_t block, globalblock; + + /* If the source is null, set the destination to null. Then, + allocate memory to the destination. */ + gfc_init_block (&block); + gfc_init_block (&globalblock); + + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) + { + gfc_se se; + symbol_attribute attr; + tree dummy_desc; + + gfc_init_se (&se, NULL); + dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr); + gfc_add_block_to_block (&globalblock, &se.pre); + size = TYPE_SIZE_UNIT (TREE_TYPE (type)); + + gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node)); + gfc_allocate_using_caf_lib (&block, dummy_desc, size, + gfc_build_addr_expr (NULL_TREE, dest_tok), + NULL_TREE, NULL_TREE, NULL_TREE, + GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); + null_data = gfc_finish_block (&block); + + gfc_init_block (&block); + + gfc_allocate_using_caf_lib (&block, dummy_desc, + fold_convert (size_type_node, size), + gfc_build_addr_expr (NULL_TREE, dest_tok), + NULL_TREE, NULL_TREE, NULL_TREE, + GFC_CAF_COARRAY_ALLOC); + + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); + tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, + fold_convert (size_type_node, size)); + gfc_add_expr_to_block (&block, tmp); + } + else + { + /* Set the rank or unitialized memory access may be reported. */ + tmp = gfc_conv_descriptor_dtype (dest); + gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank)); + + if (rank) + nelems = gfc_full_array_size (&block, src, rank); + else + nelems = integer_one_node; + + tmp = fold_convert (size_type_node, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, nelems), tmp); + + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node, + size), + gfc_build_addr_expr (NULL_TREE, dest_tok), + NULL_TREE, NULL_TREE, NULL_TREE, + GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); + null_data = gfc_finish_block (&block); + + gfc_init_block (&block); + gfc_allocate_using_caf_lib (&block, dest, + fold_convert (size_type_node, size), + gfc_build_addr_expr (NULL_TREE, dest_tok), + NULL_TREE, NULL_TREE, NULL_TREE, + GFC_CAF_COARRAY_ALLOC); + + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); + tmp = build_call_expr_loc (input_location, tmp, 3, + gfc_conv_descriptor_data_get (dest), + gfc_conv_descriptor_data_get (src), + fold_convert (size_type_node, size)); + gfc_add_expr_to_block (&block, tmp); + } + + tmp = gfc_finish_block (&block); + + /* Null the destination if the source is null; otherwise do + the register and copy. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))) + null_cond = src; + else + null_cond = gfc_conv_descriptor_data_get (src); + + null_cond = convert (pvoid_type_node, null_cond); + null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + null_cond, null_pointer_node); + gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp, + null_data)); + return gfc_finish_block (&globalblock); +} + /* Recursively traverse an object of derived type, generating code to deallocate, nullify or copy allocatable components. This is the work horse function for the functions named in this enum. */ -enum {DEALLOCATE_ALLOC_COMP = 1, DEALLOCATE_ALLOC_COMP_NO_CAF, - NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, - COPY_ALLOC_COMP_CAF}; +enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, + COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP}; static tree structure_alloc_comps (gfc_symbol * der_type, tree decl, - tree dest, int rank, int purpose) + tree dest, int rank, int purpose, int caf_mode) { gfc_component *c; gfc_loopinfo loop; @@ -8011,10 +8113,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, /* Deref dest in sync with decl, but only when it is not NULL. */ if (dest) dest = build_fold_indirect_ref_loc (input_location, dest); - } - /* Just in case it gets dereferenced. */ - decl_type = TREE_TYPE (decl); + /* Update the decl_type because it got dereferenced. */ + decl_type = TREE_TYPE (decl); + } /* If this is an array of derived types with allocatable components build a loop and recursively call this function. */ @@ -8056,16 +8158,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, vref = gfc_build_array_ref (var, index, NULL); - if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) - { + if ((purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) + && (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) == 0) + { tmp = build_fold_indirect_ref_loc (input_location, gfc_conv_array_data (dest)); dref = gfc_build_array_ref (tmp, index, NULL); tmp = structure_alloc_comps (der_type, vref, dref, rank, - COPY_ALLOC_COMP); + COPY_ALLOC_COMP, 0); } else - tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose); + tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose, + caf_mode); gfc_add_expr_to_block (&loopbody, tmp); @@ -8111,7 +8215,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, switch (purpose) { case DEALLOCATE_ALLOC_COMP: - case DEALLOCATE_ALLOC_COMP_NO_CAF: /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp (i.e. this function) so generate all the calls and suppress the @@ -8128,21 +8231,59 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, /* The finalizer frees allocatable components. */ called_dealloc_with_status = gfc_add_comp_finalizer_call (&tmpblock, comp, c, - purpose == DEALLOCATE_ALLOC_COMP); + purpose == DEALLOCATE_ALLOC_COMP + && (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) != 0); } else comp = NULL_TREE; - if (c->attr.allocatable && !c->attr.proc_pointer + if (c->attr.allocatable && !c->attr.proc_pointer && !same_type && (c->attr.dimension - || (c->attr.codimension - && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF)) - && !same_type) + || ((caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) != 0 + && ((caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0 + || c->attr.codimension)))) { + /* Allocatable arrays or coarray'ed components (scalar or + array). */ + int caf_dereg_mode + = ((caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0 + || c->attr.codimension) + ? ((caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) != 0 + ? 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); - tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL); + + if (c->attr.dimension || c->attr.codimension) + /* Deallocate array. */ + tmp = gfc_trans_dealloc_allocated (comp, NULL, caf_dereg_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)); + } + gfc_add_expr_to_block (&tmpblock, tmp); } else if (c->attr.allocatable && !c->attr.codimension && !same_type) @@ -8152,7 +8293,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); - tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, + 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; @@ -8168,8 +8310,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree is_allocated; tree ubound; tree cdesc; - tree zero = build_int_cst (gfc_array_index_type, 0); - tree unity = build_int_cst (gfc_array_index_type, 1); tree data; stmtblock_t dealloc_block; @@ -8191,8 +8331,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ubound = build_int_cst (gfc_array_index_type, 1); } - cdesc = gfc_get_array_type_bounds (tmp, 1, 0, - &unity, &ubound, 1, + cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, + &ubound, 1, GFC_ARRAY_ALLOCATABLE, false); cdesc = gfc_create_var (cdesc, "cdesc"); @@ -8201,11 +8341,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc), gfc_get_dtype_rank_type (1, tmp)); gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc, - zero, unity); + gfc_index_zero_node, + gfc_index_one_node); gfc_conv_descriptor_stride_set (&dealloc_block, cdesc, - zero, unity); + gfc_index_zero_node, + gfc_index_one_node); gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc, - zero, ubound); + gfc_index_zero_node, ubound); if (c->attr.dimension) data = gfc_conv_descriptor_data_get (comp); @@ -8247,7 +8389,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable && (!CLASS_DATA (c)->attr.codimension - || purpose != DEALLOCATE_ALLOC_COMP_NO_CAF)) + || (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) == 0)) { /* Allocatable CLASS components. */ @@ -8257,11 +8399,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, TREE_TYPE (tmp), comp, tmp, NULL_TREE); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) - tmp = gfc_trans_dealloc_allocated (comp, - CLASS_DATA (c)->attr.codimension, NULL); + 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, true, NULL, + 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; @@ -8317,7 +8463,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, decl, cdecl, NULL_TREE); rank = c->as ? c->as->rank : 0; tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - rank, purpose); + rank, purpose, caf_mode); gfc_add_expr_to_block (&fnblock, tmp); } @@ -8326,14 +8472,20 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, break; case NULLIFY_ALLOC_COMP: - if (c->attr.pointer || c->attr.proc_pointer) + if (c->attr.pointer || c->attr.proc_pointer + || !(c->attr.allocatable || (c->ts.type == BT_CLASS + && CLASS_DATA (c)->attr.allocatable) + || cmp_has_alloc_comps)) continue; - else if (c->attr.allocatable - && (c->attr.dimension|| c->attr.codimension)) + + /* Coarrays need the component to be initialized before the api-call + is made. */ + if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension)) { comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); + cmp_has_alloc_comps = false; } else if (c->attr.allocatable) { @@ -8354,6 +8506,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); } + cmp_has_alloc_comps = false; } else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { @@ -8371,46 +8524,98 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); } + cmp_has_alloc_comps = false; + } + + if (flag_coarray == GFC_FCOARRAY_LIB + && ((caf_mode & (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)) + == (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) + || c->attr.codimension)) + { + /* Register the component with the coarray library. */ + tree token; + + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + if (c->attr.dimension || c->attr.codimension) + { + tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + token = gfc_conv_descriptor_token (tmp); + } + else + { + gfc_se se; + symbol_attribute attr; + + gfc_init_se (&se, NULL); + gfc_clear_attr (&attr); + token = fold_build3_loc (input_location, COMPONENT_REF, + pvoid_type_node, decl, c->caf_token, + NULL_TREE); + comp = gfc_conv_scalar_to_descriptor (&se, comp, attr); + gfc_add_block_to_block (&fnblock, &se.pre); + } + + /* NULL the member-token before registering it or uninitialized + memory accesses may occur. */ + gfc_add_modify (&fnblock, token, fold_convert (TREE_TYPE (token), + null_pointer_node)); + gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node, + gfc_build_addr_expr (NULL_TREE, + token), + NULL_TREE, NULL_TREE, NULL_TREE, + GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); } - else if (cmp_has_alloc_comps) + + if (cmp_has_alloc_comps) { 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); + rank, purpose, caf_mode); gfc_add_expr_to_block (&fnblock, tmp); } break; - case COPY_ALLOC_COMP_CAF: - if (!c->attr.codimension - && (c->ts.type != BT_CLASS || CLASS_DATA (c)->attr.coarray_comp) - && (c->ts.type != BT_DERIVED - || !c->ts.u.derived->attr.coarray_comp)) - continue; - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, - cdecl, NULL_TREE); - dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest, - cdecl, NULL_TREE); - - if (c->attr.codimension) + case REASSIGN_CAF_COMP: + if ((caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) != 0 + && (c->attr.codimension + || (c->ts.type == BT_CLASS + && (CLASS_DATA (c)->attr.coarray_comp + || (caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) + != 0)) + || (c->ts.type == BT_DERIVED + && (c->ts.u.derived->attr.coarray_comp + || (caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) + != 0))) + && !same_type) { - if (c->ts.type == BT_CLASS) + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + dest, cdecl, NULL_TREE); + + if (c->attr.codimension) { - comp = gfc_class_data_get (comp); - dcmp = gfc_class_data_get (dcmp); - } - gfc_conv_descriptor_data_set (&fnblock, dcmp, + if (c->ts.type == BT_CLASS) + { + comp = gfc_class_data_get (comp); + dcmp = gfc_class_data_get (dcmp); + } + gfc_conv_descriptor_data_set (&fnblock, dcmp, gfc_conv_descriptor_data_get (comp)); - } - else - { - tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, - rank, purpose); - gfc_add_expr_to_block (&fnblock, tmp); - + } + else + { + tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, + rank, purpose, caf_mode + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY); + gfc_add_expr_to_block (&fnblock, tmp); + } } break; @@ -8503,7 +8708,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_modify (&fnblock, dcmp, tmp); add_when_allocated = structure_alloc_comps (c->ts.u.derived, comp, dcmp, - rank, purpose); + rank, purpose, + caf_mode); } else add_when_allocated = NULL_TREE; @@ -8530,11 +8736,24 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_expr_to_block (&fnblock, tmp); } else if (c->attr.allocatable && !c->attr.proc_pointer && !same_type - && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension)) + && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension + || (caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0)) { rank = c->as ? c->as->rank : 0; if (c->attr.codimension) tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank); + else if (flag_coarray == GFC_FCOARRAY_LIB + && (caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0) + { + tree dst_tok = c->as ? gfc_conv_descriptor_token (dcmp) + : fold_build3_loc (input_location, + COMPONENT_REF, + pvoid_type_node, dest, + c->caf_token, + NULL_TREE); + tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp, + ctype, rank); + } else tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank, add_when_allocated); @@ -8562,7 +8781,8 @@ tree gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank) { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - NULLIFY_ALLOC_COMP); + NULLIFY_ALLOC_COMP, + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY); } @@ -8570,10 +8790,12 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank) deallocate allocatable components. */ tree -gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank) +gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank, + int caf_mode) { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_ALLOC_COMP); + DEALLOCATE_ALLOC_COMP, + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode); } @@ -8586,14 +8808,15 @@ tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank) { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_ALLOC_COMP_NO_CAF); + DEALLOCATE_ALLOC_COMP, 0); } tree gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest) { - return structure_alloc_comps (der_type, decl, dest, 0, COPY_ALLOC_COMP_CAF); + return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP, + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY); } @@ -8601,9 +8824,11 @@ gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest) copy it and its allocatable components. */ tree -gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) +gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank, + int caf_mode) { - return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP); + return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP, + caf_mode); } @@ -8613,7 +8838,8 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) tree gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) { - return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP); + return structure_alloc_comps (der_type, decl, dest, rank, + COPY_ONLY_ALLOC_COMP, 0); } @@ -9205,15 +9431,17 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, else { tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, - 4, token, null_pointer_node, - null_pointer_node, integer_zero_node); + gfor_fndecl_caf_deregister, 5, token, + build_int_cst (integer_type_node, + GFC_CAF_COARRAY_DEALLOCATE_ONLY), + null_pointer_node, null_pointer_node, + integer_zero_node); gfc_add_expr_to_block (&realloc_block, tmp); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size2, build_int_cst (integer_type_node, - GFC_CAF_COARRAY_ALLOC), + GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY), token, gfc_build_addr_expr (NULL_TREE, desc), null_pointer_node, null_pointer_node, integer_zero_node); @@ -9398,7 +9626,20 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) /* NULLIFY the data pointer, for non-saved allocatables. */ if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable) - gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); + { + gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); + if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) + { + /* Declare the variable static so its array descriptor stays present + after leaving the scope. It may still be accessed through another + image. This may happen, for example, with the caf_mpi + implementation. */ + TREE_STATIC (descriptor) = 1; + tmp = gfc_conv_descriptor_token (descriptor); + gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + } + } gfc_restore_backend_locus (&loc); gfc_init_block (&cleanup); @@ -9432,8 +9673,10 @@ 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, - sym->attr.codimension, e); + tmp = gfc_trans_dealloc_allocated (sym->backend_decl, 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 d0309b2..d87b724 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -19,7 +19,7 @@ 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*); +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. */ @@ -42,7 +42,7 @@ 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, bool, gfc_expr *); +tree gfc_trans_dealloc_allocated (tree, gfc_expr *, int); tree gfc_full_array_size (stmtblock_t *, tree, int); @@ -54,11 +54,11 @@ tree gfc_duplicate_allocatable_nocopy (tree, tree, tree, int); tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int); -tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int); +tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0); tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int); tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree); -tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int); +tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int); tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index ba71a21..2e6ef2a 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -159,6 +159,7 @@ tree gfor_fndecl_co_max; tree gfor_fndecl_co_min; tree gfor_fndecl_co_reduce; tree gfor_fndecl_co_sum; +tree gfor_fndecl_caf_is_present; /* Math functions. Many other math functions are handled in @@ -3573,8 +3574,9 @@ gfc_build_builtin_function_decls (void) pint_type, pchar_type_node, integer_type_node); gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_deregister")), "WWWR", void_type_node, 4, - ppvoid_type_node, pint_type, pchar_type_node, integer_type_node); + get_identifier (PREFIX("caf_deregister")), "WRWWR", void_type_node, 5, + ppvoid_type_node, integer_type_node, pint_type, pchar_type_node, + integer_type_node); gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_get")), ".R.RRWRRRW", void_type_node, 10, @@ -3726,6 +3728,11 @@ gfc_build_builtin_function_decls (void) get_identifier (PREFIX("caf_co_sum")), "W.WW", void_type_node, 5, pvoid_type_node, integer_type_node, pint_type, pchar_type_node, integer_type_node); + + gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_is_present")), "RRR", + integer_type_node, 3, pvoid_type_node, integer_type_node, + pvoid_type_node); } gfc_build_intrinsic_function_decls (); @@ -4447,12 +4454,15 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) tmp = gfc_deallocate_with_status (descriptor, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, NULL, - true); + GFC_CAF_COARRAY_ANALYZE); else { gfc_expr *expr = gfc_lval_expr_from_sym (sym); - tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE, - true, expr, sym->ts); + tmp = gfc_deallocate_scalar_with_status (se.expr, + NULL_TREE, + NULL_TREE, + true, expr, + sym->ts); gfc_free_expr (expr); } } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1331b07..1c5644c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5208,7 +5208,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ptr = gfc_class_data_get (ptr); tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE, - true, e, e->ts); + NULL_TREE, true, + e, e->ts); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ptr, @@ -5317,7 +5318,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_deallocate_with_status (ptr, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, e, - false); + GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ptr, @@ -5440,7 +5441,8 @@ 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, false, e); + tmp = gfc_trans_dealloc_allocated (tmp, e, + GFC_CAF_COARRAY_NOCOARRAY); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) @@ -5552,7 +5554,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tree local_tmp; local_tmp = gfc_evaluate_now (tmp, &se->pre); - local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank); + local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, + parm_rank, 0); gfc_add_expr_to_block (&se->post, local_tmp); } @@ -6207,7 +6210,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, from being corrupted. */ tmp2 = gfc_evaluate_now (result, &se->pre); tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived, - result, tmp2, expr->rank); + result, tmp2, expr->rank, 0); gfc_add_expr_to_block (&se->pre, tmp); tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2), expr->rank); @@ -6217,7 +6220,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_conv_descriptor_data_get (tmp2); tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, - NULL, false); + NULL, GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&se->pre, tmp); } } @@ -6932,16 +6935,18 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, /* Deal with arrays of derived types with allocatable components. */ if (gfc_bt_struct (cm->ts.type) && cm->ts.u.derived->attr.alloc_comp) + // TODO: Fix caf_mode tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest, - cm->as->rank); + cm->as->rank, 0); else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED && CLASS_DATA(cm)->attr.allocatable) { if (cm->ts.u.derived->attr.alloc_comp) + // TODO: Fix caf_mode tmp = gfc_copy_alloc_comp (expr->ts.u.derived, se.expr, dest, - expr->rank); + expr->rank, 0); else { tmp = TREE_TYPE (dest); @@ -7367,8 +7372,9 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, if (cm->ts.u.derived->attr.alloc_comp && expr->expr_type != EXPR_NULL) { + // TODO: Fix caf_mode tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, - dest, expr->rank); + dest, expr->rank, 0); gfc_add_expr_to_block (&block, tmp); if (dealloc != NULL_TREE) gfc_add_expr_to_block (&block, dealloc); @@ -7434,13 +7440,14 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, /* Assign a derived type constructor to a variable. */ tree -gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) +gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray) { gfc_constructor *c; gfc_component *cm; stmtblock_t block; tree field; tree tmp; + gfc_se se; gfc_start_block (&block); cm = expr->ts.u.derived->components; @@ -7449,7 +7456,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR)) { - gfc_se se, lse; + gfc_se lse; gfc_init_se (&se, NULL); gfc_init_se (&lse, NULL); @@ -7461,6 +7468,9 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) return gfc_finish_block (&block); } + if (coarray) + gfc_init_se (&se, NULL); + for (c = gfc_constructor_first (expr->value.constructor); c; c = gfc_constructor_next (c), cm = cm->next) { @@ -7468,6 +7478,62 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) if (!c->expr && !cm->attr.allocatable) continue; + /* Register the component with the caf-lib before it is initialized. + Register only allocatable components, that are not coarray'ed + components (%comp[*]). Only register when the constructor is not the + null-expression. */ + if (coarray && !cm->attr.codimension && cm->attr.allocatable + && (!c->expr || c->expr->expr_type == EXPR_NULL)) + { + tree token, desc, size; + symbol_attribute attr; + bool is_array = cm->ts.type == BT_CLASS + ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension; + + field = cm->backend_decl; + field = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), dest, field, NULL_TREE); + if (cm->ts.type == BT_CLASS) + field = gfc_class_data_get (field); + + token = is_array ? gfc_conv_descriptor_token (field) + : fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (cm->caf_token), dest, + cm->caf_token, NULL_TREE); + + if (is_array) + { + /* The _caf_register routine looks at the rank of the array + descriptor to decide whether the data registered is an array + or not. */ + int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank + : cm->as->rank; + /* When the rank is not known just set a positive rank, which + suffices to recognize the data as array. */ + if (rank < 0) + rank = 1; + size = integer_zero_node; + desc = field; + gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc), + build_int_cst (gfc_array_index_type, rank)); + } + else + { + desc = gfc_conv_scalar_to_descriptor (&se, field, attr); + size = TYPE_SIZE_UNIT (TREE_TYPE (field)); + } + gfc_add_block_to_block (&block, &se.pre); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, + 7, size, build_int_cst ( + integer_type_node, + GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY), + gfc_build_addr_expr (pvoid_type_node, + token), + gfc_build_addr_expr (NULL_TREE, desc), + null_pointer_node, null_pointer_node, + integer_zero_node); + gfc_add_expr_to_block (&block, tmp); + } field = cm->backend_decl; tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE); @@ -7546,7 +7612,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) se->expr = gfc_create_var (type, expr->ts.u.derived->name); /* The symtree in expr is NULL, if the code to generate is for initializing the static members only. */ - tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL); + tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL, + se->want_coarray); gfc_add_expr_to_block (&se->pre, tmp); return; } @@ -8540,7 +8607,7 @@ gfc_conv_string_parameter (gfc_se * se) tree gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, - bool deep_copy, bool dealloc) + bool deep_copy, bool dealloc, bool in_coarray) { stmtblock_t block; tree tmp; @@ -8617,7 +8684,10 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, same as the lhs. */ if (deep_copy) { - tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0); + int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0; + tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0, + caf_mode); tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), tmp); gfc_add_expr_to_block (&block, tmp); @@ -9746,6 +9816,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL); /* Translate the expression. */ + rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag + && lhs_caf_attr.codimension; gfc_conv_expr (&rse, expr2); /* Deal with the case of a scalar class function assigned to a derived type. */ @@ -9882,7 +9954,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_expr_is_variable (expr2) || scalar_to_array || expr2->expr_type == EXPR_ARRAY, - !(l_is_temp || init_flag) && dealloc); + !(l_is_temp || init_flag) && dealloc, + expr1->symtree->n.sym->attr.codimension); /* Add the pre blocks to the body. */ gfc_add_block_to_block (&body, &rse.pre); gfc_add_block_to_block (&body, &lse.pre); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 463bb58..d7612f6 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1674,7 +1674,8 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, - NULL, false); + NULL, + GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&se->post, tmp); } } @@ -1764,6 +1765,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, ar->as = ar2.as; ar->type = AR_FULL; } + // TODO: Check whether argse.want_coarray = 1 can help with the below. gfc_conv_expr_descriptor (&argse, array_expr); /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that has the wrong type if component references are done. */ @@ -1926,7 +1928,9 @@ conv_caf_send (gfc_code *code) { /* Special case: RHS is a coarray but LHS is not; this code path avoids a temporary and a loop. */ - if (!gfc_is_coindexed (lhs_expr) && !lhs_caf_attr.codimension) + if (!gfc_is_coindexed (lhs_expr) + && (!lhs_caf_attr.codimension + || !(lhs_expr->rank > 0 && lhs_caf_attr.allocatable))) { bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable; gcc_assert (gfc_is_coindexed (rhs_expr)); @@ -1957,7 +1961,7 @@ conv_caf_send (gfc_code *code) { gfc_add_block_to_block (&block, &lhs_se.pre); gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind, may_require_tmp, lhs_may_realloc, - &lhs_caf_attr); + &rhs_caf_attr); gfc_add_block_to_block (&block, &rhs_se.pre); gfc_add_block_to_block (&block, &rhs_se.post); gfc_add_block_to_block (&block, &lhs_se.post); @@ -2059,7 +2063,7 @@ conv_caf_send (gfc_code *code) { gfc_add_block_to_block (&block, &stat_se.post); } - if (!gfc_is_coindexed (rhs_expr) && !rhs_caf_attr.codimension) + if (!gfc_is_coindexed (rhs_expr)) { if (lhs_caf_attr.alloc_comp) { @@ -7318,6 +7322,42 @@ scalar_transfer: } +/* Generate a call to caf_is_present. */ + +static tree +trans_caf_is_present (gfc_se *se, gfc_expr *expr) +{ + tree caf_reference, caf_decl, token, image_index; + + /* Compile the reference chain. */ + caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr); + gcc_assert (caf_reference != NULL_TREE); + + caf_decl = gfc_get_tree_for_caf_expr (expr); + if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) + caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); + image_index = gfc_caf_get_image_index (&se->pre, expr, caf_decl); + gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, + expr); + + return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present, + 3, token, image_index, caf_reference); +} + + +/* Test whether this ref-chain refs this image only. */ + +static bool +caf_this_image_ref (gfc_ref *ref) +{ + for ( ; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE; + + return false; +} + + /* Generate code for the ALLOCATED intrinsic. Generate inline code that directly check the address of the argument. */ @@ -7327,6 +7367,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) gfc_actual_arglist *arg1; gfc_se arg1se; tree tmp; + symbol_attribute caf_attr; gfc_init_se (&arg1se, NULL); arg1 = expr->value.function.actual; @@ -7342,23 +7383,37 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) gfc_add_data_component (arg1->expr); } - if (arg1->expr->rank == 0) - { - /* Allocatable scalar. */ - arg1se.want_pointer = 1; - gfc_conv_expr (&arg1se, arg1->expr); - tmp = arg1se.expr; - } + /* When arg1 references an allocatable component in a coarray, then call + the caf-library function caf_is_present (). */ + if (flag_coarray == GFC_FCOARRAY_LIB && arg1->expr->expr_type == EXPR_FUNCTION + && arg1->expr->value.function.isym + && arg1->expr->value.function.isym->id == GFC_ISYM_CAF_GET) + caf_attr = gfc_caf_attr (arg1->expr->value.function.actual->expr); + else + gfc_clear_attr (&caf_attr); + if (flag_coarray == GFC_FCOARRAY_LIB && caf_attr.codimension + && !caf_this_image_ref (arg1->expr->value.function.actual->expr->ref)) + tmp = trans_caf_is_present (se, arg1->expr->value.function.actual->expr); else { - /* Allocatable array. */ - arg1se.descriptor_only = 1; - gfc_conv_expr_descriptor (&arg1se, arg1->expr); - tmp = gfc_conv_descriptor_data_get (arg1se.expr); - } + if (arg1->expr->rank == 0) + { + /* Allocatable scalar. */ + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, arg1->expr); + tmp = arg1se.expr; + } + else + { + /* Allocatable array. */ + arg1se.descriptor_only = 1; + gfc_conv_expr_descriptor (&arg1se, arg1->expr); + tmp = gfc_conv_descriptor_data_get (arg1se.expr); + } - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, - fold_convert (TREE_TYPE (tmp), null_pointer_node)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, + fold_convert (TREE_TYPE (tmp), null_pointer_node)); + } se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); } @@ -10270,8 +10325,8 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_block_to_block (&block, &to_se.pre); /* Deallocate "to". */ - tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true, - to_expr, to_expr->ts); + tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE, + true, to_expr, to_expr->ts); gfc_add_expr_to_block (&block, tmp); /* Assign (_data) pointers. */ @@ -10429,7 +10484,7 @@ conv_intrinsic_move_alloc (gfc_code *code) tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, to_expr, - true); + GFC_CAF_COARRAY_DEALLOCATE_ONLY); gfc_add_expr_to_block (&block, tmp); tmp = gfc_conv_descriptor_data_get (to_se.expr); @@ -10457,7 +10512,8 @@ conv_intrinsic_move_alloc (gfc_code *code) tmp = gfc_conv_descriptor_data_get (to_se.expr); tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, - NULL_TREE, true, to_expr, false); + NULL_TREE, true, to_expr, + GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&block, tmp); } diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 59fd6b3..d460048 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -420,8 +420,8 @@ 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), - false, NULL); + tem = gfc_trans_dealloc_allocated (unshare_expr (declf), NULL, + GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); } else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) @@ -812,7 +812,8 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) if (GFC_DESCRIPTOR_TYPE_P (type)) gfc_add_expr_to_block (&cond_block, gfc_trans_dealloc_allocated (unshare_expr (dest), - false, NULL)); + NULL, + GFC_CAF_COARRAY_NOCOARRAY)); else { destptr = gfc_evaluate_now (destptr, &cond_block); @@ -988,7 +989,7 @@ 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, false, NULL); + tem = gfc_trans_dealloc_allocated (decl, 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 490b18d..b35075e 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -6406,6 +6406,9 @@ gfc_trans_deallocate (gfc_code *code) for (al = code->ext.alloc.list; al != NULL; al = al->next) { gfc_expr *expr = gfc_copy_expr (al->expr); + bool is_coarray = false, is_coarray_array = false; + int caf_mode = 0; + gcc_assert (expr->expr_type == EXPR_VARIABLE); if (expr->ts.type == BT_CLASS) @@ -6418,11 +6421,32 @@ gfc_trans_deallocate (gfc_code *code) se.descriptor_only = 1; gfc_conv_expr (&se, expr); - if (expr->rank || gfc_caf_attr (expr).codimension) + if (flag_coarray == GFC_FCOARRAY_LIB) + { + bool comp_ref; + symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref); + if (caf_attr.codimension) + { + is_coarray = true; + is_coarray_array = caf_attr.dimension || !comp_ref + || caf_attr.coarray_comp; + + /* When the expression to deallocate is referencing a + component, then only deallocate it, but do not deregister. */ + caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY + | (comp_ref && !caf_attr.coarray_comp + ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0); + } + } + else if (flag_coarray == GFC_FCOARRAY_SINGLE) + is_coarray = is_coarray_array = gfc_caf_attr (expr).codimension; + + if (expr->rank || is_coarray_array) { gfc_ref *ref; - if (gfc_bt_struct (expr->ts.type) && expr->ts.u.derived->attr.alloc_comp + if (gfc_bt_struct (expr->ts.type) + && expr->ts.u.derived->attr.alloc_comp && !gfc_is_finalizable (expr->ts.u.derived, NULL)) { gfc_ref *last = NULL; @@ -6436,16 +6460,35 @@ gfc_trans_deallocate (gfc_code *code) if (!(last && last->u.c.component->attr.pointer) && !(!last && expr->symtree->n.sym->attr.pointer)) { - tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr, - expr->rank); + if (is_coarray && expr->rank == 0 + && (!last || !last->u.c.component->attr.dimension)) + { + /* Add the ref to the data member only, when this is not + a regular array or deallocate_alloc_comp will try to + add another one. */ + tmp = gfc_conv_descriptor_data_get (se.expr); + } + else + tmp = se.expr; + tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, + expr->rank, caf_mode); gfc_add_expr_to_block (&se.pre, tmp); } } if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) { + gfc_coarray_deregtype caf_dtype; + + if (is_coarray) + caf_dtype + = (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) == 0 + ? GFC_CAF_COARRAY_DEREGISTER + : GFC_CAF_COARRAY_DEALLOCATE_ONLY; + else + caf_dtype = GFC_CAF_COARRAY_NOCOARRAY; tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen, - label_finish, expr); + label_finish, expr, caf_dtype); gfc_add_expr_to_block (&se.pre, tmp); } else if (TREE_CODE (se.expr) == COMPONENT_REF @@ -6488,8 +6531,9 @@ gfc_trans_deallocate (gfc_code *code) } else { - tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false, - al->expr, al->expr->ts); + tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish, + false, al->expr, + al->expr->ts, is_coarray); gfc_add_expr_to_block (&se.pre, tmp); /* Set to zero after deallocation. */ diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index aaec1c2..6a1d481 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -709,10 +709,10 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen); return newmem; } */ -static void -gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, - tree token, tree status, tree errmsg, tree errlen, - bool lock_var, bool event_var) +void +gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size, + tree token, tree status, tree errmsg, tree errlen, + gfc_coarray_regtype alloc_type) { tree tmp, pstat; @@ -735,12 +735,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, fold_build2_loc (input_location, - MAX_EXPR, size_type_node, size, - build_int_cst (size_type_node, 1)), - build_int_cst (integer_type_node, - lock_var ? GFC_CAF_LOCK_ALLOC - : event_var ? GFC_CAF_EVENT_ALLOC - : GFC_CAF_COARRAY_ALLOC), + MAX_EXPR, size_type_node, size, size_one_node), + build_int_cst (integer_type_node, alloc_type), token, gfc_build_addr_expr (pvoid_type_node, pointer), pstat, errmsg, errlen); @@ -787,7 +783,8 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree tmp, null_mem, alloc, error; tree type = TREE_TYPE (mem); symbol_attribute caf_attr; - bool need_assign = false; + bool need_assign = false, refs_comp = false; + gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC; size = fold_convert (size_type_node, size); null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, @@ -800,27 +797,36 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, gfc_start_block (&alloc_block); if (flag_coarray == GFC_FCOARRAY_LIB) - caf_attr = gfc_caf_attr (expr, true); + caf_attr = gfc_caf_attr (expr, true, &refs_comp); if (flag_coarray == GFC_FCOARRAY_LIB && (corank > 0 || caf_attr.codimension)) { - tree cond; - bool lock_var = expr->ts.type == BT_DERIVED - && expr->ts.u.derived->from_intmod - == INTMOD_ISO_FORTRAN_ENV - && expr->ts.u.derived->intmod_sym_id - == ISOFORTRAN_LOCK_TYPE; - bool event_var = expr->ts.type == BT_DERIVED - && expr->ts.u.derived->from_intmod - == INTMOD_ISO_FORTRAN_ENV - && expr->ts.u.derived->intmod_sym_id - == ISOFORTRAN_EVENT_TYPE; + tree cond, sub_caf_tree; gfc_se se; - gfc_init_se (&se, NULL); + bool compute_special_caf_types_size = false; - tree sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, - expr); + if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) + { + compute_special_caf_types_size = true; + caf_alloc_type = GFC_CAF_LOCK_ALLOC; + } + else if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + { + compute_special_caf_types_size = true; + caf_alloc_type = GFC_CAF_EVENT_ALLOC; + } + else if (!caf_attr.coarray_comp && refs_comp) + /* Only allocatable components in a derived type coarray can be + allocate only. */ + caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY; + + gfc_init_se (&se, NULL); + sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr); if (sub_caf_tree == NULL_TREE) sub_caf_tree = token; @@ -847,12 +853,12 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, the FE only passes the pointer around and leaves the actual representation to the library. Hence, we have to convert back to the number of elements. */ - if (lock_var || event_var) + if (compute_special_caf_types_size) size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node, size, TYPE_SIZE_UNIT (ptr_type_node)); - gfc_allocate_using_lib (&alloc_block, tmp, size, sub_caf_tree, - status, errmsg, errlen, lock_var, event_var); + gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree, + status, errmsg, errlen, caf_alloc_type); if (need_assign) gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem), gfc_conv_descriptor_data_get (tmp))); @@ -1265,23 +1271,40 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2) expression being deallocated for its locus and variable name. For coarrays, "pointer" must be the array descriptor and not its - "data" component. */ + "data" component. + + COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are + the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be + analyzed and set by this routine, and -2 to indicate that a non-coarray is to + be deallocated. */ tree gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen, tree label_finish, - bool can_fail, gfc_expr* expr, bool coarray) + bool can_fail, gfc_expr* expr, + int coarray_dealloc_mode) { stmtblock_t null, non_null; tree cond, tmp, error; tree status_type = NULL_TREE; tree caf_decl = NULL_TREE; + gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; - if (coarray) + 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) + { + 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; } cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, @@ -1326,7 +1349,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, /* When POINTER is not NULL, we free it. */ gfc_start_block (&non_null); gfc_add_finalizer_call (&non_null, expr); - if (!coarray || flag_coarray != GFC_FCOARRAY_LIB) + if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY + || flag_coarray != GFC_FCOARRAY_LIB) { tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, @@ -1392,9 +1416,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, } token = gfc_build_addr_expr (NULL_TREE, token); + gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE); tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 4, - token, pstat, errmsg, errlen); + gfor_fndecl_caf_deregister, 5, + token, build_int_cst (integer_type_node, + caf_dereg_type), + pstat, errmsg, errlen); gfc_add_expr_to_block (&non_null, tmp); /* It guarantees memory consistency within the same segment */ @@ -1431,12 +1458,18 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, subcomponents are being deallocated. */ tree -gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, - gfc_expr* expr, gfc_typespec ts) +gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, + bool can_fail, gfc_expr* expr, + gfc_typespec ts, bool coarray) { stmtblock_t null, non_null; tree cond, tmp, error; - bool finalizable; + bool finalizable, comp_ref; + gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; + + if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp + && comp_ref) + caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); @@ -1474,7 +1507,6 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, error = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, tmp, error); } - gfc_add_expr_to_block (&null, error); /* When POINTER is not NULL, we free it. */ @@ -1484,31 +1516,84 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, finalizable = gfc_add_finalizer_call (&non_null, expr); if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { - tmp = build_fold_indirect_ref_loc (input_location, pointer); + if (coarray) + 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); gfc_add_expr_to_block (&non_null, tmp); } - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_FREE), 1, - fold_convert (pvoid_type_node, pointer)); - gfc_add_expr_to_block (&non_null, tmp); + if (!coarray) + { + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_FREE), 1, + fold_convert (pvoid_type_node, pointer)); + gfc_add_expr_to_block (&non_null, tmp); - if (status != NULL_TREE && !integer_zerop (status)) + if (status != NULL_TREE && !integer_zerop (status)) + { + /* We set STATUS to zero if it is present. */ + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + status, + build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond2, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } + } + else { - /* We set STATUS to zero if it is present. */ - tree status_type = TREE_TYPE (TREE_TYPE (status)); - tree cond2; + tree token; + tree pstat = null_pointer_node; + gfc_se se; - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - status, build_int_cst (TREE_TYPE (status), 0)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, status), - build_int_cst (status_type, 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, - tmp, build_empty_stmt (input_location)); + gfc_init_se (&se, NULL); + token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr); + gcc_assert (token != NULL_TREE); + + if (status != NULL_TREE && !integer_zerop (status)) + { + gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node); + pstat = status; + } + + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_deregister, 5, + token, build_int_cst (integer_type_node, + caf_dereg_type), + pstat, null_pointer_node, integer_zero_node); 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 = 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); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&non_null, tmp); + + if (status != NULL_TREE) + { + tree stat = build_fold_indirect_ref_loc (input_location, status); + tree cond2; + + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + 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)); + gfc_add_expr_to_block (&non_null, tmp); + } } return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, @@ -1516,7 +1601,6 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, gfc_finish_block (&non_null)); } - /* Reallocate MEM so it has SIZE bytes of data. This behaves like the following pseudo-code: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 02a8a56..ae1f156 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -107,7 +107,7 @@ gfc_se; /* Denotes different types of coarray. Please keep in sync with libgfortran/caf/libcaf.h. */ -enum gfc_coarray_type +enum gfc_coarray_regtype { GFC_CAF_COARRAY_STATIC, GFC_CAF_COARRAY_ALLOC, @@ -115,7 +115,22 @@ enum gfc_coarray_type GFC_CAF_LOCK_ALLOC, GFC_CAF_CRITICAL, GFC_CAF_EVENT_STATIC, - GFC_CAF_EVENT_ALLOC + GFC_CAF_EVENT_ALLOC, + GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY, + GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY +}; + + +/* Describes the action to take on _caf_deregister. Keep in sync with + gcc/fortran/trans.h. The negative values are not valid for the library and + are used by the drivers for building the correct call. */ +enum gfc_coarray_deregtype { + /* This is no coarray, i.e. build a call to a free (). */ + GFC_CAF_COARRAY_NOCOARRAY = -2, + /* The driver is to analyze which _caf_deregister ()-call to generate. */ + GFC_CAF_COARRAY_ANALYZE = -1, + GFC_CAF_COARRAY_DEREGISTER = 0, + GFC_CAF_COARRAY_DEALLOCATE_ONLY }; @@ -140,6 +155,15 @@ enum gfc_caf_array_ref_t { GFC_CAF_ARR_REF_OPEN_START }; + +/* trans-array (structure_alloc_comps) caf_mode bits. */ +enum gfc_structure_caf_mode_t { + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY = 1 << 0, + GFC_STRUCTURE_CAF_MODE_IN_COARRAY = 1 << 1, + GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY = 1 << 2 +}; + + /* The array-specific scalarization information. The array members of this struct are indexed by actual array index, and thus can be sparse. */ @@ -506,7 +530,8 @@ int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *, void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool); /* Generate code for a scalar assignment. */ -tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool); +tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool, + bool c = false); /* Translate COMMON blocks. */ void gfc_trans_common (gfc_namespace *); @@ -681,6 +706,10 @@ tree gfc_call_malloc (stmtblock_t *, tree, tree); /* Build a memcpy call. */ tree gfc_build_memcpy_call (tree, tree, tree); +/* Register memory with the coarray library. */ +void gfc_allocate_using_caf_lib (stmtblock_t *, tree, tree, tree, tree, tree, + tree, gfc_coarray_regtype); + /* Allocate memory for allocatable variables, with optional status variable. */ void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree, tree, tree, tree, gfc_expr*, int); @@ -690,14 +719,15 @@ 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 *, bool); -tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespec); + gfc_expr *, int); +tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*, + gfc_typespec, bool c = false); /* Generate code to call realloc(). */ tree gfc_call_realloc (stmtblock_t *, tree, tree); /* Assign a derived type constructor to a variable. */ -tree gfc_trans_structure_assign (tree, gfc_expr *, bool); +tree gfc_trans_structure_assign (tree, gfc_expr *, bool, bool c = false); /* Generate code for an assignment, includes scalarization. */ tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool, bool p = false, @@ -808,7 +838,7 @@ extern GTY(()) tree gfor_fndecl_co_max; extern GTY(()) tree gfor_fndecl_co_min; extern GTY(()) tree gfor_fndecl_co_reduce; extern GTY(()) tree gfor_fndecl_co_sum; - +extern GTY(()) tree gfor_fndecl_caf_is_present; /* Math functions. Many other math functions are handled in trans-intrinsic.c. */ diff --git a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_1.f90 b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_1.f90 index 6baeabf..f1136e3 100644 --- a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_1.f90 @@ -8,9 +8,9 @@ end type t type(t) :: a allocate (a%caf[3:*]) a%caf = 7 -!print *, a%caf if (a%caf /= 7) call abort () if (any (lcobound (a%caf) /= [ 3 ]) & .or. ucobound (a%caf, dim=1) /= this_image ()+2) & call abort () +deallocate (a%caf) end diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_1.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_1.f08 index 659fd48..8c35fc8 100644 --- a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_1.f08 +++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_1.f08 @@ -90,4 +90,7 @@ if (.not. allocated(bar%vec( 2)%indices)) call abort() if (any(bar[me]%vec(2)%indices /= 89)) call abort() if (any (bar[neighbor]%vec(1)%indices /= [ 3,4,15])) call abort() + +deallocate(bar%vec(2)%indices, object%scalar, object%matrix) +deallocate(bar%vec) end program diff --git a/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08 b/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08 index 4b08941..d924176 100644 --- a/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08 +++ b/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08 @@ -23,6 +23,7 @@ program main if ( object%indices(1) /= 1 ) call abort() end program -! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 1, &\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\) \\*object\\).indices, 0B, 0B, 0\\);" 2 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct mytype\\) \\*object\\).indices.token, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 1, &\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\) \\*object\\).indices, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 8, &\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\) \\*object\\).indices, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct mytype\\) \\*object\\).indices.token, 1, 0B, 0B, 0\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 index 31e4cf5..4f90bdf 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 @@ -15,7 +15,7 @@ ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(4, 1, &xx.token, \\(void \\*\\) &xx, &stat.., &errmsg, 200\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(8, 1, &yy.token, \\(void \\*\\) &yy, &stat.., &errmsg, 200\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0B, 0B, 0.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0, 0B, 0B, 0.;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 index a83963c..90998ee 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 @@ -17,7 +17,7 @@ ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &xx._data.token, \\(void \\*\\) &xx._data, &stat.., &errmsg, 200\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &yy._data.token, \\(void \\*\\) &yy._data, &stat.., &errmsg, 200\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, 0B, 0B, 0.;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 index 33cda92..17f800f 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 @@ -18,7 +18,7 @@ subroutine test ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &xx._data.token, \\(void \\*\\) &xx._data, &stat.., &errmsg, 200\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &yy._data.token, \\(void \\*\\) &yy._data, &stat.., &errmsg, 200\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, 0B, 0B, 0.;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_4.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_4.f90 new file mode 100644 index 0000000..2ec56f0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_4.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" } +! +! Allocate/deallocate with libcaf. +! + +program test_caf_alloc + + type t + integer, allocatable :: i + real, allocatable :: r(:) + end type t + + type(t), allocatable :: xx[:] + + allocate (xx[*]) + + if (allocated(xx%i)) call abort() + if (allocated(xx[1]%i)) call abort() + if (allocated(xx[1]%r)) call abort() + allocate(xx%i) + if (.not. allocated(xx[1]%i)) call abort() + if (allocated(xx[1]%r)) call abort() + + allocate(xx%r(5)) + if (.not. allocated(xx[1]%i)) call abort() + if (.not. allocated(xx[1]%r)) call abort() + + deallocate(xx%i) + if (allocated(xx[1]%i)) call abort() + if (.not. allocated(xx[1]%r)) call abort() + + deallocate(xx%r) + if (allocated(xx[1]%i)) call abort() + if (allocated(xx[1]%r)) call abort() + + deallocate(xx) +end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_is_present \\(xx\\.token, 2 - \\(integer\\(kind=4\\)\\) xx\\.dim\\\[0\\\]\\.lbound, &caf_ref\\.\[0-9\]+\\)" 10 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(72, 1, &xx\\.token, \\(void \\*\\) &xx, 0B, 0B, 0\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(\[0-9\]+, 7" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(\[0-9\]+, 8" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&xx\\.token, 0, 0B, 0B, 0\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct t \\* restrict\\) xx\\.data\\)->r\\.token, 1, 0B, 0B, 0\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct t \\* restrict\\) xx\\.data\\)->_caf_i, 1, 0B, 0B, 0\\)" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 index a17feab..8ad6b08 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 @@ -38,8 +38,8 @@ B(1:5) = B(3:7) if (any (A-B /= 0)) call abort end -! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, _gfortran_caf_this_image \\\(0\\\), &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 0, 0B\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, _gfortran_caf_this_image \\\(0\\\), &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 1, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1, 0B\\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 1, 0B\\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 0, 0B\\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 0, 0B\\\);" 1 "original" } } diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index aad0f62..1bb5176 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -50,7 +50,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #define STAT_STOPPED_IMAGE 6000 #endif -/* Describes what type of array we are registerring. Keep in sync with +/* Describes what type of array we are registerring. Keep in sync with gcc/fortran/trans.h. */ typedef enum caf_register_t { CAF_REGTYPE_COARRAY_STATIC, @@ -59,10 +59,20 @@ typedef enum caf_register_t { CAF_REGTYPE_LOCK_ALLOC, CAF_REGTYPE_CRITICAL, CAF_REGTYPE_EVENT_STATIC, - CAF_REGTYPE_EVENT_ALLOC + CAF_REGTYPE_EVENT_ALLOC, + CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY, + CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY } caf_register_t; +/* Describes the action to take on _caf_deregister. Keep in sync with + gcc/fortran/trans.h. */ +typedef enum caf_deregister_t { + CAF_DEREGTYPE_COARRAY_DEREGISTER, + CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY +} +caf_deregister_t; + typedef void* caf_token_t; typedef gfc_array_void gfc_descriptor_t; @@ -174,7 +184,8 @@ int _gfortran_caf_num_images (int, int); void _gfortran_caf_register (size_t, caf_register_t, caf_token_t *, gfc_descriptor_t *, int *, char *, int); -void _gfortran_caf_deregister (caf_token_t *, int *, char *, int); +void _gfortran_caf_deregister (caf_token_t *, caf_deregister_t, int *, char *, + int); void _gfortran_caf_sync_all (int *, char *, int); void _gfortran_caf_sync_memory (int *, char *, int); @@ -232,4 +243,6 @@ void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, int); void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, int); void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *); +int _gfortran_caf_is_present (caf_token_t, int, caf_reference_t *); + #endif /* LIBCAF_H */ diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 00b7120..5e2932c 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -144,11 +144,17 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC || type == CAF_REGTYPE_EVENT_ALLOC) local = calloc (size, sizeof (bool)); + else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY) + local = NULL; else local = malloc (size); - *token = malloc (sizeof (struct caf_single_token)); - if (unlikely (local == NULL || *token == NULL)) + if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY) + *token = malloc (sizeof (struct caf_single_token)); + + if (unlikely (*token == NULL + || (local == NULL + && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY))) { /* Freeing the memory conditionally seems pointless, but caf_internal_error () may return, when a stat is given and then the @@ -163,7 +169,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, single_token = TOKEN (*token); single_token->memptr = local; - single_token->owning_memory = true; + single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY; single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL; @@ -184,7 +190,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, void -_gfortran_caf_deregister (caf_token_t *token, int *stat, +_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, char *errmsg __attribute__ ((unused)), int errmsg_len __attribute__ ((unused))) { @@ -193,7 +199,16 @@ _gfortran_caf_deregister (caf_token_t *token, int *stat, if (single_token->owning_memory && single_token->memptr) free (single_token->memptr); - free (TOKEN (*token)); + if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY) + { + free (TOKEN (*token)); + *token = NULL; + } + else + { + single_token->memptr = NULL; + single_token->owning_memory = false; + } if (stat) *stat = 0; @@ -2882,3 +2897,102 @@ _gfortran_caf_unlock (caf_token_t token, size_t index, } _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg)); } + +int +_gfortran_caf_is_present (caf_token_t token, + int image_index __attribute__ ((unused)), + caf_reference_t *refs) +{ + const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): " + "only scalar indexes allowed.\n"; + const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): " + "unknown reference type.\n"; + const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): " + "unknown array reference type.\n"; + size_t i; + caf_single_token_t single_token = TOKEN (token); + void *memptr = single_token->memptr; + gfc_descriptor_t *src = single_token->desc; + caf_reference_t *riter = refs; + + while (riter) + { + switch (riter->type) + { + case CAF_REF_COMPONENT: + if (riter->u.c.caf_token_offset) + { + single_token = *(caf_single_token_t*) + (memptr + riter->u.c.caf_token_offset); + memptr = single_token->memptr; + src = single_token->desc; + } + else + { + memptr += riter->u.c.offset; + src = (gfc_descriptor_t *)memptr; + } + break; + case CAF_REF_ARRAY: + for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) + { + switch (riter->u.a.mode[i]) + { + case CAF_ARR_REF_SINGLE: + memptr += (riter->u.a.dim[i].s.start + - GFC_DIMENSION_LBOUND (src->dim[i])) + * GFC_DIMENSION_STRIDE (src->dim[i]) + * riter->item_size; + break; + case CAF_ARR_REF_FULL: + /* A full array ref is allowed on the last reference only. */ + if (riter->next == NULL) + break; + /* else fall through reporting an error. */ + case CAF_ARR_REF_VECTOR: + case CAF_ARR_REF_RANGE: + case CAF_ARR_REF_OPEN_END: + case CAF_ARR_REF_OPEN_START: + caf_internal_error (arraddressingnotallowed, 0, NULL, 0); + return 0; + default: + caf_internal_error (unknownarrreftype, 0, NULL, 0); + return 0; + } + } + break; + case CAF_REF_STATIC_ARRAY: + for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) + { + switch (riter->u.a.mode[i]) + { + case CAF_ARR_REF_SINGLE: + memptr += riter->u.a.dim[i].s.start + * riter->u.a.dim[i].s.stride + * riter->item_size; + break; + case CAF_ARR_REF_FULL: + /* A full array ref is allowed on the last reference only. */ + if (riter->next == NULL) + break; + /* else fall through reporting an error. */ + case CAF_ARR_REF_VECTOR: + case CAF_ARR_REF_RANGE: + case CAF_ARR_REF_OPEN_END: + case CAF_ARR_REF_OPEN_START: + caf_internal_error (arraddressingnotallowed, 0, NULL, 0); + return 0; + default: + caf_internal_error (unknownarrreftype, 0, NULL, 0); + return 0; + } + } + break; + default: + caf_internal_error (unknownreftype, 0, NULL, 0); + return 0; + } + riter = riter->next; + } + return memptr != NULL; +}