case COMP_ASSOCIATE:
case COMP_BLOCK:
+ case COMP_CHANGE_TEAM:
case COMP_IF:
case COMP_SELECT:
case COMP_SELECT_TYPE:
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 (;;)
{
{
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));
{
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,
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
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. */
integer :: a[*]
type(team_type) :: team
+ team = get_team()
me = this_image()
n = num_images()
a = 42
--- /dev/null
+!{ 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
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
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
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" } }
/* 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,
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. */
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);
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))
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,
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;
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;
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;
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,
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);
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);
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;
projects / thirdparty / gcc.git / commitdiff
