https://gcc.gnu.org/g:6e3b92848b529b1c4b7fc12fa3fe0f54df16ecec
commit r16-79-g6e3b92848b529b1c4b7fc12fa3fe0f54df16ecec
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Tue Apr 15 15:21:26 2025 +0200
Fortran: Various fixes on F2018 teams.
gcc/fortran/ChangeLog:
* match.cc (match_exit_cycle): Allow to exit team block.
(gfc_match_end_team): Create end_team node also without
parameter list.
* trans-intrinsic.cc (conv_stat_and_team): Team and team_number
only need to be a single pointer.
* trans-stmt.cc (trans_associate_var): Create a mapping coarray
token for coarray associations or it is not addressed correctly.
* trans.h (enum gfc_coarray_regtype): Add mapping mode to
coarray register.
libgfortran/ChangeLog:
* caf/libcaf.h: Add mapping mode to coarray's register.
* caf/single.c (_gfortran_caf_register): Create a token sharing
another token's memory.
(check_team): Check team parameters to coindexed expressions are
valid.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/coindexed_3.f08: Add minimal test for
get_team().
* gfortran.dg/team_change_2.f90: Add test for change team with
label and exiting out of it.
* gfortran.dg/team_end_2.f90: Check parsing to labeled team
blocks is correct now.
* gfortran.dg/team_end_3.f90: Check that end_team call is
generated for labeled end_teams, too.
* gfortran.dg/coarray/coindexed_5.f90: New test.
Diff:
---
gcc/fortran/match.cc | 10 ++-
gcc/fortran/trans-intrinsic.cc | 4 +-
gcc/fortran/trans-stmt.cc | 24 +++++++
gcc/fortran/trans.h | 4 +-
gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 | 1 +
gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 | 80 +++++++++++++++++++++++
gcc/testsuite/gfortran.dg/team_change_2.f90 | 7 ++
gcc/testsuite/gfortran.dg/team_end_2.f90 | 9 +++
gcc/testsuite/gfortran.dg/team_end_3.f90 | 8 ++-
libgfortran/caf/libcaf.h | 9 +--
libgfortran/caf/single.c | 60 ++++++++++++++---
11 files changed, 193 insertions(+), 23 deletions(-)
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 0d81b69025e0..474ba81b2aa0 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -3325,6 +3325,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
case COMP_ASSOCIATE:
case COMP_BLOCK:
+ case COMP_CHANGE_TEAM:
case COMP_IF:
case COMP_SELECT:
case COMP_SELECT_TYPE:
@@ -4162,9 +4163,12 @@ gfc_match_end_team (void)
goto done;
if (gfc_match_char ('(') != MATCH_YES)
- /* There could be a team-construct-name following. Let caller decide
- about error. */
- return MATCH_NO;
+ {
+ /* There could be a team-construct-name following. Let caller decide
+ about error. */
+ new_st.op = EXEC_END_TEAM;
+ return MATCH_NO;
+ }
for (;;)
{
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index f388ba5bc81d..440cbdd19abc 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1183,7 +1183,7 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr,
tree *stat, tree *team,
{
gfc_se team_se;
gfc_init_se (&team_se, NULL);
- gfc_conv_expr_reference (&team_se, team_e);
+ gfc_conv_expr (&team_se, team_e);
*team
= gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre,
team_se.expr));
@@ -1198,7 +1198,7 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr,
tree *stat, tree *team,
{
gfc_se team_se;
gfc_init_se (&team_se, NULL);
- gfc_conv_expr_reference (&team_se, team_e);
+ gfc_conv_expr (&team_se, team_e);
*team_no = gfc_build_addr_expr (
NULL_TREE,
gfc_trans_force_lval (&team_se.pre,
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 11fc1a8ff064..487b7687ef14 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2056,6 +2056,30 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
gfc_conv_expr_descriptor (&se, e);
+ if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
+ {
+ tree token = gfc_conv_descriptor_token (se.expr),
+ size
+ = sym->attr.dimension
+ ? fold_build2 (MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_size (se.expr, e->rank),
+ gfc_conv_descriptor_span_get (se.expr))
+ : gfc_conv_descriptor_span_get (se.expr);
+ /* Create a new token, because in the token the modified descriptor
+ is stored. The modified descriptor is needed for accesses on the
+ remote image. In the scalar case, the base address needs to be
+ associated correctly, which also needs a new token.
+ The token is freed automatically be the end team statement. */
+ gfc_add_expr_to_block (
+ &se.pre,
+ build_call_expr_loc (
+ input_location, gfor_fndecl_caf_register, 7, size,
+ build_int_cst (integer_type_node, GFC_CAF_COARRAY_MAP_EXISTING),
+ gfc_build_addr_expr (pvoid_type_node, token),
+ gfc_build_addr_expr (NULL_TREE, se.expr), null_pointer_node,
+ null_pointer_node, integer_zero_node));
+ }
+
if (sym->ts.type == BT_CHARACTER
&& !sym->attr.select_type_temporary
&& sym->ts.u.cl->backend_decl
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 13bb04af1d2c..461b0cdac71c 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -139,10 +139,10 @@ enum gfc_coarray_regtype
GFC_CAF_EVENT_STATIC,
GFC_CAF_EVENT_ALLOC,
GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY,
- GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
+ GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY,
+ GFC_CAF_COARRAY_MAP_EXISTING
};
-
/* Describes the action to take on _caf_deregister. Keep in sync with
gcc/fortran/trans.h. The negative values are not valid for the library and
are used by the drivers for building the correct call. */
diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08
b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08
index 29c2b3a80287..7fd20851e0a9 100644
--- a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08
+++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08
@@ -9,6 +9,7 @@ program pr98903
integer :: a[*]
type(team_type) :: team
+ team = get_team()
me = this_image()
n = num_images()
a = 42
diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90
b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90
new file mode 100644
index 000000000000..c35ec1093c1f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90
@@ -0,0 +1,80 @@
+!{ dg-do run }
+
+! Check coindexes with team= or team_number= are working.
+
+program coindexed_5
+ use, intrinsic :: iso_fortran_env
+
+ type(team_type) :: parentteam, team, formed_team
+ integer :: t_num= 42, stat = 42, lhs
+ integer(kind=2) :: st_num=42
+ integer :: caf(2)[*]
+
+ parentteam = get_team()
+
+ caf = [23, 32]
+ form team(t_num, team, new_index=1)
+ form team(t_num, formed_team)
+
+ change team(team, cell[*] => caf(2))
+ ! for get_from_remote
+ ! Checking against caf_single is very limitted.
+ if (cell[1, team_number=t_num] /= 32) stop 1
+ if (cell[1, team_number=st_num] /= 32) stop 2
+ if (cell[1, team=parentteam] /= 32) stop 3
+
+ ! Check that team_number is validated
+ lhs = cell[1, team_number=5, stat=stat]
+ if (stat /= 1) stop 4
+
+ ! Check that only access to active teams is valid
+ stat = 42
+ lhs = cell[1, team=formed_team, stat=stat]
+ if (stat /= 1) stop 5
+
+ ! for send_to_remote
+ ! Checking against caf_single is very limitted.
+ cell[1, team_number=t_num] = 45
+ if (cell /= 45) stop 11
+ cell[1, team_number=st_num] = 46
+ if (cell /= 46) stop 12
+ cell[1, team=parentteam] = 47
+ if (cell /= 47) stop 13
+
+ ! Check that team_number is validated
+ stat = -1
+ cell[1, team_number=5, stat=stat] = 0
+ if (stat /= 1) stop 14
+
+ ! Check that only access to active teams is valid
+ stat = 42
+ cell[1, team=formed_team, stat=stat] = -1
+ if (stat /= 1) stop 15
+
+ ! for transfer_between_remotes
+ ! Checking against caf_single is very limitted.
+ cell[1, team_number=t_num] = caf(1)[1, team_number=-1]
+ if (cell /= 23) stop 21
+ cell[1, team_number=st_num] = caf(2)[1, team_number=-1]
+ ! cell is an alias for caf(2) and has been overwritten by caf(1)!
+ if (cell /= 23) stop 22
+ cell[1, team=parentteam] = caf(1)[1, team= team]
+ if (cell /= 23) stop 23
+
+ ! Check that team_number is validated
+ stat = -1
+ cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1]
+ if (stat /= 1) stop 24
+ stat = -1
+ cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat]
+ if (stat /= 1) stop 25
+
+ ! Check that only access to active teams is valid
+ stat = 42
+ cell[1, team=formed_team, stat=stat] = caf(1)[1]
+ if (stat /= 1) stop 26
+ stat = 42
+ cell[1] = caf(1)[1, team=formed_team, stat=stat]
+ if (stat /= 1) stop 27
+ end team
+end program coindexed_5
diff --git a/gcc/testsuite/gfortran.dg/team_change_2.f90
b/gcc/testsuite/gfortran.dg/team_change_2.f90
index 00cc489bf1fd..66fe63c829b7 100644
--- a/gcc/testsuite/gfortran.dg/team_change_2.f90
+++ b/gcc/testsuite/gfortran.dg/team_change_2.f90
@@ -74,6 +74,13 @@
continue
end team !{ dg-error "Expecting END PROGRAM statement" }
+ t: change team(team)
+ exit t
+ end team t
+
+ change team(team)
+ exit t !{ dg-error "EXIT statement at \\(1\\) is not within construct 't'"
}
+ end team
contains
subroutine foo(team)
type(team_type) :: team
diff --git a/gcc/testsuite/gfortran.dg/team_end_2.f90
b/gcc/testsuite/gfortran.dg/team_end_2.f90
index 64f072aed3de..c27b59d17384 100644
--- a/gcc/testsuite/gfortran.dg/team_end_2.f90
+++ b/gcc/testsuite/gfortran.dg/team_end_2.f90
@@ -29,5 +29,14 @@
change team (team)
continue
end team (stat=istat, errmsg=err, errmsg=err) ! { dg-error "Duplicate
ERRMSG" }
+
+ t: change team (team)
+ continue
+ end team (stat=istat) t ! ok
+
+ t2: change team (team)
+ continue
+ end team ! { dg-error "Expected block name of 't2' in END TEAM" }
+ end team t2 ! close the team correctly to catch other errors
end
diff --git a/gcc/testsuite/gfortran.dg/team_end_3.f90
b/gcc/testsuite/gfortran.dg/team_end_3.f90
index 5e004ada64f7..9cd7d4c9d64d 100644
--- a/gcc/testsuite/gfortran.dg/team_end_3.f90
+++ b/gcc/testsuite/gfortran.dg/team_end_3.f90
@@ -29,10 +29,12 @@
deallocate(sample, stat=istat)
if (istat == 0) stop 6
- change team (team)
+ istat = 42
+ t: change team (team)
continue
- end team (stat=istat, errmsg=err)
- if (trim(err) /= 'unchanged') stop 7
+ end team (stat=istat, errmsg=err) t
+ if (istat /= 0) stop 7
+ if (trim(err) /= 'unchanged') stop 8
end
! { dg-final { scan-tree-dump "_gfortran_caf_end_team \\(&istat, 0B, 0\\)"
"original" } }
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 2db8e3903822..7267bc76905e 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -55,7 +55,8 @@ typedef enum
/* Describes what type of array we are registerring. Keep in sync with
gcc/fortran/trans.h. */
-typedef enum caf_register_t {
+typedef enum caf_register_t
+{
CAF_REGTYPE_COARRAY_STATIC,
CAF_REGTYPE_COARRAY_ALLOC,
CAF_REGTYPE_LOCK_STATIC,
@@ -64,9 +65,9 @@ typedef enum caf_register_t {
CAF_REGTYPE_EVENT_STATIC,
CAF_REGTYPE_EVENT_ALLOC,
CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY,
- CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY
-}
-caf_register_t;
+ CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY,
+ CAF_REGTYPE_COARRAY_MAP_EXISTING,
+} caf_register_t;
/* Describes the action to take on _caf_deregister. Keep in sync with
gcc/fortran/trans.h. */
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index a80fd966f441..97876fa9d8c2 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -227,6 +227,8 @@ _gfortran_caf_register (size_t size, caf_register_t type,
caf_token_t *token,
local = calloc (size, sizeof (uint32_t));
else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
local = NULL;
+ else if (type == CAF_REGTYPE_COARRAY_MAP_EXISTING)
+ local = GFC_DESCRIPTOR_DATA (data);
else
local = malloc (size);
@@ -248,7 +250,8 @@ _gfortran_caf_register (size_t size, caf_register_t type,
caf_token_t *token,
single_token = TOKEN (*token);
single_token->memptr = local;
- single_token->owning_memory = type !=
CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
+ single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY
+ && type != CAF_REGTYPE_COARRAY_MAP_EXISTING;
single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
if (unlikely (!caf_team_stack))
@@ -620,6 +623,37 @@ _gfortran_caf_get_remote_function_index (const int hash)
return index;
}
+static bool
+check_team (caf_team_t *team, int *team_number, int *stat)
+{
+ if (team || team_number)
+ {
+ caf_single_team_t cur = caf_team_stack;
+
+ if (team)
+ {
+ caf_single_team_t single_team = (caf_single_team_t) (*team);
+ while (cur && cur != single_team)
+ cur = cur->parent;
+ }
+ else
+ while (cur && cur->team_no != *team_number)
+ cur = cur->parent;
+
+ if (!cur)
+ {
+ if (stat)
+ {
+ *stat = 1;
+ return false;
+ }
+ else
+ caf_runtime_error ("requested team not found");
+ }
+ }
+ return true;
+}
+
void
_gfortran_caf_get_from_remote (
caf_token_t token, const gfc_descriptor_t *opt_src_desc,
@@ -628,8 +662,7 @@ _gfortran_caf_get_from_remote (
size_t *opt_dst_charlen, gfc_descriptor_t *opt_dst_desc,
const bool may_realloc_dst, const int getter_index, void *add_data,
const size_t add_data_size __attribute__ ((unused)), int *stat,
- caf_team_t *team __attribute__ ((unused)),
- int *team_number __attribute__ ((unused)))
+ caf_team_t *team, int *team_number)
{
caf_single_token_t single_token = TOKEN (token);
void *src_ptr = opt_src_desc ? (void *) opt_src_desc : single_token->memptr;
@@ -644,6 +677,9 @@ _gfortran_caf_get_from_remote (
if (stat)
*stat = 0;
+ if (!check_team (team, team_number, stat))
+ return;
+
if (opt_dst_desc && !may_realloc_dst)
{
old_dst_data_ptr = opt_dst_desc->base_addr;
@@ -696,8 +732,7 @@ _gfortran_caf_send_to_remote (
const size_t *opt_src_charlen, const gfc_descriptor_t *opt_src_desc,
const int accessor_index, void *add_data,
const size_t add_data_size __attribute__ ((unused)), int *stat,
- caf_team_t *team __attribute__ ((unused)),
- int *team_number __attribute__ ((unused)))
+ caf_team_t *team, int *team_number)
{
caf_single_token_t single_token = TOKEN (token);
void *dst_ptr = opt_dst_desc ? (void *) opt_dst_desc : single_token->memptr;
@@ -710,6 +745,9 @@ _gfortran_caf_send_to_remote (
if (stat)
*stat = 0;
+ if (!check_team (team, team_number, stat))
+ return;
+
accessor_hash_table[accessor_index].u.receiver (add_data, &image_index,
dst_ptr, src_ptr, &cb_token,
0, opt_dst_charlen,
@@ -727,10 +765,8 @@ _gfortran_caf_transfer_between_remotes (
const int src_access_index, void *src_add_data,
const size_t src_add_data_size __attribute__ ((unused)),
const size_t src_size, const bool scalar_transfer, int *dst_stat,
- int *src_stat, caf_team_t *dst_team __attribute__ ((unused)),
- int *dst_team_number __attribute__ ((unused)),
- caf_team_t *src_team __attribute__ ((unused)),
- int *src_team_number __attribute__ ((unused)))
+ int *src_stat, caf_team_t *dst_team, int *dst_team_number,
+ caf_team_t *src_team, int *src_team_number)
{
caf_single_token_t src_single_token = TOKEN (src_token),
dst_single_token = TOKEN (dst_token);
@@ -749,6 +785,9 @@ _gfortran_caf_transfer_between_remotes (
if (src_stat)
*src_stat = 0;
+ if (!check_team (src_team, src_team_number, src_stat))
+ return;
+
if (!scalar_transfer)
{
const size_t desc_size = sizeof (*transfer_desc);
@@ -771,6 +810,9 @@ _gfortran_caf_transfer_between_remotes (
if (dst_stat)
*dst_stat = 0;
+ if (!check_team (dst_team, dst_team_number, dst_stat))
+ return;
+
if (scalar_transfer)
transfer_ptr = *(void **) transfer_ptr;
