OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

check.c (gfc_check_atomic, [...]): Use argument for GFC_ISYM_CAF_GET. 

gcc/fortran/
2014-06-17  Tobias Burnus  <burnus@net-b.de>

        * check.c (gfc_check_atomic, gfc_check_atomic_def):
        Use argument for GFC_ISYM_CAF_GET.
        * resolve.c (resolve_variable): Enable CAF_GET insertion.
        (resolve_lock_unlock): Remove GFC_ISYM_CAF_GET.
        (resolve_ordinary_assign): Enable CAF_SEND insertion.
        * trans-const.c (gfc_build_string_const,
        gfc_build_wide_string_const): Set TYPE_STRING_FLAG.
        * trans-decl.c (gfor_fndecl_caf_get, gfor_fndecl_caf_send,
        gfor_fndecl_caf_sendget): New global variables.
        (gfc_build_builtin_function_decls): Initialize them;
        update co_min/max/sum initialization.
        * trans-expr.c (gfc_get_tree_for_caf_expr): Renamed from
        get_tree_for_caf_expr and removed static.
        (gfc_conv_procedure_call): Update call.
        * trans-intrinsic.c (caf_get_image_index,
        conv_caf_vector_subscript_elem, conv_caf_vector_subscript,
        get_caf_token_offset, gfc_conv_intrinsic_caf_get,
        conv_caf_send): New.
        (gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine,
        gfc_walk_intrinsic_function): Handle CAF_GET and CAF_SEND.
        (conv_co_minmaxsum): Update call for remove unused vector
        subscript.
        (conv_intrinsic_atomic_def, conv_intrinsic_atomic_ref):
        Skip a CAF_GET of the argument.
        * trans-types.c (gfc_get_caf_vector_type): New.
        * trans-types.h (gfc_get_caf_vector_type): New.
        * trans.h (gfor_fndecl_caf_get, gfor_fndecl_caf_send,
        gfor_fndecl_caf_sendget): New global variables.
        (gfc_get_tree_for_caf_expr): New prototypes.

libgfortran/
2014-06-17  Tobias Burnus  <burnus@net-b.de>

        * caf/libcaf.h (gfc_descriptor_t): New typedef.
        (caf_vector_t): Update.
        (_gfortran_caf_co_sum, _gfortran_caf_co_max, _gfortran_caf_co_min):
        Remove vector-subscript argument.
        (_gfortran_caf_co_send, _gfortran_caf_co_get,
        _gfortran_caf_co_sendget): New.
        * caf/single.c (_gfortran_caf_co_sum, _gfortran_caf_co_max,
        _gfortran_caf_co_min): Remove vector-subscript argument.
        (_gfortran_caf_co_send, _gfortran_caf_co_get,
        _gfortran_caf_co_sendget): New.

gcc/testsuite/
2014-06-17  Tobias Burnus  <burnus@net-b.de>
            Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>

        * gfortran.dg/coarray/send_array.f90: New.
        * gfortran.dg/coarray/get_array.f90: New.
        * gfortran.dg/coarray/sendget_array.f90: New.
        * gfortran.dg/coarray/collectives_1.f90: Correct subroutine
        names.
        * gfortran.dg/coarray/collectives_2.f90: New.



Co-Authored-By: Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>

From-SVN: r211748
This commit is contained in:
Tobias Burnus 2014-06-17 22:54:14 +02:00 committed by Tobias Burnus
parent dc3368d0f5
commit b511626828
19 changed files with 2074 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/fortran/ChangeLog
View File

@ -1,3 +1,35 @@
2014-06-17 Tobias Burnus <burnus@net-b.de>
* check.c (gfc_check_atomic, gfc_check_atomic_def):
Use argument for GFC_ISYM_CAF_GET.
* resolve.c (resolve_variable): Enable CAF_GET insertion.
(resolve_lock_unlock): Remove GFC_ISYM_CAF_GET.
(resolve_ordinary_assign): Enable CAF_SEND insertion.
* trans-const.c (gfc_build_string_const,
gfc_build_wide_string_const): Set TYPE_STRING_FLAG.
* trans-decl.c (gfor_fndecl_caf_get, gfor_fndecl_caf_send,
gfor_fndecl_caf_sendget): New global variables.
(gfc_build_builtin_function_decls): Initialize them;
update co_min/max/sum initialization.
* trans-expr.c (gfc_get_tree_for_caf_expr): Renamed from
get_tree_for_caf_expr and removed static.
(gfc_conv_procedure_call): Update call.
* trans-intrinsic.c (caf_get_image_index,
conv_caf_vector_subscript_elem, conv_caf_vector_subscript,
get_caf_token_offset, gfc_conv_intrinsic_caf_get,
conv_caf_send): New.
(gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine,
gfc_walk_intrinsic_function): Handle CAF_GET and CAF_SEND.
(conv_co_minmaxsum): Update call for remove unused vector
subscript.
(conv_intrinsic_atomic_def, conv_intrinsic_atomic_ref):
Skip a CAF_GET of the argument.
* trans-types.c (gfc_get_caf_vector_type): New.
* trans-types.h (gfc_get_caf_vector_type): New.
* trans.h (gfor_fndecl_caf_get, gfor_fndecl_caf_send,
gfor_fndecl_caf_sendget): New global variables.
(gfc_get_tree_for_caf_expr): New prototypes.
2014-06-15 Jan Hubicka <hubicka@ucw.cz>
* trans-common.c (build_common_decl): Use

10
gcc/fortran/check.c
View File

