From 0e3184ac544fea00da542ed0a9644f0fdba00f10 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Tue, 3 May 2011 23:44:27 +0200 Subject: [PATCH] re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) 2011-05-03 Tobias Burnus PR fortran/18918 * trans-intrinsic.c (trans_this_image): Implement version with coarray argument. 2011-05-03 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray/this_image_1.f90: New. From-SVN: r173342 --- gcc/fortran/ChangeLog | 9 + gcc/fortran/trans-intrinsic.c | 207 +++++++++++++++++- gcc/testsuite/ChangeLog | 5 + .../gfortran.dg/coarray/this_image_1.f90 | 197 +++++++++++++++++ 4 files changed, 406 insertions(+), 12 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray/this_image_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 89669e522fc..ba20715f020 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2011-05-03 Tobias Burnus + + 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 PR fortran/48720 diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 180aba18b17..10dadf7555a 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5ce6d37ad1c..29908e671a0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-05-03 Tobias Burnus + + PR fortran/18918 + * gfortran.dg/coarray/this_image_1.f90: New. + 2011-05-03 Tobias Burnus PR fortran/18918 diff --git a/gcc/testsuite/gfortran.dg/coarray/this_image_1.f90 b/gcc/testsuite/gfortran.dg/coarray/this_image_1.f90 new file mode 100644 index 00000000000..64d222b76de --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/this_image_1.f90 @@ -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 -- 2.30.2