This patch adds multi-image support to UCOBOUND. In the -fcoarray=single
case, the last dimension is just "LCOARRAY (coarray, dim=corank)".
However, if there are multiple images, one has for corank-1 coarrays:
"lcobound(coarray) + num_images() -1" and for multi-rank coarrays for
the last dimension "lcobound(coarray, dim=corank) + ceiling (real
(num_images ()) / real (size)) - 1", where size is the product of the
extends in all but the last codimension.
Well, that's actually all the patch does. (Except that "ceiling(N/S)-1"
is replaced by "(N+S-1)/S-1" = "(N-1)/S".)
Build an regtested on x86-64-linux.
OK for the trunk?
(Sorry, no test case. I think one should soon start to create a
-fcoarray=lib version of the test suite, where one passes the link (e.g.
"$DIR/mpi.o $MPI_LIB" or "$DIR/single.o") and run command (e.g. "mpiexec
-n 3" or "") via environment variables.)
Tobias
PS: We should soon work again on the regressions. Currently there are 10
regressions of which 6 are GCC 4.6/4.7 regressions - and 1 is 4.7 only.
We should fix all of the 4.6/4.7 regressions before the GCC 4.6.1 release!
PPS: Maybe someone understands why UCOBOUND(corank_1_coarray) for which
one has the pseudo code:
D = [codim=1].lbound + num_image - 1
gets translated as:
D.1571 = (integer(kind=4)) (((character(kind=4))
parm.2.dim[NON_LVALUE_EXPR <S.1> + 1].lbound + (character(kind=4))
_gfortran_caf_num_images.4) + 4294967295);
Namely: Why are there all those casts to "character(kind=4)" and why is
"+ (-1)" converted into 4294967295? The result surely works, but the
dump looks odd.
2011-04-05 Tobias Burnus <bur...@net-b.de>
PR fortran/18918
* simplify.c (simplify_bound_dim): Exit for
ucobound's last dimension unless -fcoarray=single.
* trans-array (gfc_conv_descriptor_size_1): Renamed from
gfc_conv_descriptor_size, made static, has now from_dim and
to_dim arguments.
(gfc_conv_descriptor_size): Call gfc_conv_descriptor_size.
(gfc_conv_descriptor_cosize): New function.
* trans-array.h (gfc_conv_descriptor_cosize): New prototype.
* trans-intrinsic.c (conv_intrinsic_cobound): Add input_location
and handle last codim of ucobound for when -fcoarray is not "single".
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 2a99445..abc3383 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3298,7 +3298,8 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
/* The last dimension of an assumed-size array is special. */
if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
- || (coarray && d == as->rank + as->corank))
+ || (coarray && d == as->rank + as->corank
+ && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
{
if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0046d0a..f8e26b0 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4055,17 +4055,17 @@ gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
/* For an array descriptor, get the total number of elements. This is just
- the product of the extents along all dimensions. */
+ the product of the extents along from_dim to to_dim. */
-tree
-gfc_conv_descriptor_size (tree desc, int rank)
+static tree
+gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
{
tree res;
int dim;
res = gfc_index_one_node;
- for (dim = 0; dim < rank; ++dim)
+ for (dim = from_dim; dim < to_dim; ++dim)
{
tree lbound;
tree ubound;
@@ -4083,6 +4083,24 @@ gfc_conv_descriptor_size (tree desc, int rank)
}
+/* Full size of an array. */
+
+tree
+gfc_conv_descriptor_size (tree desc, int rank)
+{
+ return gfc_conv_descriptor_size_1 (desc, 0, rank);
+}
+
+
+/* Size of a coarray for all dimensions but the last. */
+
+tree
+gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
+{
+ return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
+}
+
+
/* Helper function for marking a boolean expression tree as unlikely. */
static tree
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1b35759..fef56ae 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -164,3 +164,4 @@ void gfc_trans_string_copy (stmtblock_t *, tree, tree, int, tree, tree, int);
/* Calculate extent / size of an array. */
tree gfc_conv_array_extent_dim (tree, tree, tree*);
tree gfc_conv_descriptor_size (tree, int);
+tree gfc_conv_descriptor_cosize (tree, int, int);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 9a69632..0c2ce51 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1170,10 +1170,10 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
tree_rank = gfc_conv_mpz_to_tree (mpz_rank, gfc_index_integer_kind);
bound = se->loop->loopvar[0];
- bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound,
- se->ss->data.info.delta[0]);
- bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound,
- tree_rank);
+ bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ bound, se->ss->data.info.delta[0]);
+ bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ bound, tree_rank);
gfc_advance_se_ss_chain (se);
}
else
@@ -1199,11 +1199,13 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
bound = gfc_evaluate_now (bound, &se->pre);
- cond = fold_build2 (LT_EXPR, boolean_type_node,
- bound, build_int_cst (TREE_TYPE (bound), 1));
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ bound, build_int_cst (TREE_TYPE (bound), 1));
tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
- tmp = fold_build2 (GT_EXPR, boolean_type_node, bound, tmp);
- cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ bound, tmp);
+ cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ boolean_type_node, cond, tmp);
gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
gfc_msg_fault);
}
@@ -1213,26 +1215,74 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
switch (arg->expr->rank)
{
case 0:
- bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
- gfc_index_one_node);
+ bound = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, bound,
+ gfc_index_one_node);
case 1:
break;
default:
- bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound,
- gfc_rank_cst[arg->expr->rank - 1]);
+ bound = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, bound,
+ gfc_rank_cst[arg->expr->rank - 1]);
}
}
resbound = gfc_conv_descriptor_lbound_get (desc, bound);
+ /* Handle UCOBOUND with special handling of the last codimension. */
if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
{
- cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
- build_int_cst (TREE_TYPE (bound),
- arg->expr->rank + corank - 1));
- resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
- se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
- resbound, resbound2);
+ /* Last codimension: For -fcoarray=single just return
+ the lcobound - otherwise add
+ ceiling (real (num_images ()) / real (size)) - 1
+ = (num_images () + size - 1) / size - 1
+ = (num_images - 1) / size(),
+ where size is the product of the extend of all but the last
+ codimension. */
+
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
+ {
+ tree cosize;
+
+ gfc_init_coarray_decl ();
+ cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfort_gvar_caf_num_images,
+ build_int_cst (gfc_array_index_type, 1));
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type, tmp,
+ fold_convert (gfc_array_index_type, cosize));
+ resbound = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, resbound, tmp);
+ }
+ else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+ {
+ /* ubound = lbound + num_images() - 1. */
+ gfc_init_coarray_decl ();
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfort_gvar_caf_num_images,
+ build_int_cst (gfc_array_index_type, 1));
+ resbound = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, resbound, tmp);
+ }
+
+ if (corank > 1)
+ {
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ bound,
+ build_int_cst (TREE_TYPE (bound),
+ arg->expr->rank + corank - 1));
+
+ resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
+ se->expr = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ resbound, resbound2);
+ }
+ else
+ se->expr = resbound;
}
else
se->expr = resbound;
