re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])
2011-05-03 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* trans-intrinsic.c (trans_this_image): Implement version with
coarray argument.
2011-05-03 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* gfortran.dg/coarray/this_image_1.f90: New.
From-SVN: r173342
This commit is contained in:
Tobias Burnus
Tobias Burnus
parent
b0d1c284ed
commit
0e3184ac54
4 changed files with 406 additions and 12 deletions
|
|
@ -1,3 +1,12 @@
|
|||
2011-05-03 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/18918
|
||||
* trans-intrinsic.c (trans_this_image): Implement version with
|
||||
coarray argument.
|
||||
(conv_intrinsic_cobound): Simplify code.
|
||||
(gfc_conv_intrinsic_function): Call trans_this_image for
|
||||
this_image(coarray) except for -fcoarray=single.
|
||||
|
||||
2011-05-02 Steven G. Kargl <kargl@gcc.gnu.org>
|
||||
|
||||
PR fortran/48720
|
||||
|
|
|
|||
|
|
@ -923,10 +923,199 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
|
|||
|
||||
|
||||
static void
|
||||
trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED)
|
||||
trans_this_image (gfc_se * se, gfc_expr *expr)
|
||||
{
|
||||
stmtblock_t loop;
|
||||
tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
|
||||
lbound, ubound, extent, ml;
|
||||
gfc_se argse;
|
||||
gfc_ss *ss;
|
||||
int rank, corank;
|
||||
|
||||
/* The case -fcoarray=single is handled elsewhere. */
|
||||
gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
|
||||
|
||||
gfc_init_coarray_decl ();
|
||||
se->expr = gfort_gvar_caf_this_image;
|
||||
|
||||
/* Argument-free version: THIS_IMAGE(). */
|
||||
if (expr->value.function.actual->expr == NULL)
|
||||
{
|
||||
se->expr = gfort_gvar_caf_this_image;
|
||||
return;
|
||||
}
|
||||
|
||||
/* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
|
||||
|
||||
type = gfc_get_int_type (gfc_default_integer_kind);
|
||||
corank = gfc_get_corank (expr->value.function.actual->expr);
|
||||
rank = expr->value.function.actual->expr->rank;
|
||||
|
||||
/* Obtain the descriptor of the COARRAY. */
|
||||
gfc_init_se (&argse, NULL);
|
||||
ss = gfc_walk_expr (expr->value.function.actual->expr);
|
||||
gcc_assert (ss != gfc_ss_terminator);
|
||||
ss->data.info.codimen = corank;
|
||||
gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
|
||||
gfc_add_block_to_block (&se->pre, &argse.pre);
|
||||
gfc_add_block_to_block (&se->post, &argse.post);
|
||||
desc = argse.expr;
|
||||
|
||||
if (se->ss)
|
||||
{
|
||||
/* Create an implicit second parameter from the loop variable. */
|
||||
gcc_assert (!expr->value.function.actual->next->expr);
|
||||
gcc_assert (corank > 0);
|
||||
gcc_assert (se->loop->dimen == 1);
|
||||
gcc_assert (se->ss->expr == expr);
|
||||
|
||||
dim_arg = se->loop->loopvar[0];
|
||||
dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
|
||||
gfc_array_index_type, dim_arg,
|
||||
gfc_rank_cst[rank]);
|
||||
gfc_advance_se_ss_chain (se);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Use the passed DIM= argument. */
|
||||
gcc_assert (expr->value.function.actual->next->expr);
|
||||
gfc_init_se (&argse, NULL);
|
||||
gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
|
||||
gfc_array_index_type);
|
||||
gfc_add_block_to_block (&se->pre, &argse.pre);
|
||||
dim_arg = argse.expr;
|
||||
|
||||
if (INTEGER_CST_P (dim_arg))
|
||||
{
|
||||
int hi, co_dim;
|
||||
|
||||
hi = TREE_INT_CST_HIGH (dim_arg);
|
||||
co_dim = TREE_INT_CST_LOW (dim_arg);
|
||||
if (hi || co_dim < 1
|
||||
|| co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
|
||||
gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
|
||||
"dimension index", expr->value.function.isym->name,
|
||||
&expr->where);
|
||||
}
|
||||
else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
|
||||
{
|
||||
dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
|
||||
cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
|
||||
dim_arg,
|
||||
build_int_cst (TREE_TYPE (dim_arg), 1));
|
||||
tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
|
||||
tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
|
||||
dim_arg, 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);
|
||||
}
|
||||
}
|
||||
|
||||
/* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
|
||||
one always has a dim_arg argument.
|
||||
|
||||
m = this_images() - 1
|
||||
i = rank
|
||||
min_var = min (corank - 2, dim_arg)
|
||||
for (;;)
|
||||
{
|
||||
extent = gfc_extent(i)
|
||||
ml = m
|
||||
m = m/extent
|
||||
if (i >= min_var)
|
||||
goto exit_label
|
||||
i++
|
||||
}
|
||||
exit_label:
|
||||
sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
|
||||
: m + lcobound(corank)
|
||||
*/
|
||||
|
||||
m = gfc_create_var (type, NULL);
|
||||
ml = gfc_create_var (type, NULL);
|
||||
loop_var = gfc_create_var (integer_type_node, NULL);
|
||||
min_var = gfc_create_var (integer_type_node, NULL);
|
||||
|
||||
/* m = this_image () - 1. */
|
||||
tmp = fold_convert (type, gfort_gvar_caf_this_image);
|
||||
tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
|
||||
build_int_cst (type, 1));
|
||||
gfc_add_modify (&se->pre, m, tmp);
|
||||
|
||||
/* min_var = min (rank+corank-2, dim_arg). */
|
||||
tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
|
||||
build_int_cst (integer_type_node, rank + corank - 2),
|
||||
fold_convert (integer_type_node, dim_arg));
|
||||
gfc_add_modify (&se->pre, min_var, tmp);
|
||||
|
||||
/* i = rank. */
|
||||
tmp = build_int_cst (integer_type_node, rank);
|
||||
gfc_add_modify (&se->pre, loop_var, tmp);
|
||||
|
||||
exit_label = gfc_build_label_decl (NULL_TREE);
|
||||
TREE_USED (exit_label) = 1;
|
||||
|
||||
/* Loop body. */
|
||||
gfc_init_block (&loop);
|
||||
|
||||
/* ml = m. */
|
||||
gfc_add_modify (&loop, ml, m);
|
||||
|
||||
/* extent = ... */
|
||||
lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
|
||||
ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
|
||||
extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
|
||||
extent = fold_convert (type, extent);
|
||||
|
||||
/* m = m/extent. */
|
||||
gfc_add_modify (&loop, m,
|
||||
fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
|
||||
m, extent));
|
||||
|
||||
/* Exit condition: if (i >= min_var) goto exit_label. */
|
||||
cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
|
||||
min_var);
|
||||
tmp = build1_v (GOTO_EXPR, exit_label);
|
||||
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
|
||||
build_empty_stmt (input_location));
|
||||
gfc_add_expr_to_block (&loop, tmp);
|
||||
|
||||
/* Increment loop variable: i++. */
|
||||
gfc_add_modify (&loop, loop_var,
|
||||
fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
|
||||
loop_var,
|
||||
build_int_cst (integer_type_node, 1)));
|
||||
|
||||
/* Making the loop... actually loop! */
|
||||
tmp = gfc_finish_block (&loop);
|
||||
tmp = build1_v (LOOP_EXPR, tmp);
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
|
||||
/* The exit label. */
|
||||
tmp = build1_v (LABEL_EXPR, exit_label);
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
|
||||
/* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
|
||||
: m + lcobound(corank) */
|
||||
|
||||
cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
|
||||
build_int_cst (TREE_TYPE (dim_arg), corank));
|
||||
|
||||
lbound = gfc_conv_descriptor_lbound_get (desc,
|
||||
fold_build2_loc (input_location, PLUS_EXPR,
|
||||
gfc_array_index_type, dim_arg,
|
||||
gfc_rank_cst[rank - 1]));
|
||||
lbound = fold_convert (type, lbound);
|
||||
|
||||
tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
|
||||
fold_build2_loc (input_location, MULT_EXPR, type,
|
||||
m, extent));
|
||||
tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
|
||||
|
||||
se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
|
||||
fold_build2_loc (input_location, PLUS_EXPR, type,
|
||||
m, lbound));
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1281,23 +1470,15 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
|
|||
|
||||
if (se->ss)
|
||||
{
|
||||
mpz_t mpz_rank;
|
||||
tree tree_rank;
|
||||
|
||||
/* Create an implicit second parameter from the loop variable. */
|
||||
gcc_assert (!arg2->expr);
|
||||
gcc_assert (corank > 0);
|
||||
gcc_assert (se->loop->dimen == 1);
|
||||
gcc_assert (se->ss->expr == expr);
|
||||
|
||||
mpz_init_set_ui (mpz_rank, arg->expr->rank);
|
||||
tree_rank = gfc_conv_mpz_to_tree (mpz_rank, gfc_index_integer_kind);
|
||||
|
||||
bound = se->loop->loopvar[0];
|
||||
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);
|
||||
bound, gfc_rank_cst[arg->expr->rank]);
|
||||
gfc_advance_se_ss_chain (se);
|
||||
}
|
||||
else
|
||||
|
|
@ -6434,7 +6615,9 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
break;
|
||||
|
||||
case GFC_ISYM_THIS_IMAGE:
|
||||
if (expr->value.function.actual->expr)
|
||||
/* For num_images() == 1, handle as LCOBOUND. */
|
||||
if (expr->value.function.actual->expr
|
||||
&& gfc_option.coarray == GFC_FCOARRAY_SINGLE)
|
||||
conv_intrinsic_cobound (se, expr);
|
||||
else
|
||||
trans_this_image (se, expr);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2011-05-03 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/18918
|
||||
* gfortran.dg/coarray/this_image_1.f90: New.
|
||||
|
||||
2011-05-03 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/18918
|
||||
|
|
|
|||
197
gcc/testsuite/gfortran.dg/coarray/this_image_1.f90
Normal file
197
gcc/testsuite/gfortran.dg/coarray/this_image_1.f90
Normal file
|
|
@ -0,0 +1,197 @@
|
|||
! { dg-do run }
|
||||
! { dg-options "-fcoarray=lib -lcaf_single" }
|
||||
!
|
||||
! PR fortran/18918
|
||||
!
|
||||
! this_image(coarray) run test,
|
||||
! expecially for num_images > 1
|
||||
!
|
||||
! Tested are values up to num_images == 8,
|
||||
! higher values are OK, but not tested for
|
||||
!
|
||||
implicit none
|
||||
integer :: a(1)[2:2, 3:4, 7:*]
|
||||
integer :: b(:)[:, :,:]
|
||||
allocatable :: b
|
||||
integer :: i
|
||||
|
||||
if (this_image(A, dim=1) /= 2) call abort()
|
||||
i = 1
|
||||
if (this_image(A, dim=i) /= 2) call abort()
|
||||
|
||||
select case (this_image())
|
||||
case (1)
|
||||
if (this_image(A, dim=2) /= 3) call abort()
|
||||
if (this_image(A, dim=3) /= 7) call abort()
|
||||
i = 2
|
||||
if (this_image(A, dim=i) /= 3) call abort()
|
||||
i = 3
|
||||
if (this_image(A, dim=i) /= 7) call abort()
|
||||
if (any (this_image(A) /= [2,3,7])) call abort()
|
||||
|
||||
case (2)
|
||||
if (this_image(A, dim=2) /= 4) call abort()
|
||||
if (this_image(A, dim=3) /= 7) call abort()
|
||||
i = 2
|
||||
if (this_image(A, dim=i) /= 4) call abort()
|
||||
i = 3
|
||||
if (this_image(A, dim=i) /= 7) call abort()
|
||||
if (any (this_image(A) /= [2,4,7])) call abort()
|
||||
|
||||
case (3)
|
||||
if (this_image(A, dim=2) /= 3) call abort()
|
||||
if (this_image(A, dim=3) /= 8) call abort()
|
||||
i = 2
|
||||
if (this_image(A, dim=i) /= 3) call abort()
|
||||
i = 3
|
||||
if (this_image(A, dim=i) /= 8) call abort()
|
||||
if (any (this_image(A) /= [2,3,8])) call abort()
|
||||
|
||||
case (4)
|
||||
if (this_image(A, dim=2) /= 4) call abort()
|
||||
if (this_image(A, dim=3) /= 8) call abort()
|
||||
i = 2
|
||||
if (this_image(A, dim=i) /= 4) call abort()
|
||||
i = 3
|
||||
if (this_image(A, dim=i) /= 8) call abort()
|
||||
if (any (this_image(A) /= [2,4,8])) call abort()
|
||||
|
||||
case (5)
|
||||
if (this_image(A, dim=2) /= 3) call abort()
|
||||
if (this_image(A, dim=3) /= 9) call abort()
|
||||
i = 2
|
||||
if (this_image(A, dim=i) /= 3) call abort()
|
||||
i = 3
|
||||
if (this_image(A, dim=i) /= 9) call abort()
|
||||
if (any (this_image(A) /= [2,3,9])) call abort()
|
||||
|
||||
case (6)
|
||||
if (this_image(A, dim=2) /= 4) call abort()
|
||||
if (this_image(A, dim=3) /= 9) call abort()
|
||||
i = 2
|
||||
if (this_image(A, dim=i) /= 4) call abort()
|
||||
i = 3
|
||||
if (this_image(A, dim=i) /= 9) call abort()
|
||||
if (any (this_image(A) /= [2,4,9])) call abort()
|
||||
|
||||
case (7)
|
||||
if (this_image(A, dim=2) /= 3) call abort()
|
||||
if (this_image(A, dim=3) /= 10) call abort()
|
||||
i = 2
|
||||
if (this_image(A, dim=i) /= 3) call abort()
|
||||
i = 3
|
||||
if (this_image(A, dim=i) /= 10) call abort()
|
||||
if (any (this_image(A) /= [2,3,10])) call abort()
|
||||
|
||||
case (8)
|
||||
if (this_image(A, dim=2) /= 4) call abort()
|
||||
if (this_image(A, dim=3) /= 10) call abort()
|
||||
i = 2
|
||||
if (this_image(A, dim=i) /= 4) call abort()
|
||||
i = 3
|
||||
if (this_image(A, dim=i) /= 10) call abort()
|
||||
if (any (this_image(A) /= [2,4,10])) call abort()
|
||||
end select
|
||||
|
||||
|
||||
allocate (b(3)[-1:0,2:4,*])
|
||||
|
||||
select case (this_image())
|
||||
case (1)
|
||||
if (this_image(B, dim=1) /= -1) call abort()
|
||||
if (this_image(B, dim=2) /= 2) call abort()
|
||||
if (this_image(B, dim=3) /= 1) call abort()
|
||||
i = 1
|
||||
if (this_image(B, dim=i) /= -1) call abort()
|
||||
i = 2
|
||||
if (this_image(B, dim=i) /= 2) call abort()
|
||||
i = 3
|
||||
if (this_image(B, dim=i) /= 1) call abort()
|
||||
if (any (this_image(B) /= [-1,2,1])) call abort()
|
||||
|
||||
case (2)
|
||||
if (this_image(B, dim=1) /= 0) call abort()
|
||||
if (this_image(B, dim=2) /= 2) call abort()
|
||||
if (this_image(B, dim=3) /= 1) call abort()
|
||||
i = 1
|
||||
if (this_image(B, dim=i) /= 0) call abort()
|
||||
i = 2
|
||||
if (this_image(B, dim=i) /= 2) call abort()
|
||||
i = 3
|
||||
if (this_image(B, dim=i) /= 1) call abort()
|
||||
if (any (this_image(B) /= [0,2,1])) call abort()
|
||||
|
||||
case (3)
|
||||
if (this_image(B, dim=1) /= -1) call abort()
|
||||
if (this_image(B, dim=2) /= 3) call abort()
|
||||
if (this_image(B, dim=3) /= 1) call abort()
|
||||
i = 1
|
||||
if (this_image(B, dim=i) /= -1) call abort()
|
||||
i = 2
|
||||
if (this_image(B, dim=i) /= 3) call abort()
|
||||
i = 3
|
||||
if (this_image(B, dim=i) /= 1) call abort()
|
||||
if (any (this_image(B) /= [-1,3,1])) call abort()
|
||||
|
||||
case (4)
|
||||
if (this_image(B, dim=1) /= 0) call abort()
|
||||
if (this_image(B, dim=2) /= 3) call abort()
|
||||
if (this_image(B, dim=3) /= 1) call abort()
|
||||
i = 1
|
||||
if (this_image(B, dim=i) /= 0) call abort()
|
||||
i = 2
|
||||
if (this_image(B, dim=i) /= 3) call abort()
|
||||
i = 3
|
||||
if (this_image(B, dim=i) /= 1) call abort()
|
||||
if (any (this_image(B) /= [0,3,1])) call abort()
|
||||
|
||||
case (5)
|
||||
if (this_image(B, dim=1) /= -1) call abort()
|
||||
if (this_image(B, dim=2) /= 4) call abort()
|
||||
if (this_image(B, dim=3) /= 1) call abort()
|
||||
i = 1
|
||||
if (this_image(B, dim=i) /= -1) call abort()
|
||||
i = 2
|
||||
if (this_image(B, dim=i) /= 4) call abort()
|
||||
i = 3
|
||||
if (this_image(B, dim=i) /= 1) call abort()
|
||||
if (any (this_image(B) /= [-1,4,1])) call abort()
|
||||
|
||||
case (6)
|
||||
if (this_image(B, dim=1) /= 0) call abort()
|
||||
if (this_image(B, dim=2) /= 4) call abort()
|
||||
if (this_image(B, dim=3) /= 1) call abort()
|
||||
i = 1
|
||||
if (this_image(B, dim=i) /= 0) call abort()
|
||||
i = 2
|
||||
if (this_image(B, dim=i) /= 4) call abort()
|
||||
i = 3
|
||||
if (this_image(B, dim=i) /= 1) call abort()
|
||||
if (any (this_image(B) /= [0,4,1])) call abort()
|
||||
|
||||
case (7)
|
||||
if (this_image(B, dim=1) /= -1) call abort()
|
||||
if (this_image(B, dim=2) /= 2) call abort()
|
||||
if (this_image(B, dim=3) /= 2) call abort()
|
||||
i = 1
|
||||
if (this_image(B, dim=i) /= -1) call abort()
|
||||
i = 2
|
||||
if (this_image(B, dim=i) /= 2) call abort()
|
||||
i = 3
|
||||
if (this_image(B, dim=i) /= 2) call abort()
|
||||
if (any (this_image(B) /= [-1,2,2])) call abort()
|
||||
|
||||
case (8)
|
||||
if (this_image(B, dim=1) /= 0) call abort()
|
||||
if (this_image(B, dim=2) /= 2) call abort()
|
||||
if (this_image(B, dim=3) /= 2) call abort()
|
||||
i = 1
|
||||
if (this_image(B, dim=i) /= 0) call abort()
|
||||
i = 2
|
||||
if (this_image(B, dim=i) /= 2) call abort()
|
||||
i = 3
|
||||
if (this_image(B, dim=i) /= 2) call abort()
|
||||
if (any (this_image(B) /= [0,2,2])) call abort()
|
||||
end select
|
||||
|
||||
end
|
||||
Loading…
Add table
Reference in a new issue