This patch implements the call to the library for code of the form: caf[j] = (rhs - expr)
Caveats: It currently only handles scalars and for characters only len-one ones. While it copies also derived types, it does not handle allocatable components.
With a suitable communication library, this patch finally permits real multi-image communication. Hooray!
The next steps are (in no specific order and without committal to do it myself):
- Adding test cases for this code (dumps, -fcaf_single run-time checks) - supporting array sections and array vector sections - supporting len > 1 character strings - allocatable/pointer components of coarrays - supporting coindexed coarray on the RHS. Committed to the Fortran-CAF branch as Rev. Tobias
Index: gcc/fortran/ChangeLog.fortran-caf =================================================================== --- gcc/fortran/ChangeLog.fortran-caf (Revision 208886) +++ gcc/fortran/ChangeLog.fortran-caf (Arbeitskopie) @@ -1,3 +1,10 @@ +2014-03-28 Tobias Burnus <bur...@net-b.de> + + * trans-intrinsic.c (caf_get_image_index, conv_caf_send): New. + (gfc_conv_intrinsic_subroutine): Call it. + * resolve.c (resolve_ordinary_assign): Enable coindex LHS + support for -fcoarray=lib. + 2014-03-15 Tobias Burnus <bur...@net-b.de> * gfortran.h (gfc_isym_id): Add GFC_ISYM_CAF_SEND. @@ -6,6 +13,8 @@ * resolve.c (resolve_ordinary_assign): Prepare the replacement of the assignment for coindexed LHS by a call to caf_send. + (resolve_code): Ignore component_assignments for those + assignments which have been replaced. 2014-03-14 Tobias Burnus <bur...@net-b.de> Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (Revision 208886) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -9229,7 +9229,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_names gfc_check_assign (lhs, rhs, 1); - if (false && lhs_coindexed && gfc_option.coarray == GFC_FCOARRAY_LIB) + if (lhs_coindexed && gfc_option.coarray == GFC_FCOARRAY_LIB) { code->op = EXEC_CALL; gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true); Index: gcc/fortran/trans-intrinsic.c =================================================================== --- gcc/fortran/trans-intrinsic.c (Revision 208886) +++ gcc/fortran/trans-intrinsic.c (Arbeitskopie) @@ -7788,6 +7788,182 @@ conv_intrinsic_move_alloc (gfc_code *code) } +/* 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, PLUS_EXPR, integer_type_node, + tmp, integer_one_node); + 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, PLUS_EXPR, integer_type_node, + tmp, integer_one_node); + 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); + } + } + return img_idx; +} + + +/* Send data to a remove coarray. */ + +static tree +conv_caf_send (gfc_code *code) { + gfc_expr *lhs_expr, *rhs_expr, *async_expr; + gfc_se lhs_se, rhs_se, async_se; + stmtblock_t block; + tree caf_decl, token, offset, image_index, tmp; + + gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB); + + lhs_expr = code->ext.actual->expr; + rhs_expr = code->ext.actual->next->expr; + async_expr = code->ext.actual->next->next->expr; + gfc_init_block (&block); + + /* LHS: The coarray. */ + + if (lhs_expr->rank) + gfc_fatal_error ("Remote coarray access at %L for array sections not yet " + " implemented", &lhs_expr->where); + + gfc_init_se (&lhs_se, NULL); + gfc_conv_expr_reference (&lhs_se, lhs_expr); + + 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); + + /* Coarray token. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)) + && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE) + 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 (lhs_se.expr)) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (lhs_se.expr)))) + { + tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); + tmp = gfc_conv_descriptor_data_get (tmp); + } + else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lhs_se.expr))) + tmp = gfc_conv_descriptor_data_get (lhs_se.expr); + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (lhs_se.expr))); + tmp = lhs_se.expr; + } + + offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + offset, 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, + offset, tmp); + + /* RHS - a noncoarray. */ + + gfc_init_se (&rhs_se, NULL); + rhs_se.want_pointer = 1; + gfc_conv_expr_reference (&rhs_se, rhs_expr); + gfc_add_block_to_block (&block, &rhs_se.pre); + + gfc_init_se (&async_se, NULL); + gfc_conv_expr (&async_se, async_expr); + + tree size = size_in_bytes (TREE_TYPE (TREE_TYPE (rhs_se.expr))); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 6, + token, offset, image_index, rhs_se.expr, size, + fold_convert (boolean_type_node, async_se.expr)); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &rhs_se.post); + return gfc_finish_block (&block); +} + + tree gfc_conv_intrinsic_subroutine (gfc_code *code) { @@ -7814,6 +7990,9 @@ gfc_conv_intrinsic_subroutine (gfc_code *code) res = conv_isocbinding_subroutine (code); break; + case GFC_ISYM_CAF_SEND: + res = conv_caf_send (code); + break; default: res = NULL_TREE;