From: Andre Vehreschild <vehre@gmx.de>
To: GCC-Patches-ML <gcc-patches@gcc.gnu.org>,
GCC-Fortran-ML <fortran@gcc.gnu.org>
Subject: [PR103970, Fortran, Coarray] Multi-image co_broadcast of derived type with allocatable components fails^
Date: Tue, 25 Jan 2022 17:32:13 +0100 [thread overview]
Message-ID: <20220125173213.1265f8e3@vepi2> (raw)
[-- Attachment #1: Type: text/plain, Size: 574 bytes --]
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
[-- Attachment #2: pr103970.changelog --]
[-- Type: text/x-changelog, Size: 454 bytes --]
gcc/fortran/ChangeLog:
2022-01-24 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/103790
* trans-array.cc (structure_alloc_comps): Prevent descriptor
stacking for non-array data; do not broadcast caf-tokens.
* trans-intrinsic.cc (conv_co_collective): Prevent generation
of unused descriptor.
gcc/testsuite/ChangeLog:
2022-01-24 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/103790
* gfortran.dg/coarray_collectives_18.f90: New test.
[-- Attachment #3: pr103970_patch.txt --]
[-- Type: text/plain, Size: 7479 bytes --]
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" } }
+
next reply other threads:[~2022-01-25 16:32 UTC|newest]
Thread overview: 8+ messages / expand[flat|nested] mbox.gz Atom feed top
2022-01-25 16:32 Andre Vehreschild [this message]
2022-01-25 21:30 ` Harald Anlauf
2022-01-25 21:30 ` Harald Anlauf
2022-01-28 9:07 ` [Submitted, PR103970, " Andre Vehreschild
2022-01-28 9:27 ` Tobias Burnus
2022-01-28 9:36 ` Andre Vehreschild
2022-01-28 11:39 ` Andre Vehreschild
2022-02-14 15:20 ` [Backport, committed, " Andre Vehreschild
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20220125173213.1265f8e3@vepi2 \
--to=vehre@gmx.de \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).