Hi Jerry,
thanks for the review and sorry for the long delay. With publishing the team's
patches for gfortran, I also created a pull request for OpenCoarrays. There I
was asked to add some testcase with more "beef" in it. I.e. something that
really makes use of teams and not only smoke tests it. This unfortunately made
me discover some issues, that I needed to fix. The attached patch 6/5
addresses these issues. Some of them were as easy as not being able to exit out
of change team block or an end team with a label not being parsed correctly and
not generated in resulting binary. Others were more subtle, like having to
create coarray tokens for association in the change team.
The attached patch addresses all these issues and
bootstraps and regtests ok on x86_64-pc-linux-gnu / F41. Ok for mainline?
Btw, do I still merge to master, or am I to wait for the bump to 16th master?
Regards,
Andre
On Sun, 13 Apr 2025 18:40:44 -0700
Jerry D <jvdelis...@gmail.com> wrote:
> On 4/10/25 5:59 AM, Andre Vehreschild wrote:
> > Hi all,
> >
> > I again have a series of patches. This time to improve the teams support in
> > gfortran.
> >
> > 1/5: Improves/Unifies handling of STAT= and ERRMSG= handling, which is part
> > of all TEAM statements. I wanted to prevent repeating myself over and over
> > so I factored this out (DRY principle). Because the standard's rule name
> > for this is sync_stat the structure to store the information in gfc_code is
> > named like that.
> >
> > 2/5: Rework (FORM|CHANGE|END|SYNC) TEAM and CRITICAL to use sync_stat and
> > adhere to F2018 standard as much as possible. Because CHANGE TEAM has kind
> > of an association list (but for coarrays only), I choose to factor out that
> > parsing and other preparations from ASSOCIATE. Added support to caf_single
> > for testing.
> >
> > 3/5: Update/Implement get_team()/team_number() and image_status() parsing
> > and also add testcases as well as support in caf_single.
> >
> > 4/5: Update this_image() parsing and treatment as well as adding testcases
> > and support in caf_single.
> >
> > 5/5: Update image_index() and num_images() support also in caf_single.
> >
> > All patches together have been bootstrapped and regtested ok on
> > x86_64-pc-linux-gnu.
> >
> > Regards,
> > Andre
> > --
> > Andre Vehreschild * Email: vehre ad gmx dot de
>
> I have reviewed the five patches and have the following nits shown
> below. These are simply white space fixes.
>
> I had a couple of reject hunks in intrinsics.texi when applying the
> patches.
>
> All applies cleanly and regression tests here as well.
>
> It looks OK to commit.
>
> Regards,
>
> Jerry
>
> --- a/gcc/fortran/resolve.cc
> +++ b/gcc/fortran/resolve.cc
> @@ -11467,12 +11467,11 @@ resolve_scalar_variable_as_arg (const char
> *name, bt exp_type, int exp_kind,
> gfc_expr *e)
> {
> gfc_resolve_expr (e);
> if (e
> && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0
> || e->expr_type != EXPR_VARIABLE))
> gfc_error (
> "%s argument at %L must be a scalar %s variable of at least kind %d",
> name, &e->where, gfc_basic_typename (exp_type), exp_kind);
>
> @@ -11685,8 +11684,7 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
>
> if (code->here == label)
> {
> gfc_warning (0,
> "Branch at %L may result in an infinite loop", &code->loc);
> return;
> }
>
> @@ -11753,8 +11751,7 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
> allowed in Fortran 66, so we allow it as extension. No
> further checks are necessary in this case. */
> gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
> "as the GOTO statement at %L", &label->where, &code->loc);
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
From d3db7fc88a52310bfec0d362080a1631d2b87efb Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Tue, 15 Apr 2025 15:21:26 +0200
Subject: [PATCH 6/6] 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.
---
gcc/fortran/match.cc | 10 ++-
gcc/fortran/trans-intrinsic.cc | 4 +-
gcc/fortran/trans-stmt.cc | 24 ++++++
gcc/fortran/trans.h | 4 +-
.../gfortran.dg/coarray/coindexed_3.f08 | 1 +
.../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(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 0d81b69025e..474ba81b2aa 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 f388ba5bc81..440cbdd19ab 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 11fc1a8ff06..487b7687ef1 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 13bb04af1d2..461b0cdac71 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 29c2b3a8028..7fd20851e0a 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 00000000000..c35ec1093c1
--- /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 00cc489bf1f..66fe63c829b 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 64f072aed3d..c27b59d1738 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 5e004ada64f..9cd7d4c9d64 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 2db8e390382..7267bc76905 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 a80fd966f44..97876fa9d8c 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;
--
2.49.0