@ -1008,6 +1008,11 @@ gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
static bool
gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
{
if (atom->expr_type == EXPR_FUNCTION
&& atom->value.function.isym
&& atom->value.function.isym->id == GFC_ISYM_CAF_GET)
atom = atom->value.function.actual->expr;
if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
&& !(atom->ts.type == BT_LOGICAL
&& atom->ts.kind == gfc_atomic_logical_kind))
@ -1040,6 +1045,11 @@ gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
bool
gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
{
if (atom->expr_type == EXPR_FUNCTION
&& atom->value.function.isym
&& atom->value.function.isym->id == GFC_ISYM_CAF_GET)
atom = atom->value.function.actual->expr;
if (!scalar_check (atom, 0) || !scalar_check (value, 1))
return false;

27
gcc/fortran/resolve.c
View File

@ -4766,7 +4766,7 @@ remove_caf_get_intrinsic (gfc_expr *e)
gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
&& e->value.function.isym->id == GFC_ISYM_CAF_GET);
gfc_expr *e2 = e->value.function.actual->expr;
e->value.function.actual->expr =NULL;
e->value.function.actual->expr = NULL;
gfc_free_actual_arglist (e->value.function.actual);
gfc_free_shape (&e->shape, e->rank);
*e = *e2;
@ -5056,7 +5056,7 @@ resolve_procedure:
if (t)
expression_rank (e);
if (0 && t && gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
if (t && gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
add_caf_get_intrinsic (e);
return t;
@ -8424,6 +8424,11 @@ find_reachable_labels (gfc_code *block)
static void
resolve_lock_unlock (gfc_code *code)
{
if (code->expr1->expr_type == EXPR_FUNCTION
&& code->expr1->value.function.isym
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr1);
if (code->expr1->ts.type != BT_DERIVED
|| code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
@ -9276,8 +9281,22 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
gfc_check_assign (lhs, rhs, 1);
if (0 && lhs_coindexed && gfc_option.coarray == GFC_FCOARRAY_LIB)
/* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
Additionally, insert this code when the RHS is a CAF as we then use the
GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
the LHS is (re)allocatable or has a vector subscript. */
if (gfc_option.coarray == GFC_FCOARRAY_LIB
&& (lhs_coindexed
|| (code->expr2->expr_type == EXPR_FUNCTION
&& code->expr2->value.function.isym
&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
&& !gfc_expr_attr (rhs).allocatable
&& !gfc_has_vector_subscript (rhs))))
{
if (code->expr2->expr_type == EXPR_FUNCTION
&& code->expr2->value.function.isym
&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr2);
code->op = EXEC_CALL;
gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
code->resolved_sym = code->symtree->n.sym;
@ -9919,6 +9938,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (!t)
break;
/* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
the LHS. */
if (code->expr1->expr_type == EXPR_FUNCTION
&& code->expr1->value.function.isym
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)

2
gcc/fortran/trans-const.c
View File

@ -81,6 +81,7 @@ gfc_build_string_const (int length, const char *s)
build_array_type (gfc_character1_type_node,
build_range_type (gfc_charlen_type_node,
size_one_node, len));
TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
return str;
}
@ -110,6 +111,7 @@ gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)
build_array_type (gfc_get_char_type (kind),
build_range_type (gfc_charlen_type_node,
size_one_node, len));
TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
return str;
}

31
gcc/fortran/trans-decl.c
View File

@ -127,6 +127,9 @@ tree gfor_fndecl_caf_this_image;
tree gfor_fndecl_caf_num_images;
tree gfor_fndecl_caf_register;
tree gfor_fndecl_caf_deregister;
tree gfor_fndecl_caf_get;
tree gfor_fndecl_caf_send;
tree gfor_fndecl_caf_sendget;
tree gfor_fndecl_caf_critical;
tree gfor_fndecl_caf_end_critical;
tree gfor_fndecl_caf_sync_all;
@ -3327,6 +3330,22 @@ gfc_build_builtin_function_decls (void)
get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 8,
pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node);
gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 8,
pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node);
gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRR", void_type_node,
12, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
pvoid_type_node, pvoid_type_node, size_type_node, integer_type_node,
pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node);
gfor_fndecl_caf_critical = gfc_build_library_function_decl (
get_identifier (PREFIX("caf_critical")), void_type_node, 0);
@ -3355,18 +3374,18 @@ gfc_build_builtin_function_decls (void)
TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_max")), "WR.WW",
void_type_node, 7, pvoid_type_node, pvoid_type_node, integer_type_node,
get_identifier (PREFIX("caf_co_max")), "W.WW",
void_type_node, 6, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node, integer_type_node);
gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_min")), "WR.WW",
void_type_node, 7, pvoid_type_node, pvoid_type_node, integer_type_node,
get_identifier (PREFIX("caf_co_min")), "W.WW",
void_type_node, 6, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node, integer_type_node);
gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_sum")), "WR.WW",
void_type_node, 6, pvoid_type_node, pvoid_type_node, integer_type_node,
get_identifier (PREFIX("caf_co_sum")), "W.WW",
void_type_node, 5, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node);
}

6
gcc/fortran/trans-expr.c
View File

