+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
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))
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;
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;
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;
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
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;
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)
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;
}
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;
}
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;
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);
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);
}
/* 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;
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)
}
+/* 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)
{
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;
return gfc_walk_intrinsic_bound (ss, expr);
case GFC_ISYM_TRANSFER:
+ case GFC_ISYM_CAF_GET:
return gfc_walk_intrinsic_libfunc (ss, expr);
default:
{
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);
else
strlen = integer_zero_node;
- vec = null_pointer_node;
-
/* image_index. */
if (code->ext.actual->next->expr)
{
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);
{
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);
{
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);
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:
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"
tree gfc_get_dtype (tree);
tree gfc_get_ppc_type (gfc_component *);
+tree gfc_get_caf_vector_type (int dim);
#endif
/* 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);
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;
+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
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)
!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)
!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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+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.
#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)
#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. */
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 {
}
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;
__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 */
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)))
}
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)),
}
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)),
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;
+}
projects / thirdparty / gcc.git / commitdiff
