From patchwork Tue Apr 5 17:44:29 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 89906 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 8848CB6F12 for ; Wed, 6 Apr 2011 03:44:52 +1000 (EST) Received: (qmail 11457 invoked by alias); 5 Apr 2011 17:44:43 -0000 Received: (qmail 11271 invoked by uid 22791); 5 Apr 2011 17:44:40 -0000 X-SWARE-Spam-Status: No, hits=-1.0 required=5.0 tests=AWL, BAYES_00, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 05 Apr 2011 17:44:33 +0000 Received: from [192.168.178.22] (port-92-204-58-2.dynamic.qsc.de [92.204.58.2]) by mx01.qsc.de (Postfix) with ESMTP id A6B313C956; Tue, 5 Apr 2011 19:44:30 +0200 (CEST) Message-ID: <4D9B54FD.2050408@net-b.de> Date: Tue, 05 Apr 2011 19:44:29 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.9.2.13) Gecko/20101206 SUSE/3.1.7 Thunderbird/3.1.7 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR 18918 - Fix/Add multi-image support to UCOBOUND Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 + 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 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;