@ -1384,8 +1384,8 @@ gfc_get_expr_charlen (gfc_expr *e)
/* Return for an expression the backend decl of the coarray. */
static tree
get_tree_for_caf_expr (gfc_expr *expr)
tree
gfc_get_tree_for_caf_expr (gfc_expr *expr)
{
tree caf_decl;
bool found;
@ -4807,7 +4807,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tree caf_decl, caf_type;
tree offset, tmp2;
caf_decl = get_tree_for_caf_expr (e);
caf_decl = gfc_get_tree_for_caf_expr (e);
caf_type = TREE_TYPE (caf_decl);
if (GFC_DESCRIPTOR_TYPE_P (caf_type)

594
gcc/fortran/trans-intrinsic.c
View File

@ -926,6 +926,560 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
}
/* Convert the coindex of a coarray into an image index; the result is
image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2)+1)*extent(1)
+ (idx(3)-lcobound(3)+1)*extent(2) + ... */
static tree
caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
{
gfc_ref *ref;
tree lbound, ubound, extent, tmp, img_idx;
gfc_se se;
int i;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
break;
gcc_assert (ref != NULL);
img_idx = integer_zero_node;
extent = integer_one_node;
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
gfc_add_block_to_block (block, &se.pre);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
integer_type_node, se.expr,
fold_convert(integer_type_node, lbound));
tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
extent, tmp);
img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
img_idx, tmp);
if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
{
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
extent = fold_convert (integer_type_node, extent);
}
}
else
for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
gfc_add_block_to_block (block, &se.pre);
lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
lbound = fold_convert (integer_type_node, lbound);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
integer_type_node, se.expr, lbound);
tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
extent, tmp);
img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
img_idx, tmp);
if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
{
ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
ubound = fold_convert (integer_type_node, ubound);
extent = fold_build2_loc (input_location, MINUS_EXPR,
integer_type_node, ubound, lbound);
extent = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
extent, integer_one_node);
}
}
img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
img_idx, integer_one_node);
return img_idx;
}
/* Fill in the following structure
struct caf_vector_t {
size_t nvec; // size of the vector
union {
struct {
void *vector;
int kind;
} v;
struct {
ptrdiff_t lower_bound;
ptrdiff_t upper_bound;
ptrdiff_t stride;
} triplet;
} u;
} */
static void
conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
tree lower, tree upper, tree stride,
tree vector, int kind, tree nvec)
{
tree field, type, tmp;
desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
type = TREE_TYPE (desc);
field = gfc_advance_chain (TYPE_FIELDS (type), 0);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
/* Access union. */
field = gfc_advance_chain (TYPE_FIELDS (type), 1);
desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
type = TREE_TYPE (desc);
/* Access the inner struct. */
field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
type = TREE_TYPE (desc);
if (vector != NULL_TREE)
{
/* Set dim.lower/upper/stride. */
field = gfc_advance_chain (TYPE_FIELDS (type), 0);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
field = gfc_advance_chain (TYPE_FIELDS (type), 1);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
}
else
{
/* Set vector and kind. */
field = gfc_advance_chain (TYPE_FIELDS (type), 0);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
field = gfc_advance_chain (TYPE_FIELDS (type), 1);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
field = gfc_advance_chain (TYPE_FIELDS (type), 2);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
}
}
static tree
conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
{
gfc_se argse;
tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
tree lbound, ubound, tmp;
int i;
var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
for (i = 0; i < ar->dimen; i++)
switch (ar->dimen_type[i])
{
case DIMEN_RANGE:
if (ar->end[i])
{
gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, ar->end[i]);
gfc_add_block_to_block (block, &argse.pre);
upper = gfc_evaluate_now (argse.expr, block);
}
else
upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
if (ar->stride[i])
{
gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, ar->stride[i]);
gfc_add_block_to_block (block, &argse.pre);
stride = gfc_evaluate_now (argse.expr, block);
}
else
stride = gfc_index_one_node;
/* Fall through. */
case DIMEN_ELEMENT:
if (ar->start[i])
{
gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, ar->start[i]);
gfc_add_block_to_block (block, &argse.pre);
lower = gfc_evaluate_now (argse.expr, block);
}
else
lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
if (ar->dimen_type[i] == DIMEN_ELEMENT)
{
upper = lower;
stride = gfc_index_one_node;
}
vector = NULL_TREE;
nvec = size_zero_node;
conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
vector, 0, nvec);
break;
case DIMEN_VECTOR:
gfc_init_se (&argse, NULL);
argse.descriptor_only = 1;
gfc_conv_expr_descriptor (&argse, ar->start[i]);
gfc_add_block_to_block (block, &argse.pre);
vector = argse.expr;
lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
TREE_TYPE (nvec), nvec, tmp);
lower = gfc_index_zero_node;
upper = gfc_index_zero_node;
stride = gfc_index_zero_node;
vector = gfc_conv_descriptor_data_get (vector);
conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
vector, ar->start[i]->ts.kind, nvec);
break;
default:
gcc_unreachable();
}
return gfc_build_addr_expr (NULL_TREE, var);
}
static void
get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr,
gfc_expr *expr)
{
tree tmp;
/* Coarray token. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
{
gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
== GFC_ARRAY_ALLOCATABLE
|| expr->symtree->n.sym->attr.select_type_temporary);
*token = gfc_conv_descriptor_token (caf_decl);
}
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
*token = GFC_DECL_TOKEN (caf_decl);
else
{
gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
&& GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
*token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
}
/* Offset between the coarray base address and the address wanted. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE)
*offset = build_int_cst (gfc_array_index_type, 0);
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
*offset = GFC_DECL_CAF_OFFSET (caf_decl);
else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
*offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
else
*offset = build_int_cst (gfc_array_index_type, 0);
if (POINTER_TYPE_P (TREE_TYPE (se_expr))
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
{
tmp = build_fold_indirect_ref_loc (input_location, se_expr);
tmp = gfc_conv_descriptor_data_get (tmp);
}
else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
tmp = gfc_conv_descriptor_data_get (se_expr);
else
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
tmp = se_expr;
}
*offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
*offset, fold_convert (gfc_array_index_type, tmp));
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
tmp = gfc_conv_descriptor_data_get (caf_decl);
else
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
tmp = caf_decl;
}
*offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
fold_convert (gfc_array_index_type, *offset),
fold_convert (gfc_array_index_type, tmp));
}
/* Get data from a remote coarray. */
static void
gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind)
{
gfc_expr *array_expr;
gfc_se argse;
tree caf_decl, token, offset, image_index, tmp;
tree res_var, dst_var, type, kind, vec;
gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
if (se->ss && se->ss->info->useflags)
{
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
return;
}
/* If lhs is set, the CAF_GET intrinsic has already been stripped. */
array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
type = gfc_typenode_for_spec (&array_expr->ts);
res_var = lhs;
dst_var = lhs;
gfc_init_se (&argse, NULL);
if (array_expr->rank == 0)
{
symbol_attribute attr;
gfc_clear_attr (&attr);
gfc_conv_expr (&argse, array_expr);
if (lhs == NULL_TREE)
{
gfc_clear_attr (&attr);
if (array_expr->ts.type == BT_CHARACTER)
res_var = gfc_conv_string_tmp (se, type, argse.string_length);
else
res_var = gfc_create_var (type, "caf_res");
dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
}
argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
}
else
{
/* If has_vector, pass descriptor for whole array and the
vector bounds separately. */
gfc_array_ref *ar, ar2;
bool has_vector = false;
if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
{
has_vector = true;
ar = gfc_find_array_ref (expr);
ar2 = *ar;
memset (ar, '\0', sizeof (*ar));
ar->as = ar2.as;
ar->type = AR_FULL;
}
gfc_conv_expr_descriptor (&argse, array_expr);
if (has_vector)
{
vec = conv_caf_vector_subscript (&argse.pre, argse.expr, ar);
*ar = ar2;
}
if (lhs == NULL_TREE)
{
/* Create temporary. */
for (int n = 0; n < se->ss->loop->dimen; n++)
if (se->loop->to[n] == NULL_TREE)
{
se->loop->from[n] =
gfc_conv_descriptor_lbound_get (argse.expr, gfc_rank_cst[n]);
se->loop->to[n] =
gfc_conv_descriptor_ubound_get (argse.expr, gfc_rank_cst[n]);
}
gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
NULL_TREE, false, true, false,
&array_expr->where);
res_var = se->ss->info->data.array.descriptor;
dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
}
argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
}
kind = build_int_cst (integer_type_node, expr->ts.kind);
if (lhs_kind == NULL_TREE)
lhs_kind = kind;
vec = null_pointer_node;
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
caf_decl = gfc_get_tree_for_caf_expr (array_expr);
if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
image_index = caf_get_image_index (&se->pre, array_expr, caf_decl);
get_caf_token_offset (&token, &offset, caf_decl, argse.expr, array_expr);
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 8,
token, offset, image_index, argse.expr, vec,
dst_var, kind, lhs_kind);
gfc_add_expr_to_block (&se->pre, tmp);
if (se->ss)
gfc_advance_se_ss_chain (se);
se->expr = res_var;
if (array_expr->ts.type == BT_CHARACTER)
se->string_length = argse.string_length;
}
/* Send data to a remove coarray. */
static tree
conv_caf_send (gfc_code *code) {
gfc_expr *lhs_expr, *rhs_expr;
gfc_se lhs_se, rhs_se;
stmtblock_t block;
tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
tree vec = null_pointer_node, rhs_vec = null_pointer_node;
gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
lhs_expr = code->ext.actual->expr;
rhs_expr = code->ext.actual->next->expr;
gfc_init_block (&block);
/* LHS. */
gfc_init_se (&lhs_se, NULL);
if (lhs_expr->rank == 0)
{
symbol_attribute attr;
gfc_clear_attr (&attr);
gfc_conv_expr (&lhs_se, lhs_expr);
lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr);
lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
}
else
{
/* If has_vector, pass descriptor for whole array and the
vector bounds separately. */
gfc_array_ref *ar, ar2;
bool has_vector = false;
if (gfc_is_coindexed (lhs_expr) && gfc_has_vector_subscript (lhs_expr))
{
has_vector = true;
ar = gfc_find_array_ref (lhs_expr);
ar2 = *ar;
memset (ar, '\0', sizeof (*ar));
ar->as = ar2.as;
ar->type = AR_FULL;
}
lhs_se.want_pointer = 1;
gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
if (has_vector)
{
vec = conv_caf_vector_subscript (&block, lhs_se.expr, ar);
*ar = ar2;
}
}
lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
gfc_add_block_to_block (&block, &lhs_se.pre);
/* 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))
{
gcc_assert (gfc_is_coindexed (rhs_expr));
gfc_init_se (&rhs_se, NULL);
gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind);
gfc_add_block_to_block (&block, &rhs_se.pre);
gfc_add_block_to_block (&block, &rhs_se.post);
gfc_add_block_to_block (&block, &lhs_se.post);
return gfc_finish_block (&block);
}
/* Obtain token, offset and image index for the LHS. */
caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
image_index = caf_get_image_index (&block, lhs_expr, caf_decl);
get_caf_token_offset (&token, &offset, caf_decl, lhs_se.expr, lhs_expr);
/* RHS. */
gfc_init_se (&rhs_se, NULL);
if (rhs_expr->rank == 0)
{
symbol_attribute attr;
gfc_clear_attr (&attr);
gfc_conv_expr (&rhs_se, rhs_expr);
rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
}
else
{
/* If has_vector, pass descriptor for whole array and the
vector bounds separately. */
gfc_array_ref *ar, ar2;
bool has_vector = false;
if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
{
has_vector = true;
ar = gfc_find_array_ref (rhs_expr);
ar2 = *ar;
memset (ar, '\0', sizeof (*ar));
ar->as = ar2.as;
ar->type = AR_FULL;
}
rhs_se.want_pointer = 1;
gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
if (has_vector)
{
rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, ar);
*ar = ar2;
}
}
gfc_add_block_to_block (&block, &rhs_se.pre);
rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
if (!gfc_is_coindexed (rhs_expr))
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 8, token,
offset, image_index, lhs_se.expr, vec,
rhs_se.expr, lhs_kind, rhs_kind);
else
{
tree rhs_token, rhs_offset, rhs_image_index;
caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
rhs_image_index = caf_get_image_index (&block, rhs_expr, caf_decl);
get_caf_token_offset (&rhs_token, &rhs_offset, caf_decl, rhs_se.expr,
rhs_expr);
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget, 12,
token, offset, image_index, lhs_se.expr, vec,
rhs_token, rhs_offset, rhs_image_index,
rhs_se.expr, rhs_vec, lhs_kind, rhs_kind);
}
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &lhs_se.post);
gfc_add_block_to_block (&block, &rhs_se.post);
return gfc_finish_block (&block);
}
static void
trans_this_image (gfc_se * se, gfc_expr *expr)
{
@ -6866,6 +7420,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_mod (se, expr, 1);
break;
case GFC_ISYM_CAF_GET:
gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE);
break;
case GFC_ISYM_CMPLX:
gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
break;
@ -7629,6 +8187,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
return gfc_walk_intrinsic_bound (ss, expr);
case GFC_ISYM_TRANSFER:
case GFC_ISYM_CAF_GET:
return gfc_walk_intrinsic_libfunc (ss, expr);
default:
@ -7645,7 +8204,7 @@ conv_co_minmaxsum (gfc_code *code)
{
gfc_se argse;
stmtblock_t block, post_block;
tree fndecl, array, vec, strlen, image_index, stat, errmsg, errmsg_len;
tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len;
gfc_start_block (&block);
gfc_init_block (&post_block);
@ -7702,8 +8261,6 @@ conv_co_minmaxsum (gfc_code *code)
else
strlen = integer_zero_node;
vec = null_pointer_node;
/* image_index. */
if (code->ext.actual->next->expr)
{
@ -7743,12 +8300,13 @@ conv_co_minmaxsum (gfc_code *code)
gcc_unreachable ();
if (code->resolved_isym->id == GFC_ISYM_CO_SUM)
fndecl = build_call_expr_loc (input_location, fndecl, 6, array, vec,
image_index, stat, errmsg, errmsg_len);
else
fndecl = build_call_expr_loc (input_location, fndecl, 7, array, vec,
image_index, stat, errmsg, strlen,
fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
null_pointer_node, image_index, stat, errmsg,
errmsg_len);
else
fndecl = build_call_expr_loc (input_location, fndecl, 7, array,
null_pointer_node, image_index, stat, errmsg,
strlen, errmsg_len);
gfc_add_expr_to_block (&block, fndecl);
gfc_add_block_to_block (&block, &post_block);
@ -7762,10 +8320,16 @@ conv_intrinsic_atomic_def (gfc_code *code)
{
gfc_se atom, value;
stmtblock_t block;
gfc_expr *atom_expr = code->ext.actual->expr;
if (atom_expr->expr_type == EXPR_FUNCTION
&& atom_expr->value.function.isym
&& atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
atom_expr = atom_expr->value.function.actual->expr;
gfc_init_se (&atom, NULL);
gfc_init_se (&value, NULL);
gfc_conv_expr (&atom, code->ext.actual->expr);
gfc_conv_expr (&atom, atom_expr);
gfc_conv_expr (&value, code->ext.actual->next->expr);
gfc_init_block (&block);
@ -7780,10 +8344,16 @@ conv_intrinsic_atomic_ref (gfc_code *code)
{
gfc_se atom, value;
stmtblock_t block;
gfc_expr *atom_expr = code->ext.actual->expr;
if (atom_expr->expr_type == EXPR_FUNCTION
&& atom_expr->value.function.isym
&& atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
atom_expr = atom_expr->value.function.actual->expr;
gfc_init_se (&atom, NULL);
gfc_init_se (&value, NULL);
gfc_conv_expr (&value, code->ext.actual->expr);
gfc_conv_expr (&value, atom_expr);
gfc_conv_expr (&atom, code->ext.actual->next->expr);
gfc_init_block (&block);
@ -8052,6 +8622,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_isocbinding_subroutine (code);
break;
case GFC_ISYM_CAF_SEND:
res = conv_caf_send (code);
break;
case GFC_ISYM_CO_MIN:
case GFC_ISYM_CO_MAX:
case GFC_ISYM_CO_SUM:

87
gcc/fortran/trans-types.c
View File

@ -3107,4 +3107,91 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
return true;
}
/* Create a type to handle vector subscripts for coarray library calls. It
has the form:
struct caf_vector_t {
size_t nvec; // size of the vector
union {
struct {
void *vector;
int kind;
} v;
struct {
ptrdiff_t lower_bound;
ptrdiff_t upper_bound;
ptrdiff_t stride;
} triplet;
} u;
}
where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
tree
gfc_get_caf_vector_type (int dim)
{
static tree vector_types[GFC_MAX_DIMENSIONS];
static tree vec_type = NULL_TREE;
tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain;
if (vector_types[dim-1] != NULL_TREE)
return vector_types[dim-1];
if (vec_type == NULL_TREE)
{
chain = 0;
vect_struct_type = make_node (RECORD_TYPE);
tmp = gfc_add_field_to_struct_1 (vect_struct_type,
get_identifier ("vector"),
pvoid_type_node, &chain);
TREE_NO_WARNING (tmp) = 1;
tmp = gfc_add_field_to_struct_1 (vect_struct_type,
get_identifier ("kind"),
integer_type_node, &chain);
TREE_NO_WARNING (tmp) = 1;
gfc_finish_type (vect_struct_type);
chain = 0;
triplet_struct_type = make_node (RECORD_TYPE);
tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
get_identifier ("lower_bound"),
gfc_array_index_type, &chain);
TREE_NO_WARNING (tmp) = 1;
tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
get_identifier ("upper_bound"),
gfc_array_index_type, &chain);
TREE_NO_WARNING (tmp) = 1;
tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"),
gfc_array_index_type, &chain);
TREE_NO_WARNING (tmp) = 1;
gfc_finish_type (triplet_struct_type);
chain = 0;
union_type = make_node (UNION_TYPE);
tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
vect_struct_type, &chain);
TREE_NO_WARNING (tmp) = 1;
tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"),
triplet_struct_type, &chain);
TREE_NO_WARNING (tmp) = 1;
gfc_finish_type (union_type);
chain = 0;
vec_type = make_node (RECORD_TYPE);
tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"),
size_type_node, &chain);
TREE_NO_WARNING (tmp) = 1;
tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"),
union_type, &chain);
TREE_NO_WARNING (tmp) = 1;
gfc_finish_type (vec_type);
TYPE_NAME (vec_type) = get_identifier ("caf_vector_t");
}
tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
gfc_rank_cst[dim-1]);
vector_types[dim-1] = build_array_type (vec_type, tmp);
return vector_types[dim-1];
}
#include "gt-fortran-trans-types.h"

1
gcc/fortran/trans-types.h
View File

@ -100,5 +100,6 @@ int gfc_is_nodesc_array (gfc_symbol *);
tree gfc_get_dtype (tree);
tree gfc_get_ppc_type (gfc_component *);
tree gfc_get_caf_vector_type (int dim);
#endif

4
gcc/fortran/trans.h
View File

@ -418,6 +418,7 @@ tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
/* trans-expr.c */
void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr);
tree gfc_string_to_single_character (tree len, tree str, int kind);
tree gfc_get_tree_for_caf_expr (gfc_expr *);
/* Find the decl containing the auxiliary variables for assigned variables. */
void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr);
@ -708,6 +709,9 @@ extern GTY(()) tree gfor_fndecl_caf_this_image;
extern GTY(()) tree gfor_fndecl_caf_num_images;
extern GTY(()) tree gfor_fndecl_caf_register;
extern GTY(()) tree gfor_fndecl_caf_deregister;
extern GTY(()) tree gfor_fndecl_caf_get;
extern GTY(()) tree gfor_fndecl_caf_send;
extern GTY(()) tree gfor_fndecl_caf_sendget;
extern GTY(()) tree gfor_fndecl_caf_critical;
extern GTY(()) tree gfor_fndecl_caf_end_critical;
extern GTY(()) tree gfor_fndecl_caf_sync_all;

10
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,13 @@
2014-06-17 Tobias Burnus <burnus@net-b.de>
Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
* gfortran.dg/coarray/send_array.f90: New.
* gfortran.dg/coarray/get_array.f90: New.
* gfortran.dg/coarray/sendget_array.f90: New.
* gfortran.dg/coarray/collectives_1.f90: Correct subroutine
names.
* gfortran.dg/coarray/collectives_2.f90: New.
2014-06-17 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
PR target/61533

8
gcc/testsuite/gfortran.dg/coarray/collectives_1.f90
View File

@ -11,7 +11,7 @@ program test
call test_max
call test_sum
contains
subroutine test_min
subroutine test_max
integer :: val
val = this_image ()
call co_max (val, result_image=1)
@ -19,9 +19,9 @@ contains
!write(*,*) "Maximal value", val
if (val /= num_images()) call abort()
end if
end subroutine test_min
end subroutine test_max
subroutine test_max
subroutine test_min
integer :: val
val = this_image ()
call co_min (val, result_image=1)
@ -29,7 +29,7 @@ contains
!write(*,*) "Minimal value", val
if (val /= 1) call abort()
end if
end subroutine test_max
end subroutine test_min
subroutine test_sum
integer :: val, n

59
gcc/testsuite/gfortran.dg/coarray/collectives_2.f90 Normal file
View File

@ -0,0 +1,59 @@
! { dg-do run }
!
! CO_SUM/CO_MIN/CO_MAX
!
program test
implicit none
intrinsic co_max
intrinsic co_min
intrinsic co_sum
integer :: val(3)
integer :: vec(3)
vec = [2,3,1]
if (this_image() == 1) then
val(1) = 42
else
val(1) = -99
endif
val(2) = this_image()
if (this_image() == num_images()) then
val(3) = -55
else
val(3) = 101
endif
call test_min
call test_max
call test_sum
contains
subroutine test_max
call co_max (val(vec))
!write(*,*) "Maximal value", val
if (num_images() > 1) then
if (any (val /= [42, num_images(), 101])) call abort()
else
if (any (val /= [42, num_images(), -55])) call abort()
endif
end subroutine test_max
subroutine test_min
call co_min (val, result_image=num_images())
if (this_image() == num_images()) then
!write(*,*) "Minimal value", val
if (num_images() > 1) then
if (any (val /= [-99, num_images(), -55])) call abort()
else
if (any (val /= [42, num_images(), -55])) call abort()
endif
endif
end subroutine test_min
subroutine test_sum
integer :: n
call co_sum (val, result_image=1)
if (this_image() == 1) then
n = num_images()
!write(*,*) "The sum is ", val
if (any (val /= [42 + (n-1)*(-99), (n**2 + n)/2, -55+(n-1)*101])) call abort()
end if
end subroutine test_sum
end program test

279
gcc/testsuite/gfortran.dg/coarray/get_array.f90 Normal file
View File

@ -0,0 +1,279 @@
! { dg-do run }
!
! This program does a correctness check for
! ... = ARRAY[idx] and ... = SCALAR[idx]
!
!
! FIXME: two/three has to be modified, test has to be checked and
! diagnostic has to be removed
!
program main
implicit none
integer, parameter :: n = 3
integer, parameter :: m = 4
! Allocatable coarrays
call one(-5, 1)
call one(0, 0)
call one(1, -5)
call one(0, -11)
! Static coarrays
call two()
call three()
contains
subroutine one(lb1, lb2)
integer, value :: lb1, lb2
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, allocatable :: caf(:,:)[:]
integer, allocatable :: a(:,:), b(:,:), c(:,:)
allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
a(lb1:n+lb1-1, lb2:m+lb2-1), &
b(lb1:n+lb1-1, lb2:m+lb2-1), &
c(lb1:n+lb1-1, lb2:m+lb2-1))
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
c(:,:) = caf(:,:)[num_images()]
if (any (a /= c)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
if (any (a /= c)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (c /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine one
subroutine two()
integer, parameter :: lb1 = -5, lb2 = 1
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: c(lb1:n+lb1-1, lb2:m+lb2-1)
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
c(:,:) = caf(:,:)[num_images()]
if (any (a /= c)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
if (any (a /= c)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (c /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine two
subroutine three()
integer, parameter :: lb1 = 0, lb2 = 0
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: c(lb1:n+lb1-1, lb2:m+lb2-1)
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
c(:,:) = caf(:,:)[num_images()]
if (any (a /= c)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
if (any (a /= c)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (c /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine three
end program main

398
gcc/testsuite/gfortran.dg/coarray/send_array.f90 Normal file
View File

@ -0,0 +1,398 @@
! { dg-do run }
!
! This program does a correctness check for
! ARRAY[idx] = SCALAR, ARRAY[idx] = ARRAY and SCALAR[idx] = SCALAR
!
program main
implicit none
integer, parameter :: n = 3
integer, parameter :: m = 4
! Allocatable coarrays
call one(-5, 1)
call one(0, 0)
call one(1, -5)
call one(0, -11)
! Static coarrays
call two()
call three()
contains
subroutine one(lb1, lb2)
integer, value :: lb1, lb2
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, allocatable :: caf(:,:)[:]
integer, allocatable :: a(:,:), b(:,:)
allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
a(lb1:n+lb1-1, lb2:m+lb2-1), &
b(lb1:n+lb1-1, lb2:m+lb2-1))
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = SCALAR
caf = -42
a = -42
a(:,:) = b(lb1, lb2)
sync all
if (this_image() == 1) then
caf(:,:)[num_images()] = b(lb1, lb2)
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) &
call abort()
end if
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
a(:,:) = b(:, :)
sync all
if (this_image() == 1) then
caf(:,:)[num_images()] = b(:, :)
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) &
call abort()
end if
! Scalar assignment
caf = -42
a = -42
do j = lb2, m+lb2-1
do i = n+lb1-1, 1, -2
a(i,j) = b(i,j)
end do
end do
do j = lb2, m+lb2-1
do i = 1, n+lb1-1, 2
a(i,j) = b(i,j)
end do
end do
sync all
if (this_image() == 1) then
do j = lb2, m+lb2-1
do i = n+lb1-1, 1, -2
caf(i,j)[num_images()] = b(i, j)
end do
end do
do j = lb2, m+lb2-1
do i = 1, n+lb1-1, 2
caf(i,j)[num_images()] = b(i, j)
end do
end do
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) &
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = SCALAR
caf = -42
a = -42
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
sync all
if (this_image() == 1) then
caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
= b(lb1, lb2)
end if
sync all
! ARRAY = ARRAY
caf = -42
a = -42
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
sync all
if (this_image() == 1) then
caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) then
print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
lb2,":",m+lb2-1
print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
", ", j,":",j_e,":",j_s*i_sgn2
print *, i
print *, a
print *, caf
print *, a-caf
call abort()
endif
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine one
subroutine two()
integer, parameter :: lb1 = -5, lb2 = 1
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = SCALAR
caf = -42
a = -42
a(:,:) = b(lb1, lb2)
sync all
if (this_image() == 1) then
caf(:,:)[num_images()] = b(lb1, lb2)
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) &
call abort()
end if
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
a(:,:) = b(:, :)
sync all
if (this_image() == 1) then
caf(:,:)[num_images()] = b(:, :)
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) &
call abort()
end if
! Scalar assignment
caf = -42
a = -42
do j = lb2, m+lb2-1
do i = n+lb1-1, 1, -2
a(i,j) = b(i,j)
end do
end do
do j = lb2, m+lb2-1
do i = 1, n+lb1-1, 2
a(i,j) = b(i,j)
end do
end do
sync all
if (this_image() == 1) then
do j = lb2, m+lb2-1
do i = n+lb1-1, 1, -2
caf(i,j)[num_images()] = b(i, j)
end do
end do
do j = lb2, m+lb2-1
do i = 1, n+lb1-1, 2
caf(i,j)[num_images()] = b(i, j)
end do
end do
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) &
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = SCALAR
caf = -42
a = -42
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
sync all
if (this_image() == 1) then
caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
= b(lb1, lb2)
end if
sync all
! ARRAY = ARRAY
caf = -42
a = -42
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
sync all
if (this_image() == 1) then
caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) then
print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
lb2,":",m+lb2-1
print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
", ", j,":",j_e,":",j_s*i_sgn2
print *, i
print *, a
print *, caf
print *, a-caf
call abort()
endif
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine two
subroutine three()
integer, parameter :: lb1 = 0, lb2 = 0
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = SCALAR
caf = -42
a = -42
a(:,:) = b(lb1, lb2)
sync all
if (this_image() == 1) then
caf(:,:)[num_images()] = b(lb1, lb2)
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) &
call abort()
end if
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
a(:,:) = b(:, :)
sync all
if (this_image() == 1) then
caf(:,:)[num_images()] = b(:, :)
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) &
call abort()
end if
! Scalar assignment
caf = -42
a = -42
do j = lb2, m+lb2-1
do i = n+lb1-1, 1, -2
a(i,j) = b(i,j)
end do
end do
do j = lb2, m+lb2-1
do i = 1, n+lb1-1, 2
a(i,j) = b(i,j)
end do
end do
sync all
if (this_image() == 1) then
do j = lb2, m+lb2-1
do i = n+lb1-1, 1, -2
caf(i,j)[num_images()] = b(i, j)
end do
end do
do j = lb2, m+lb2-1
do i = 1, n+lb1-1, 2
caf(i,j)[num_images()] = b(i, j)
end do
end do
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) &
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = SCALAR
caf = -42
a = -42
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
sync all
if (this_image() == 1) then
caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
= b(lb1, lb2)
end if
sync all
! ARRAY = ARRAY
caf = -42
a = -42
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
sync all
if (this_image() == 1) then
caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
end if
sync all
if (this_image() == num_images()) then
if (any (a /= caf)) then
print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
lb2,":",m+lb2-1
print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
", ", j,":",j_e,":",j_s*i_sgn2
print *, i
print *, a
print *, caf
print *, a-caf
call abort()
endif
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine three
end program main

