From: Tobias Burnus Date: Mon, 11 Apr 2011 15:50:47 +0000 (+0200) Subject: re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=155e5d5f559fc3639da157b4c3a7ee41f62f43cb;p=gcc.git re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) 2011-04-11 Tobias Burnus 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". From-SVN: r172262 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0a4872c55c0..68440f4c840 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2011-04-11 Tobias Burnus + + 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". + 2011-04-08 Thomas Koenig PR fortran/48448 diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 2a994454b05..abc33837e6c 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 0046d0ac103..f8e26b0992e 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 1b357596915..fef56ae8535 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 1a90204a2da..b4cc360706d 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;