diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc
index 50029102eb9ad5a7e0adda212bfa5143c3851612..e5648e0d02798a219b534f46c6ce95ab30eb84ac 100644
--- a/gcc/fortran/coarray.cc
+++ b/gcc/fortran/coarray.cc
@@ -1351,12 +1351,6 @@ rewrite_caf_send (gfc_code *c)
&& arg->next->next && arg->next->next->expr->expr_type == EXPR_VARIABLE)
return;
- if (gfc_is_coindexed (rhs))
- {
- c->resolved_isym->id = GFC_ISYM_CAF_SENDGET;
- return;
- }
-
send_to_remote_expr = create_send_callback (lhs, rhs);
send_to_remote_hash_expr = gfc_get_expr ();
send_to_remote_hash_expr->expr_type = EXPR_CONSTANT;
@@ -1372,6 +1366,28 @@ rewrite_caf_send (gfc_code *c)
arg = arg->next;
arg->expr = send_to_remote_expr;
gfc_add_caf_accessor (send_to_remote_hash_expr, send_to_remote_expr);
+
+ if (gfc_is_coindexed (rhs))
+ {
+ gfc_expr *get_from_remote_expr, *get_from_remote_hash_expr;
+
+ c->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SENDGET);
+ get_from_remote_expr = create_get_callback (rhs);
+ get_from_remote_hash_expr = gfc_get_expr ();
+ get_from_remote_hash_expr->expr_type = EXPR_CONSTANT;
+ get_from_remote_hash_expr->ts.type = BT_INTEGER;
+ get_from_remote_hash_expr->ts.kind = gfc_default_integer_kind;
+ get_from_remote_hash_expr->where = rhs->where;
+ mpz_init_set_ui (get_from_remote_hash_expr->value.integer,
+ gfc_hash_value (get_from_remote_expr->symtree->n.sym));
+ arg->next = gfc_get_actual_arglist ();
+ arg = arg->next;
+ arg->expr = get_from_remote_hash_expr;
+ arg->next = gfc_get_actual_arglist ();
+ arg = arg->next;
+ arg->expr = get_from_remote_expr;
+ gfc_add_caf_accessor (get_from_remote_hash_expr, get_from_remote_expr);
+ }
}
static int
@@ -1451,7 +1467,9 @@ coindexed_code_callback (gfc_code **c, int *walk_subtrees,
*walk_subtrees = 0;
break;
case GFC_ISYM_CAF_SENDGET:
- // rewrite_caf_sendget (*c);
+ /* Seldomly this routine is called again with the symbol already
+ changed to CAF_SENDGET. Do not process the subtree again. The
+ rewrite has already been done by rewrite_caf_send (). */
*walk_subtrees = 0;
break;
case GFC_ISYM_ATOMIC_ADD:
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 059022ea54393845cb6f33d1229e21ae6a61503a..36c203b27b3a993d98c2fff2b674e05d5f8e25c7 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -4214,6 +4214,7 @@ future implementation of teams. It is about to change without further notice.
* _gfortran_caf_get_from_remote:: Getting data from a remote image using a remote side accessor
* _gfortran_caf_is_present_on_remote:: Check that a coarray or a part of it is allocated on the remote image
* _gfortran_caf_send_to_remote:: Send data to a remote image using a remote side accessor to store it
+* _gfortran_caf_transfer_between_remotes:: Initiate data transfer between to remote images
* _gfortran_caf_sendget_by_ref:: Sending data between remote images using enhanced references
* _gfortran_caf_lock:: Locking a lock variable
* _gfortran_caf_unlock:: Unlocking a lock variable
@@ -5153,6 +5154,111 @@ The implementation has to take care that it handles this case, e.g. using
@end table
+@node _gfortran_caf_transfer_between_remotes
+@subsection @code{_gfortran_caf_transfer_between_remotes} --- Initiate data transfer between to remote images
+@cindex Coarray, _gfortran_caf_transfer_between_remotes
+
+@table @asis
+@item @emph{Description}:
+Initiates a transfer of data from one remote image to another remote image.
+The call modifies the memory of the receiving remote image given by
+@code{dst_image_index}. The @code{src_image_index}'s memory is not modified.
+The call returns when the transfer has commenced.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_transfer_between_remotes (caf_token_t dst_token,
+gfc_descriptor_t *opt_dst_desc, size_t *opt_dst_charlen,
+const int dst_image_index, const int dst_access_index, void *dst_add_data,
+const size_t dst_add_data_size, caf_token_t src_token,
+const gfc_descriptor_t *opt_src_desc, const size_t *opt_src_charlen,
+const int src_image_index, const int src_access_index, void *src_add_data,
+const size_t src_add_data_size, const size_t src_size,
+const bool scalar_transfer, int *dst_stat, int *src_stat, caf_team_t *dst_team,
+int *dst_team_number, caf_team_t *src_team, int *src_team_number)
+}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{dst_token} @tab intent(in) An opaque pointer identifying the coarray
+on the receiving image.
+@item @var{opt_dst_desc} @tab intent(inout) A pointer to the descriptor when
+the object identified by @var{dst_token} is an array with a descriptor. The
+parameter needs to be set to @code{NULL}, when @var{dst_token} identifies a
+scalar or is an array without a descriptor.
+@item @var{opt_dst_charlen} @tab intent(in) When the object to modify on the
+receiving image is a char array with deferred length, then this parameter needs
+to be set to point to its length. Else the parameter needs to be set to
+@code{NULL}.
+@item @var{dst_image_index} @tab intent(in) The ID of the receiving/destination
+remote image; must be a positive number. @code{this_image ()} is valid.
+@item @var{dst_access_index} @tab intent(in) The index of the accessor to
+execute on the receiving image as returned by
+@code{_gfortran_caf_get_remote_function_index ()}.
+@item @var{dst_add_data} @tab intent(inout) Additional data needed in the
+accessor on the receiving side. I.e., when an array reference uses a local
+variable @var{v}, it is transported in this structure and all references in the
+accessor are rewritten to access the member. The data in the structure of
+@var{dst_add_data} may be changed by the accessor, but these changes are lost to
+the calling Fortran program.
+@item @var{dst_add_data_size} @tab intent(in) The size of the
+@var{dst_add_data} structure.
+@item @var{src_token} @tab intent(in) An opaque pointer identifying the coarray
+on the sending image.
+@item @var{opt_src_desc} @tab intent(inout) A pointer to the descriptor when
+the object identified by @var{src_token} is an array with a descriptor. The
+parameter needs to be set to @code{NULL}, when @var{src_token} identifies a
+scalar or is an array without a descriptor.
+@item @var{opt_src_charlen} @tab intent(in) When the object to get from the
+source image is a char array with deferred length, then this parameter needs
+to be set to point to its length. Else the parameter needs to be set to
+@code{NULL}.
+@item @var{src_image_index} @tab intent(in) The ID of the sending/source
+remote image; must be a positive number. @code{this_image ()} is valid.
+@item @var{src_access_index} @tab intent(in) The index of the accessor to
+execute on the sending image as returned by
+@code{_gfortran_caf_get_remote_function_index ()}.
+@item @var{src_add_data} @tab intent(inout) Additional data needed in the
+accessor on the sending side. I.e., when an array reference uses a local
+variable @var{v}, it is transported in this structure and all references in the
+accessor are rewritten to access the member. The data in the structure of
+@var{src_add_data} may be changed by the accessor, but these changes are lost to
+the calling Fortran program.
+@item @var{src_add_data_size} @tab intent(in) The size of the
+@var{src_add_data} structure.
+@item @var{src_size} @tab intent(in) The size of data expected to be transferred
+between the images. If the data type to get is a string or string array,
+then this needs to be set to the byte size of each character, i.e. @code{4} for
+a @code{CHARACTER (KIND=4)} string. The length of the string is then given
+in @code{opt_src_charlen} and @code{opt_dst_charlen} (also for string arrays).
+@item @var{scalar_transfer} @tab intent(in) Is set to true when the data to be
+transfered between the two images is not an array with a descriptor.
+@item @var{dst_stat} @tab intent(out) When non-@code{NULL} give the result of
+the operation on the receiving side, i.e., zero on success and non-zero on
+error. When @code{NULL} and an error occurs, then an error message is printed
+and the program is terminated.
+@item @var{src_stat} @tab intent(out) When non-@code{NULL} give the result of
+the operation on the sending side, i.e., zero on success and non-zero on error.
+When @code{NULL} and an error occurs, then an error message is printed and the
+program is terminated.
+@item @var{dst_team} @tab intent(in) The opaque team handle as returned by
+@code{FORM TEAM}. Unused at the moment.
+@item @var{dst_team_number} @tab intent(in) The number of the team this access
+is to be part of. Unused at the moment.
+@item @var{src_team} @tab intent(in) The opaque team handle as returned by
+@code{FORM TEAM}. Unused at the moment.
+@item @var{src_team_number} @tab intent(in) The number of the team this access
+is to be part of. Unused at the moment.
+@end multitable
+
+@item @emph{NOTES}
+It is permitted to have both @code{dst_image_index} and @code{src_image_index}
+equal the current image; the memory to send the data to and the memory to read
+for the data may (partially) overlap. The implementation has to take care that
+it handles this case, e.g. using @code{memmove} which handles (partially)
+overlapping memory.
+@end table
+
+
@node _gfortran_caf_sendget_by_ref
@subsection @code{_gfortran_caf_sendget_by_ref} --- Sending data between remote images using enhanced references on both sides
@cindex Coarray, _gfortran_caf_sendget_by_ref
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 99d5abcb9d5de464101e6a4f2c531a94102ef65b..30f532b5766b2a6460d4cc8d6ecf2e9fbde0599b 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -3898,6 +3898,10 @@ add_subroutines (void)
"y", BT_REAL, dr, REQUIRED, INTENT_IN);
make_from_module();
+ add_sym_2s (GFC_PREFIX ("caf_sendget"), GFC_ISYM_CAF_SENDGET, CLASS_IMPURE,
+ BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, NULL, "x", BT_REAL, dr,
+ REQUIRED, INTENT_OUT, "y", BT_REAL, dr, REQUIRED, INTENT_IN);
+ make_from_module ();
/* More G77 compatibility garbage. */
add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 37df931075bb0ed1d93e49d53a18a609944709f4..025ad539d25307b29758127b28dfe42c63ee2753 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -149,6 +149,7 @@ tree gfor_fndecl_caf_register_accessors_finish;
tree gfor_fndecl_caf_get_remote_function_index;
tree gfor_fndecl_caf_get_from_remote;
tree gfor_fndecl_caf_send_to_remote;
+tree gfor_fndecl_caf_transfer_between_remotes;
tree gfor_fndecl_caf_sync_all;
tree gfor_fndecl_caf_sync_memory;
@@ -4144,9 +4145,19 @@ gfc_build_builtin_function_decls (void)
pvoid_type_node, size_type_node, pint_type, pvoid_type_node,
pint_type);
+ gfor_fndecl_caf_transfer_between_remotes
+ = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_transfer_between_remotes")),
+ ". r r r r r r r r r r r r r r r r w w r r ", void_type_node, 20,
+ pvoid_type_node, pvoid_type_node, psize_type, integer_type_node,
+ integer_type_node, pvoid_type_node, size_type_node, pvoid_type_node,
+ pvoid_type_node, psize_type, integer_type_node, integer_type_node,
+ pvoid_type_node, size_type_node, size_type_node, boolean_type_node,
+ pint_type, pint_type, pvoid_type_node, pint_type);
+
gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_sync_all")), ". w w . ", void_type_node,
- 3, pint_type, pchar_type_node, size_type_node);
+ get_identifier (PREFIX ("caf_sync_all")), ". w w . ", void_type_node, 3,
+ pint_type, pchar_type_node, size_type_node);
gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_sync_memory")), ". w w . ", void_type_node,
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 19286f7a0ae07e56d824496b4f7d3aa24efce1ae..84f18a533a9292b01bb440f5bbdd37083fa5f0b8 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1041,632 +1041,636 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
} 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 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), 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 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), 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 tree
-compute_component_offset (tree field, tree type)
-{
- tree tmp;
- if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
- && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
- {
- tmp = fold_build2 (TRUNC_DIV_EXPR, type,
- DECL_FIELD_BIT_OFFSET (field),
- bitsize_unit_node);
- return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
- }
- else
- return DECL_FIELD_OFFSET (field);
-}
-
-
-static tree
-conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
-{
- gfc_ref *ref = expr->ref, *last_comp_ref;
- tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2,
- field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
- start, end, stride, vector, nvec;
- gfc_se se;
- bool ref_static_array = false;
- tree last_component_ref_tree = NULL_TREE;
- int i, last_type_n;
-
- if (expr->symtree)
- {
- last_component_ref_tree = expr->symtree->n.sym->backend_decl;
- ref_static_array = !expr->symtree->n.sym->attr.allocatable
- && !expr->symtree->n.sym->attr.pointer;
- }
-
- /* Prevent uninit-warning. */
- reference_type = NULL_TREE;
-
- /* Skip refs upto the first coarray-ref. */
- last_comp_ref = NULL;
- while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
- {
- /* Remember the type of components skipped. */
- if (ref->type == REF_COMPONENT)
- last_comp_ref = ref;
- ref = ref->next;
- }
- /* When a component was skipped, get the type information of the last
- component ref, else get the type from the symbol. */
- if (last_comp_ref)
- {
- last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
- last_type_n = last_comp_ref->u.c.component->ts.type;
- }
- else
- {
- last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
- last_type_n = expr->symtree->n.sym->ts.type;
- }
-
- while (ref)
- {
- if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
- && ref->u.ar.dimen == 0)
- {
- /* Skip pure coindexes. */
- ref = ref->next;
- continue;
- }
- tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
- reference_type = TREE_TYPE (tmp);
-
- if (caf_ref == NULL_TREE)
- caf_ref = tmp;
-
- /* Construct the chain of refs. */
- if (prev_caf_ref != NULL_TREE)
- {
- field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
- tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), prev_caf_ref, field,
- NULL_TREE);
- gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
- tmp));
- }
- prev_caf_ref = tmp;
-
- switch (ref->type)
- {
- case REF_COMPONENT:
- last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
- last_type_n = ref->u.c.component->ts.type;
- /* Set the type of the ref. */
- field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), prev_caf_ref, field,
- NULL_TREE);
- gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
- GFC_CAF_REF_COMPONENT));
-
- /* Ref the c in union u. */
- field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), prev_caf_ref, field,
- NULL_TREE);
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
- inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), tmp, field,
- NULL_TREE);
-
- /* Set the offset. */
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), inner_struct, field,
- NULL_TREE);
- /* Computing the offset is somewhat harder. The bit_offset has to be
- taken into account. When the bit_offset in the field_decl is non-
- null, divide it by the bitsize_unit and add it to the regular
- offset. */
- tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
- TREE_TYPE (tmp));
- gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
-
- /* Set caf_token_offset. */
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), inner_struct, field,
- NULL_TREE);
- if ((ref->u.c.component->attr.allocatable
- || ref->u.c.component->attr.pointer)
- && ref->u.c.component->attr.dimension)
- {
- tree arr_desc_token_offset;
- /* Get the token field from the descriptor. */
- arr_desc_token_offset = TREE_OPERAND (
- gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1);
- arr_desc_token_offset
- = compute_component_offset (arr_desc_token_offset,
- TREE_TYPE (tmp));
- tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
- TREE_TYPE (tmp2), tmp2,
- arr_desc_token_offset);
- }
- else if (ref->u.c.component->caf_token)
- tmp2 = compute_component_offset (gfc_comp_caf_token (
- ref->u.c.component),
- TREE_TYPE (tmp));
- else
- tmp2 = integer_zero_node;
- gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
-
- /* Remember whether this ref was to a non-allocatable/non-pointer
- component so the next array ref can be tailored correctly. */
- ref_static_array = !ref->u.c.component->attr.allocatable
- && !ref->u.c.component->attr.pointer;
- last_component_ref_tree = ref_static_array
- ? ref->u.c.component->backend_decl : NULL_TREE;
- break;
- case REF_ARRAY:
- if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
- ref_static_array = false;
- /* Set the type of the ref. */
- field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), prev_caf_ref, field,
- NULL_TREE);
- gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
- ref_static_array
- ? GFC_CAF_REF_STATIC_ARRAY
- : GFC_CAF_REF_ARRAY));
-
- /* Ref the a in union u. */
- field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), prev_caf_ref, field,
- NULL_TREE);
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
- inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), tmp, field,
- NULL_TREE);
-
- /* Set the static_array_type in a for static arrays. */
- if (ref_static_array)
- {
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
- 1);
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), inner_struct, field,
- NULL_TREE);
- gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
- last_type_n));
- }
- /* Ref the mode in the inner_struct. */
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
- mode = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), inner_struct, field,
- NULL_TREE);
- /* Ref the dim in the inner_struct. */
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
- dim_array = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), inner_struct, field,
- NULL_TREE);
- for (i = 0; i < ref->u.ar.dimen; ++i)
- {
- /* Ref dim i. */
- dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
- dim_type = TREE_TYPE (dim);
- mode_rhs = start = end = stride = NULL_TREE;
- switch (ref->u.ar.dimen_type[i])
- {
- case DIMEN_RANGE:
- if (ref->u.ar.end[i])
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, ref->u.ar.end[i]);
- gfc_add_block_to_block (block, &se.pre);
- if (ref_static_array)
- {
- /* Make the index zero-based, when reffing a static
- array. */
- end = se.expr;
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
- gfc_add_block_to_block (block, &se.pre);
- se.expr = fold_build2 (MINUS_EXPR,
- gfc_array_index_type,
- end, fold_convert (
- gfc_array_index_type,
- se.expr));
- }
- end = gfc_evaluate_now (fold_convert (
- gfc_array_index_type,
- se.expr),
- block);
- }
- else if (ref_static_array)
- end = fold_build2 (MINUS_EXPR,
- gfc_array_index_type,
- gfc_conv_array_ubound (
- last_component_ref_tree, i),
- gfc_conv_array_lbound (
- last_component_ref_tree, i));
- else
- {
- end = NULL_TREE;
- mode_rhs = build_int_cst (unsigned_char_type_node,
- GFC_CAF_ARR_REF_OPEN_END);
- }
- if (ref->u.ar.stride[i])
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, ref->u.ar.stride[i]);
- gfc_add_block_to_block (block, &se.pre);
- stride = gfc_evaluate_now (fold_convert (
- gfc_array_index_type,
- se.expr),
- block);
- if (ref_static_array)
- {
- /* Make the index zero-based, when reffing a static
- array. */
- stride = fold_build2 (MULT_EXPR,
- gfc_array_index_type,
- gfc_conv_array_stride (
- last_component_ref_tree,
- i),
- stride);
- gcc_assert (end != NULL_TREE);
- /* Multiply with the product of array's stride and
- the step of the ref to a virtual upper bound.
- We cannot compute the actual upper bound here or
- the caflib would compute the extend
- incorrectly. */
- end = fold_build2 (MULT_EXPR, gfc_array_index_type,
- end, gfc_conv_array_stride (
- last_component_ref_tree,
- i));
- end = gfc_evaluate_now (end, block);
- stride = gfc_evaluate_now (stride, block);
- }
- }
- else if (ref_static_array)
- {
- stride = gfc_conv_array_stride (last_component_ref_tree,
- i);
- end = fold_build2 (MULT_EXPR, gfc_array_index_type,
- end, stride);
- end = gfc_evaluate_now (end, block);
- }
- else
- /* Always set a ref stride of one to make caflib's
- handling easier. */
- stride = gfc_index_one_node;
-
- /* Fall through. */
- case DIMEN_ELEMENT:
- if (ref->u.ar.start[i])
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, ref->u.ar.start[i]);
- gfc_add_block_to_block (block, &se.pre);
- if (ref_static_array)
- {
- /* Make the index zero-based, when reffing a static
- array. */
- start = fold_convert (gfc_array_index_type, se.expr);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
- gfc_add_block_to_block (block, &se.pre);
- se.expr = fold_build2 (MINUS_EXPR,
- gfc_array_index_type,
- start, fold_convert (
- gfc_array_index_type,
- se.expr));
- /* Multiply with the stride. */
- se.expr = fold_build2 (MULT_EXPR,
- gfc_array_index_type,
- se.expr,
- gfc_conv_array_stride (
- last_component_ref_tree,
- i));
- }
- start = gfc_evaluate_now (fold_convert (
- gfc_array_index_type,
- se.expr),
- block);
- if (mode_rhs == NULL_TREE)
- mode_rhs = build_int_cst (unsigned_char_type_node,
- ref->u.ar.dimen_type[i]
- == DIMEN_ELEMENT
- ? GFC_CAF_ARR_REF_SINGLE
- : GFC_CAF_ARR_REF_RANGE);
- }
- else if (ref_static_array)
- {
- start = integer_zero_node;
- mode_rhs = build_int_cst (unsigned_char_type_node,
- ref->u.ar.start[i] == NULL
- ? GFC_CAF_ARR_REF_FULL
- : GFC_CAF_ARR_REF_RANGE);
- }
- else if (end == NULL_TREE)
- mode_rhs = build_int_cst (unsigned_char_type_node,
- GFC_CAF_ARR_REF_FULL);
- else
- mode_rhs = build_int_cst (unsigned_char_type_node,
- GFC_CAF_ARR_REF_OPEN_START);
-
- /* Ref the s in dim. */
- field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), dim, field,
- NULL_TREE);
-
- /* Set start in s. */
- if (start != NULL_TREE)
- {
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
- 0);
- tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), tmp, field,
- NULL_TREE);
- gfc_add_modify (block, tmp2,
- fold_convert (TREE_TYPE (tmp2), start));
- }
-
- /* Set end in s. */
- if (end != NULL_TREE)
- {
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
- 1);
- tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), tmp, field,
- NULL_TREE);
- gfc_add_modify (block, tmp2,
- fold_convert (TREE_TYPE (tmp2), end));
- }
-
- /* Set end in s. */
- if (stride != NULL_TREE)
- {
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
- 2);
- tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), tmp, field,
- NULL_TREE);
- gfc_add_modify (block, tmp2,
- fold_convert (TREE_TYPE (tmp2), stride));
- }
- break;
- case DIMEN_VECTOR:
- /* TODO: In case of static array. */
- gcc_assert (!ref_static_array);
- mode_rhs = build_int_cst (unsigned_char_type_node,
- GFC_CAF_ARR_REF_VECTOR);
- gfc_init_se (&se, NULL);
- se.descriptor_only = 1;
- gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
- gfc_add_block_to_block (block, &se.pre);
- vector = se.expr;
- tmp = gfc_conv_descriptor_lbound_get (vector,
- gfc_rank_cst[0]);
- tmp2 = gfc_conv_descriptor_ubound_get (vector,
- gfc_rank_cst[0]);
- nvec = gfc_conv_array_extent_dim (tmp, tmp2, 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);
- vector = gfc_conv_descriptor_data_get (vector);
-
- /* Ref the v in dim. */
- field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
- tmp = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), dim, field,
- NULL_TREE);
-
- /* Set vector in v. */
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
- tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), tmp, field,
- NULL_TREE);
- gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
- vector));
-
- /* Set nvec in v. */
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
- tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), tmp, field,
- NULL_TREE);
- gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
- nvec));
-
- /* Set kind in v. */
- field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
- tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), tmp, field,
- NULL_TREE);
- gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
- ref->u.ar.start[i]->ts.kind));
- break;
- default:
- gcc_unreachable ();
- }
- /* Set the mode for dim i. */
- tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
- gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
- mode_rhs));
- }
-
- /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
- if (i < GFC_MAX_DIMENSIONS)
- {
- tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
- gfc_add_modify (block, tmp,
- build_int_cst (unsigned_char_type_node,
- GFC_CAF_ARR_REF_NONE));
- }
- break;
- default:
- gcc_unreachable ();
- }
-
- /* Set the size of the current type. */
- field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- prev_caf_ref, field, NULL_TREE);
- gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
- TYPE_SIZE_UNIT (last_type)));
-
- ref = ref->next;
- }
-
- if (prev_caf_ref != NULL_TREE)
- {
- field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- prev_caf_ref, field, NULL_TREE);
- gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
- null_pointer_node));
- }
- return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
- : NULL_TREE;
-}
+// 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 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), 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 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), 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 tree
+// compute_component_offset (tree field, tree type)
+// {
+// tree tmp;
+// if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
+// && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
+// {
+// tmp = fold_build2 (TRUNC_DIV_EXPR, type,
+// DECL_FIELD_BIT_OFFSET (field),
+// bitsize_unit_node);
+// return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
+// }
+// else
+// return DECL_FIELD_OFFSET (field);
+// }
+
+// static tree
+// conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
+// {
+// gfc_ref *ref = expr->ref, *last_comp_ref;
+// tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp,
+// tmp2,
+// field, last_type, inner_struct, mode, mode_rhs, dim_array, dim,
+// dim_type, start, end, stride, vector, nvec;
+// gfc_se se;
+// bool ref_static_array = false;
+// tree last_component_ref_tree = NULL_TREE;
+// int i, last_type_n;
+
+// if (expr->symtree)
+// {
+// last_component_ref_tree = expr->symtree->n.sym->backend_decl;
+// ref_static_array = !expr->symtree->n.sym->attr.allocatable
+// && !expr->symtree->n.sym->attr.pointer;
+// }
+
+// /* Prevent uninit-warning. */
+// reference_type = NULL_TREE;
+
+// /* Skip refs upto the first coarray-ref. */
+// last_comp_ref = NULL;
+// while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
+// {
+// /* Remember the type of components skipped. */
+// if (ref->type == REF_COMPONENT)
+// last_comp_ref = ref;
+// ref = ref->next;
+// }
+// /* When a component was skipped, get the type information of the last
+// component ref, else get the type from the symbol. */
+// if (last_comp_ref)
+// {
+// last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
+// last_type_n = last_comp_ref->u.c.component->ts.type;
+// }
+// else
+// {
+// last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
+// last_type_n = expr->symtree->n.sym->ts.type;
+// }
+
+// while (ref)
+// {
+// if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
+// && ref->u.ar.dimen == 0)
+// {
+// /* Skip pure coindexes. */
+// ref = ref->next;
+// continue;
+// }
+// tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
+// reference_type = TREE_TYPE (tmp);
+
+// if (caf_ref == NULL_TREE)
+// caf_ref = tmp;
+
+// /* Construct the chain of refs. */
+// if (prev_caf_ref != NULL_TREE)
+// {
+// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
+// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), prev_caf_ref, field,
+// NULL_TREE);
+// gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
+// tmp));
+// }
+// prev_caf_ref = tmp;
+
+// switch (ref->type)
+// {
+// case REF_COMPONENT:
+// last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
+// last_type_n = ref->u.c.component->ts.type;
+// /* Set the type of the ref. */
+// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), prev_caf_ref, field,
+// NULL_TREE);
+// gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
+// GFC_CAF_REF_COMPONENT));
+
+// /* Ref the c in union u. */
+// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), prev_caf_ref, field,
+// NULL_TREE);
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
+// inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), tmp, field,
+// NULL_TREE);
+
+// /* Set the offset. */
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), inner_struct, field,
+// NULL_TREE);
+// /* Computing the offset is somewhat harder. The bit_offset has to be
+// taken into account. When the bit_offset in the field_decl is non-
+// null, divide it by the bitsize_unit and add it to the regular
+// offset. */
+// tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
+// TREE_TYPE (tmp));
+// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+
+// /* Set caf_token_offset. */
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), inner_struct, field,
+// NULL_TREE);
+// if ((ref->u.c.component->attr.allocatable
+// || ref->u.c.component->attr.pointer)
+// && ref->u.c.component->attr.dimension)
+// {
+// tree arr_desc_token_offset;
+// /* Get the token field from the descriptor. */
+// arr_desc_token_offset = TREE_OPERAND (
+// gfc_conv_descriptor_token
+// (ref->u.c.component->backend_decl), 1); arr_desc_token_offset
+// = compute_component_offset (arr_desc_token_offset,
+// TREE_TYPE (tmp)); tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
+// TREE_TYPE (tmp2), tmp2, arr_desc_token_offset);
+// }
+// else if (ref->u.c.component->caf_token)
+// tmp2 = compute_component_offset (gfc_comp_caf_token (
+// ref->u.c.component),
+// TREE_TYPE (tmp));
+// else
+// tmp2 = integer_zero_node;
+// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+
+// /* Remember whether this ref was to a non-allocatable/non-pointer
+// component so the next array ref can be tailored correctly. */
+// ref_static_array = !ref->u.c.component->attr.allocatable
+// && !ref->u.c.component->attr.pointer;
+// last_component_ref_tree = ref_static_array
+// ? ref->u.c.component->backend_decl : NULL_TREE;
+// break;
+// case REF_ARRAY:
+// if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
+// ref_static_array = false;
+// /* Set the type of the ref. */
+// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), prev_caf_ref, field,
+// NULL_TREE);
+// gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
+// ref_static_array
+// ? GFC_CAF_REF_STATIC_ARRAY
+// : GFC_CAF_REF_ARRAY));
+
+// /* Ref the a in union u. */
+// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), prev_caf_ref, field,
+// NULL_TREE);
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
+// inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), tmp, field,
+// NULL_TREE);
+
+// /* Set the static_array_type in a for static arrays. */
+// if (ref_static_array)
+// {
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
+// 1);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), inner_struct, field,
+// NULL_TREE);
+// gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
+// last_type_n));
+// }
+// /* Ref the mode in the inner_struct. */
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
+// mode = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), inner_struct, field,
+// NULL_TREE);
+// /* Ref the dim in the inner_struct. */
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
+// dim_array = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), inner_struct, field,
+// NULL_TREE);
+// for (i = 0; i < ref->u.ar.dimen; ++i)
+// {
+// /* Ref dim i. */
+// dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
+// dim_type = TREE_TYPE (dim);
+// mode_rhs = start = end = stride = NULL_TREE;
+// switch (ref->u.ar.dimen_type[i])
+// {
+// case DIMEN_RANGE:
+// if (ref->u.ar.end[i])
+// {
+// gfc_init_se (&se, NULL);
+// gfc_conv_expr (&se, ref->u.ar.end[i]);
+// gfc_add_block_to_block (block, &se.pre);
+// if (ref_static_array)
+// {
+// /* Make the index zero-based, when reffing a static
+// array. */
+// end = se.expr;
+// gfc_init_se (&se, NULL);
+// gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
+// gfc_add_block_to_block (block, &se.pre);
+// se.expr = fold_build2 (MINUS_EXPR,
+// gfc_array_index_type,
+// end, fold_convert (
+// gfc_array_index_type,
+// se.expr));
+// }
+// end = gfc_evaluate_now (fold_convert (
+// gfc_array_index_type,
+// se.expr),
+// block);
+// }
+// else if (ref_static_array)
+// end = fold_build2 (MINUS_EXPR,
+// gfc_array_index_type,
+// gfc_conv_array_ubound (
+// last_component_ref_tree, i),
+// gfc_conv_array_lbound (
+// last_component_ref_tree, i));
+// else
+// {
+// end = NULL_TREE;
+// mode_rhs = build_int_cst (unsigned_char_type_node,
+// GFC_CAF_ARR_REF_OPEN_END);
+// }
+// if (ref->u.ar.stride[i])
+// {
+// gfc_init_se (&se, NULL);
+// gfc_conv_expr (&se, ref->u.ar.stride[i]);
+// gfc_add_block_to_block (block, &se.pre);
+// stride = gfc_evaluate_now (fold_convert (
+// gfc_array_index_type,
+// se.expr),
+// block);
+// if (ref_static_array)
+// {
+// /* Make the index zero-based, when reffing a static
+// array. */
+// stride = fold_build2 (MULT_EXPR,
+// gfc_array_index_type,
+// gfc_conv_array_stride (
+// last_component_ref_tree,
+// i),
+// stride);
+// gcc_assert (end != NULL_TREE);
+// /* Multiply with the product of array's stride and
+// the step of the ref to a virtual upper bound.
+// We cannot compute the actual upper bound here or
+// the caflib would compute the extend
+// incorrectly. */
+// end = fold_build2 (MULT_EXPR, gfc_array_index_type,
+// end, gfc_conv_array_stride (
+// last_component_ref_tree,
+// i));
+// end = gfc_evaluate_now (end, block);
+// stride = gfc_evaluate_now (stride, block);
+// }
+// }
+// else if (ref_static_array)
+// {
+// stride = gfc_conv_array_stride (last_component_ref_tree,
+// i);
+// end = fold_build2 (MULT_EXPR, gfc_array_index_type,
+// end, stride);
+// end = gfc_evaluate_now (end, block);
+// }
+// else
+// /* Always set a ref stride of one to make caflib's
+// handling easier. */
+// stride = gfc_index_one_node;
+
+// /* Fall through. */
+// case DIMEN_ELEMENT:
+// if (ref->u.ar.start[i])
+// {
+// gfc_init_se (&se, NULL);
+// gfc_conv_expr (&se, ref->u.ar.start[i]);
+// gfc_add_block_to_block (block, &se.pre);
+// if (ref_static_array)
+// {
+// /* Make the index zero-based, when reffing a static
+// array. */
+// start = fold_convert (gfc_array_index_type, se.expr);
+// gfc_init_se (&se, NULL);
+// gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
+// gfc_add_block_to_block (block, &se.pre);
+// se.expr = fold_build2 (MINUS_EXPR,
+// gfc_array_index_type,
+// start, fold_convert (
+// gfc_array_index_type,
+// se.expr));
+// /* Multiply with the stride. */
+// se.expr = fold_build2 (MULT_EXPR,
+// gfc_array_index_type,
+// se.expr,
+// gfc_conv_array_stride (
+// last_component_ref_tree,
+// i));
+// }
+// start = gfc_evaluate_now (fold_convert (
+// gfc_array_index_type,
+// se.expr),
+// block);
+// if (mode_rhs == NULL_TREE)
+// mode_rhs = build_int_cst (unsigned_char_type_node,
+// ref->u.ar.dimen_type[i]
+// == DIMEN_ELEMENT
+// ? GFC_CAF_ARR_REF_SINGLE
+// : GFC_CAF_ARR_REF_RANGE);
+// }
+// else if (ref_static_array)
+// {
+// start = integer_zero_node;
+// mode_rhs = build_int_cst (unsigned_char_type_node,
+// ref->u.ar.start[i] == NULL
+// ? GFC_CAF_ARR_REF_FULL
+// : GFC_CAF_ARR_REF_RANGE);
+// }
+// else if (end == NULL_TREE)
+// mode_rhs = build_int_cst (unsigned_char_type_node,
+// GFC_CAF_ARR_REF_FULL);
+// else
+// mode_rhs = build_int_cst (unsigned_char_type_node,
+// GFC_CAF_ARR_REF_OPEN_START);
+
+// /* Ref the s in dim. */
+// field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), dim, field,
+// NULL_TREE);
+
+// /* Set start in s. */
+// if (start != NULL_TREE)
+// {
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
+// 0);
+// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), tmp, field,
+// NULL_TREE);
+// gfc_add_modify (block, tmp2,
+// fold_convert (TREE_TYPE (tmp2), start));
+// }
+
+// /* Set end in s. */
+// if (end != NULL_TREE)
+// {
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
+// 1);
+// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), tmp, field,
+// NULL_TREE);
+// gfc_add_modify (block, tmp2,
+// fold_convert (TREE_TYPE (tmp2), end));
+// }
+
+// /* Set end in s. */
+// if (stride != NULL_TREE)
+// {
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
+// 2);
+// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), tmp, field,
+// NULL_TREE);
+// gfc_add_modify (block, tmp2,
+// fold_convert (TREE_TYPE (tmp2), stride));
+// }
+// break;
+// case DIMEN_VECTOR:
+// /* TODO: In case of static array. */
+// gcc_assert (!ref_static_array);
+// mode_rhs = build_int_cst (unsigned_char_type_node,
+// GFC_CAF_ARR_REF_VECTOR);
+// gfc_init_se (&se, NULL);
+// se.descriptor_only = 1;
+// gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
+// gfc_add_block_to_block (block, &se.pre);
+// vector = se.expr;
+// tmp = gfc_conv_descriptor_lbound_get (vector,
+// gfc_rank_cst[0]);
+// tmp2 = gfc_conv_descriptor_ubound_get (vector,
+// gfc_rank_cst[0]);
+// nvec = gfc_conv_array_extent_dim (tmp, tmp2, 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);
+// vector = gfc_conv_descriptor_data_get (vector);
+
+// /* Ref the v in dim. */
+// field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), dim, field,
+// NULL_TREE);
+
+// /* Set vector in v. */
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
+// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), tmp, field,
+// NULL_TREE);
+// gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
+// vector));
+
+// /* Set nvec in v. */
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
+// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), tmp, field,
+// NULL_TREE);
+// gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
+// nvec));
+
+// /* Set kind in v. */
+// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
+// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
+// TREE_TYPE (field), tmp, field,
+// NULL_TREE);
+// gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
+// ref->u.ar.start[i]->ts.kind));
+// break;
+// default:
+// gcc_unreachable ();
+// }
+// /* Set the mode for dim i. */
+// tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
+// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
+// mode_rhs));
+// }
+
+// /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
+// if (i < GFC_MAX_DIMENSIONS)
+// {
+// tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
+// gfc_add_modify (block, tmp,
+// build_int_cst (unsigned_char_type_node,
+// GFC_CAF_ARR_REF_NONE));
+// }
+// break;
+// default:
+// gcc_unreachable ();
+// }
+
+// /* Set the size of the current type. */
+// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE
+// (field),
+// prev_caf_ref, field, NULL_TREE);
+// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
+// TYPE_SIZE_UNIT (last_type)));
+
+// ref = ref->next;
+// }
+
+// if (prev_caf_ref != NULL_TREE)
+// {
+// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
+// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE
+// (field),
+// prev_caf_ref, field, NULL_TREE);
+// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
+// null_pointer_node));
+// }
+// return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
+// : NULL_TREE;
+// }
static int caf_call_cnt = 0;
@@ -1802,16 +1806,48 @@ conv_shape_to_cst (gfc_expr *e)
return fold_convert (size_type_node, tmp);
}
+static void
+conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team)
+{
+ gfc_expr *stat_e, *team_e;
+
+ stat_e = gfc_find_stat_co (expr);
+ if (stat_e)
+ {
+ gfc_se stat_se;
+ gfc_init_se (&stat_se, NULL);
+ gfc_conv_expr_reference (&stat_se, stat_e);
+ *stat = stat_se.expr;
+ gfc_add_block_to_block (block, &stat_se.pre);
+ gfc_add_block_to_block (block, &stat_se.post);
+ }
+ else
+ *stat = null_pointer_node;
+
+ team_e = gfc_find_team_co (expr);
+ if (team_e)
+ {
+ gfc_se team_se;
+ gfc_init_se (&team_se, NULL);
+ gfc_conv_expr_reference (&team_se, team_e);
+ *team = team_se.expr;
+ gfc_add_block_to_block (block, &team_se.pre);
+ gfc_add_block_to_block (block, &team_se.post);
+ }
+ else
+ *team = null_pointer_node;
+}
+
/* Get data from a remote coarray. */
static void
gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
bool may_realloc, symbol_attribute *caf_attr)
{
- gfc_expr *array_expr, *tmp_stat;
+ gfc_expr *array_expr;
tree caf_decl, token, image_index, tmp, res_var, type, stat, dest_size,
dest_data, opt_dest_desc, get_fn_index_tree, add_data_tree, add_data_size,
- opt_src_desc, opt_src_charlen, opt_dest_charlen;
+ opt_src_desc, opt_src_charlen, opt_dest_charlen, team;
symbol_attribute caf_attr_store;
gfc_namespace *ns;
gfc_expr *get_fn_hash = expr->value.function.actual->next->expr,
@@ -1842,19 +1878,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
res_var = lhs;
- tmp_stat = gfc_find_stat_co (expr);
-
- if (tmp_stat)
- {
- gfc_se stat_se;
- gfc_init_se (&stat_se, NULL);
- gfc_conv_expr_reference (&stat_se, tmp_stat);
- stat = stat_se.expr;
- gfc_add_block_to_block (&se->pre, &stat_se.pre);
- gfc_add_block_to_block (&se->post, &stat_se.post);
- }
- else
- stat = null_pointer_node;
+ conv_stat_and_team (&se->pre, expr, &stat, &team);
get_fn_index_tree
= conv_caf_func_index (&se->pre, ns, "__caf_get_from_remote_fn_index_%d",
@@ -1958,7 +1982,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
input_location, gfor_fndecl_caf_get_from_remote, 15, token, opt_src_desc,
opt_src_charlen, image_index, dest_size, dest_data, opt_dest_charlen,
opt_dest_desc, constant_boolean_node (may_realloc, boolean_type_node),
- get_fn_index_tree, add_data_tree, add_data_size, stat, null_pointer_node,
+ get_fn_index_tree, add_data_tree, add_data_size, stat, team,
null_pointer_node);
gfc_add_expr_to_block (&se->pre, tmp);
@@ -2014,8 +2038,7 @@ gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
static tree
conv_caf_send_to_remote (gfc_code *code)
{
- gfc_expr *lhs_expr, *rhs_expr, *lhs_hash, *receiver_fn_expr, *tmp_stat,
- *tmp_team;
+ gfc_expr *lhs_expr, *rhs_expr, *lhs_hash, *receiver_fn_expr;
gfc_symbol *add_data_sym;
gfc_se lhs_se, rhs_se;
stmtblock_t block;
@@ -2041,9 +2064,6 @@ conv_caf_send_to_remote (gfc_code *code)
gfc_init_block (&block);
- lhs_stat = null_pointer_node;
- lhs_team = null_pointer_node;
-
/* LHS. */
gfc_init_se (&lhs_se, NULL);
caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
@@ -2089,6 +2109,7 @@ conv_caf_send_to_remote (gfc_code *code)
gfc_init_se (&rhs_se, NULL);
if (rhs_expr->rank == 0)
{
+ rhs_se.want_pointer = rhs_expr->ts.type == BT_CHARACTER;
gfc_conv_expr (&rhs_se, rhs_expr);
gfc_add_block_to_block (&block, &rhs_se.pre);
opt_rhs_desc = null_pointer_node;
@@ -2111,7 +2132,7 @@ conv_caf_send_to_remote (gfc_code *code)
gfc_trans_force_lval (&block, rhs_se.expr));
opt_rhs_charlen
= build_zero_cst (build_pointer_type (size_type_node));
- rhs_size = rhs_se.expr->typed.type->type_common.size_unit;
+ rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
}
}
else
@@ -2149,29 +2170,7 @@ conv_caf_send_to_remote (gfc_code *code)
}
gfc_add_block_to_block (&block, &rhs_se.pre);
- tmp_stat = gfc_find_stat_co (lhs_expr);
-
- if (tmp_stat)
- {
- gfc_se stat_se;
- gfc_init_se (&stat_se, NULL);
- gfc_conv_expr_reference (&stat_se, tmp_stat);
- lhs_stat = stat_se.expr;
- gfc_add_block_to_block (&block, &stat_se.pre);
- gfc_add_block_to_block (&block, &stat_se.post);
- }
-
- tmp_team = gfc_find_team_co (lhs_expr);
-
- if (tmp_team)
- {
- gfc_se team_se;
- gfc_init_se (&team_se, NULL);
- gfc_conv_expr_reference (&team_se, tmp_team);
- lhs_team = team_se.expr;
- gfc_add_block_to_block (&block, &team_se.pre);
- gfc_add_block_to_block (&block, &team_se.post);
- }
+ conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team);
receiver_fn_index_tree
= conv_caf_func_index (&block, ns, "__caf_send_to_remote_fn_index_%d",
@@ -2203,447 +2202,225 @@ conv_caf_send_to_remote (gfc_code *code)
return gfc_finish_block (&block);
}
-static bool
-has_ref_after_cafref (gfc_expr *expr)
-{
- for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.codimen)
- return ref->next;
- return false;
-}
+// static bool
+// has_ref_after_cafref (gfc_expr *expr)
+// {
+// for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
+// if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+// return ref->next;
+// return false;
+// }
/* Send-get data to a remote coarray. */
static tree
conv_caf_sendget (gfc_code *code)
{
- gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
- gfc_se lhs_se, rhs_se;
+ /* lhs stuff */
+ gfc_expr *lhs_expr, *lhs_hash, *receiver_fn_expr;
+ gfc_symbol *lhs_add_data_sym;
+ gfc_se lhs_se;
+ tree lhs_caf_decl, lhs_token, opt_lhs_charlen,
+ opt_lhs_desc = NULL_TREE, receiver_fn_index_tree, lhs_image_index,
+ lhs_add_data_tree, lhs_add_data_size, lhs_stat, lhs_team;
+ int transfer_rank;
+
+ /* rhs stuff */
+ gfc_expr *rhs_expr, *rhs_hash, *sender_fn_expr;
+ gfc_symbol *rhs_add_data_sym;
+ gfc_se rhs_se;
+ tree rhs_caf_decl, rhs_token, opt_rhs_charlen,
+ opt_rhs_desc = NULL_TREE, sender_fn_index_tree, rhs_image_index,
+ rhs_add_data_tree, rhs_add_data_size, rhs_stat, rhs_team;
+
+ /* shared */
stmtblock_t block;
- tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
- tree may_require_tmp, src_stat, dst_stat, dst_team;
- tree lhs_type = NULL_TREE;
- tree vec = null_pointer_node, rhs_vec = null_pointer_node;
- symbol_attribute lhs_caf_attr, rhs_caf_attr;
- bool lhs_is_coindexed, rhs_is_coindexed;
+ gfc_namespace *ns;
+ tree tmp, rhs_size;
gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
+ gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SENDGET);
+
+ lhs_expr = code->ext.actual->expr;
+ rhs_expr = code->ext.actual->next->expr;
+ lhs_hash = code->ext.actual->next->next->expr;
+ receiver_fn_expr = code->ext.actual->next->next->next->expr;
+ rhs_hash = code->ext.actual->next->next->next->next->expr;
+ sender_fn_expr = code->ext.actual->next->next->next->next->next->expr;
+
+ lhs_add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
+ rhs_add_data_sym = sender_fn_expr->symtree->n.sym->formal->sym;
+
+ ns = lhs_expr->expr_type == EXPR_VARIABLE
+ && !lhs_expr->symtree->n.sym->attr.associate_var
+ ? lhs_expr->symtree->n.sym->ns
+ : gfc_current_ns;
- lhs_expr
- = code->ext.actual->expr->expr_type == EXPR_FUNCTION
- && code->ext.actual->expr->value.function.isym->id == GFC_ISYM_CAF_GET
- ? code->ext.actual->expr->value.function.actual->expr
- : code->ext.actual->expr;
- rhs_expr = code->ext.actual->next->expr->expr_type == EXPR_FUNCTION
- && code->ext.actual->next->expr->value.function.isym->id
- == GFC_ISYM_CAF_GET
- ? code->ext.actual->next->expr->value.function.actual->expr
- : code->ext.actual->next->expr;
- lhs_is_coindexed = gfc_is_coindexed (lhs_expr);
- rhs_is_coindexed = gfc_is_coindexed (rhs_expr);
- may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
- ? boolean_false_node : boolean_true_node;
gfc_init_block (&block);
- lhs_caf_attr = gfc_caf_attr (lhs_expr);
- rhs_caf_attr = gfc_caf_attr (rhs_expr);
- src_stat = dst_stat = null_pointer_node;
- dst_team = null_pointer_node;
+ lhs_stat = null_pointer_node;
+ lhs_team = null_pointer_node;
+ rhs_stat = null_pointer_node;
+ rhs_team = null_pointer_node;
/* LHS. */
gfc_init_se (&lhs_se, NULL);
+ lhs_caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
+ if (TREE_CODE (TREE_TYPE (lhs_caf_decl)) == REFERENCE_TYPE)
+ lhs_caf_decl = build_fold_indirect_ref_loc (input_location, lhs_caf_decl);
if (lhs_expr->rank == 0)
{
- if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
+ if (lhs_expr->ts.type == BT_CHARACTER)
{
- lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
- if (!POINTER_TYPE_P (TREE_TYPE (lhs_se.expr)))
- lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
+ gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
+ lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
+ opt_lhs_charlen = gfc_build_addr_expr (
+ NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
}
else
- {
- symbol_attribute attr;
- gfc_clear_attr (&attr);
- gfc_conv_expr (&lhs_se, lhs_expr);
- lhs_type = TREE_TYPE (lhs_se.expr);
- if (lhs_is_coindexed)
- 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 ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
- && lhs_caf_attr.codimension)
- {
- lhs_se.want_pointer = 1;
- gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
- /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
- has the wrong type if component references are done. */
- lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
- tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
- gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
- gfc_get_dtype_rank_type (
- gfc_has_vector_subscript (lhs_expr)
- ? gfc_find_array_ref (lhs_expr)->dimen
- : lhs_expr->rank,
- lhs_type));
+ opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
+ opt_lhs_desc = null_pointer_node;
}
else
{
- bool has_vector = gfc_has_vector_subscript (lhs_expr);
-
- if (lhs_is_coindexed || !has_vector)
- {
- /* If has_vector, pass descriptor for whole array and the
- vector bounds separately. */
- gfc_array_ref *ar, ar2;
- bool has_tmp_lhs_array = false;
- if (has_vector)
- {
- has_tmp_lhs_array = 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);
- /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
- that has the wrong type if component references are done. */
- lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
- tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
- gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
- gfc_get_dtype_rank_type (has_vector ? ar2.dimen
- : lhs_expr->rank,
- lhs_type));
- if (has_tmp_lhs_array)
- {
- vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
- *ar = ar2;
- }
- }
- else if (rhs_is_coindexed)
- {
- /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
- indexed array expression. This is rewritten to:
-
- tmp_array = arr2[...]
- arr1 ([...]) = tmp_array
-
- because using the standard gfc_conv_expr (lhs_expr) did the
- assignment with lhs and rhs exchanged. */
-
- gfc_ss *lss_for_tmparray, *lss_real;
- gfc_loopinfo loop;
- gfc_se se;
- stmtblock_t body;
- tree tmparr_desc, src;
- tree index = gfc_index_zero_node;
- tree stride = gfc_index_zero_node;
- int n;
-
- /* Walk both sides of the assignment, once to get the shape of the
- temporary array to create right. */
- lss_for_tmparray = gfc_walk_expr (lhs_expr);
- /* And a second time to be able to create an assignment of the
- temporary to the lhs_expr. gfc_trans_create_temp_array replaces
- the tree in the descriptor with the one for the temporary
- array. */
- lss_real = gfc_walk_expr (lhs_expr);
- gfc_init_loopinfo (&loop);
- gfc_add_ss_to_loop (&loop, lss_for_tmparray);
- gfc_add_ss_to_loop (&loop, lss_real);
- gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &lhs_expr->where);
- lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
- gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
- lss_for_tmparray, lhs_type, NULL_TREE,
- false, true, false,
- &lhs_expr->where);
- tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
- gfc_start_scalarized_body (&loop, &body);
- gfc_init_se (&se, NULL);
- gfc_copy_loopinfo_to_se (&se, &loop);
- se.ss = lss_real;
- gfc_conv_expr (&se, lhs_expr);
- gfc_add_block_to_block (&body, &se.pre);
-
- /* Walk over all indexes of the loop. */
- for (n = loop.dimen - 1; n > 0; --n)
- {
- tmp = loop.loopvar[n];
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, tmp, loop.from[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp, index);
-
- stride = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- loop.to[n - 1], loop.from[n - 1]);
- stride = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- stride, gfc_index_one_node);
-
- index = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp, stride);
- }
-
- index = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- index, loop.from[0]);
-
- index = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- loop.loopvar[0], index);
-
- src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
- src = gfc_build_array_ref (src, index, NULL);
- /* Now create the assignment of lhs_expr = tmp_array. */
- gfc_add_modify (&body, se.expr, src);
- gfc_add_block_to_block (&body, &se.post);
- lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
- gfc_trans_scalarizing_loops (&loop, &body);
- gfc_add_block_to_block (&loop.pre, &loop.post);
- gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
- gfc_free_ss (lss_for_tmparray);
- gfc_free_ss (lss_real);
- }
- }
-
- lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
-
- /* Special case: RHS is a coarray but LHS is not; this code path avoids a
- temporary and a loop. */
- if (!lhs_is_coindexed && rhs_is_coindexed
- && (!lhs_caf_attr.codimension
- || !(lhs_expr->rank > 0
- && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
- {
- bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
- gfc_init_se (&rhs_se, NULL);
- if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
- {
- gfc_se scal_se;
- gfc_init_se (&scal_se, NULL);
- scal_se.want_pointer = 1;
- gfc_conv_expr (&scal_se, lhs_expr);
- /* Ensure scalar on lhs is allocated. */
- gfc_add_block_to_block (&block, &scal_se.pre);
-
- gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
- TYPE_SIZE_UNIT (
- gfc_typenode_for_spec (&lhs_expr->ts)),
- NULL_TREE);
- tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr,
- null_pointer_node);
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- tmp, gfc_finish_block (&scal_se.pre),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&block, tmp);
- }
- else
- lhs_may_realloc = lhs_may_realloc
- && gfc_full_array_ref_p (lhs_expr->ref, NULL);
+ gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
gfc_add_block_to_block (&block, &lhs_se.pre);
- gfc_conv_intrinsic_caf_get (&rhs_se, code->ext.actual->next->expr,
- lhs_se.expr, lhs_may_realloc, &rhs_caf_attr);
- 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);
+ opt_lhs_desc = lhs_se.expr;
+ if (lhs_expr->ts.type == BT_CHARACTER)
+ opt_lhs_charlen = gfc_build_addr_expr (
+ NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
+ else
+ opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
+ if (!TYPE_LANG_SPECIFIC (TREE_TYPE (lhs_caf_decl))->rank
+ || GFC_ARRAY_TYPE_P (TREE_TYPE (lhs_caf_decl)))
+ opt_lhs_desc = null_pointer_node;
+ else
+ opt_lhs_desc
+ = gfc_build_addr_expr (NULL_TREE,
+ gfc_trans_force_lval (&block, opt_lhs_desc));
}
- gfc_add_block_to_block (&block, &lhs_se.pre);
-
/* 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 = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
- tmp = lhs_se.expr;
- if (lhs_caf_attr.alloc_comp)
- gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
- NULL);
- else
- gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
- lhs_expr);
- lhs_se.expr = tmp;
+ lhs_image_index = gfc_caf_get_image_index (&block, lhs_expr, lhs_caf_decl);
+ gfc_get_caf_token_offset (&lhs_se, &lhs_token, NULL, lhs_caf_decl, NULL,
+ lhs_expr);
/* RHS. */
+ rhs_caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
+ if (TREE_CODE (TREE_TYPE (rhs_caf_decl)) == REFERENCE_TYPE)
+ rhs_caf_decl = build_fold_indirect_ref_loc (input_location, rhs_caf_decl);
+ transfer_rank = rhs_expr->rank;
+ gfc_expression_rank (rhs_expr);
gfc_init_se (&rhs_se, NULL);
- if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
- && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
- rhs_expr = rhs_expr->value.function.actual->expr;
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 ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
- && rhs_caf_attr.codimension)
- {
- tree tmp2;
- rhs_se.want_pointer = 1;
- gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
- /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
- has the wrong type if component references are done. */
- tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
- tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
- gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
- gfc_get_dtype_rank_type (
- gfc_has_vector_subscript (rhs_expr)
- ? gfc_find_array_ref (rhs_expr)->dimen
- : rhs_expr->rank,
- tmp2));
- }
- else
- {
- /* If has_vector, pass descriptor for whole array and the
- vector bounds separately. */
- gfc_array_ref *ar, ar2;
- bool has_vector = false;
- tree tmp2;
-
- if (rhs_is_coindexed && gfc_has_vector_subscript (rhs_expr))
+ gfc_add_block_to_block (&block, &rhs_se.pre);
+ opt_rhs_desc = null_pointer_node;
+ if (rhs_expr->ts.type == BT_CHARACTER)
{
- 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;
+ opt_rhs_charlen = gfc_build_addr_expr (
+ NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
+ rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
}
- rhs_se.want_pointer = 1;
- gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
- /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
- has the wrong type if component references are done. */
- tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
- tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
- gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
- gfc_get_dtype_rank_type (has_vector ? ar2.dimen
- : rhs_expr->rank,
- tmp2));
- if (has_vector)
- {
- rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
- *ar = ar2;
+ else
+ {
+ opt_rhs_charlen
+ = build_zero_cst (build_pointer_type (size_type_node));
+ rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
}
}
-
- gfc_add_block_to_block (&block, &rhs_se.pre);
-
- rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
-
- tmp_stat = gfc_find_stat_co (lhs_expr);
-
- if (tmp_stat)
- {
- gfc_se stat_se;
- gfc_init_se (&stat_se, NULL);
- gfc_conv_expr_reference (&stat_se, tmp_stat);
- dst_stat = stat_se.expr;
- gfc_add_block_to_block (&block, &stat_se.pre);
- gfc_add_block_to_block (&block, &stat_se.post);
- }
-
- tmp_team = gfc_find_team_co (lhs_expr);
-
- if (tmp_team)
- {
- gfc_se team_se;
- gfc_init_se (&team_se, NULL);
- gfc_conv_expr_reference (&team_se, tmp_team);
- dst_team = team_se.expr;
- gfc_add_block_to_block (&block, &team_se.pre);
- gfc_add_block_to_block (&block, &team_se.post);
- }
-
- if (!rhs_is_coindexed)
+ else if (!TYPE_LANG_SPECIFIC (TREE_TYPE (rhs_caf_decl))->rank
+ || GFC_ARRAY_TYPE_P (TREE_TYPE (rhs_caf_decl)))
{
- if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp
- || has_ref_after_cafref (lhs_expr))
+ rhs_se.data_not_needed = 1;
+ gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
+ gfc_add_block_to_block (&block, &rhs_se.pre);
+ if (rhs_expr->ts.type == BT_CHARACTER)
{
- tree reference, dst_realloc;
- reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
- dst_realloc
- = lhs_caf_attr.allocatable ? boolean_true_node : boolean_false_node;
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_send_by_ref,
- 10, token, image_index, rhs_se.expr,
- reference, lhs_kind, rhs_kind,
- may_require_tmp, dst_realloc, src_stat,
- build_int_cst (integer_type_node,
- lhs_expr->ts.type));
+ opt_rhs_charlen = gfc_build_addr_expr (
+ NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
+ rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
}
else
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11,
- token, offset, image_index, lhs_se.expr, vec,
- rhs_se.expr, lhs_kind, rhs_kind,
- may_require_tmp, src_stat, dst_team);
+ {
+ opt_rhs_charlen
+ = build_zero_cst (build_pointer_type (size_type_node));
+ rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
+ }
+ opt_rhs_desc = null_pointer_node;
}
else
{
- tree rhs_token, rhs_offset, rhs_image_index;
-
- /* It guarantees memory consistency within the same segment. */
- tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
- tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
- gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
- tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
- ASM_VOLATILE_P (tmp) = 1;
- gfc_add_expr_to_block (&block, tmp);
-
- 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 = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
- tmp = rhs_se.expr;
- if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp
- || has_ref_after_cafref (lhs_expr))
+ gfc_ref *arr_ref = rhs_expr->ref;
+ while (arr_ref && arr_ref->type != REF_ARRAY)
+ arr_ref = arr_ref->next;
+ rhs_se.force_tmp
+ = (rhs_expr->shape == NULL
+ && (!arr_ref || !gfc_full_array_ref_p (arr_ref, nullptr)))
+ || !gfc_is_simply_contiguous (rhs_expr, false, false);
+ gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
+ gfc_add_block_to_block (&block, &rhs_se.pre);
+ opt_rhs_desc = rhs_se.expr;
+ if (rhs_expr->ts.type == BT_CHARACTER)
{
- tmp_stat = gfc_find_stat_co (lhs_expr);
-
- if (tmp_stat)
- {
- gfc_se stat_se;
- gfc_init_se (&stat_se, NULL);
- gfc_conv_expr_reference (&stat_se, tmp_stat);
- src_stat = stat_se.expr;
- gfc_add_block_to_block (&block, &stat_se.pre);
- gfc_add_block_to_block (&block, &stat_se.post);
- }
-
- gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
- NULL_TREE, NULL);
- tree lhs_reference, rhs_reference;
- lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
- rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr);
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_sendget_by_ref, 13,
- token, image_index, lhs_reference,
- rhs_token, rhs_image_index, rhs_reference,
- lhs_kind, rhs_kind, may_require_tmp,
- dst_stat, src_stat,
- build_int_cst (integer_type_node,
- lhs_expr->ts.type),
- build_int_cst (integer_type_node,
- rhs_expr->ts.type));
+ opt_rhs_charlen = gfc_build_addr_expr (
+ NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
+ rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
}
else
{
- gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
- tmp, rhs_expr);
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
- 14, token, offset, image_index,
- lhs_se.expr, vec, rhs_token, rhs_offset,
- rhs_image_index, tmp, rhs_vec, lhs_kind,
- rhs_kind, may_require_tmp, src_stat);
+ opt_rhs_charlen
+ = build_zero_cst (build_pointer_type (size_type_node));
+ rhs_size = fold_build2 (
+ MULT_EXPR, size_type_node,
+ fold_convert (size_type_node,
+ rhs_expr->shape
+ ? conv_shape_to_cst (rhs_expr)
+ : gfc_conv_descriptor_size (rhs_se.expr,
+ rhs_expr->rank)),
+ fold_convert (size_type_node,
+ gfc_conv_descriptor_span_get (rhs_se.expr)));
}
+
+ opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
}
+ gfc_add_block_to_block (&block, &rhs_se.pre);
+
+ /* Obtain token, offset and image index for the RHS. */
+ rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, rhs_caf_decl);
+ gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, rhs_caf_decl, NULL,
+ rhs_expr);
+
+ /* stat and team. */
+ conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team);
+ conv_stat_and_team (&block, rhs_expr, &rhs_stat, &rhs_team);
+
+ sender_fn_index_tree
+ = conv_caf_func_index (&block, ns, "__caf_transfer_from_fn_index_%d",
+ rhs_hash);
+ rhs_add_data_tree
+ = conv_caf_add_call_data (&block, ns,
+ "__caf_transfer_from_remote_add_data_%d",
+ rhs_add_data_sym, &rhs_add_data_size);
+ receiver_fn_index_tree
+ = conv_caf_func_index (&block, ns, "__caf_transfer_to_remote_fn_index_%d",
+ lhs_hash);
+ lhs_add_data_tree
+ = conv_caf_add_call_data (&block, ns,
+ "__caf_transfer_to_remote_add_data_%d",
+ lhs_add_data_sym, &lhs_add_data_size);
+ ++caf_call_cnt;
+
+ tmp = build_call_expr_loc (
+ input_location, gfor_fndecl_caf_transfer_between_remotes, 20, lhs_token,
+ opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree,
+ lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc,
+ opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree,
+ rhs_add_data_size, rhs_size,
+ transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat,
+ lhs_team, null_pointer_node, rhs_stat, rhs_team, null_pointer_node);
+
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);
@@ -2659,6 +2436,451 @@ conv_caf_sendget (gfc_code *code)
return gfc_finish_block (&block);
}
+// static tree
+// conv_caf_sendget (gfc_code *code)
+// {
+// gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
+// gfc_se lhs_se, rhs_se;
+// stmtblock_t block;
+// tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
+// tree may_require_tmp, src_stat, dst_stat, dst_team;
+// tree lhs_type = NULL_TREE;
+// tree vec = null_pointer_node, rhs_vec = null_pointer_node;
+// symbol_attribute lhs_caf_attr, rhs_caf_attr;
+// bool lhs_is_coindexed, rhs_is_coindexed;
+
+// gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
+
+// lhs_expr
+// = code->ext.actual->expr->expr_type == EXPR_FUNCTION
+// && code->ext.actual->expr->value.function.isym->id == GFC_ISYM_CAF_GET
+// ? code->ext.actual->expr->value.function.actual->expr
+// : code->ext.actual->expr;
+// rhs_expr = code->ext.actual->next->expr->expr_type == EXPR_FUNCTION
+// && code->ext.actual->next->expr->value.function.isym->id
+// == GFC_ISYM_CAF_GET
+// ? code->ext.actual->next->expr->value.function.actual->expr
+// : code->ext.actual->next->expr;
+// lhs_is_coindexed = gfc_is_coindexed (lhs_expr);
+// rhs_is_coindexed = gfc_is_coindexed (rhs_expr);
+// may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
+// ? boolean_false_node : boolean_true_node;
+// gfc_init_block (&block);
+
+// lhs_caf_attr = gfc_caf_attr (lhs_expr);
+// rhs_caf_attr = gfc_caf_attr (rhs_expr);
+// src_stat = dst_stat = null_pointer_node;
+// dst_team = null_pointer_node;
+
+// /* LHS. */
+// gfc_init_se (&lhs_se, NULL);
+// if (lhs_expr->rank == 0)
+// {
+// if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
+// {
+// lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
+// if (!POINTER_TYPE_P (TREE_TYPE (lhs_se.expr)))
+// lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
+// }
+// else
+// {
+// symbol_attribute attr;
+// gfc_clear_attr (&attr);
+// gfc_conv_expr (&lhs_se, lhs_expr);
+// lhs_type = TREE_TYPE (lhs_se.expr);
+// if (lhs_is_coindexed)
+// 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 ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
+// && lhs_caf_attr.codimension)
+// {
+// lhs_se.want_pointer = 1;
+// gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
+// /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
+// has the wrong type if component references are done. */
+// lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
+// tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
+// gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
+// gfc_get_dtype_rank_type (
+// gfc_has_vector_subscript (lhs_expr)
+// ? gfc_find_array_ref (lhs_expr)->dimen
+// : lhs_expr->rank,
+// lhs_type));
+// }
+// else
+// {
+// bool has_vector = gfc_has_vector_subscript (lhs_expr);
+
+// if (lhs_is_coindexed || !has_vector)
+// {
+// /* If has_vector, pass descriptor for whole array and the
+// vector bounds separately. */
+// gfc_array_ref *ar, ar2;
+// bool has_tmp_lhs_array = false;
+// if (has_vector)
+// {
+// has_tmp_lhs_array = 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);
+// /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
+// that has the wrong type if component references are done. */
+// lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
+// tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
+// gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
+// gfc_get_dtype_rank_type (has_vector ? ar2.dimen
+// : lhs_expr->rank,
+// lhs_type));
+// if (has_tmp_lhs_array)
+// {
+// vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
+// *ar = ar2;
+// }
+// }
+// else if (rhs_is_coindexed)
+// {
+// /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
+// indexed array expression. This is rewritten to:
+
+// tmp_array = arr2[...]
+// arr1 ([...]) = tmp_array
+
+// because using the standard gfc_conv_expr (lhs_expr) did the
+// assignment with lhs and rhs exchanged. */
+
+// gfc_ss *lss_for_tmparray, *lss_real;
+// gfc_loopinfo loop;
+// gfc_se se;
+// stmtblock_t body;
+// tree tmparr_desc, src;
+// tree index = gfc_index_zero_node;
+// tree stride = gfc_index_zero_node;
+// int n;
+
+// /* Walk both sides of the assignment, once to get the shape of the
+// temporary array to create right. */
+// lss_for_tmparray = gfc_walk_expr (lhs_expr);
+// /* And a second time to be able to create an assignment of the
+// temporary to the lhs_expr. gfc_trans_create_temp_array replaces
+// the tree in the descriptor with the one for the temporary
+// array. */
+// lss_real = gfc_walk_expr (lhs_expr);
+// gfc_init_loopinfo (&loop);
+// gfc_add_ss_to_loop (&loop, lss_for_tmparray);
+// gfc_add_ss_to_loop (&loop, lss_real);
+// gfc_conv_ss_startstride (&loop);
+// gfc_conv_loop_setup (&loop, &lhs_expr->where);
+// lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
+// gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
+// lss_for_tmparray, lhs_type, NULL_TREE,
+// false, true, false,
+// &lhs_expr->where);
+// tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
+// gfc_start_scalarized_body (&loop, &body);
+// gfc_init_se (&se, NULL);
+// gfc_copy_loopinfo_to_se (&se, &loop);
+// se.ss = lss_real;
+// gfc_conv_expr (&se, lhs_expr);
+// gfc_add_block_to_block (&body, &se.pre);
+
+// /* Walk over all indexes of the loop. */
+// for (n = loop.dimen - 1; n > 0; --n)
+// {
+// tmp = loop.loopvar[n];
+// tmp = fold_build2_loc (input_location, MINUS_EXPR,
+// gfc_array_index_type, tmp, loop.from[n]);
+// tmp = fold_build2_loc (input_location, PLUS_EXPR,
+// gfc_array_index_type, tmp, index);
+
+// stride = fold_build2_loc (input_location, MINUS_EXPR,
+// gfc_array_index_type,
+// loop.to[n - 1], loop.from[n - 1]);
+// stride = fold_build2_loc (input_location, PLUS_EXPR,
+// gfc_array_index_type,
+// stride, gfc_index_one_node);
+
+// index = fold_build2_loc (input_location, MULT_EXPR,
+// gfc_array_index_type, tmp, stride);
+// }
+
+// index = fold_build2_loc (input_location, MINUS_EXPR,
+// gfc_array_index_type,
+// index, loop.from[0]);
+
+// index = fold_build2_loc (input_location, PLUS_EXPR,
+// gfc_array_index_type,
+// loop.loopvar[0], index);
+
+// src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
+// src = gfc_build_array_ref (src, index, NULL);
+// /* Now create the assignment of lhs_expr = tmp_array. */
+// gfc_add_modify (&body, se.expr, src);
+// gfc_add_block_to_block (&body, &se.post);
+// lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
+// gfc_trans_scalarizing_loops (&loop, &body);
+// gfc_add_block_to_block (&loop.pre, &loop.post);
+// gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
+// gfc_free_ss (lss_for_tmparray);
+// gfc_free_ss (lss_real);
+// }
+// }
+
+// lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
+
+// /* Special case: RHS is a coarray but LHS is not; this code path avoids a
+// temporary and a loop. */
+// if (!lhs_is_coindexed && rhs_is_coindexed
+// && (!lhs_caf_attr.codimension
+// || !(lhs_expr->rank > 0
+// && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
+// {
+// bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
+// gfc_init_se (&rhs_se, NULL);
+// if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
+// {
+// gfc_se scal_se;
+// gfc_init_se (&scal_se, NULL);
+// scal_se.want_pointer = 1;
+// gfc_conv_expr (&scal_se, lhs_expr);
+// /* Ensure scalar on lhs is allocated. */
+// gfc_add_block_to_block (&block, &scal_se.pre);
+
+// gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
+// TYPE_SIZE_UNIT (
+// gfc_typenode_for_spec (&lhs_expr->ts)),
+// NULL_TREE);
+// tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr,
+// null_pointer_node);
+// tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+// tmp, gfc_finish_block (&scal_se.pre),
+// build_empty_stmt (input_location));
+// gfc_add_expr_to_block (&block, tmp);
+// }
+// else
+// lhs_may_realloc = lhs_may_realloc
+// && gfc_full_array_ref_p (lhs_expr->ref, NULL);
+// gfc_add_block_to_block (&block, &lhs_se.pre);
+// gfc_conv_intrinsic_caf_get (&rhs_se, code->ext.actual->next->expr,
+// lhs_se.expr, lhs_may_realloc, &rhs_caf_attr);
+// 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);
+// }
+
+// gfc_add_block_to_block (&block, &lhs_se.pre);
+
+// /* 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 = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
+// tmp = lhs_se.expr;
+// if (lhs_caf_attr.alloc_comp)
+// gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
+// NULL);
+// else
+// gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
+// lhs_expr);
+// lhs_se.expr = tmp;
+
+// /* RHS. */
+// gfc_init_se (&rhs_se, NULL);
+// if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
+// && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
+// rhs_expr = rhs_expr->value.function.actual->expr;
+// 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 ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
+// && rhs_caf_attr.codimension)
+// {
+// tree tmp2;
+// rhs_se.want_pointer = 1;
+// gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
+// /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
+// has the wrong type if component references are done. */
+// tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
+// tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
+// gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
+// gfc_get_dtype_rank_type (
+// gfc_has_vector_subscript (rhs_expr)
+// ? gfc_find_array_ref (rhs_expr)->dimen
+// : rhs_expr->rank,
+// tmp2));
+// }
+// else
+// {
+// /* If has_vector, pass descriptor for whole array and the
+// vector bounds separately. */
+// gfc_array_ref *ar, ar2;
+// bool has_vector = false;
+// tree tmp2;
+
+// if (rhs_is_coindexed && 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);
+// /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
+// has the wrong type if component references are done. */
+// tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
+// tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
+// gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
+// gfc_get_dtype_rank_type (has_vector ? ar2.dimen
+// : rhs_expr->rank,
+// tmp2));
+// if (has_vector)
+// {
+// rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
+// *ar = ar2;
+// }
+// }
+
+// gfc_add_block_to_block (&block, &rhs_se.pre);
+
+// rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
+
+// tmp_stat = gfc_find_stat_co (lhs_expr);
+
+// if (tmp_stat)
+// {
+// gfc_se stat_se;
+// gfc_init_se (&stat_se, NULL);
+// gfc_conv_expr_reference (&stat_se, tmp_stat);
+// dst_stat = stat_se.expr;
+// gfc_add_block_to_block (&block, &stat_se.pre);
+// gfc_add_block_to_block (&block, &stat_se.post);
+// }
+
+// tmp_team = gfc_find_team_co (lhs_expr);
+
+// if (tmp_team)
+// {
+// gfc_se team_se;
+// gfc_init_se (&team_se, NULL);
+// gfc_conv_expr_reference (&team_se, tmp_team);
+// dst_team = team_se.expr;
+// gfc_add_block_to_block (&block, &team_se.pre);
+// gfc_add_block_to_block (&block, &team_se.post);
+// }
+
+// if (!rhs_is_coindexed)
+// {
+// if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp
+// || has_ref_after_cafref (lhs_expr))
+// {
+// tree reference, dst_realloc;
+// reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
+// dst_realloc
+// = lhs_caf_attr.allocatable ? boolean_true_node : boolean_false_node;
+// tmp = build_call_expr_loc (input_location,
+// gfor_fndecl_caf_send_by_ref,
+// 10, token, image_index, rhs_se.expr,
+// reference, lhs_kind, rhs_kind,
+// may_require_tmp, dst_realloc, src_stat,
+// build_int_cst (integer_type_node,
+// lhs_expr->ts.type));
+// }
+// else
+// tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11,
+// token, offset, image_index, lhs_se.expr, vec,
+// rhs_se.expr, lhs_kind, rhs_kind,
+// may_require_tmp, src_stat, dst_team);
+// }
+// else
+// {
+// tree rhs_token, rhs_offset, rhs_image_index;
+
+// /* It guarantees memory consistency within the same segment. */
+// tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
+// tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
+// gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
+// tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
+// ASM_VOLATILE_P (tmp) = 1;
+// gfc_add_expr_to_block (&block, tmp);
+
+// 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 = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
+// tmp = rhs_se.expr;
+// if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp
+// || has_ref_after_cafref (lhs_expr))
+// {
+// tmp_stat = gfc_find_stat_co (lhs_expr);
+
+// if (tmp_stat)
+// {
+// gfc_se stat_se;
+// gfc_init_se (&stat_se, NULL);
+// gfc_conv_expr_reference (&stat_se, tmp_stat);
+// src_stat = stat_se.expr;
+// gfc_add_block_to_block (&block, &stat_se.pre);
+// gfc_add_block_to_block (&block, &stat_se.post);
+// }
+
+// gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
+// NULL_TREE, NULL);
+// tree lhs_reference, rhs_reference;
+// lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
+// rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr);
+// tmp = build_call_expr_loc (input_location,
+// gfor_fndecl_caf_sendget_by_ref, 13,
+// token, image_index, lhs_reference,
+// rhs_token, rhs_image_index, rhs_reference,
+// lhs_kind, rhs_kind, may_require_tmp,
+// dst_stat, src_stat,
+// build_int_cst (integer_type_node,
+// lhs_expr->ts.type),
+// build_int_cst (integer_type_node,
+// rhs_expr->ts.type));
+// }
+// else
+// {
+// gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
+// tmp, rhs_expr);
+// tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
+// 14, token, offset, image_index,
+// lhs_se.expr, vec, rhs_token, rhs_offset,
+// rhs_image_index, tmp, rhs_vec, lhs_kind,
+// rhs_kind, may_require_tmp, src_stat);
+// }
+// }
+// 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);
+
+// /* It guarantees memory consistency within the same segment. */
+// tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
+// tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
+// gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
+// tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
+// ASM_VOLATILE_P (tmp) = 1;
+// gfc_add_expr_to_block (&block, tmp);
+
+// return gfc_finish_block (&block);
+// }
+
static void
trans_this_image (gfc_se * se, gfc_expr *expr)
{
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 8b76a277c07c362701909cb748bf99a7b8070845..fcb091a3cc6cdc473a8fd7b61b5dec4c711e9474 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -897,6 +897,7 @@ extern GTY(()) tree gfor_fndecl_caf_register_accessors_finish;
extern GTY(()) tree gfor_fndecl_caf_get_remote_function_index;
extern GTY(()) tree gfor_fndecl_caf_get_from_remote;
extern GTY(()) tree gfor_fndecl_caf_send_to_remote;
+extern GTY(()) tree gfor_fndecl_caf_transfer_between_remotes;
extern GTY(()) tree gfor_fndecl_caf_sync_all;
extern GTY(()) tree gfor_fndecl_caf_sync_memory;
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90
index 56f2a6c5c7a2990b3bc7e3e36c8df5f3677b42f0..9da15053290d3542f3322ef9dae97c1a176030d5 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90
@@ -39,5 +39,7 @@ if (any (A-B /= 0)) STOP 4
end
! { dg-final { scan-tree-dump-times "_gfortran_caf_get_from_remote" 4 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.\[0-9\]+, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.\[0-9\]+, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 1, 0B\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_transfer_between_remotes" 1 "original" } }
+! { dg-final { scan-tree-dump-not "_gfortran_caf_transfer_get" "original" } }
+! { dg-final { scan-tree-dump-not "_gfortran_caf_transfer_send" "original" } }
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 0af1813bbd5649b8d87a55c81248e71def9f98a6..ef3dacfd8e761380ceecf3cbd2050328ecc5db62 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -261,6 +261,18 @@ void _gfortran_caf_send_to_remote (
void *add_data, const size_t add_data_size, int *stat, caf_team_t *team,
int *team_number);
+void _gfortran_caf_transfer_between_remotes (
+ caf_token_t dst_token, gfc_descriptor_t *opt_dst_desc,
+ size_t *opt_dst_charlen, const int dst_image_index,
+ const int dst_access_index, void *dst_add_data,
+ const size_t dst_add_data_size, caf_token_t src_token,
+ const gfc_descriptor_t *opt_src_desc, const size_t *opt_src_charlen,
+ const int src_image_index, const int src_access_index, void *src_add_data,
+ const size_t src_add_data_size, const size_t src_size,
+ const bool scalar_transfer, int *dst_stat, int *src_stat,
+ caf_team_t *dst_team, int *dst_team_number, caf_team_t *src_team,
+ int *src_team_number);
+
void _gfortran_caf_atomic_define (caf_token_t, size_t, int, void *, int *,
int, int);
void _gfortran_caf_atomic_ref (caf_token_t, size_t, int, void *, int *,
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 625e1a71148bb9265c9fdcf5261781ff9e0b5114..1f7a9022e39e32e5b4ce5b85d1b129c0ab7a2fe8 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -3023,6 +3023,75 @@ _gfortran_caf_send_to_remote (
opt_src_charlen);
}
+void
+_gfortran_caf_transfer_between_remotes (
+ caf_token_t dst_token, gfc_descriptor_t *opt_dst_desc,
+ size_t *opt_dst_charlen, const int dst_image_index,
+ const int dst_access_index, void *dst_add_data,
+ const size_t dst_add_data_size __attribute__ ((unused)),
+ caf_token_t src_token, const gfc_descriptor_t *opt_src_desc,
+ const size_t *opt_src_charlen, const int src_image_index,
+ const int src_access_index, void *src_add_data,
+ const size_t src_add_data_size __attribute__ ((unused)),
+ const size_t src_size, const bool scalar_transfer, int *dst_stat,
+ int *src_stat, caf_team_t *dst_team __attribute__ ((unused)),
+ int *dst_team_number __attribute__ ((unused)),
+ caf_team_t *src_team __attribute__ ((unused)),
+ int *src_team_number __attribute__ ((unused)))
+{
+ caf_single_token_t src_single_token = TOKEN (src_token),
+ dst_single_token = TOKEN (dst_token);
+ void *src_ptr
+ = opt_src_desc ? (void *) opt_src_desc : src_single_token->memptr;
+ int32_t free_buffer;
+ void *dst_ptr
+ = opt_dst_desc ? (void *) opt_dst_desc : dst_single_token->memptr;
+ void *transfer_ptr, *buffer;
+ GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) *transfer_desc = NULL;
+ struct caf_single_token cb_token;
+ cb_token.memptr = src_add_data;
+ cb_token.desc = NULL;
+ cb_token.owning_memory = false;
+
+ if (src_stat)
+ *src_stat = 0;
+
+ if (!scalar_transfer)
+ {
+ const size_t desc_size = sizeof (*transfer_desc);
+ transfer_desc = alloca (desc_size);
+ memset (transfer_desc, 0, desc_size);
+ transfer_ptr = transfer_desc;
+ }
+ else if (opt_dst_charlen)
+ transfer_ptr = alloca (*opt_dst_charlen * src_size);
+ else
+ {
+ buffer = NULL;
+ transfer_ptr = &buffer;
+ }
+
+ accessor_hash_table[src_access_index].u.getter (
+ src_add_data, &src_image_index, transfer_ptr, &free_buffer, src_ptr,
+ &cb_token, 0, opt_dst_charlen, opt_src_charlen);
+
+ if (dst_stat)
+ *dst_stat = 0;
+
+ if (scalar_transfer)
+ transfer_ptr = *(void **) transfer_ptr;
+
+ cb_token.memptr = dst_add_data;
+ accessor_hash_table[dst_access_index].u.receiver (dst_add_data,
+ &dst_image_index, dst_ptr,
+ transfer_ptr, &cb_token, 0,
+ opt_dst_charlen,
+ opt_src_charlen);
+
+ if (free_buffer)
+ free (transfer_desc ? transfer_desc->base_addr : transfer_ptr);
+}
+
void
_gfortran_caf_atomic_define (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),