From patchwork Sat Apr 16 20:25:19 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 91498 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 9F7E0B6F94 for ; Sun, 17 Apr 2011 06:25:46 +1000 (EST) Received: (qmail 5858 invoked by alias); 16 Apr 2011 20:25:43 -0000 Received: (qmail 5833 invoked by uid 22791); 16 Apr 2011 20:25:40 -0000 X-SWARE-Spam-Status: No, hits=-0.3 required=5.0 tests=AWL, BAYES_05, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE, TW_TM 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; Sat, 16 Apr 2011 20:25:21 +0000 Received: from [192.168.178.22] (port-92-204-66-174.dynamic.qsc.de [92.204.66.174]) by mx01.qsc.de (Postfix) with ESMTP id 6E95F3CA5A; Sat, 16 Apr 2011 22:25:19 +0200 (CEST) Message-ID: <4DA9FB2F.3030002@net-b.de> Date: Sat, 16 Apr 2011 22:25:19 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; 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 - implement coarray's IMAGE_INDEX for nonconstant bounds 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 The attached patch implements IMAGE_INDEX(COARRAY, SUB) for nonconstant bounds; the patch (and the test case) work both with -fcoarray=single and with -fcoarray=lib (with any number of images - I tried up to 21). Note: If the image index would exceed the number of images, 0 is returned. Additionally, there are also no other restrictions to the used values of SUB. Thus, I had to add an additional check for whether the cobounds are exceeded; in that case also 0 is returned. In simplify.c, currently an error is returned if the cobounds are exceeded. One should probably downgrade those to warnings. (Nevertheless, if this happens for constant cobounds and constant SUB, the algorithm has a problem.) Build and regtested on x86-64-linux. OK for the trunk? Tobias PS: In terms of cobounds intrinsics, only THIS_IMAGE(coarray) remains to be fixed. Currently, it always returns LCOBOUND(coarray) which is only valid for num_images() == 1. 2011-04-16 Tobias Burnus PR fortran/18918 * iresolve.c (gfc_resolve_image_index): Set ts.type. * simplify.c (gfc_simplify_image_index): Don't abort if the bounds are not known at compile time and handle -fcoarray=lib. * trans-intrinsics.c (gfc_conv_intrinsic_function): Handle IMAGE_INDEX. (conv_intrinsic_cobound): Fix comment typo. (trans_this_image): New function. * trans-array.c (gfc_unlikely): Move to trans.c. * trans.c (gfc_unlikely): Function moved from trans-array.c. (gfc_trans_runtime_check): Use it. * trans-io.c (gfc_trans_io_runtime_check): Ditto. * trans.h (gfc_unlikely): Add prototype. 2011-04-16 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_16.f90: New. diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 5042db3..24c9f76 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -2547,9 +2547,10 @@ void gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, gfc_expr *sub ATTRIBUTE_UNUSED) { - static char this_image[] = "__image_index"; + static char image_index[] = "__image_index"; + f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; - f->value.function.name = this_image; + f->value.function.name = image_index; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index abc3383..b744a21 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -6189,7 +6189,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) int d; if (!is_constant_array_expr (sub)) - goto not_implemented; /* return NULL;*/ + return NULL; /* Follow any component references. */ as = coarray->symtree->n.sym->as; @@ -6198,7 +6198,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) as = ref->u.ar.as; if (as->type == AS_DEFERRED) - goto not_implemented; /* return NULL;*/ + return NULL; /* "valid sequence of cosubscripts" are required; thus, return 0 unless the cosubscript addresses the first image. */ @@ -6221,7 +6221,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true); if (ca_bound == NULL) - goto not_implemented; /* return NULL */ + return NULL; if (ca_bound == &gfc_bad_expr) return ca_bound; @@ -6285,6 +6285,10 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) return &gfc_bad_expr; } + + if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image) + return NULL; + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); if (first_image) @@ -6293,11 +6297,6 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) mpz_set_si (result->value.integer, 0); return result; - -not_implemented: - gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant " - "cobounds at %L", &coarray->where); - return &gfc_bad_expr; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 638234e..5293fec 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4111,21 +4111,6 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank) } -/* Helper function for marking a boolean expression tree as unlikely. */ - -static tree -gfc_unlikely (tree cond) -{ - tree tmp; - - cond = fold_convert (long_integer_type_node, cond); - tmp = build_zero_cst (long_integer_type_node); - cond = build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); - cond = fold_convert (boolean_type_node, cond); - return cond; -} - /* Fills in an array descriptor, and returns the size of the array. The size will be a simple_val, ie a variable or a constant. Also calculates the offset of the base. The pointer argument overflow, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index bb9d7e1..aec670d 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -921,6 +921,7 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) se->expr = fold_convert (type, res); } + static void trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED) { @@ -928,6 +929,133 @@ trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED) se->expr = gfort_gvar_caf_this_image; } + +static void +trans_image_index (gfc_se * se, gfc_expr *expr) +{ + tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, + tmp, invalid_bound; + gfc_se argse, subse; + gfc_ss *ss, *subss; + int rank, corank, codim; + + 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; + + /* Obtain a handle to the SUB argument. */ + gfc_init_se (&subse, NULL); + subss = gfc_walk_expr (expr->value.function.actual->next->expr); + gcc_assert (subss != gfc_ss_terminator); + gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr, + subss); + gfc_add_block_to_block (&se->pre, &subse.pre); + gfc_add_block_to_block (&se->post, &subse.post); + subdesc = build_fold_indirect_ref_loc (input_location, + gfc_conv_descriptor_data_get (subse.expr)); + + /* Fortran 2008 does not require that the values remain in the cobounds, + thus we need explicitly check this - and return 0 if they are exceeded. */ + + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]); + tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL); + invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + fold_convert (gfc_array_index_type, tmp), + lbound); + + for (codim = corank + rank - 2; codim >= rank; codim--) + { + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]); + tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + fold_convert (gfc_array_index_type, tmp), + lbound); + invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, invalid_bound, cond); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + fold_convert (gfc_array_index_type, tmp), + ubound); + invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, invalid_bound, cond); + } + + invalid_bound = gfc_unlikely (invalid_bound); + + + /* See Fortran 2008, C.10 for the following algorithm. */ + + /* coindex = sub(corank) - lcobound(n). */ + coindex = fold_convert (gfc_array_index_type, + gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], + NULL)); + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]); + coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + fold_convert (gfc_array_index_type, coindex), + lbound); + + for (codim = corank + rank - 2; codim >= rank; codim--) + { + tree extent, ubound; + + /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */ + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]); + extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); + + /* coindex *= extent. */ + coindex = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, coindex, extent); + + /* coindex += sub(codim). */ + tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL); + coindex = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, coindex, + fold_convert (gfc_array_index_type, tmp)); + + /* coindex -= lbound(codim). */ + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); + coindex = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, coindex, lbound); + } + + coindex = fold_build2_loc (input_location, PLUS_EXPR, type, + fold_convert(type, coindex), + build_int_cst (type, 1)); + + /* Return 0 if "coindex" exceeds num_images(). */ + + if (gfc_option.coarray == GFC_FCOARRAY_SINGLE) + num_images = build_int_cst (type, 1); + else + { + gfc_init_coarray_decl (); + num_images = gfort_gvar_caf_num_images; + } + + tmp = gfc_create_var (type, NULL); + gfc_add_modify (&se->pre, tmp, coindex); + + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp, + num_images); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, + cond, + fold_convert (boolean_type_node, invalid_bound)); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, + build_int_cst (type, 0), tmp); +} + + static void trans_num_images (gfc_se * se) { @@ -1233,7 +1361,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) 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 + where size is the product of the extent of all but the last codimension. */ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1) @@ -6312,6 +6440,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) trans_this_image (se, expr); break; + case GFC_ISYM_IMAGE_INDEX: + trans_image_index (se, expr); + break; + case GFC_ISYM_NUM_IMAGES: trans_num_images (se); break; diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index f6a783f..883ec5c 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -267,13 +267,7 @@ gfc_trans_io_runtime_check (tree cond, tree var, int error_code, } else { - /* Tell the compiler that this isn't likely. */ - cond = fold_convert (long_integer_type_node, cond); - tmp = build_int_cst (long_integer_type_node, 0); - cond = build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); - cond = fold_convert (boolean_type_node, cond); - + cond = gfc_unlikely (cond); tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location)); gfc_add_expr_to_block (pblock, tmp); } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 27a352a..9786d97 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -505,11 +505,7 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, else cond = fold_convert (long_integer_type_node, cond); - tmp = build_int_cst (long_integer_type_node, 0); - cond = build_call_expr_loc (where->lb->location, - built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); - cond = fold_convert (boolean_type_node, cond); - + cond = gfc_unlikely (cond); tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node, cond, body, build_empty_stmt (where->lb->location)); @@ -1565,3 +1561,19 @@ gfc_finish_wrapped_block (gfc_wrapped_block* block) return result; } + + +/* Helper function for marking a boolean expression tree as unlikely. */ + +tree +gfc_unlikely (tree cond) +{ + tree tmp; + + cond = fold_convert (long_integer_type_node, cond); + tmp = build_zero_cst (long_integer_type_node); + cond = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); + cond = fold_convert (boolean_type_node, cond); + return cond; +} diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 543ad52..6a2e4f5 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -512,6 +512,9 @@ void gfc_generate_constructors (void); /* Get the string length of an array constructor. */ bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *); +/* Mark a condition as unlikely. */ +tree gfc_unlikely (tree); + /* Generate a runtime error call. */ tree gfc_trans_runtime_error (bool, locus*, const char*, ...); --- /dev/null 2011-04-16 08:01:23.231890280 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray_16.f90 2011-04-16 21:41:32.000000000 +0200 @@ -0,0 +1,100 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Run-time test for IMAGE_INDEX with cobounds only known at +! the compile time, suitable for any number of NUM_IMAGES() +! For compile-time cobounds, the -fcoarray=lib version still +! needs to run-time evalulation if image_index returns > 1 +! as image_index is 0 if the index would exceed num_images(). +! +! Please set num_images() to >= 13, if possible. +! +! PR fortran/18918 +! + +program test_image_index +implicit none +integer :: index1, index2, index3 +logical :: one + +integer, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:,:)[:] +integer, save :: d(2)[-1:3, *] +integer, save :: e(2)[-1:-1, 3:*] + +one = num_images() == 1 + +allocate(a(1)[3:3, -4:-3, 88:*]) +allocate(b(2)[-1:0,0:*]) +allocate(c(3,3)[*]) + +index1 = image_index(a, [3, -4, 88] ) +index2 = image_index(b, [-1, 0] ) +index3 = image_index(c, [1] ) +if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort() + + +index1 = image_index(a, [3, -3, 88] ) +index2 = image_index(b, [0, 0] ) +index3 = image_index(c, [2] ) + +if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) & + call abort() +if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) & + call abort() + + +index1 = image_index(d, [-1, 1] ) +index2 = image_index(d, [0, 1] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + call abort() +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + call abort() + +index1 = image_index(e, [-1, 3] ) +index2 = image_index(e, [-1, 4] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + call abort() +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + call abort() + +call test(1, a,b,c) + +! The following test is in honour of the F2008 standard: +deallocate(a) +allocate(a (10) [10, 0:9, 0:*]) + +index1 = image_index(a, [1, 0, 0] ) +index2 = image_index(a, [3, 1, 2] ) ! = 213, yeah! +index3 = image_index(a, [3, 1, 0] ) ! = 13 + +if (num_images() < 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 0)) & + call abort() +if (num_images() >= 213 .and. (index1 /= 1 .or. index2 /= 213 .or. index3 /= 13)) & + call abort() +if (num_images() >= 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 13)) & + call abort() + + +contains +subroutine test(n, a, b, c) + integer :: n + integer :: a(1)[3*n:3*n, -4*n:-3*n, 88*n:*], b(2)[-1*n:0*n,0*n:*], c(3*n,3*n)[*] + + index1 = image_index(a, [3, -4, 88] ) + index2 = image_index(b, [-1, 0] ) + index3 = image_index(c, [1] ) + if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort() + + + index1 = image_index(a, [3, -3, 88] ) + index2 = image_index(b, [0, 0] ) + index3 = image_index(c, [2] ) + + if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) & + call abort() + if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) & + call abort() +end subroutine test +end program test_image_index