From patchwork Tue Jan 25 16:32:13 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 50430 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 6279F385AC19 for ; Tue, 25 Jan 2022 16:33:05 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 6279F385AC19 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1643128385; bh=5PTJj53NDjoYGEcuatYEgxdX06laU7aLjBQXOd5uTWk=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=POxGNlLyt2eLVFY6zYdL2uVq8LnLleuxV1gJfK6LO/MESj7HNARv0yYTdAsVeVnP2 4fufYxJ6hq+3PHD6iIhXpANJLkAyAgdGclPTJbfJPBUoZrFYrDxQ1NPn45U+DSA+tC F1tft1V6gfxbK8RLAG27Z/az9g0UI7n6Etdajh0M= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mout.gmx.net (mout.gmx.net [212.227.17.20]) by sourceware.org (Postfix) with ESMTPS id 66BAA3857C70; Tue, 25 Jan 2022 16:32:16 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 66BAA3857C70 X-UI-Sender-Class: 01bb95c1-4bf8-414a-932a-4f6e2808ef9c Received: from vepi2 ([79.194.174.218]) by mail.gmx.net (mrgmx105 [212.227.17.168]) with ESMTPSA (Nemesis) id 1MYvcG-1mheUI26pE-00Uu5M; Tue, 25 Jan 2022 17:32:14 +0100 Date: Tue, 25 Jan 2022 17:32:13 +0100 To: GCC-Patches-ML , GCC-Fortran-ML Subject: [PR103970, Fortran, Coarray] Multi-image co_broadcast of derived type with allocatable components fails^ Message-ID: <20220125173213.1265f8e3@vepi2> X-Mailer: Claws Mail 4.0.0 (GTK+ 3.24.31; x86_64-redhat-linux-gnu) MIME-Version: 1.0 X-Provags-ID: V03:K1:tchDs0tKCTaxmkYIiS6NWu/RCysba/J2Pj3IXTEntcyQ8sxxpZS c/mXkOeq3ZTSUI01GuhwbhnI+4a73iY3fnGQ1ISnuXj6nV0U2rZJ4QhL9utDlRE2B2juxgS xfeeu3IVmTOgQU2OpIsnBbkfIX2cHVUJbbVIWYekySt/seKKZAtkc2JGgtiDI/N1GP7z2UN ulYpk/bKSUSh+Dlde7Lig== X-UI-Out-Filterresults: notjunk:1;V03:K0:4xhDbEE0WOI=:RV692ugXmvgIyGRplty3iN Qc9pVcYyQF4PcI3dEgTbl+yS4pDM7E3LC929BEfV5uSYCTWkK2b7G4AtqqEYQDs8WvqI6VO0b Urwo1Hs1NcC254KiOOH0inp6rsdAdjFpdtPnaVrHg+0v/7cpIEAgtvjBuLc1+U3in8pIqeWgc HUxT2cxEut0sYobms7KqSKpYs/o0uycuPZkp0rySCrSQHMoR41qabmJ5NrtvpesRU8H2aSc2g kw3/HBW/HwyCxOpAt1q2nGPaiIFZTmEVCVgU8aUEP6MNCnsDSYq4dWhvQvkQntSL5Z3abv8fv 8wgSIkoX/+m/I76QHKIIawbIw3N1IDMyx/4OMCWndImtOPylvKm0vtsVhlieHnA8tt9niSxhQ a0Qf94R1dzmjlsdVDY1kKIfCnxzrzG0kLcCLWsV9i+0jKj+GTgVV635qhpqd1trcY28eDOSYm 1yjXKg4n9KJD7n92MdMcQDGDclnWC0SfwKQ+Uc9WZQVcfSB+3sPRWRuxiS4KqND3pQYCbls71 Tq3w1Ba2tCmlqHXqaKowrUgRH8Qkw2NUxx2Mgct2Gd7jsZH54xPEHnLCbTYDk4vRdb0nPp60Y gMElgrkn9zXC5tOHHzWJhsvJUNVxmZrW8bkSZmDxZMitmmOC0vZBbOSlqKVBkgwI7etuMxX/u L/AK65MdN8XvKTlrEOhqNLPg6VvAZnVjAzvtkCNaMzKWY1tpDTA8GHOPbHkg+w8RK+IAmHS+l Z/gCE8JQjnltbzppLyQ9IvYnVxc0W9y4uNJP3UpLfYd8WppnSQLt6WsALe4a4WSrjPk/+c4sG A1RvivyOjXclBAl8YLU5feojoxHukmZjkyOlWBNueoRnOFJDvVVpbZ0U69ps5sQ9V2KYYPCtZ r+Md65xBu//OBA7y9YnFND6wt/DlZze9lHe39XYOPdJf6kJKSkzrOboFOd0q9gbG8F1CNc3BI crWBvglB9hIvgm5W87gFsRm1BkKQEayzqVYCUG2KdLWO9Pgi18vT7pAu8ITqe2W2dVoPoc7CS /WlW8cZwLIGnmLFOpOvXv/wuGhC7tkZWFtp1G0aBDk61bGmQhgRlrurOI5aeMy9WEA== X-Spam-Status: No, score=-10.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FREEMAIL_FROM, GIT_PATCH_0, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Andre Vehreschild via Gcc-patches From: Andre Vehreschild Reply-To: Andre Vehreschild Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Hi all, attached patch fixes wrong code generation when broadcasting a derived type containing allocatable and non-allocatable scalars. Furthermore does it prevent broadcasting of coarray-tokens, which are always local this_image. Thus having them on a different image makes no sense. Bootstrapped and regtested ok on x86_64-linux/F35. Ok, for trunk and backport to 12 and 11-branch after decent time? I perceived that 12 is closed for this kind of bugfix, therefore asking ok for 13. Regards, Andre --- Andre Vehreschild * Email: vehre ad gmx dot de diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 2f0c8a4d412..1234932aaff 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -9102,6 +9102,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, continue; } + /* Do not broadcast a caf_token. These are local to the image. */ + if (attr->caf_token) + continue; + add_when_allocated = NULL_TREE; if (cmp_has_alloc_comps && !c->attr.pointer && !c->attr.proc_pointer) @@ -9134,10 +9138,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (attr->dimension) { tmp = gfc_get_element_type (TREE_TYPE (comp)); - ubound = gfc_full_array_size (&tmpblock, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->as->rank - : c->as->rank); + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) + ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp)); + else + ubound = gfc_full_array_size (&tmpblock, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->as->rank + : c->as->rank); } else { @@ -9145,26 +9152,36 @@ 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, &gfc_index_one_node, - &ubound, 1, - GFC_ARRAY_ALLOCATABLE, false); + /* Treat strings like arrays. Or the other way around, do not + * generate an additional array layer for scalar components. */ + if (attr->dimension || c->ts.type == BT_CHARACTER) + { + 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"); - DECL_ARTIFICIAL (cdesc) = 1; + cdesc = gfc_create_var (cdesc, "cdesc"); + DECL_ARTIFICIAL (cdesc) = 1; - gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc), - gfc_get_dtype_rank_type (1, tmp)); - gfc_conv_descriptor_lbound_set (&tmpblock, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_stride_set (&tmpblock, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&tmpblock, cdesc, - gfc_index_zero_node, ubound); + gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc), + gfc_get_dtype_rank_type (1, tmp)); + gfc_conv_descriptor_lbound_set (&tmpblock, cdesc, + gfc_index_zero_node, + gfc_index_one_node); + gfc_conv_descriptor_stride_set (&tmpblock, cdesc, + gfc_index_zero_node, + gfc_index_one_node); + gfc_conv_descriptor_ubound_set (&tmpblock, cdesc, + gfc_index_zero_node, ubound); + } if (attr->dimension) - comp = gfc_conv_descriptor_data_get (comp); + { + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) + comp = gfc_conv_descriptor_data_get (comp); + else + comp = gfc_build_addr_expr (NULL_TREE, comp); + } else { gfc_se se; @@ -9172,14 +9189,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_init_se (&se, NULL); comp = gfc_conv_scalar_to_descriptor (&se, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->attr - : c->attr); - comp = gfc_build_addr_expr (NULL_TREE, comp); + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->attr + : c->attr); + if (c->ts.type == BT_CHARACTER) + comp = gfc_build_addr_expr (NULL_TREE, comp); gfc_add_block_to_block (&tmpblock, &se.pre); } - gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp); + if (attr->dimension || c->ts.type == BT_CHARACTER) + gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp); + else + cdesc = comp; tree fndecl; diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index fccf0a9b229..8a3636ca5b2 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -11211,24 +11211,31 @@ conv_co_collective (gfc_code *code) return gfc_finish_block (&block); } + gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED + ? code->ext.actual->expr->ts.u.derived : NULL; + /* Handle the array. */ gfc_init_se (&argse, NULL); - if (code->ext.actual->expr->rank == 0) - { - symbol_attribute attr; - gfc_clear_attr (&attr); - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, code->ext.actual->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); - array = gfc_build_addr_expr (NULL_TREE, array); - } - else + if (!derived || !derived->attr.alloc_comp + || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST) { - argse.want_pointer = 1; - gfc_conv_expr_descriptor (&argse, code->ext.actual->expr); - array = argse.expr; + if (code->ext.actual->expr->rank == 0) + { + symbol_attribute attr; + gfc_clear_attr (&attr); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, code->ext.actual->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); + array = gfc_build_addr_expr (NULL_TREE, array); + } + else + { + argse.want_pointer = 1; + gfc_conv_expr_descriptor (&argse, code->ext.actual->expr); + array = argse.expr; + } } gfc_add_block_to_block (&block, &argse.pre); @@ -11289,9 +11296,6 @@ conv_co_collective (gfc_code *code) gcc_unreachable (); } - gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED - ? code->ext.actual->expr->ts.u.derived : NULL; - if (derived && derived->attr.alloc_comp && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) /* The derived type has the attribute 'alloc_comp'. */ diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 new file mode 100644 index 00000000000..c83899de0e5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original -fcoarray=lib" } +! +! PR 103970 +! Test case inspired by code submitted by Damian Rousson + +program main + + implicit none + + type foo_t + integer i + integer, allocatable :: j + end type + + type(foo_t) foo + integer, parameter :: source_image = 1 + + if (this_image() == source_image) then + foo = foo_t(2,3) + else + allocate(foo%j) + end if + call co_broadcast(foo, source_image) + + if ((foo%i /= 2) .or. (foo%j /= 3)) error stop 1 + sync all + +end program + +! Wrong code generation produced too many temp descriptors +! leading to stacked descriptors handed to the co_broadcast. +! This lead to access to non exsitant memory in opencoarrays. +! In single image mode just checking for reduced number of +! descriptors is possible, i.e., execute always works. +! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 12 "original" } } +