From b511626828a636ed6310cd94c4fa78365450fb34 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Tue, 17 Jun 2014 22:54:14 +0200 Subject: [PATCH] check.c (gfc_check_atomic, [...]): Use argument for GFC_ISYM_CAF_GET. gcc/fortran/ 2014-06-17 Tobias Burnus * 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 * 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 Alessandro Fanfarillo * 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 From-SVN: r211748 --- gcc/fortran/ChangeLog | 32 ++ gcc/fortran/check.c | 10 + gcc/fortran/resolve.c | 29 +- gcc/fortran/trans-const.c | 2 + gcc/fortran/trans-decl.c | 31 +- gcc/fortran/trans-expr.c | 6 +- gcc/fortran/trans-intrinsic.c | 594 ++++++++++++++++++++- gcc/fortran/trans-types.c | 87 +++ gcc/fortran/trans-types.h | 1 + gcc/fortran/trans.h | 4 + gcc/testsuite/ChangeLog | 10 + .../gfortran.dg/coarray/collectives_1.f90 | 8 +- .../gfortran.dg/coarray/collectives_2.f90 | 59 ++ gcc/testsuite/gfortran.dg/coarray/get_array.f90 | 279 ++++++++++ gcc/testsuite/gfortran.dg/coarray/send_array.f90 | 398 ++++++++++++++ .../gfortran.dg/coarray/sendget_array.f90 | 279 ++++++++++ libgfortran/ChangeLog | 13 + libgfortran/caf/libcaf.h | 35 +- libgfortran/caf/single.c | 240 ++++++++- 19 files changed, 2076 insertions(+), 41 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray/collectives_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/coarray/get_array.f90 create mode 100644 gcc/testsuite/gfortran.dg/coarray/send_array.f90 create mode 100644 gcc/testsuite/gfortran.dg/coarray/sendget_array.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e795de6767b..262858d6edf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,35 @@ +2014-06-17 Tobias Burnus + + * 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 * trans-common.c (build_common_decl): Use diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index caf3b6cbb4e..bd3eff68156 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bc2db7deb58..7ea7c36e8f9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 6c54e202777..34ab78e25d6 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -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; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index bd82a905560..2e129c96118 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 5338b0901a0..d67d737f92d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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) diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 613beef4331..52a2788080e 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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: diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 71a159b6b99..bb930f9cdea 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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" diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index e57c9d1089e..5ed87c0bb5a 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -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 diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index d1c778f7b5a..7ab9dd4feed 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 543fa01b30c..560f45abdee 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2014-06-17 Tobias Burnus + Alessandro Fanfarillo + + * 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 PR target/61533 diff --git a/gcc/testsuite/gfortran.dg/coarray/collectives_1.f90 b/gcc/testsuite/gfortran.dg/coarray/collectives_1.f90 index 14049389167..68b19a0dda8 100644 --- a/gcc/testsuite/gfortran.dg/coarray/collectives_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/collectives_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/collectives_2.f90 b/gcc/testsuite/gfortran.dg/coarray/collectives_2.f90 new file mode 100644 index 00000000000..a2f5939160c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/collectives_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/get_array.f90 b/gcc/testsuite/gfortran.dg/coarray/get_array.f90 new file mode 100644 index 00000000000..cf7674ab273 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/get_array.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/send_array.f90 b/gcc/testsuite/gfortran.dg/coarray/send_array.f90 new file mode 100644 index 00000000000..372718f53b9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/send_array.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/sendget_array.f90 b/gcc/testsuite/gfortran.dg/coarray/sendget_array.f90 new file mode 100644 index 00000000000..98e4cbe8c46 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/sendget_array.f90 @@ -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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 34f36a1fa64..0a89a989635 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,16 @@ +2014-06-17 Tobias Burnus + + * 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 * libgfortran.h (xmallocarray): New prototype. diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index 1c01f9f09b3..2c97880f122 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -30,6 +30,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include /* For size_t. */ #include /* 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 */ diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 521c93c34b0..cf1d420758a 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -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; +} -- 2.11.4.GIT