From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mout.gmx.net (mout.gmx.net [212.227.15.15]) by sourceware.org (Postfix) with ESMTPS id A7CA8388A409 for ; Mon, 12 Oct 2020 13:48:20 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org A7CA8388A409 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=vehre@gmx.de DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.net; s=badeba3b8450; t=1602510498; bh=nZilZlKTzAhEsF7q2vXo5NcLlSkzliY17lTmC1+1Zsw=; h=X-UI-Sender-Class:Date:From:To:Cc:Subject:In-Reply-To:References; b=WchYTaVJpPKucqtdhwik0xRQLCHst8yLFjXZDpEbUcQkoVo+iHqwIu8H2ysjxoOnF kC04NHOtMpKugXro8lOXqJ2x4bVExBzuyyehdwzO7DmzKgNVKfIpGiHeK6OWMKYnba 3xCyMbwy4z2SGZWGXSka/XPel5Apfwg1L+8MfW2U= X-UI-Sender-Class: 01bb95c1-4bf8-414a-932a-4f6e2808ef9c Received: from vepi2 ([37.201.215.237]) by mail.gmx.com (mrgmx004 [212.227.17.190]) with ESMTPSA (Nemesis) id 1N63Ra-1kPqZO0sH2-016RoU; Mon, 12 Oct 2020 15:48:18 +0200 Date: Mon, 12 Oct 2020 15:48:17 +0200 From: Andre Vehreschild To: Nicolas =?UTF-8?B?S8O2bmln?= Cc: fortran@gcc.gnu.org Subject: Re: [RFC] Native Coarrays (finally!) [Review part 2] Message-ID: <20201012154817.16d1a2a9@vepi2> In-Reply-To: <7b0ebe4e-1f82-6988-b15d-85506e1c9d61@student.ethz.ch> References: <63411801-ad6e-15c3-8fe7-933841fd02e9@codesourcery.com> <7b0ebe4e-1f82-6988-b15d-85506e1c9d61@student.ethz.ch> X-Mailer: Claws Mail 3.17.6 (GTK+ 2.24.32; x86_64-redhat-linux-gnu) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/x52aQKKZMnPdH6bZv/EW21Z" X-Provags-ID: V03:K1:qGiwVnR/+EerAbAK4jzF0dGFdayIos/3elsktU7ULlKk0UKT86o RWQRXhxUAcU8i0DgOay3lT5ZAN9aT2xxAMjJUaGg95Sus/ACVWWEpLuBk09OwgIatGOWJ3W LX7jyd8NRCeeROM/ExQLPjyY+/D3M+ARbvEllRzOk2MvhSYO1MQ7ze0JvWa/uIsdpvKtvai IfgM0ygMAqN+mOIDepIwA== X-UI-Out-Filterresults: notjunk:1;V03:K0:2qFTjOTC7no=:QJcHyw7ZsCiyzB2csGTVeW ttO0a5VVZX4JZ1EqL/0+Z89aUF2P19yvUQuSa9HOSEuTmCF8A8SRogjaXjqn1wwJOeoxWAGJ9 WiWjM/pk+EuP+yRq8OLkzoSTD05x1VJ3DpSDt/XPAv/eIzmqX/NqMIHv055nJ+fCsbe/5MH/h hhZw9AaVG/AdlKmsO2NuZGQUCLm5pEI7eErdPBI9bb8pAJKxjGUdw3iCWnxBbrQ6XMEuCa6Bd fmf+QgZvDSgRHOMg24h73+WfZZ97NaITpIS/hBZL9BoyMVsJkilFVfIkdTcNfHoI2O1mXnro2 37+O8KzF7ygzYpPzeR82D4u8iEd34NWX8hY9LjAYwghNhFRolvLekFVJ6n1WO5g+VfXHHRBhg GE+Jd5G30V6GEki6F+ugV336icKafZ0J9itxbrij+Y5oiip8FwdMiNE02GkIgWaB8FmvR4/su 4EhT244c0NnIhsy7E7TpeP8WS2fPABgX9bDOG5cFPGHUc0GLn0gszobJuf5k1z8lq592KAwV9 hOqMt25GIbpXNVp8chzXmdiypatTgCvDWEqOYkIcxPpOGPc9b4yx3BLo0fC4sxPk8lc+dtzJn 2XvNflsMsHhr/1en1wLkIDFmaUoYsBqYucJaAmrfeTwnuMG8smQaJhPbufFqSf4eIQ9k7K3/7 vhdEbHDKN5dbicNFGLkatkhVraq7x47SjVP188PMWwK/bBiQXYrzvifEGxaVbOesL7gOy+H06 Mp7oGC6evYl+MofXsu8o8AGTVq4t1GE8RPFDUIkP3aTC1tIp4m83AY5YklAIwwHzliQcaw+Gl OLfWp1NJk/ais1opfN/NuutyNYDHJJEwxVwqIkdokg+OS+YugNUo/eXeHVi4MS2sGBl0cky5B yS/VexCuPRO/NIsHJ2DHEjRh+kgvg/z0D+N29bkAW2zdTNaUTjr8BFtwdIHx8JOA2HBjHBVkj 3jGB7QiWSil2fXOkkdXQq7jg63fWI3ccy7HkIqAIwY3umtAh9ifJnrbKZhO6QgGpkI7YRWgXl fq897CA8ct1CgX3BK6YbabydSJElh+lmQXyzeAQy0gI8Fk/XL/Op3quGOI+eUFIfQmIi+mCny dChYaDZlyKfafZ7bYA/0b9p2KC5tgMrQWe4wA3FD/j+ZkBs1Q0WUedqWgXLY0HTRgVLdYQXrD U/K9Ie5w9j8cQrN/6z3xNlcOnVPO26OcQI6KoJrz5C2IeDdRGe1YABMy8pnkYUvGyO3gfaoq1 g7Ch5LN4cZ1TI/Jud X-Spam-Status: No, score=-6.1 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FREEMAIL_FROM, GIT_PATCH_0, KAM_STOCKGEN, RCVD_IN_BARRACUDACENTRAL, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H2, SCC_5_SHORT_WORD_LINES, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: fortran@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Fortran mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Mon, 12 Oct 2020 13:48:27 -0000 --MP_/x52aQKKZMnPdH6bZv/EW21Z Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Content-Disposition: inline Hi Nicolas, here is part two of the review of the compiler components. I will do the testsuite and library parts another day, because now I am already completely bonkers. (Yes, I know, that's normal for me :-) Regards, Andre On Mon, 5 Oct 2020 15:23:27 +0200 Nicolas K=C3=B6nig wrote: > Hello Tobias, >=20 > On 05/10/2020 11:54, Tobias Burnus wrote: > > Hi Nicolas, > >=20 > > admittedly, I have not yet looked at your patch. However, I have to > > admit that I do not like the name. I understand that "native" refers > > to not needing an external library (libcaf.../libopencoarray...), > > but I still wonder whether something like "-fcoarray=3Dshared" (i.e. > > working on a shared-memory system) would be better name from an end-user > > point of view. =20 >=20 > I think the name has been the most critized point of the entire patch up= =20 > till now. I'm going to change it to -fcoarray=3Dshared, as you (and a few= =20 > other people) suggested :) >=20 > >=20 > > Tobias, > > who likes that coarray can be used without extra libs and thinks > > that this will help with users starting to use coarrays. =20 >=20 > That is the main reason I wrote the patch. >=20 > >=20 > > ----------------- > > Mentor Graphics (Deutschland) GmbH, Arnulfstra=C3=9Fe 201, 80634 M=C3= =BCnchen /=20 > > Germany > > Registergericht M=C3=BCnchen HRB 106955, Gesch=C3=A4ftsf=C3=BChrer: Tho= mas Heurung,=20 > > Alexander Walter =20 --=20 Andre Vehreschild * Email: vehre ad gmx dot de=20 --MP_/x52aQKKZMnPdH6bZv/EW21Z Content-Type: text/x-patch Content-Transfer-Encoding: quoted-printable Content-Disposition: attachment; filename=caf_shared_part_2.patch diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6566c47d4ae..9013f1984af 100644 =2D-- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2940,6 +2940,60 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss *= ss, bool subscript, gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, wher= e); } +static tree +gfc_add_strides (tree expr, tree desc, int beg, int end) +{ + int i; + tree tmp, stride; + tmp =3D gfc_index_zero_node; + for (i =3D beg; i < end; i++) + { + stride =3D gfc_conv_array_stride (desc, i); + tmp =3D fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(tmp), + tmp, stride); + } + return fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(expr), + expr, tmp); +} + +/* This function calculates the new offset via + new_offset =3D offset + this_image () + * arrray.stride[first_codimension] ###AV: Fix typo: arrray -> array + + sum (remaining codimension offsets) + If offset is a pointer, we also need to multiply it by the size.*/ ###AV: Gcc style enforces '. */' for the end of a comment. Or did that ch= ange? +static tree +gfc_native_coarray_add_this_image_offset (tree offset, tree desc, + gfc_array_ref *ar, int is_pointer, + int subtract) +{ + tree tmp, off; + /* Calculate the actual offset. */ + tmp =3D build_call_expr_loc (input_location, gfor_fndecl_nca_this_image= , + 1, integer_zero_node); + tmp =3D convert (TREE_TYPE(gfc_index_zero_node), tmp); ###AV: Style! It should be 'TREE_TYPE (...'. + tmp =3D fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE(tmp), tm= p, + build_int_cst (TREE_TYPE(tmp), subtract)); + tmp =3D fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(tmp), + gfc_conv_array_stride (desc, ar->dimen), tmp); + /* We also need to add the missing strides once to compensate for the + offset, that is to large now. The loop starts at sym->as.rank+1 + because we need to skip the first corank stride */ + off =3D gfc_add_strides (tmp, desc, ar->as->rank + 1, + ar->as->rank + ar->as->corank); + if (is_pointer) + { + /* Remove pointer and array from type in order to get the raw base = type. */ + tmp =3D TREE_TYPE(TREE_TYPE(TREE_TYPE(offset))); + /* And get the size of that base type. */ + tmp =3D convert (TREE_TYPE(off), size_in_bytes_loc (input_location,= tmp)); + tmp =3D fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(off), + off, tmp); + return fold_build_pointer_plus_loc (input_location, offset, tmp); + } + else + return fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(offset), + offset, off); +} /* Translate expressions for the descriptor and data pointer of a SS. */ /*GCC ARRAYS*/ @@ -2951,6 +3005,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss = * ss, int base) gfc_ss_info *ss_info; gfc_array_info *info; tree tmp; + gfc_ref *ref; ss_info =3D ss->info; info =3D &ss_info->data.array; @@ -2982,10 +3037,18 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_s= s * ss, int base) } /* Also the data pointer. */ tmp =3D gfc_conv_array_data (se.expr); + /* If we have a native coarray with implied this_image (), add the + appropriate offset to the data pointer. */ + ref =3D ss_info->expr->ref; + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && ref + && ref->u.ar.dimen_type[ref->u.ar.dimen + ref->u.ar.codimen - 1] + =3D=3D DIMEN_THIS_IMAGE) + tmp =3D gfc_native_coarray_add_this_image_offset (tmp, se.expr, &ref->u= .ar, 1, 1); /* If this is a variable or address of a variable we use it directl= y. Otherwise we must evaluate it now to avoid breaking dependency analysis by pulling the expressions for elemental array indices inside the loop. */ + if (!(DECL_P (tmp) || (TREE_CODE (tmp) =3D=3D ADDR_EXPR && DECL_P (TREE_OPERAND (tmp, 0))))) @@ -2993,6 +3056,15 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss= * ss, int base) info->data =3D tmp; tmp =3D gfc_conv_array_offset (se.expr); + /* If we have a native coarray, adjust the offset to remove the + offset for the codimensions. */ + // TODO: check whether the recipient is a coarray, if it is, disabl= e + // all of this + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && ref + && ref->u.ar.dimen_type[ref->u.ar.dimen + ref->u.ar.codimen - 1] + =3D=3D DIMEN_THIS_IMAGE) + tmp =3D gfc_add_strides (tmp, se.expr, ref->u.ar.as->rank, + ref->u.ar.as->rank + ref->u.ar.as->corank); info->offset =3D gfc_evaluate_now (tmp, block); /* Make absolutely sure that the saved_offset is indeed saved @@ -3593,6 +3665,7 @@ build_array_ref (tree desc, tree offset, tree decl, = tree vptr) } + ###AV: ??? /* Build an array reference. se->expr already holds the array descriptor= . This should be either a variable, indirect variable reference or compo= nent reference. For arrays which do not have a descriptor, se->expr will b= e @@ -3612,8 +3685,20 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar= , gfc_expr *expr, gfc_se tmpse; gfc_symbol * sym =3D expr->symtree->n.sym; char *var_name =3D NULL; + bool need_impl_this_image; ###AV: Why name this 'need_...' when you're checking that it is an impl_th= is_image? ###AV: Better 'is_impl_this_image'? + int eff_dimen; + + need_impl_this_image =3D + ar->dimen_type[ar->dimen + ar->codimen - 1] =3D=3D DIMEN_THIS_IMAGE= ; + + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE + && !need_impl_this_image) + eff_dimen =3D ar->dimen + ar->codimen - 1; + else + eff_dimen =3D ar->dimen - 1; - if (ar->dimen =3D=3D 0) + + if (flag_coarray !=3D GFC_FCOARRAY_NATIVE && ar->dimen =3D=3D 0) { gcc_assert (ar->codimen || sym->attr.select_rank_temporary || (ar->as && ar->as->corank)); @@ -3681,7 +3766,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar,= gfc_expr *expr, /* Calculate the offsets from all the dimensions. Make sure to associa= te the final offset so that we form a chain of loop invariant summands.= */ - for (n =3D ar->dimen - 1; n >=3D 0; n--) + for (n =3D eff_dimen; n >=3D 0; n--) { /* Calculate the index for this dimension. */ gfc_init_se (&indexse, se); @@ -3753,6 +3838,9 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar,= gfc_expr *expr, add_to_offset (&cst_offset, &offset, tmp); } + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && need_impl_this_image) + offset =3D gfc_native_coarray_add_this_image_offset (offset, se->expr= , ar, 0, 0); + if (!integer_zerop (cst_offset)) offset =3D fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); @@ -5423,7 +5511,7 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int= corank) } */ /*GCC ARRAYS*/ -static tree +tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffse= t, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, @@ -5441,6 +5529,8 @@ gfc_array_init_size (tree descriptor, int rank, int = corank, tree * poffset, tree elsecase; tree cond; tree var; + tree conv_lbound; + tree conv_ubound; stmtblock_t thenblock; stmtblock_t elseblock; gfc_expr *ubound; @@ -5454,7 +5544,7 @@ gfc_array_init_size (tree descriptor, int rank, int = corank, tree * poffset, /* Set the dtype before the alloc, because registration of coarrays nee= ds it initialized. */ - if (expr->ts.type =3D=3D BT_CHARACTER + if (expr && expr->ts.type =3D=3D BT_CHARACTER && expr->ts.deferred && VAR_P (expr->ts.u.cl->backend_decl)) { @@ -5462,7 +5552,7 @@ gfc_array_init_size (tree descriptor, int rank, int = corank, tree * poffset, tmp =3D gfc_conv_descriptor_dtype (descriptor); gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); } - else if (expr->ts.type =3D=3D BT_CHARACTER + else if (expr && expr->ts.type =3D=3D BT_CHARACTER && expr->ts.deferred && TREE_CODE (descriptor) =3D=3D COMPONENT_REF) { @@ -5494,9 +5584,6 @@ gfc_array_init_size (tree descriptor, int rank, int = corank, tree * poffset, for (n =3D 0; n < rank; n++) { - tree conv_lbound; - tree conv_ubound; - ###AV: This changes semantics when not in shared coarray mode. I can't see= the ###AV: adjacent code here, but you better should do something like ###AV: >>> if (flag_coarray !=3D GFC_FCOARRAY_NATIVE) conv_lbound =3D conv_ubound =3D NULL_TREE; ###AV: <<< ###AV: here to keep semantics the same when not in shared coarray mode. Or= you ###AV: have to carefully examine each line of code in the loop to make sur= e ###AV: that keeping a former iteration's l|ubound does mean no harm. /* We have 3 possibilities for determining the size of the array: lower =3D=3D NULL =3D> lbound =3D 1, ubound =3D upper[n] upper[n] =3D NULL =3D> lbound =3D 1, ubound =3D lower[n] @@ -5646,6 +5733,15 @@ gfc_array_init_size (tree descriptor, int rank, int= corank, tree * poffset, } gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); + conv_lbound =3D se.expr; + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + { + + tmp =3D fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_t= ype, + se.expr, stride); + offset =3D fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, tmp); + } if (n < rank + corank - 1) { @@ -5655,6 +5751,18 @@ gfc_array_init_size (tree descriptor, int rank, int= corank, tree * poffset, gfc_add_block_to_block (pblock, &se.pre); gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); + gfc_conv_descriptor_stride_set (descriptor_block, descriptor, + gfc_rank_cst[n], stride); ###AV: This line looks dubious to me. Why is always needed and not only in ###AV: shared coarray mode? + conv_ubound =3D se.expr; + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + { + size =3D gfc_conv_array_extent_dim (conv_lbound, conv_ubound, + &or_expr); ###AV: Something went wrong with the indentation here. But that also be ju= st my ###AV: editor. + size =3D gfc_evaluate_now (size, descriptor_block); + stride =3D fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, size); + stride =3D gfc_evaluate_now (stride, descriptor_block); + } } } @@ -5688,7 +5796,7 @@ gfc_array_init_size (tree descriptor, int rank, int = corank, tree * poffset, /* Convert to size_t. */ *element_size =3D fold_convert (size_type_node, tmp); - if (rank =3D=3D 0) + if (rank =3D=3D 0 && !(flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && coran= k)) return *element_size; *nelems =3D gfc_evaluate_now (stride, pblock); @@ -5773,6 +5881,38 @@ retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev= _ref_in) return true; } +int +gfc_native_coarray_get_allocation_type (gfc_symbol * sym) +{ + bool is_lock_type, is_event_type; + is_lock_type =3D sym->ts.type =3D=3D BT_DERIVED + && sym->ts.u.derived->from_intmod =3D=3D INTMOD_ISO_FORTRAN_ENV + && sym->ts.u.derived->intmod_sym_id =3D=3D ISOFORTRAN_LOCK_TYPE; + + is_event_type =3D sym->ts.type =3D=3D BT_DERIVED + && sym->ts.u.derived->from_intmod =3D=3D INTMOD_ISO_FORTRAN_ENV + && sym->ts.u.derived->intmod_sym_id =3D=3D ISOFORTRAN_EVENT_TYPE; + + if (is_lock_type) + return GFC_NCA_LOCK_COARRAY; + else if (is_event_type) + return GFC_NCA_EVENT_COARRAY; + else + return GFC_NCA_NORMAL_COARRAY; +} + +void +gfc_allocate_native_coarray (stmtblock_t *b, tree decl, tree size, int co= rank, + int alloc_type) +{ + gfc_add_expr_to_block (b, + build_call_expr_loc (input_location, gfor_fndecl_nca_coarray_allocate, + 4, gfc_build_addr_expr (pvoid_type_node, decl), + size, build_int_cst (integer_type_node, corank), + build_int_cst (integer_type_node, alloc_type))); + +} + /* Initializes the descriptor and generates a call to _gfor_allocate. Do= es the work for an ALLOCATE statement. */ /*GCC ARRAYS*/ @@ -5784,6 +5924,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tr= ee status, tree errmsg, bool e3_has_nodescriptor) { tree tmp; + tree allocation; tree pointer; tree offset =3D NULL_TREE; tree token =3D NULL_TREE; @@ -5914,7 +6055,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tr= ee status, tree errmsg, expr3_elem_size, nelems, expr3, e3_arr_desc, e3_has_nodescriptor, expr, &element_size); - if (dimension) + if (dimension || (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && coarray)) ###AV: How about setting 'bool is_shared_coarray =3D flag_coarray =3D=3D G= FC_FCOARRAY_NATIVE && coarray;' ###AV: above and reusing it here over and over again? { var_overflow =3D gfc_create_var (integer_type_node, "overflow"); gfc_add_modify (&se->pre, var_overflow, overflow); @@ -5956,7 +6097,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tr= ee status, tree errmsg, pointer =3D gfc_conv_descriptor_data_get (se->expr); STRIP_NOPS (pointer); - if (allocatable) + if (allocatable && !(flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && coarray= )) { not_prev_allocated =3D gfc_create_var (logical_type_node, "not_prev_allocated"); @@ -5969,8 +6110,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, t= ree status, tree errmsg, gfc_start_block (&elseblock); + if (coarray && flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + { + tree elem_size + =3D size_in_bytes (gfc_get_element_type (TREE_TYPE(se->expr))); + int alloc_type + =3D gfc_native_coarray_get_allocation_type (expr->symtree->n.sym); + gfc_allocate_native_coarray (&elseblock, se->expr, elem_size, + ref->u.ar.as->corank, alloc_type); + } /* The allocatable variant takes the old pointer as first argument. */ - if (allocatable) + else if (allocatable) gfc_allocate_allocatable (&elseblock, pointer, size, token, status, errmsg, errlen, label_finish, expr, coref !=3D NULL ? coref->u.ar.as->corank : 0); @@ -5987,13 +6137,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, = tree status, tree errmsg, cond =3D gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, logical_type_node, var_overflow, integer_zero_node), PRED_FORTRAN_OVERFLOW); - tmp =3D fold_build3_loc (input_location, COND_EXPR, void_type_node,= cond, + allocation =3D fold_build3_loc (input_location, COND_EXPR, void_typ= e_node, cond, error, gfc_finish_block (&elseblock)); } else - tmp =3D gfc_finish_block (&elseblock); + allocation =3D gfc_finish_block (&elseblock); - gfc_add_expr_to_block (&se->pre, tmp); /* Update the array descriptor with the offset and the span. */ if (dimension) @@ -6004,6 +6153,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tr= ee status, tree errmsg, } set_descriptor =3D gfc_finish_block (&set_descriptor_block); + if (status !=3D NULL_TREE) { cond =3D fold_build2_loc (input_location, EQ_EXPR, @@ -6014,14 +6164,25 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, = tree status, tree errmsg, cond =3D fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node, cond, not_prev_allocated); - gfc_add_expr_to_block (&se->pre, - fold_build3_loc (input_location, COND_EXPR, void_type_node, + set_descriptor =3D fold_build3_loc (input_location, COND_EXPR, void= _type_node, cond, set_descriptor, - build_empty_stmt (input_location))); + build_empty_stmt (input_location)); + } + + // For native coarrays, the size must be set before the allocation rout= ine + // can be called. ###AV: GCC coding prefers block comments! + if (coarray && flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + { + gfc_add_expr_to_block (&se->pre, set_descriptor); + gfc_add_expr_to_block (&se->pre, allocation); } else + { + gfc_add_expr_to_block (&se->pre, allocation); gfc_add_expr_to_block (&se->pre, set_descriptor); + } + return true; } @@ -6524,6 +6685,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree t= mpdesc, bool optional_arg; gfc_array_spec *as; bool is_classarray =3D IS_CLASS_ARRAY (sym); + int eff_dimen; /* Do nothing for pointer and allocatable arrays. */ if ((sym->ts.type !=3D BT_CLASS && sym->attr.pointer) @@ -6638,8 +6800,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree = tmpdesc, offset =3D gfc_index_zero_node; size =3D gfc_index_one_node; + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + eff_dimen =3D as->rank + as->corank; + else + eff_dimen =3D as->rank; + /* Evaluate the bounds of the array. */ - for (n =3D 0; n < as->rank; n++) + for (n =3D 0; n < eff_dimen; n++) { if (checkparm || !as->upper[n]) { @@ -6724,7 +6891,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree t= mpdesc, gfc_array_index_type, offset, tmp); /* The size of this dimension, and the stride of the next. */ - if (n + 1 < as->rank) + if (n + 1 < eff_dimen) { stride =3D GFC_TYPE_ARRAY_STRIDE (type, n + 1); @@ -6879,20 +7046,35 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree p= arm, tree desc, tree offset, return; } + /* if it's a coarray with implicit this_image, add that to the offset. = */ + ref =3D expr->ref; + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && ref && ref->type =3D=3D = REF_ARRAY + && ref->u.ar.dimen_type[ref->u.ar.dimen + ref->u.ar.codimen - 1] + =3D=3D DIMEN_THIS_IMAGE + && !ref->u.ar.native_coarray_argument) + offset =3D gfc_native_coarray_add_this_image_offset (offset, desc, + &ref->u.ar, 0, 1); + tmp =3D build_array_ref (desc, offset, NULL, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer =3D> my_type(:)%integer_component. *= / if (subref) { - /* Go past the array reference. */ + /* Go past the array reference. */ ###AV: Nop, '. */' i.e. dot, two spaces, closing comment marked is accord= ing ###AV: to the style guide the way required. for (ref =3D expr->ref; ref; ref =3D ref->next) - if (ref->type =3D=3D REF_ARRAY && - ref->u.ar.type !=3D AR_ELEMENT) - { - ref =3D ref->next; - break; - } + { + if (ref->type =3D=3D REF_ARRAY && + ref->u.ar.type !=3D AR_ELEMENT) + { + ref =3D ref->next; + break; + } + else if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && ref->type =3D=3D R= EF_ARRAY && + ref->u.ar.dimen_type[ref->u.ar.dimen +ref->u.ar.codimen -1] + =3D=3D DIMEN_THIS_IMAGE) + tmp =3D gfc_native_coarray_add_this_image_offset (tmp, desc, &ref->u= .ar, 0, 1); + } /* Calculate the offset for each subsequent subreference. */ for (; ref; ref =3D ref->next) @@ -6955,7 +7137,10 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree pa= rm, tree desc, tree offset, gfc_array_index_type, stride, itmp); stride =3D gfc_evaluate_now (stride, block); } - + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && + ref->u.ar.dimen_type[ref->u.ar.dimen +ref->u.ar.codimen -1] ###AV: A space goes before and after each operator! + =3D=3D DIMEN_THIS_IMAGE) + tmp =3D gfc_native_coarray_add_this_image_offset (tmp, desc, &ref->u.ar= , 0, 1); /* Apply the index to obtain the array element. */ tmp =3D gfc_build_array_ref (tmp, index, NULL); break; @@ -7306,6 +7491,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *exp= r) else full =3D gfc_full_array_ref_p (info->ref, NULL); + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && + info->ref->type =3D=3D REF_ARRAY && + info->ref->u.ar.dimen_type[info->ref->u.ar.dimen + + info->ref->u.ar.codimen - 1] =3D=3D + DIMEN_THIS_IMAGE) + full =3D 0; + if (full && !transposed_dims (ss)) { if (se->direct_byref && !se->byref_noassign) @@ -7540,9 +7732,19 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *exp= r) tree to; tree base; tree offset; - +#if 0 /* TK */ ndim =3D info->ref ? info->ref->u.ar.dimen : ss->dimen; - +#else + if (info->ref) + { + if (info->ref->u.ar.native_coarray_argument) + ndim =3D info->ref->u.ar.dimen + info->ref->u.ar.codimen; + else + ndim =3D info->ref->u.ar.dimen; + } + else + ndim =3D ss->dimen; +#endif ###AV: FIX !!! if (se->want_coarray) { gfc_array_ref *ar =3D &info->ref->u.ar; @@ -7911,7 +8113,15 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * e= xpr, bool g77, expr->ts.u.cl->backend_decl =3D tmp; se->string_length =3D tmp; } - +#if 0 + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && fsym && fsym->attr.codim= ension && sym) + { + gfc_init_se (se, NULL); + tmp =3D gfc_get_symbol_decl (sym); + se->expr =3D gfc_build_addr_expr (NULL_TREE, tmp); + return; + } +#endif ###AV: FIX !!! /* Is this the result of the enclosing procedure? */ this_array_result =3D (full_array_var && sym->attr.flavor =3D=3D FL_PRO= CEDURE); if (this_array_result @@ -7919,6 +8129,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * e= xpr, bool g77, && (sym->backend_decl !=3D parent)) this_array_result =3D false; +#if 1 /* TK */ + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && fsym && fsym->attr.codim= ension) + g77 =3D false; +#endif ###AV: Fix !!! /* Passing address of the array if it is not pointer or assumed-shape. = */ if (full_array_var && g77 && !this_array_result && sym->ts.type !=3D BT_DERIVED && sym->ts.type !=3D BT_CLASS) @@ -8053,8 +8267,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * ex= pr, bool g77, { /* Every other type of array. */ se->want_pointer =3D 1; - gfc_conv_expr_descriptor (se, expr); + gfc_conv_expr_descriptor (se, expr); ###AV: Uhh? if (size) array_parameter_size (build_fold_indirect_ref_loc (input_location, se->expr), @@ -10869,9 +11083,15 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr,= gfc_ref * ref) case AR_SECTION: newss =3D gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION); newss->info->data.array.ref =3D ref; - +#if 1 /* TK */ + int eff_dimen; + if (ar->native_coarray_argument) + eff_dimen =3D ar->dimen + ar->codimen; + else + eff_dimen =3D ar->dimen; +#endif ###AV: Fix !!! /* We add SS chains for all the subscripts in the section. */ - for (n =3D 0; n < ar->dimen; n++) + for (n =3D 0; n < eff_dimen; n++) { gfc_ss *indexss; diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index e561605aaed..0bfd1b03022 100644 =2D-- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -23,6 +23,15 @@ along with GCC; see the file COPYING3. If not see bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, tree, tree *, gfc_expr *, tree, bool); +enum gfc_coarray_allocation_type { + GFC_NCA_NORMAL_COARRAY =3D 3, ###AV: Why does this start with 3? + GFC_NCA_LOCK_COARRAY, + GFC_NCA_EVENT_COARRAY +}; ###AV: Add an empty line between the enum the func decl. +int gfc_native_coarray_get_allocation_type (gfc_symbol *); + +void gfc_allocate_native_coarray (stmtblock_t *, tree, tree, int, int); + /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, gfc_se *, gfc_array_spec *); @@ -57,6 +66,10 @@ tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, in= t, tree, tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int); tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree); +tree gfc_array_init_size (tree, int, int, tree *, gfc_expr **, gfc_expr *= *, + stmtblock_t *, stmtblock_t *, tree *, tree, tree *, + gfc_expr *, tree, bool, gfc_expr *, tree *); + 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 92242771dde..5eadf40e367 100644 =2D-- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -170,6 +170,21 @@ tree gfor_fndecl_co_reduce; tree gfor_fndecl_co_sum; tree gfor_fndecl_caf_is_present; +/* Native coarray functions. */ + +tree gfor_fndecl_nca_master; +tree gfor_fndecl_nca_coarray_allocate; +tree gfor_fndecl_nca_coarray_free; +tree gfor_fndecl_nca_this_image; +tree gfor_fndecl_nca_num_images; +tree gfor_fndecl_nca_sync_all; +tree gfor_fndecl_nca_sync_images; +tree gfor_fndecl_nca_lock; +tree gfor_fndecl_nca_unlock; +tree gfor_fndecl_nca_reduce_scalar; +tree gfor_fndecl_nca_reduce_array; +tree gfor_fndecl_nca_broadcast_scalar; +tree gfor_fndecl_nca_broadcast_array; /* Math functions. Many other math functions are handled in trans-intrinsic.c. */ @@ -961,6 +976,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym= ) tree type; int dim; int nest; + int eff_dimen; gfc_namespace* procns; symbol_attribute *array_attr; gfc_array_spec *as; @@ -1031,8 +1047,12 @@ gfc_build_qualified_array (tree decl, gfc_symbol * = sym) else gfc_add_decl_to_function (token); } + + eff_dimen =3D flag_coarray =3D=3D GFC_FCOARRAY_NATIVE + ? GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) + : GFC_TYPE_ARRAY_RANK (type); - for (dim =3D 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++) + for (dim =3D 0; dim < eff_dimen; dim++) { if (GFC_TYPE_ARRAY_LBOUND (type, dim) =3D=3D NULL_TREE) { @@ -1054,22 +1074,30 @@ gfc_build_qualified_array (tree decl, gfc_symbol *= sym) TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) =3D 1; } } - for (dim =3D GFC_TYPE_ARRAY_RANK (type); - dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); d= im++) - { - if (GFC_TYPE_ARRAY_LBOUND (type, dim) =3D=3D NULL_TREE) - { - GFC_TYPE_ARRAY_LBOUND (type, dim) =3D create_index_var ("lbound", nest= ); - TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) =3D 1; - } - /* Don't try to use the unknown ubound for the last coarray dimensi= on. */ - if (GFC_TYPE_ARRAY_UBOUND (type, dim) =3D=3D NULL_TREE - && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (ty= pe) - 1) - { - GFC_TYPE_ARRAY_UBOUND (type, dim) =3D create_index_var ("ubound", nest= ); - TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) =3D 1; - } - } + + if (flag_coarray !=3D GFC_FCOARRAY_NATIVE) + for (dim =3D GFC_TYPE_ARRAY_RANK (type); + dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); + dim++) + { + if (GFC_TYPE_ARRAY_LBOUND (type, dim) =3D=3D NULL_TREE) + { + GFC_TYPE_ARRAY_LBOUND (type, dim) + =3D create_index_var ("lbound", nest); + TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) =3D 1; + } + /* Don't try to use the unknown ubound for the last coarray + dimension. */ + if (GFC_TYPE_ARRAY_UBOUND (type, dim) =3D=3D NULL_TREE + && dim < GFC_TYPE_ARRAY_RANK (type) + + GFC_TYPE_ARRAY_CORANK (type) - 1) + { + GFC_TYPE_ARRAY_UBOUND (type, dim) + =3D create_index_var ("ubound", nest); + TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) =3D 1; + } + } + ###AV: No need to do something similar for shared coarrays? if (GFC_TYPE_ARRAY_OFFSET (type) =3D=3D NULL_TREE) { GFC_TYPE_ARRAY_OFFSET (type) =3D gfc_create_var_np (gfc_array_index= _type, @@ -1202,6 +1230,10 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree = dummy) || (as && as->type =3D=3D AS_ASSUMED_RANK)) return dummy; + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && sym->attr.codimension + && sym->attr.allocatable) + return dummy; + /* Add to list of variables if not a fake result variable. These symbols are set on the symbol only, not on the class component= . */ if (sym->attr.result || sym->attr.dummy) @@ -1504,7 +1536,6 @@ add_attributes_to_decl (symbol_attribute sym_attr, t= ree list) static void build_function_decl (gfc_symbol * sym, bool global); - /* Return the decl for a gfc_symbol, create it if it doesn't already exist. */ @@ -1820,7 +1851,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) } /* Remember this variable for allocation/cleanup. */ - if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimensi= on + if (sym->attr.dimension || sym->attr.codimension || sym->attr.allocatab= le ###AV: Unnecessary! || (sym->ts.type =3D=3D BT_CLASS && (CLASS_DATA (sym)->attr.dimension || CLASS_DATA (sym)->attr.allocatable)) @@ -1869,6 +1900,9 @@ gfc_get_symbol_decl (gfc_symbol * sym) gcc_assert (!sym->value || sym->value->expr_type =3D=3D EXPR_NULL); } + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && sym->attr.codimension) + TREE_STATIC(decl) =3D 1; + gfc_finish_var_decl (decl, sym); if (sym->ts.type =3D=3D BT_CHARACTER) @@ -3693,6 +3727,7 @@ void gfc_build_builtin_function_decls (void) { tree gfc_int8_type_node =3D gfc_get_int_type (8); + tree pint_type =3D build_pointer_type (integer_type_node); gfor_fndecl_stop_numeric =3D gfc_build_library_function_decl ( get_identifier (PREFIX("stop_numeric")), @@ -3820,9 +3855,8 @@ gfc_build_builtin_function_decls (void) /* Coarray library calls. */ if (flag_coarray =3D=3D GFC_FCOARRAY_LIB) { - tree pint_type, pppchar_type; + tree pppchar_type; - pint_type =3D build_pointer_type (integer_type_node); pppchar_type =3D build_pointer_type (build_pointer_type (pchar_type_node)); @@ -4062,6 +4096,68 @@ gfc_build_builtin_function_decls (void) integer_type_node, 3, pvoid_type_node, integer_type_node, pvoid_type_node); } + else if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + { + gfor_fndecl_nca_master =3D gfc_build_library_function_decl_with_spe= c ( + get_identifier (PREFIX("nca_master")), ".r", integer_type_node, 1, + build_pointer_type (build_function_type_list (void_type_node, NULL_TREE)= )); + gfor_fndecl_nca_coarray_allocate =3D gfc_build_library_function_dec= l_with_spec ( + get_identifier (PREFIX("nca_coarray_alloc")), "..RRR", integer_type_nod= e, 4, + pvoid_type_node, integer_type_node, integer_type_node, integer_type_node= , + NULL_TREE); + gfor_fndecl_nca_coarray_free =3D gfc_build_library_function_decl_wi= th_spec ( + get_identifier (PREFIX("nca_coarray_free")), "..R", integer_type_node, = 2, + pvoid_type_node, /* Pointer to the descriptor to be deallocated. */ + integer_type_node, /* Type of allocation (normal, event, lock). */ + NULL_TREE); + gfor_fndecl_nca_this_image =3D gfc_build_library_function_decl_with= _spec ( + get_identifier (PREFIX("nca_coarray_this_image")), ".X", integer_type_no= de, 1, + integer_type_node, /* This is the team number. Currently ignored. */ + NULL_TREE); + DECL_PURE_P (gfor_fndecl_nca_this_image) =3D 1; + gfor_fndecl_nca_num_images =3D gfc_build_library_function_decl_with= _spec ( + get_identifier (PREFIX("nca_coarray_num_images")), ".X", integer_type_no= de, 1, + integer_type_node, /* See above. */ + NULL_TREE); + DECL_PURE_P (gfor_fndecl_nca_num_images) =3D 1; + gfor_fndecl_nca_sync_all =3D gfc_build_library_function_decl_with_s= pec ( + get_identifier (PREFIX("nca_coarray_sync_all")), ".X", void_type_node, 1= , + build_pointer_type (integer_type_node), NULL_TREE); + gfor_fndecl_nca_sync_images =3D gfc_build_library_function_decl_wit= h_spec ( + get_identifier (PREFIX("nca_sync_images")), ".RRXXX", void_type_node, + 5, integer_type_node, pint_type, pint_type, + pchar_type_node, size_type_node, NULL_TREE); + gfor_fndecl_nca_lock =3D gfc_build_library_function_decl_with_spec = ( + get_identifier (PREFIX("nca_lock")), ".w", void_type_node, 1, + pvoid_type_node, NULL_TREE); + gfor_fndecl_nca_unlock =3D gfc_build_library_function_decl_with_spe= c ( + get_identifier (PREFIX("nca_unlock")), ".w", void_type_node, 1, + pvoid_type_node, NULL_TREE); + + gfor_fndecl_nca_reduce_scalar =3D + gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("nca_collsub_reduce_scalar")), ".wrW", + void_type_node, 3, pvoid_type_node, + build_pointer_type (build_function_type_list (void_type_node, + pvoid_type_node, pvoid_type_node, NULL_TREE)), + pint_type, NULL_TREE); + + gfor_fndecl_nca_reduce_array =3D + gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("nca_collsub_reduce_array")), ".wrWR", + void_type_node, 4, pvoid_type_node, + build_pointer_type (build_function_type_list (void_type_node, + pvoid_type_node, pvoid_type_node, NULL_TREE)), + pint_type, integer_type_node, NULL_TREE); + + gfor_fndecl_nca_broadcast_scalar =3D gfc_build_library_function_dec= l_with_spec ( + get_identifier (PREFIX ("nca_collsub_broadcast_scalar")), ".w..", + void_type_node, 3, pvoid_type_node, size_type_node, integer_type_node); + gfor_fndecl_nca_broadcast_array =3D gfc_build_library_function_decl= _with_spec ( + get_identifier (PREFIX ("nca_collsub_broadcast_array")), ".W.", + void_type_node, 2, pvoid_type_node, integer_type_node); + } ###AV: Note, I just learned, that the spec strings ".W." have changed. The= re is ###AV: a space after each character. Making them something like ". W . ". + gfc_build_intrinsic_function_decls (); gfc_build_intrinsic_lib_fndecls (); @@ -4538,6 +4634,74 @@ get_proc_result (gfc_symbol* sym) } +void +gfc_trans_native_coarray (stmtblock_t * init, stmtblock_t *cleanup, gfc_s= ymbol * sym) +{ + tree tmp, decl; + tree overflow =3D build_int_cst (integer_type_node, 0), nelems, element= _size; //All unused ###AV: "//All unused" means what? Remove what is not used anymore. + tree offset; + tree elem_size; + int alloc_type; + + decl =3D sym->backend_decl; + + TREE_STATIC(decl) =3D 1; + + /* Tell the library to handle arrays of locks and event types seperatly= . */ + alloc_type =3D gfc_native_coarray_get_allocation_type (sym); + + if (init) + { + gfc_array_init_size (decl, sym->as->rank, sym->as->corank, &offset, + sym->as->lower, sym->as->upper, init, + init, &overflow, + NULL_TREE, &nelems, NULL, + NULL_TREE, true, NULL, &element_size); + gfc_conv_descriptor_offset_set (init, decl, offset); + elem_size =3D size_in_bytes (gfc_get_element_type (TREE_TYPE(decl))= ); + gfc_allocate_native_coarray (init, decl, elem_size, sym->as->corank= , + alloc_type); + } + + if (cleanup) + { + tmp =3D build_call_expr_loc (input_location, gfor_fndecl_nca_coarra= y_free, + 2, gfc_build_addr_expr (pvoid_type_node, decl), + build_int_cst (integer_type_node, alloc_type)); + gfc_add_expr_to_block (cleanup, tmp); + } +} + +static void +finish_coarray_constructor_function (tree *, tree *); + +static void +generate_coarray_constructor_function (tree *, tree *); + +static void +gfc_trans_native_coarray_static (gfc_symbol * sym) +{ + tree save_fn_decl, fndecl; + generate_coarray_constructor_function (&save_fn_decl, &fndecl); + gfc_trans_native_coarray (&caf_init_block, NULL, sym); + finish_coarray_constructor_function (&save_fn_decl, &fndecl); +} + +static void +gfc_trans_native_coarray_inline (gfc_wrapped_block * block, gfc_symbol * = sym) +{ + stmtblock_t init, cleanup; + + gfc_init_block (&init); + gfc_init_block (&cleanup); + + gfc_trans_native_coarray (&init, &cleanup, sym); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), gfc_finish_block= (&cleanup)); +} + + + /* Generate function entry and exit code, and add it to the function body= . This includes: Allocation and initialization of array variables. @@ -4833,7 +4997,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_= wrapped_block * block) gfc_trans_deferred_array (sym, block); } } - else if (sym->attr.codimension + else if (flag_coarray !=3D GFC_FCOARRAY_NATIVE + && sym->attr.codimension && TREE_STATIC (sym->backend_decl)) { gfc_init_block (&tmpblock); @@ -4843,6 +5008,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc= _wrapped_block * block) NULL_TREE); continue; } + else if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE + && sym->attr.codimension) + { + gfc_trans_native_coarray_inline (block, sym); + } else { gfc_save_backend_locus (&loc); @@ -5333,6 +5503,11 @@ gfc_create_module_variable (gfc_symbol * sym) && sym->fn_result_spec)); DECL_CONTEXT (decl) =3D sym->ns->proc_name->backend_decl; rest_of_decl_compilation (decl, 1, 0); + + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && sym->attr.codimension + && !sym->attr.allocatable) + gfc_trans_native_coarray_static (sym); + gfc_module_add_decl (cur_module, decl); /* Also add length of strings. */ @@ -5730,64 +5905,82 @@ generate_coarray_sym_init (gfc_symbol *sym) } -/* Generate constructor function to initialize static, nonallocatable - coarrays. */ static void -generate_coarray_init (gfc_namespace * ns __attribute((unused))) +generate_coarray_constructor_function (tree *save_fn_decl, tree *fndecl) { - tree fndecl, tmp, decl, save_fn_decl; + tree tmp, decl; - save_fn_decl =3D current_function_decl; + *save_fn_decl =3D current_function_decl; push_function_context (); tmp =3D build_function_type_list (void_type_node, NULL_TREE); - fndecl =3D build_decl (input_location, FUNCTION_DECL, - create_tmp_var_name ("_caf_init"), tmp); + *fndecl =3D build_decl (input_location, FUNCTION_DECL, + create_tmp_var_name (flag_coarray =3D=3D GFC_FCOARRAY_LIB ? "_ca= f_init" : "_nca_init"), tmp); ###AV: IMHO there is a line length limit of 80 characters! - DECL_STATIC_CONSTRUCTOR (fndecl) =3D 1; - SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY); + DECL_STATIC_CONSTRUCTOR (*fndecl) =3D 1; + SET_DECL_INIT_PRIORITY (*fndecl, DEFAULT_INIT_PRIORITY); decl =3D build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_= node); DECL_ARTIFICIAL (decl) =3D 1; DECL_IGNORED_P (decl) =3D 1; - DECL_CONTEXT (decl) =3D fndecl; - DECL_RESULT (fndecl) =3D decl; + DECL_CONTEXT (decl) =3D *fndecl; + DECL_RESULT (*fndecl) =3D decl; - pushdecl (fndecl); - current_function_decl =3D fndecl; - announce_function (fndecl); + pushdecl (*fndecl); + current_function_decl =3D *fndecl; + announce_function (*fndecl); - rest_of_decl_compilation (fndecl, 0, 0); - make_decl_rtl (fndecl); - allocate_struct_function (fndecl, false); + rest_of_decl_compilation (*fndecl, 0, 0); + make_decl_rtl (*fndecl); + allocate_struct_function (*fndecl, false); pushlevel (); gfc_init_block (&caf_init_block); +} - gfc_traverse_ns (ns, generate_coarray_sym_init); +static void +finish_coarray_constructor_function (tree *save_fn_decl, tree *fndecl) +{ + tree decl; - DECL_SAVED_TREE (fndecl) =3D gfc_finish_block (&caf_init_block); + DECL_SAVED_TREE (*fndecl) =3D gfc_finish_block (&caf_init_block); decl =3D getdecls (); poplevel (1, 1); - BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) =3D fndecl; + BLOCK_SUPERCONTEXT (DECL_INITIAL (*fndecl)) =3D *fndecl; - DECL_SAVED_TREE (fndecl) - =3D build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl), - DECL_INITIAL (fndecl)); - dump_function (TDI_original, fndecl); + DECL_SAVED_TREE (*fndecl) + =3D build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (*fndecl), + DECL_INITIAL (*fndecl)); + dump_function (TDI_original, *fndecl); cfun->function_end_locus =3D input_location; set_cfun (NULL); - if (decl_function_context (fndecl)) - (void) cgraph_node::create (fndecl); + if (decl_function_context (*fndecl)) + (void) cgraph_node::create (*fndecl); else - cgraph_node::finalize_function (fndecl, true); + cgraph_node::finalize_function (*fndecl, true); pop_function_context (); - current_function_decl =3D save_fn_decl; + current_function_decl =3D *save_fn_decl; +} + +/* Generate constructor function to initialize static, nonallocatable + coarrays. */ + +static void +generate_coarray_init (gfc_namespace * ns) +{ + tree save_fn_decl, fndecl; + + generate_coarray_constructor_function (&save_fn_decl, &fndecl); + + gfc_traverse_ns (ns, generate_coarray_sym_init); + + finish_coarray_constructor_function (&save_fn_decl, &fndecl); + } @@ -6470,7 +6663,11 @@ create_main_function (tree fndecl) } /* Call MAIN__(). */ - tmp =3D build_call_expr_loc (input_location, + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + tmp =3D build_call_expr_loc (input_location, gfor_fndecl_nca_master, = 1, + gfc_build_addr_expr (NULL, fndecl)); + else + tmp =3D build_call_expr_loc (input_location, fndecl, 0); gfc_add_expr_to_block (&body, tmp); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 36ff9b5cbc6..99799801fcb 100644 =2D-- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2622,8 +2622,14 @@ gfc_maybe_dereference_var (gfc_symbol *sym, tree va= r, bool descriptor_only_p, } else if (!sym->attr.value) { + + /* Do not derefernce native coarray dummies. */ + if (false && flag_coarray =3D=3D GFC_FCOARRAY_NATIVE + && sym->attr.codimension && sym->attr.dummy) + return var; + ###AV: Unused code! Remove! 'if (false && ...' can never eval to true. /* Dereference temporaries for class array dummy arguments. */ - if (sym->attr.dummy && is_classarray + else if (sym->attr.dummy && is_classarray && GFC_ARRAY_TYPE_P (TREE_TYPE (var))) { if (!descriptor_only_p) @@ -2635,6 +2641,7 @@ gfc_maybe_dereference_var (gfc_symbol *sym, tree var= , bool descriptor_only_p, /* Dereference non-character scalar dummy arguments. */ if (sym->attr.dummy && !sym->attr.dimension && !(sym->attr.codimension && sym->attr.allocatable) + && !(sym->attr.codimension && flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) && (sym->ts.type !=3D BT_CLASS || (!CLASS_DATA (sym)->attr.dimension && !(CLASS_DATA (sym)->attr.codimension @@ -2670,6 +2677,7 @@ gfc_maybe_dereference_var (gfc_symbol *sym, tree var= , bool descriptor_only_p, || CLASS_DATA (sym)->attr.allocatable || CLASS_DATA (sym)->attr.class_pointer)) var =3D build_fold_indirect_ref_loc (input_location, var); + /* And the case where a non-dummy, non-result, non-function, non-allotable and non-pointer classarray is present. This case was previously covered by the first if, but with introducing the @@ -5528,7 +5536,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * = sym, nodesc_arg =3D nodesc_arg || !comp->attr.always_explicit; else nodesc_arg =3D nodesc_arg || !sym->attr.always_explicit; - +#if 0 + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && fsym->attr.codimensi= on) + nodesc_arg =3D false; +#endif ###AV: Fix or remove! /* Class array expressions are sometimes coming completely unadorne= d with either arrayspec or _data component. Correct that here. OOP-TODO: Move this to the frontend. */ @@ -5720,7 +5731,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * = sym, parmse.want_coarray =3D 1; scalar =3D false; } - +#if 0 + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && fsym->attr.codimension) + scalar =3D false; +#endif ###AV: Fix or remove! /* A scalar or transformational function. */ if (scalar) { @@ -6233,7 +6247,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * s= ym, else gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym, sym->name, NULL); - + ###AV: hu? /* Unallocated allocatable arrays and unassociated pointer arrays need their dtype setting if they are argument associated with assumed rank dummies. */ diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 32fe9886c57..b4183217f49 100644 =2D-- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -41,6 +41,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-array.h" #include "dependency.h" /* For CAF array alias analysis. */ /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ +#include "trans-stmt.h" /* This maps Fortran intrinsic math functions to external library or GCC builtin functions. */ @@ -2363,7 +2364,6 @@ conv_caf_send (gfc_code *code) { return gfc_finish_block (&block); } - static void trans_this_image (gfc_se * se, gfc_expr *expr) { @@ -2394,14 +2394,18 @@ trans_this_image (gfc_se * se, gfc_expr *expr) } else tmp =3D integer_zero_node; - tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_this_i= mage, 1, - tmp); + tmp =3D build_call_expr_loc (input_location, + flag_coarray =3D=3D GFC_FCOARRAY_NATIVE ? + gfor_fndecl_nca_this_image : + gfor_fndecl_caf_this_image, + 1, tmp); se->expr =3D fold_convert (gfc_get_int_type (gfc_default_integer_ki= nd), tmp); return; } /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */ + /* TODO: NCA handle native coarrays. */ ###AV: What? type =3D gfc_get_int_type (gfc_default_integer_kind); corank =3D gfc_get_corank (expr->value.function.actual->expr); @@ -2490,8 +2494,11 @@ trans_this_image (gfc_se * se, gfc_expr *expr) */ /* this_image () - 1. */ - tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_this_image= , 1, - integer_zero_node); + tmp =3D build_call_expr_loc (input_location, + flag_coarray =3D=3D GFC_FCOARRAY_NATIVE + ? gfor_fndecl_nca_this_image + : gfor_fndecl_caf_this_image, ###AV: Style: Align the colon beneath the '?'. + 1, integer_zero_node); tmp =3D fold_build2_loc (input_location, MINUS_EXPR, type, fold_convert (type, tmp), build_int_cst (type, 1)); if (corank =3D=3D 1) @@ -2774,7 +2781,10 @@ trans_image_index (gfc_se * se, gfc_expr *expr) num_images =3D build_int_cst (type, 1); else { - tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_num_im= ages, 2, + tmp =3D build_call_expr_loc (input_location, + flag_coarray =3D=3D GFC_FCOARRAY_NATIVE + ? gfor_fndecl_nca_num_images + : gfor_fndecl_caf_num_images, 2, integer_zero_node, build_int_cst (integer_type_node, -1)); num_images =3D fold_convert (type, tmp); @@ -2819,8 +2829,13 @@ trans_num_images (gfc_se * se, gfc_expr *expr) } else failed =3D build_int_cst (integer_type_node, -1); - tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_num_images= , 2, - distance, failed); + + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + tmp =3D build_call_expr_loc (input_location, gfor_fndecl_nca_num_imag= es, 1, + distance); + else + tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_num_imag= es, 2, + distance, failed); se->expr =3D fold_convert (gfc_get_int_type (gfc_default_integer_kind),= tmp); } @@ -3264,7 +3279,10 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * exp= r) tree cosize; cosize =3D gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank); - tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_num_image= s, + tmp =3D build_call_expr_loc (input_location, + flag_coarray =3D=3D GFC_FCOARRAY_NATIVE + ? gfor_fndecl_nca_num_images + : gfor_fndecl_caf_num_images, 2, integer_zero_node, build_int_cst (integer_type_node, -1)); tmp =3D fold_build2_loc (input_location, MINUS_EXPR, @@ -3280,7 +3298,9 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr= ) else if (flag_coarray !=3D GFC_FCOARRAY_SINGLE) { /* ubound =3D lbound + num_images() - 1. */ - tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_num_image= s, + tmp =3D build_call_expr_loc (input_location, + flag_coarray =3D=3D GFC_FCOARRAY_NATIVE ? gfor_fndecl_nca_num_im= ages : + gfor_fndecl_caf_num_images, ###AV: Style! 2, integer_zero_node, build_int_cst (integer_type_node, -1)); tmp =3D fold_build2_loc (input_location, MINUS_EXPR, @@ -11004,6 +11024,136 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_ex= pr * expr, } } +/* Helper function - advance to the next argument. */ + +static tree +trans_argument (gfc_actual_arglist **curr_al, stmtblock_t *blk, ###AV: I don't like the name. This name implies that only one argument is ###AV: translated, but it is doing so much more + stmtblock_t *postblk, gfc_se *argse, tree def) +{ + if (!(*curr_al)->expr) + return def; + if ((*curr_al)->expr->rank > 0) ###AV: Why is this testing for rank only and not also for corank? + gfc_conv_expr_descriptor (argse, (*curr_al)->expr); + else + gfc_conv_expr (argse, (*curr_al)->expr); + gfc_add_block_to_block (blk, &argse->pre); + gfc_add_block_to_block (postblk, &argse->post); + *curr_al =3D (*curr_al)->next; + return argse->expr; +} + +/* Convert CO_REDUCE for native coarrays. */ + +static tree +conv_nca_reduce (gfc_code *code, stmtblock_t *blk, stmtblock_t *postblk) +{ + gfc_actual_arglist *curr_al; + tree var, reduce_op, result_image, elem_size; + gfc_se argse; + int is_array; + + curr_al =3D code->ext.actual; + + gfc_init_se (&argse, NULL); + argse.want_pointer =3D 1; + is_array =3D curr_al->expr->rank > 0; ###AV: Move the argse treatment into the trans_argument and stop repeating ###AV: yourself. + var =3D trans_argument (&curr_al, blk, postblk, &argse, NULL_TREE); + + gfc_init_se (&argse, NULL); + argse.want_pointer =3D 1; + reduce_op =3D trans_argument (&curr_al, blk, postblk, &argse, NULL_TREE= ); + + gfc_init_se (&argse, NULL); + argse.want_pointer =3D 1; + result_image =3D trans_argument (&curr_al, blk, postblk, &argse, + null_pointer_node); + + if (is_array) + return build_call_expr_loc (input_location, gfor_fndecl_nca_reduce_ar= ray, + 3, var, reduce_op, result_image); + + elem_size =3D size_in_bytes(TREE_TYPE(TREE_TYPE(var))); + return build_call_expr_loc (input_location, gfor_fndecl_nca_reduce_scal= ar, 4, + var, elem_size, reduce_op, result_image); +} + +static tree +conv_nca_broadcast (gfc_code *code, stmtblock_t *blk, stmtblock_t *postbl= k) +{ + gfc_actual_arglist *curr_al; + tree var, source_image, elem_size; + gfc_se argse; + int is_array; + + curr_al =3D code->ext.actual; + + gfc_init_se (&argse, NULL); + argse.want_pointer =3D 1; + is_array =3D curr_al->expr->rank > 0; + var =3D trans_argument (&curr_al, blk, postblk, &argse, NULL_TREE); + + gfc_init_se (&argse, NULL); + argse.want_pointer =3D 0; + source_image =3D trans_argument (&curr_al, blk, postblk, &argse, NULL_T= REE); + + if (is_array) + return build_call_expr_loc (input_location, gfor_fndecl_nca_broadcast= _array, + 2, var, source_image); + + elem_size =3D size_in_bytes(TREE_TYPE(TREE_TYPE(var))); + return build_call_expr_loc (input_location, gfor_fndecl_nca_broadcast_s= calar, + 3, var, elem_size, source_image); +} + +static tree conv_co_collective (gfc_code *); + +/* Convert collective subroutines for native coarrays. */ + +static tree +conv_nca_collective (gfc_code *code) +{ + + switch (code->resolved_isym->id) + { + case GFC_ISYM_CO_REDUCE: + { + stmtblock_t block, postblock; + tree fcall; + + gfc_start_block (&block); + gfc_init_block (&postblock); + fcall =3D conv_nca_reduce (code, &block, &postblock); + gfc_add_expr_to_block (&block, fcall); + gfc_add_block_to_block (&block, &postblock); + return gfc_finish_block (&block); + } + case GFC_ISYM_CO_SUM: + case GFC_ISYM_CO_MIN: + case GFC_ISYM_CO_MAX: + return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false); + + case GFC_ISYM_CO_BROADCAST: + { + stmtblock_t block, postblock; + tree fcall; + + gfc_start_block (&block); + gfc_init_block (&postblock); + fcall =3D conv_nca_broadcast (code, &block, &postblock); + gfc_add_expr_to_block (&block, fcall); + gfc_add_block_to_block (&block, &postblock); + return gfc_finish_block (&block); + } +#if 0 + case GFC_ISYM_CO_BROADCAST: + return conv_co_collective (code); +#endif ###AV: Fix!!! + default: + gfc_internal_error ("Invalid or unsupported isym"); + break; + } +} + static tree conv_co_collective (gfc_code *code) { @@ -11111,7 +11261,13 @@ conv_co_collective (gfc_code *code) errmsg_len =3D build_zero_cst (size_type_node); } + /* For native coarrays, we only come here for CO_BROADCAST. */ + + gcc_assert (code->resolved_isym->id =3D=3D GFC_ISYM_CO_BROADCAST + || flag_coarray !=3D GFC_FCOARRAY_NATIVE); + /* Generate the function call. */ + switch (code->resolved_isym->id) { case GFC_ISYM_CO_BROADCAST: @@ -12104,7 +12260,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code) case GFC_ISYM_CO_MAX: case GFC_ISYM_CO_REDUCE: case GFC_ISYM_CO_SUM: - res =3D conv_co_collective (code); + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + res =3D conv_nca_collective (code); + else + res =3D conv_co_collective (code); break; case GFC_ISYM_FREE: diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1f183b9dcd0..4897fa10d9d 100644 =2D-- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -830,7 +830,9 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op) /* Short cut: For single images without STAT=3D or LOCK_ACQUIRED return early. (ERRMSG=3D is always untouched for -fcoarray=3Dsingle.= ) */ - if (!code->expr2 && !code->expr4 && flag_coarray !=3D GFC_FCOARRAY_LIB) + if (!code->expr2 && !code->expr4 + && !(flag_coarray =3D=3D GFC_FCOARRAY_LIB + || flag_coarray =3D=3D GFC_FCOARRAY_NATIVE)) return NULL_TREE; if (code->expr2) @@ -990,6 +992,29 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op= ) return gfc_finish_block (&se.pre); } + else if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + { + gfc_se arg; + stmtblock_t res; + tree call; + tree tmp; + + gfc_init_se (&arg, NULL); + gfc_start_block (&res); + gfc_conv_expr (&arg, code->expr1); + gfc_add_block_to_block (&res, &arg.pre); + call =3D build_call_expr_loc (input_location, op =3D=3D EXEC_LOCK ? + gfor_fndecl_nca_lock + : gfor_fndecl_nca_unlock, + 1, fold_convert (pvoid_type_node, + gfc_build_addr_expr (NULL, arg.expr))); + gfc_add_expr_to_block (&res, call); + gfc_add_block_to_block (&res, &arg.post); + tmp =3D gfc_trans_memory_barrier (); + gfc_add_expr_to_block (&res, tmp); + + return gfc_finish_block (&res); + } if (stat !=3D NULL_TREE) gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); @@ -1183,7 +1208,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) /* Short cut: For single images without bound checking or without STAT= =3D, return early. (ERRMSG=3D is always untouched for -fcoarray=3Dsingle.= ) */ if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - && flag_coarray !=3D GFC_FCOARRAY_LIB) + && flag_coarray !=3D GFC_FCOARRAY_LIB + && flag_coarray !=3D GFC_FCOARRAY_NATIVE) ###AV: How about adding a helper for this kind of tests, like ###AV: #define IS_NON_SINGLE_CAF (flag_coarray =3D=3D GFC_FCOARRAY_LIB || = flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) ###AV: and using that everywhere? return NULL_TREE; gfc_init_se (&se, NULL); @@ -1206,7 +1232,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) else stat =3D null_pointer_node; - if (code->expr3 && flag_coarray =3D=3D GFC_FCOARRAY_LIB) + if (code->expr3 && (flag_coarray =3D=3D GFC_FCOARRAY_LIB || flag_coarra= y =3D=3D GFC_FCOARRAY_NATIVE)) { gcc_assert (code->expr3->expr_type =3D=3D EXPR_VARIABLE); gfc_init_se (&argse, NULL); @@ -1216,7 +1242,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) errmsg =3D gfc_build_addr_expr (NULL, argse.expr); errmsglen =3D fold_convert (size_type_node, argse.string_length); } - else if (flag_coarray =3D=3D GFC_FCOARRAY_LIB) + else if (flag_coarray =3D=3D GFC_FCOARRAY_LIB || flag_coarray =3D=3D GF= C_FCOARRAY_NATIVE) { errmsg =3D null_pointer_node; errmsglen =3D build_int_cst (size_type_node, 0); @@ -1229,7 +1255,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { tree images2 =3D fold_convert (integer_type_node, images); tree cond; - if (flag_coarray !=3D GFC_FCOARRAY_LIB) + if (flag_coarray !=3D GFC_FCOARRAY_LIB && flag_coarray !=3D GFC_FCO= ARRAY_NATIVE) cond =3D fold_build2_loc (input_location, NE_EXPR, logical_type_node, images, build_int_cst (TREE_TYPE (images), 1)); else @@ -1253,17 +1279,13 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the image control statements SYNC IMAGES and SYNC ALL. */ - if (flag_coarray =3D=3D GFC_FCOARRAY_LIB) + if (flag_coarray =3D=3D GFC_FCOARRAY_LIB || flag_coarray =3D=3D GFC_FCO= ARRAY_NATIVE) { - tmp =3D gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp =3D 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) =3D 1; + tmp =3D gfc_trans_memory_barrier (); gfc_add_expr_to_block (&se.pre, tmp); } - if (flag_coarray !=3D GFC_FCOARRAY_LIB) + if (flag_coarray !=3D GFC_FCOARRAY_LIB && flag_coarray !=3D GFC_FCOARRA= Y_NATIVE) { /* Set STAT to zero. */ if (code->expr2) @@ -1285,8 +1307,14 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_sync_me= mory, 3, stat, errmsg, errmsglen); else - tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_sync_al= l, - 3, stat, errmsg, errmsglen); + { + if (flag_coarray =3D=3D GFC_FCOARRAY_LIB) + tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, + 3, stat, errmsg, errmsglen); + else + tmp =3D build_call_expr_loc (input_location, gfor_fndecl_nca_sync_all, + 1, stat); + } gfc_add_expr_to_block (&se.pre, tmp); } @@ -1351,7 +1379,10 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) if (TREE_TYPE (stat) =3D=3D integer_type_node) stat =3D gfc_build_addr_expr (NULL, stat); - tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_sync_imag= es, + tmp =3D build_call_expr_loc (input_location, + flag_coarray =3D=3D GFC_FCOARRAY_NATIVE + ? gfor_fndecl_nca_sync_images + : gfor_fndecl_caf_sync_images, 5, fold_convert (integer_type_node, len), images, stat, errmsg, errmsglen); gfc_add_expr_to_block (&se.pre, tmp); @@ -1360,7 +1391,10 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { tree tmp_stat =3D gfc_create_var (integer_type_node, "stat"); - tmp =3D build_call_expr_loc (input_location, gfor_fndecl_caf_sync_imag= es, + tmp =3D build_call_expr_loc (input_location, + flag_coarray =3D=3D GFC_FCOARRAY_NATIVE + ? gfor_fndecl_nca_sync_images + : gfor_fndecl_caf_sync_images, 5, fold_convert (integer_type_node, len), images, gfc_build_addr_expr (NULL, tmp_stat), errmsg, errmsglen); @@ -1596,6 +1630,11 @@ gfc_trans_critical (gfc_code *code) gfc_add_expr_to_block (&block, tmp); } + else if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + { + tmp =3D gfc_trans_lock_unlock (code, EXEC_LOCK); + gfc_add_expr_to_block (&block, tmp); + } tmp =3D gfc_trans_code (code->block->next); gfc_add_expr_to_block (&block, tmp); @@ -1620,6 +1659,11 @@ gfc_trans_critical (gfc_code *code) gfc_add_expr_to_block (&block, tmp); } + else if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + { + tmp =3D gfc_trans_lock_unlock (code, EXEC_UNLOCK); + gfc_add_expr_to_block (&block, tmp); + } return gfc_finish_block (&block); } @@ -7169,6 +7213,7 @@ gfc_trans_deallocate (gfc_code *code) tree apstat, pstat, stat, errmsg, errlen, tmp; tree label_finish, label_errmsg; stmtblock_t block; + bool is_native_coarray =3D false; pstat =3D apstat =3D stat =3D errmsg =3D errlen =3D tmp =3D NULL_TREE; label_finish =3D label_errmsg =3D NULL_TREE; @@ -7254,8 +7299,27 @@ gfc_trans_deallocate (gfc_code *code) ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0); } } + else if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + { + gfc_ref *ref, *last; - if (expr->rank || is_coarray_array) + for (ref =3D expr->ref, last =3D ref; ref; last =3D ref, ref =3D ref->= next); + ref =3D last; + if (ref->type =3D=3D REF_ARRAY && ref->u.ar.codimen) + { + gfc_symbol *sym =3D expr->symtree->n.sym; + int alloc_type =3D gfc_native_coarray_get_allocation_type (sym); + tmp =3D build_call_expr_loc (input_location, + gfor_fndecl_nca_coarray_free, + 2, gfc_build_addr_expr (pvoid_type_node, se.expr), + build_int_cst (integer_type_node, + alloc_type)); + gfc_add_expr_to_block (&block, tmp); + is_native_coarray =3D true; + } + } + + if ((expr->rank || is_coarray_array) && !is_native_coarray) { gfc_ref *ref; @@ -7344,7 +7408,7 @@ gfc_trans_deallocate (gfc_code *code) gfc_reset_len (&se.pre, al->expr); } } - else + else if (!is_native_coarray) { tmp =3D gfc_deallocate_scalar_with_status (se.expr, pstat, label_finis= h, false, al->expr, diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 26fdb2803a7..f100d34d65b 100644 =2D-- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1345,6 +1345,10 @@ gfc_is_nodesc_array (gfc_symbol * sym) gcc_assert (array_attr->dimension || array_attr->codimension); + /* We need a descriptor for native coarrays. */ ###AV: Style! Comments end with two spaces after the '.', with a tab and a= space. + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && sym->as && sym->as->cora= nk) + return 0; + /* We only want local arrays. */ if ((sym->ts.type !=3D BT_CLASS && sym->attr.pointer) || (sym->ts.type =3D=3D BT_CLASS && CLASS_DATA (sym)->attr.class_po= inter) @@ -1381,12 +1385,18 @@ gfc_build_array_type (tree type, gfc_array_spec * = as, tree ubound[GFC_MAX_DIMENSIONS]; int n, corank; - /* Assumed-shape arrays do not have codimension information stored in t= he - descriptor. */ - corank =3D MAX (as->corank, codim); - if (as->type =3D=3D AS_ASSUMED_SHAPE || - (as->type =3D=3D AS_ASSUMED_RANK && akind =3D=3D GFC_ARRAY_ALLOCATA= BLE)) - corank =3D codim; + /* For -fcoarray=3Dlib, assumed-shape arrays do not have codimension + information stored in the descriptor. */ + if (flag_coarray !=3D GFC_FCOARRAY_NATIVE) + { + corank =3D MAX (as->corank, codim); + + if (as->type =3D=3D AS_ASSUMED_SHAPE || + (as->type =3D=3D AS_ASSUMED_RANK && akind =3D=3D GFC_ARRAY_ALLOCATABLE= )) + corank =3D codim; + } + else + corank =3D as->corank; if (as->type =3D=3D AS_ASSUMED_RANK) for (n =3D 0; n < GFC_MAX_DIMENSIONS; n++) @@ -1427,7 +1437,7 @@ gfc_build_array_type (tree type, gfc_array_spec * as= , corank, lbound, ubound, 0, akind, restricted); } -=0C + /* Returns the struct descriptor_dimension type. */ static tree @@ -1598,7 +1608,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spe= c * as, gfc_packed packed, /* We don't use build_array_type because this does not include lang-specific information (i.e. the bounds of the array) when checki= ng for duplicates. */ - if (as->rank) + if (as->rank || (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && as->corank)= ) type =3D make_node (ARRAY_TYPE); else type =3D build_variant_type_copy (etype); @@ -1665,6 +1675,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spe= c * as, gfc_packed packed, if (packed =3D=3D PACKED_NO || packed =3D=3D PACKED_PARTIAL) known_stride =3D 0; } + for (n =3D as->rank; n < as->rank + as->corank; n++) { expr =3D as->lower[n]; @@ -1672,7 +1683,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spe= c * as, gfc_packed packed, tmp =3D gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind); else - tmp =3D NULL_TREE; + tmp =3D NULL_TREE; GFC_TYPE_ARRAY_LBOUND (type, n) =3D tmp; expr =3D as->upper[n]; @@ -1680,16 +1691,16 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_s= pec * as, gfc_packed packed, tmp =3D gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind); else - tmp =3D NULL_TREE; + tmp =3D NULL_TREE; if (n < as->rank + as->corank - 1) - GFC_TYPE_ARRAY_UBOUND (type, n) =3D tmp; + GFC_TYPE_ARRAY_UBOUND (type, n) =3D tmp; } - if (known_offset) - { - GFC_TYPE_ARRAY_OFFSET (type) =3D - gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind); - } + if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE && as->rank =3D=3D 0 && as= ->corank !=3D 0) + GFC_TYPE_ARRAY_OFFSET (type) =3D NULL_TREE; + else if (known_offset) + GFC_TYPE_ARRAY_OFFSET (type) =3D + gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind); else GFC_TYPE_ARRAY_OFFSET (type) =3D NULL_TREE; @@ -1714,7 +1725,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spe= c * as, gfc_packed packed, build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), TYPE_QUAL_RESTRICT); - if (as->rank =3D=3D 0) + if (as->rank =3D=3D 0 && (flag_coarray !=3D GFC_FCOARRAY_NATIVE || as->= corank =3D=3D 0)) { if (packed !=3D PACKED_STATIC || flag_coarray =3D=3D GFC_FCOARRAY_= LIB) { @@ -1982,7 +1993,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, in= t codimen, tree * lbound, /* TODO: known offsets for descriptors. */ GFC_TYPE_ARRAY_OFFSET (fat_type) =3D NULL_TREE; - if (dimen =3D=3D 0) + if (flag_coarray !=3D GFC_FCOARRAY_NATIVE && dimen =3D=3D 0) { arraytype =3D build_pointer_type (etype); if (restricted) @@ -2281,6 +2292,10 @@ gfc_sym_type (gfc_symbol * sym) : GFC_ARRAY_POINTER; else if (sym->attr.allocatable) akind =3D GFC_ARRAY_ALLOCATABLE; + + /* FIXME: For normal coarrays, we pass a bool to an int here. + Is this really intended? */ + type =3D gfc_build_array_type (type, sym->as, akind, restricted, sym->attr.contiguous, false); } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index ed054261452..7d9cd324828 100644 =2D-- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -33,6 +33,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-array.h" #include "trans-types.h" #include "trans-const.h" +#include "diagnostic-core.h" /* Naming convention for backend interface code: @@ -47,6 +48,21 @@ static gfc_file *gfc_current_backend_file; const char gfc_msg_fault[] =3D N_("Array reference out of bounds"); const char gfc_msg_wrong_return[] =3D N_("Incorrect function return value= "); +/* Insert a memory barrier into the code. */ + +tree +gfc_trans_memory_barrier (void) +{ + tree tmp; + + tmp =3D gfc_build_string_const (strlen ("memory")+1, "memory"), ###AV: That line has to end in a ';' and not a comma. I know it's a copy, = but ###AV: the comma although legal here, is not what is meant. + tmp =3D build5_loc (input_location, ASM_EXPR, void_type_node, ###AV: The indent needs to be fixed, too. + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) =3D 1; + + return tmp; +} /* Return a location_t suitable for 'tree' for a gfortran locus. The way= the parser works in gfortran, loc->lb->location contains only the line num= ber @@ -403,15 +419,16 @@ gfc_build_array_ref (tree base, tree offset, tree de= cl, tree vptr) tree tmp; tree span =3D NULL_TREE; - if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) =3D=3D 0) + if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) =3D=3D 0 + && flag_coarray !=3D GFC_FCOARRAY_NATIVE) { gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0); return fold_convert (TYPE_MAIN_VARIANT (type), base); } - /* Scalar coarray, there is nothing to do. */ - if (TREE_CODE (type) !=3D ARRAY_TYPE) + /* Scalar library coarray, there is nothing to do. */ + if (TREE_CODE (type) !=3D ARRAY_TYPE && flag_coarray !=3D GFC_FCOARRAY_= NATIVE) { gcc_assert (decl =3D=3D NULL_TREE); gcc_assert (integer_zerop (offset)); @@ -1335,9 +1352,10 @@ gfc_deallocate_with_status (tree pointer, tree stat= us, tree errmsg, tree cond, tmp, error; tree status_type =3D NULL_TREE; tree token =3D NULL_TREE; + tree orig_desc =3D NULL_TREE; gfc_coarray_deregtype caf_dereg_type =3D GFC_CAF_COARRAY_DEREGISTER; - if (coarray_dealloc_mode >=3D GFC_CAF_COARRAY_ANALYZE) + if (coarray_dealloc_mode >=3D GFC_CAF_COARRAY_ANALYZE ) { if (flag_coarray =3D=3D GFC_FCOARRAY_LIB) { @@ -1358,7 +1376,7 @@ gfc_deallocate_with_status (tree pointer, tree statu= s, tree errmsg, { gcc_assert (GFC_ARRAY_TYPE_P (caf_type) && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) - !=3D NULL_TREE); + !=3D NULL_TREE); ###AV: The old indent was correct! token =3D GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); } } @@ -1374,6 +1392,11 @@ gfc_deallocate_with_status (tree pointer, tree stat= us, tree errmsg, else caf_dereg_type =3D (enum gfc_coarray_deregtype) coarray_dealloc_mode= ; } + else if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE) + { + orig_desc =3D pointer; + pointer =3D gfc_conv_descriptor_data_get (pointer); + } else if (flag_coarray =3D=3D GFC_FCOARRAY_SINGLE) pointer =3D gfc_conv_descriptor_data_get (pointer); } @@ -1425,7 +1448,7 @@ gfc_deallocate_with_status (tree pointer, tree statu= s, tree errmsg, gfc_add_expr_to_block (&non_null, add_when_allocated); gfc_add_finalizer_call (&non_null, expr); if (coarray_dealloc_mode =3D=3D GFC_CAF_COARRAY_NOCOARRAY - || flag_coarray !=3D GFC_FCOARRAY_LIB) + || (flag_coarray !=3D GFC_FCOARRAY_LIB && flag_coarray !=3D GFC_FCO= ARRAY_NATIVE)) { tmp =3D build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, @@ -1453,6 +1476,19 @@ gfc_deallocate_with_status (tree pointer, tree stat= us, tree errmsg, gfc_add_expr_to_block (&non_null, tmp); } } + else if (flag_coarray =3D=3D GFC_FCOARRAY_NATIVE + && coarray_dealloc_mode >=3D GFC_CAF_COARRAY_ANALYZE) + { + tmp =3D build_call_expr_loc(input_location, gfor_fndecl_nca_coarray= _free, + 2, gfc_build_addr_expr (pvoid_type_node, orig_desc), + build_int_cst(integer_type_node, GFC_NCA_NORMAL_COARRAY)); + gfc_add_expr_to_block (&non_null, tmp); + gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (point= er), + 0)); + + if (status !=3D NULL_TREE && !integer_zerop(status)) + sorry("Status not yet implemented"); ###AV: Fix!!! + } else { tree cond2, pstat =3D null_pointer_node; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index d257963d5f8..974785f3f10 100644 =2D-- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -501,6 +501,9 @@ void gfc_conv_expr_reference (gfc_se * se, gfc_expr * = expr, bool add_clobber =3D false); void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); +/* Insert a memory barrier into the code. */ + ###AV: Remove the empty line, because the comment belongs to the routine. +tree gfc_trans_memory_barrier (void); /* trans-expr.c */ tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute); @@ -890,6 +893,21 @@ extern GTY(()) tree gfor_fndecl_co_reduce; extern GTY(()) tree gfor_fndecl_co_sum; extern GTY(()) tree gfor_fndecl_caf_is_present; + +/* Native coarray library function decls. */ +extern GTY(()) tree gfor_fndecl_nca_this_image; +extern GTY(()) tree gfor_fndecl_nca_num_images; +extern GTY(()) tree gfor_fndecl_nca_coarray_allocate; +extern GTY(()) tree gfor_fndecl_nca_coarray_free; +extern GTY(()) tree gfor_fndecl_nca_sync_images; +extern GTY(()) tree gfor_fndecl_nca_sync_all; +extern GTY(()) tree gfor_fndecl_nca_lock; +extern GTY(()) tree gfor_fndecl_nca_unlock; +extern GTY(()) tree gfor_fndecl_nca_reduce_scalar; +extern GTY(()) tree gfor_fndecl_nca_reduce_array; +extern GTY(()) tree gfor_fndecl_nca_broadcast_scalar; +extern GTY(()) tree gfor_fndecl_nca_broadcast_array; + /* Math functions. Many other math functions are handled in trans-intrinsic.c. */ --MP_/x52aQKKZMnPdH6bZv/EW21Z--