mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2024-11-24 19:05:28 +08:00
Code Issues Packages Projects Releases Wiki Activity

Fortran: Fix [Coarray] ICE in conv_caf_send, at fortran/trans-intrinsic.c:1950 [PR84246]

Browse Source 
Fix ICE caused by converted expression already being pointer by checking
for its type.  Lift rewrite to caf_send completely into resolve and
prevent more temporary arrays.

	PR fortran/84246

gcc/fortran/ChangeLog:

	* resolve.cc (caf_possible_reallocate): Detect arrays that may
	be reallocated by caf_send.
	(resolve_ordinary_assign): More reliably detect assignments
	where a rewrite to caf_send is needed.
	* trans-expr.cc (gfc_trans_assignment_1): Remove rewrite to
	caf_send, because this is done by resolve now.
	* trans-intrinsic.cc (conv_caf_send): Prevent unneeded temporary
	arrays.

libgfortran/ChangeLog:

	* caf/single.c (send_by_ref): Created array's lbound is now 1
	and the offset set correctly.

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray_allocate_7.f08: Adapt to array being
	allocate by caf_send.
This commit is contained in:
Andre Vehreschild 2024-07-17 12:30:52 +02:00
parent db2e9a2a46
commit 35f5601280
5 changed files with 32 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/fortran/resolve.cc
View File

@ -11601,6 +11601,23 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
}
}
bool
caf_possible_reallocate (gfc_expr *e)
{
symbol_attribute caf_attr;
gfc_ref *last_arr_ref = nullptr;
caf_attr = gfc_caf_attr (e);
if (!caf_attr.codimension || !caf_attr.allocatable || !caf_attr.dimension)
return false;
/* Only full array refs can indicate a needed reallocation. */
for (gfc_ref *ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.dimen)
last_arr_ref = ref;
return last_arr_ref && last_arr_ref->u.ar.type == AR_FULL;
}
/* Does everything to resolve an ordinary assignment. Returns true
if this is an interface assignment. */
@ -11845,6 +11862,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
&& (lhs_coindexed
|| caf_possible_reallocate (lhs)
|| (code->expr2->expr_type == EXPR_FUNCTION
&& code->expr2->value.function.isym
&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET

23
gcc/fortran/trans-expr.cc
View File

@ -12701,29 +12701,6 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
expr1->must_finalize = 0;
}
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
&& ((lhs_caf_attr.allocatable && lhs_refs_comp)
|| (rhs_caf_attr.allocatable && rhs_refs_comp)))
{
/* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
allocatable component, because those need to be accessed via the
caf-runtime. No need to check for coindexes here, because resolve
has rewritten those already. */
gfc_code code;
gfc_actual_arglist a1, a2;
/* Clear the structures to prevent accessing garbage. */
memset (&code, '\0', sizeof (gfc_code));
memset (&a1, '\0', sizeof (gfc_actual_arglist));
memset (&a2, '\0', sizeof (gfc_actual_arglist));
a1.expr = expr1;
a1.next = &a2;
a2.expr = expr2;
a2.next = NULL;
code.ext.actual = &a1;
code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
tmp = gfc_conv_intrinsic_subroutine (&code);
}
else if (!is_poly_assign && expr2->must_finalize
&& expr1->ts.type == BT_CLASS
&& expr2->ts.type == BT_CLASS)

17
gcc/fortran/trans-intrinsic.cc
View File

@ -1945,11 +1945,14 @@ conv_caf_send (gfc_code *code) {
tree lhs_type = NULL_TREE;
tree vec = null_pointer_node, rhs_vec = null_pointer_node;
symbol_attribute lhs_caf_attr, rhs_caf_attr;
bool lhs_is_coindexed, rhs_is_coindexed;
gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
lhs_expr = code->ext.actual->expr;
rhs_expr = code->ext.actual->next->expr;
lhs_is_coindexed = gfc_is_coindexed (lhs_expr);
rhs_is_coindexed = gfc_is_coindexed (rhs_expr);
may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
? boolean_false_node : boolean_true_node;
gfc_init_block (&block);
@ -1966,7 +1969,8 @@ conv_caf_send (gfc_code *code) {
if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
{
lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
if (!POINTER_TYPE_P (TREE_TYPE (lhs_se.expr)))
lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
}
else
{
@ -1999,7 +2003,7 @@ conv_caf_send (gfc_code *code) {
{
bool has_vector = gfc_has_vector_subscript (lhs_expr);
if (gfc_is_coindexed (lhs_expr) || !has_vector)
if (lhs_is_coindexed || !has_vector)
{
/* If has_vector, pass descriptor for whole array and the
vector bounds separately. */
@ -2030,7 +2034,7 @@ conv_caf_send (gfc_code *code) {
*ar = ar2;
}
}
else
else if (rhs_is_coindexed)
{
/* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
indexed array expression. This is rewritten to:
@ -2122,13 +2126,12 @@ conv_caf_send (gfc_code *code) {
/* Special case: RHS is a coarray but LHS is not; this code path avoids a
temporary and a loop. */
if (!gfc_is_coindexed (lhs_expr)
if (!lhs_is_coindexed && rhs_is_coindexed
&& (!lhs_caf_attr.codimension
|| !(lhs_expr->rank > 0
&& (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
{
bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
gcc_assert (gfc_is_coindexed (rhs_expr));
gfc_init_se (&rhs_se, NULL);
if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
{
@ -2217,7 +2220,7 @@ conv_caf_send (gfc_code *code) {
bool has_vector = false;
tree tmp2;
if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
if (rhs_is_coindexed && gfc_has_vector_subscript (rhs_expr))
{
has_vector = true;
ar = gfc_find_array_ref (rhs_expr);
@ -2271,7 +2274,7 @@ conv_caf_send (gfc_code *code) {
gfc_add_block_to_block (&block, &team_se.post);
}
if (!gfc_is_coindexed (rhs_expr))
if (!rhs_is_coindexed)
{
if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
{

4
gcc/testsuite/gfortran.dg/coarray_allocate_7.f08
View File

@ -23,7 +23,5 @@ program main
if ( object%indices(1) /= 1 ) STOP 2
end program
! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 1, &\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\) \\*object\\).indices, 0B, 0B, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 8, &\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\) \\*object\\).indices, 0B, 0B, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct mytype\\) \\*object\\).indices.token, 1, 0B, 0B, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(0, 7, \\(void \\*\\) &mytype\\.\[0-9\]+\\.indices\\.token, &mytype\\.\[0-9\]+\\.indices, 0B, 0B, 0\\);" 1 "original" } }

6
libgfortran/caf/single.c
View File

@ -2131,14 +2131,14 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
/* Assume that the rank and the dimensions fit for copying src
to dst. */
GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src);
dst->offset = 0;
stride_dst = 1;
for (size_t d = 0; d < src_rank; ++d)
{
extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]);
GFC_DIMENSION_LBOUND (dst->dim[d]) = 0;
GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst - 1;
GFC_DIMENSION_LBOUND (dst->dim[d]) = 1;
GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst;
GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst;
dst->offset = -extent_dst;
stride_dst *= extent_dst;
}
/* Null the data-pointer to make register_component allocate