diff options
| author | Andre Vehreschild <vehre@gcc.gnu.org> | 2025-02-07 11:25:31 +0100 |
|---|---|---|
| committer | Andre Vehreschild <vehre@gcc.gnu.org> | 2025-02-20 10:33:54 +0100 |
| commit | 8bf0ee8d62b8a08e808344d31354ab713157e15d (patch) | |
| tree | a68c67b2929bcfe28f655a54f264f9dde3202589 /gcc/fortran/trans-intrinsic.cc | |
| parent | 69eb02682b80b84dd0f562f19821c8c8c37ad243 (diff) | |
| download | gcc-8bf0ee8d62b8a08e808344d31354ab713157e15d.zip gcc-8bf0ee8d62b8a08e808344d31354ab713157e15d.tar.gz gcc-8bf0ee8d62b8a08e808344d31354ab713157e15d.tar.bz2 | |
Fortran: Add transfer_between_remotes [PR107635]
Add the last missing coarray data manipulation routine using remote
accessors.
gcc/fortran/ChangeLog:
PR fortran/107635
* coarray.cc (rewrite_caf_send): Rewrite to
transfer_between_remotes when both sides of the assignment have
a coarray.
(coindexed_code_callback): Prevent duplicate rewrite.
* gfortran.texi: Add documentation for transfer_between_remotes.
* intrinsic.cc (add_subroutines): Add intrinsic symbol for
caf_sendget to allow easy rewrite to transfer_between_remotes.
* trans-decl.cc (gfc_build_builtin_function_decls): Add
prototype for transfer_between_remotes.
* trans-intrinsic.cc (conv_caf_vector_subscript_elem): Mark as
deprecated.
(conv_caf_vector_subscript): Same.
(compute_component_offset): Same.
(conv_expr_ref_to_caf_ref): Same.
(conv_stat_and_team): Extract stat and team from expr.
(gfc_conv_intrinsic_caf_get): Use conv_stat_and_team.
(conv_caf_send_to_remote): Same.
(has_ref_after_cafref): Mark as deprecated.
(conv_caf_sendget): Translate to transfer_between_remotes.
* trans.h: Add prototype for transfer_between_remotes.
libgfortran/ChangeLog:
* caf/libcaf.h: Add prototype for transfer_between_remotes.
* caf/single.c: Implement transfer_between_remotes.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray_lib_comm_1.f90: Fix up scan_trees.
Diffstat (limited to 'gcc/fortran/trans-intrinsic.cc')
| -rw-r--r-- | gcc/fortran/trans-intrinsic.cc | 2346 |
1 files changed, 1284 insertions, 1062 deletions
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 19286f7..84f18a5 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) { |