gcc/fortran/trans-intrinsic.c | 190 ++++++++++++++++++++-
gcc/fortran/trans-types.c | 87 ++++++++++
gcc/fortran/trans-types.h | 1 +
.../gfortran.dg/coarray/collectives_2.f90 | 59 +++++++
.../gfortran.dg/coarray_collectives_7.f90 | 17 ++
5 files changed, 353 insertions(+), 1 deletion(-)
@@ -926,6 +926,163 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
}
+/* Fill in the following structure
+ struct caf_vector_t {
+ size_t nvec; // size of the vector
+ union {
+ struct {
+ void *vector;
+ int kind;
+ } v;
+ struct {
+ ptrdiff_t lower_bound;
+ ptrdiff_t upper_bound;
+ ptrdiff_t stride;
+ } triplet;
+ } u;
+ } */
+
+static void
+conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
+ tree lower, tree upper, tree stride,
+ tree vector, int kind, tree nvec)
+{
+ tree field, type, tmp;
+
+ desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
+ type = TREE_TYPE (desc);
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), 0);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
+
+ /* Access union. */
+ field = gfc_advance_chain (TYPE_FIELDS (type), 1);
+ desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ type = TREE_TYPE (desc);
+
+ /* Access the inner struct. */
+ field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
+ desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ type = TREE_TYPE (desc);
+
+ if (vector != NULL_TREE)
+ {
+ /* Set dim.lower/upper/stride. */
+ field = gfc_advance_chain (TYPE_FIELDS (type), 0);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
+ field = gfc_advance_chain (TYPE_FIELDS (type), 1);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
+ }
+ else
+ {
+ /* Set vector and kind. */
+ field = gfc_advance_chain (TYPE_FIELDS (type), 0);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), 1);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), 2);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
+ }
+}
+
+
+static tree
+conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
+{
+ gfc_se argse;
+ tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
+ tree lbound, ubound, tmp;
+ int i;
+
+ var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
+
+ for (i = 0; i < ar->dimen; i++)
+ switch (ar->dimen_type[i])
+ {
+ case DIMEN_RANGE:
+ if (ar->end[i])
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr (&argse, ar->end[i]);
+ gfc_add_block_to_block (block, &argse.pre);
+ upper = gfc_evaluate_now (argse.expr, block);
+ }
+ else
+ upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+ if (ar->stride[i])
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr (&argse, ar->stride[i]);
+ gfc_add_block_to_block (block, &argse.pre);
+ stride = gfc_evaluate_now (argse.expr, block);
+ }
+ else
+ stride = gfc_index_one_node;
+
+ /* Fall through. */
+ case DIMEN_ELEMENT:
+ if (ar->start[i])
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr (&argse, ar->start[i]);
+ gfc_add_block_to_block (block, &argse.pre);
+ lower = gfc_evaluate_now (argse.expr, block);
+ }
+ else
+ lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+ if (ar->dimen_type[i] == DIMEN_ELEMENT)
+ {
+ upper = lower;
+ stride = gfc_index_one_node;
+ }
+ vector = NULL_TREE;
+ nvec = size_zero_node;
+ conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
+ vector, 0, nvec);
+ break;
+
+ case DIMEN_VECTOR:
+ gfc_init_se (&argse, NULL);
+ argse.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&argse, ar->start[i]);
+ gfc_add_block_to_block (block, &argse.pre);
+ vector = argse.expr;
+ lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
+ ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
+ nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
+ nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ TREE_TYPE (nvec), nvec, tmp);
+ lower = gfc_index_zero_node;
+ upper = gfc_index_zero_node;
+ stride = gfc_index_zero_node;
+ vector = gfc_conv_descriptor_data_get (vector);
+ conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
+ vector, ar->start[i]->ts.kind, nvec);
+ break;
+ default:
+ gcc_unreachable();
+ }
+ return gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
static void
trans_this_image (gfc_se * se, gfc_expr *expr)
{
@@ -7553,6 +7710,9 @@ conv_co_minmaxsum (gfc_code *code)
gfc_se argse;
stmtblock_t block, post_block;
tree fndecl, array, vec, strlen, image_index, stat, errmsg, errmsg_len;
+ gfc_array_ref *ar = NULL;
+ bool has_vector = false;
+ int i;
gfc_start_block (&block);
gfc_init_block (&post_block);
@@ -7583,6 +7743,14 @@ conv_co_minmaxsum (gfc_code *code)
}
/* Handle the array. */
+ if (code->ext.actual->expr->rank)
+ {
+ ar = gfc_find_array_ref (code->ext.actual->expr);
+ for (i = 0; i < ar->dimen; i++)
+ if (ar->dimen_type[i] == DIMEN_VECTOR)
+ has_vector = true;
+ }
+
gfc_init_se (&argse, NULL);
if (code->ext.actual->expr->rank == 0)
{
@@ -7597,9 +7765,26 @@ conv_co_minmaxsum (gfc_code *code)
}
else
{
+ /* For arrays, we either pass the normal array descriptor - or if there
+ is a vector subscript, we pass the base, full-array descriptor and
+ the subscripts as struct array of size rank, which contains either
+ the (lower, upper, stride) triplets or the vector with the element
+ indexes for this dimension. To access those elements, one still
+ needs to combine those values with the lower_bound and strides of
+ those from the full-array descriptor. */
+ gfc_array_ref ar2;
+ if (has_vector)
+ {
+ ar2 = *ar;
+ memset (ar, '\0', sizeof (*ar));
+ ar->as = ar2.as;
+ ar->type = AR_FULL;
+ }
argse.want_pointer = 1;
gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
array = argse.expr;
+ if (has_vector)
+ *ar = ar2;
}
gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post);
@@ -7609,7 +7794,10 @@ conv_co_minmaxsum (gfc_code *code)
else
strlen = integer_zero_node;
- vec = null_pointer_node;
+ if (has_vector)
+ vec = conv_caf_vector_subscript (&block, array, ar);
+ else
+ vec = null_pointer_node;
/* image_index. */
if (code->ext.actual->next->expr)
@@ -3110,4 +3110,91 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
return true;
}
+
+/* Create a type to handle vector subscripts for coarray library calls. It
+ has the form:
+ struct caf_vector_t {
+ size_t nvec; // size of the vector
+ union {
+ struct {
+ void *vector;
+ int kind;
+ } v;
+ struct {
+ ptrdiff_t lower_bound;
+ ptrdiff_t upper_bound;
+ ptrdiff_t stride;
+ } triplet;
+ } u;
+ }
+ where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
+ size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
+
+tree
+gfc_get_caf_vector_type (int dim)
+{
+ static tree vector_types[GFC_MAX_DIMENSIONS];
+ static tree vec_type = NULL_TREE;
+ tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain;
+
+ if (vector_types[dim-1] != NULL_TREE)
+ return vector_types[dim-1];
+
+ if (vec_type == NULL_TREE)
+ {
+ chain = 0;
+ vect_struct_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (vect_struct_type,
+ get_identifier ("vector"),
+ pvoid_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (vect_struct_type,
+ get_identifier ("kind"),
+ integer_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (vect_struct_type);
+
+ chain = 0;
+ triplet_struct_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
+ get_identifier ("lower_bound"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
+ get_identifier ("upper_bound"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (triplet_struct_type);
+
+ chain = 0;
+ union_type = make_node (UNION_TYPE);
+ tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
+ vect_struct_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"),
+ triplet_struct_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (union_type);
+
+ chain = 0;
+ vec_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"),
+ size_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"),
+ union_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (vec_type);
+ TYPE_NAME (vec_type) = get_identifier ("caf_vector_t");
+ }
+
+ tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ gfc_rank_cst[dim-1]);
+ vector_types[dim-1] = build_array_type (vec_type, tmp);
+ return vector_types[dim-1];
+}
+
#include "gt-fortran-trans-types.h"
@@ -100,5 +100,6 @@ int gfc_is_nodesc_array (gfc_symbol *);
tree gfc_get_dtype (tree);
tree gfc_get_ppc_type (gfc_component *);
+tree gfc_get_caf_vector_type (int dim);
#endif
new file mode 100644
@@ -0,0 +1,59 @@
+! { dg-do run }
+!
+! CO_SUM/CO_MIN/CO_MAX
+!
+program test
+ implicit none
+ intrinsic co_max
+ intrinsic co_min
+ intrinsic co_sum
+ integer :: val(3)
+ integer :: vec(3)
+ vec = [2,3,1]
+ if (this_image() == 1) then
+ val(1) = 42
+ else
+ val(1) = -99
+ endif
+ val(2) = this_image()
+ if (this_image() == num_images()) then
+ val(3) = -55
+ else
+ val(3) = 101
+ endif
+ call test_min
+ call test_max
+ call test_sum
+contains
+ subroutine test_max
+ call co_max (val(vec))
+ !write(*,*) "Maximal value", val
+ if (num_images() > 1) then
+ if (any (val /= [42, num_images(), 101])) call abort()
+ else
+ if (any (val /= [42, num_images(), -55])) call abort()
+ endif
+ end subroutine test_max
+
+ subroutine test_min
+ call co_min (val, result_image=num_images())
+ if (this_image() == num_images()) then
+ !write(*,*) "Minimal value", val
+ if (num_images() > 1) then
+ if (any (val /= [-99, num_images(), -55])) call abort()
+ else
+ if (any (val /= [42, num_images(), -55])) call abort()
+ endif
+ endif
+ end subroutine test_min
+
+ subroutine test_sum
+ integer :: n
+ call co_sum (val, result_image=1)
+ if (this_image() == 1) then
+ n = num_images()
+ !write(*,*) "The sum is ", val
+ if (any (val /= [42 + (n-1)*(-99), (n**2 + n)/2, -55+(n-1)*101])) call abort()
+ end if
+ end subroutine test_sum
+end program test
new file mode 100644
@@ -0,0 +1,17 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-optimized -O1 -fcoarray=lib" }
+!
+integer, allocatable :: a(:,:)
+integer :: b(5)
+call co_sum(a(2:5,b))
+end
+
+! { dg-final { scan-tree-dump-times "vector.0\\\[0\\\].nvec = 0;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "vector.0\\\[0\\\].u.triplet.lower_bound = 2;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "vector.0\\\[0\\\].u.triplet.upper_bound = 5;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "vector.0\\\[0\\\].u.triplet.stride = 1;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "vector.0\\\[1\\\].nvec = 5;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "vector.0\\\[1\\\].u.v.vector = &b[0];" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "vector.0\\\[1\\\].u.v.kind = 4;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_sum \\(&a, &vector.0, 0, 0B, 0B, 0\\);" 1 "optimized" } }
+! { dg-final { cleanup-tree-dump "optimized" } }