279
gcc/testsuite/gfortran.dg/coarray/sendget_array.f90 Normal file
View File

@ -0,0 +1,279 @@
! { dg-do run }
!
! This program does a correctness check for
! ARRAY[idx] = ARRAY[idx] and SCALAR[idx] = SCALAR[idx]
!
!
! FIXME: two/three has to be modified, test has to be checked and
! diagnostic has to be removed
!
program main
implicit none
integer, parameter :: n = 3
integer, parameter :: m = 4
! Allocatable coarrays
call one(-5, 1)
call one(0, 0)
call one(1, -5)
call one(0, -11)
! Static coarrays
call two()
call three()
contains
subroutine one(lb1, lb2)
integer, value :: lb1, lb2
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, allocatable :: caf(:,:)[:], caf2(:,:)[:]
integer, allocatable :: a(:,:), b(:,:)
allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
caf2(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
a(lb1:n+lb1-1, lb2:m+lb2-1), &
b(lb1:n+lb1-1, lb2:m+lb2-1))
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
caf2(:,:)[this_image()] = caf(:,:)[num_images()]
if (any (a /= caf2)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
if (any (a /= caf2)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
caf2(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[this_image()] &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (caf2 /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine one
subroutine two()
integer, parameter :: lb1 = -5, lb2 = 1
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: caf2(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
caf2(:,:)[this_image()] = caf(:,:)[num_images()]
if (any (a /= caf2)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
if (any (a /= caf2)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
caf2(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[this_image()] &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (caf2 /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine two
subroutine three()
integer, parameter :: lb1 = 0, lb2 = 0
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: caf2(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
caf2(:,:)[this_image()] = caf(:,:)[num_images()]
if (any (a /= caf2)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
if (any (a /= caf2)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
caf2(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[this_image()] &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (caf2 /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine three
end program main

13
libgfortran/ChangeLog
View File

@ -1,3 +1,16 @@
2014-06-17 Tobias Burnus <burnus@net-b.de>
* caf/libcaf.h (gfc_descriptor_t): New typedef.
(caf_vector_t): Update.
(_gfortran_caf_co_sum, _gfortran_caf_co_max, _gfortran_caf_co_min):
Remove vector-subscript argument.
(_gfortran_caf_co_send, _gfortran_caf_co_get,
_gfortran_caf_co_sendget): New.
* caf/single.c (_gfortran_caf_co_sum, _gfortran_caf_co_max,
_gfortran_caf_co_min): Remove vector-subscript argument.
(_gfortran_caf_co_send, _gfortran_caf_co_get,
_gfortran_caf_co_sendget): New.
2014-06-17 Janne Blomqvist <jb@gcc.gnu.org>
* libgfortran.h (xmallocarray): New prototype.

33
libgfortran/caf/libcaf.h
View File

@ -30,6 +30,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include <stddef.h> /* For size_t. */
#include <stdint.h> /* For int32_t. */
#include "libgfortran.h"
#if 0
#ifndef __GNUC__
#define __attribute__(x)
#define likely(x) (x)
@ -45,6 +48,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#define STAT_LOCKED 1
#define STAT_LOCKED_OTHER_IMAGE 2
#define STAT_STOPPED_IMAGE 6000
#endif
/* Describes what type of array we are registerring. Keep in sync with
gcc/fortran/trans.h. */
@ -57,6 +61,7 @@ typedef enum caf_register_t {
caf_register_t;
typedef void* caf_token_t;
typedef gfc_array_void gfc_descriptor_t;
/* Linked list of static coarrays registered. */
typedef struct caf_static_t {
@ -65,13 +70,19 @@ typedef struct caf_static_t {
}
caf_static_t;
/* When there is a vector subscript in this dimension, nvec == 0, otherwise,
lower_bound, upper_bound, stride contains the bounds relative to the declared
bounds; kind denotes the integer kind of the elements of vector[]. */
typedef struct caf_vector_t {
size_t nvec; /* size of the vector; 0 means dim triplet. */
size_t nvec;
union {
struct {
void *vector;
int kind;
} v;
struct {
ptrdiff_t lower_bound, upper_bound, stride;
} triplet;
ptrdiff_t *vector;
} u;
}
caf_vector_t;
@ -103,10 +114,18 @@ void _gfortran_caf_error_stop_str (const char *, int32_t)
__attribute__ ((noreturn));
void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn));
void _gfortran_caf_co_sum (void *, caf_vector_t *, int, int *, char *, int);
void _gfortran_caf_co_min (void *, caf_vector_t *, int, int *, char *, int,
int);
void _gfortran_caf_co_max (void *, caf_vector_t *, int, int *, char *, int,
int);
void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *,
char *, int);
void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *,
int, int);
void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *,
int, int);
void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, gfc_descriptor_t *, int, int);
void _gfortran_caf_send (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, gfc_descriptor_t *, int, int);
void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, caf_token_t, size_t, int,
gfc_descriptor_t *, caf_vector_t *, int, int);
#endif /* LIBCAF_H */

240
libgfortran/caf/single.c
View File

@ -205,8 +205,7 @@ _gfortran_caf_error_stop (int32_t error)
void
_gfortran_caf_co_sum (void *a __attribute__ ((unused)),
caf_vector_t vector[] __attribute__ ((unused)),
_gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
@ -216,8 +215,7 @@ _gfortran_caf_co_sum (void *a __attribute__ ((unused)),
}
void
_gfortran_caf_co_min (void *a __attribute__ ((unused)),
caf_vector_t vector[] __attribute__ ((unused)),
_gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int src_len __attribute__ ((unused)),
@ -228,8 +226,7 @@ _gfortran_caf_co_min (void *a __attribute__ ((unused)),
}
void
_gfortran_caf_co_max (void *a __attribute__ ((unused)),
caf_vector_t vector[] __attribute__ ((unused)),
_gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int src_len __attribute__ ((unused)),
@ -238,3 +235,234 @@ _gfortran_caf_co_max (void *a __attribute__ ((unused)),
if (stat)
stat = 0;
}
void
_gfortran_caf_get (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),
gfc_descriptor_t *src ,
caf_vector_t *src_vector __attribute__ ((unused)),
gfc_descriptor_t *dest, int src_kind, int dst_kind)
{
/* FIXME: Handle vector subscript, type conversion and assignment "array = scalar".
check in particular whether strings of different kinds are permitted and
whether it makes sense to handle array = scalar. */
size_t i, k, size;
int j;
int rank = GFC_DESCRIPTOR_RANK (dest);
size_t src_size = GFC_DESCRIPTOR_SIZE (src);
size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
if (rank == 0)
{
void *sr = (void *) ((char *) TOKEN (token) + offset);
if (dst_kind == src_kind)
memmove (GFC_DESCRIPTOR_DATA (dest), sr,
dst_size > src_size ? src_size : dst_size);
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{
if (dst_kind == 1)
memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size, ' ',
dst_size-src_size);
else /* dst_kind == 4. */
for (i = src_size/4; i < dst_size/4; i++)
((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t)' ';
}
return;
}
size = 1;
for (j = 0; j < rank; j++)
{
ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
if (dimextent < 0)
dimextent = 0;
size *= dimextent;
}
if (size == 0)
return;
for (i = 0; i < size; i++)
{
ptrdiff_t array_offset_dst = 0;
ptrdiff_t stride = 1;
ptrdiff_t extent = 1;
for (j = 0; j < rank-1; j++)
{
array_offset_dst += ((i / (extent*stride))
% (dest->dim[j]._ubound
- dest->dim[j].lower_bound + 1))
* dest->dim[j]._stride;
extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
stride = dest->dim[j]._stride;
}
array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
void *sr;
if (GFC_DESCRIPTOR_RANK (src) != 0)
{
ptrdiff_t array_offset_sr = 0;
stride = 1;
extent = 1;
for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
{
array_offset_sr += ((i / (extent*stride))
% (src->dim[j]._ubound
- src->dim[j].lower_bound + 1))
* src->dim[j]._stride;
extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
stride = src->dim[j]._stride;
}
array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
sr = (void *)((char *) TOKEN (token) + offset
+ array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
}
else
sr = (void *)((char *) TOKEN (token) + offset);
if (dst_kind == src_kind)
memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{
if (dst_kind == 1)
memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
else /* dst_kind == 4. */
for (k = src_size/4; k < dst_size/4; i++)
((int32_t*) dst)[i] = (int32_t)' ';
}
}
}
void
_gfortran_caf_send (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),
gfc_descriptor_t *dest,
caf_vector_t *dst_vector __attribute__ ((unused)),
gfc_descriptor_t *src, int dst_kind,
int src_kind __attribute__ ((unused)))
{
/* FIXME: Handle vector subscript, type conversion and assignment "array = scalar".
check in particular whether strings of different kinds are permitted. */
size_t i, k, size;
int j;
int rank = GFC_DESCRIPTOR_RANK (dest);
size_t src_size = GFC_DESCRIPTOR_SIZE (src);
size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
if (rank == 0)
{
void *dst = (void *) ((char *) TOKEN (token) + offset);
if (dst_kind == src_kind)
memmove (dst, GFC_DESCRIPTOR_DATA (src),
dst_size > src_size ? src_size : dst_size);
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{
if (dst_kind == 1)
memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
else /* dst_kind == 4. */
for (i = src_size/4; i < dst_size/4; i++)
((int32_t*) dst)[i] = (int32_t)' ';
}
return;
}
size = 1;
for (j = 0; j < rank; j++)
{
ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
if (dimextent < 0)
dimextent = 0;
size *= dimextent;
}
if (size == 0)
return;
#if 0
if (dst_len == src_len && PREFIX (is_contiguous) (dest)
&& PREFIX (is_contiguous) (src))
{
void *dst = (void *)((char *) TOKEN (token) + offset);
memmove (dst, src->base_addr, GFC_DESCRIPTOR_SIZE (dest)*size);
return;
}
#endif
for (i = 0; i < size; i++)
{
ptrdiff_t array_offset_dst = 0;
ptrdiff_t stride = 1;
ptrdiff_t extent = 1;
for (j = 0; j < rank-1; j++)
{
array_offset_dst += ((i / (extent*stride))
% (dest->dim[j]._ubound
- dest->dim[j].lower_bound + 1))
* dest->dim[j]._stride;
extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
stride = dest->dim[j]._stride;
}
array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
void *dst = (void *)((char *) TOKEN (token) + offset
+ array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
void *sr;
if (GFC_DESCRIPTOR_RANK (src) != 0)
{
ptrdiff_t array_offset_sr = 0;
stride = 1;
extent = 1;
for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
{
array_offset_sr += ((i / (extent*stride))
% (src->dim[j]._ubound
- src->dim[j].lower_bound + 1))
* src->dim[j]._stride;
extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
stride = src->dim[j]._stride;
}
array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
sr = (void *)((char *) src->base_addr
+ array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
}
else
sr = src->base_addr;
if (dst_kind == src_kind)
memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{
if (dst_kind == 1)
memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
else /* dst_kind == 4. */
for (k = src_size/4; k < dst_size/4; i++)
((int32_t*) dst)[i] = (int32_t)' ';
}
}
}
void
_gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
int dst_image_index, gfc_descriptor_t *dest,
caf_vector_t *dst_vector, caf_token_t src_token,
size_t src_offset,
int src_image_index __attribute__ ((unused)),
gfc_descriptor_t *src,
caf_vector_t *src_vector __attribute__ ((unused)),
int dst_len, int src_len)
{
/* FIXME: Handle vector subscript of 'src_vector'. */
/* For a single image, src->base_addr should be the same as src_token + offset
but to play save, we do it properly. */
void *src_base = GFC_DESCRIPTOR_DATA (src);
GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
_gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
src, dst_len, src_len);
GFC_DESCRIPTOR_DATA (src) = src_base;
}