From: Tobias Burnus Date: Mon, 18 Apr 2011 05:56:05 +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=5af0793001c54632a5160a352cfdee6195338314;p=gcc.git re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) 2011-04-18 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-18 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_16.f90: New. From-SVN: r172637 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 97f34107888..7154e621211 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2011-04-18 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-18 Paul Thomas PR fortran/48462 diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 5042db37944..24c9f76d7fe 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 abc33837e6c..b744a214ed5 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 638234efd69..5293fec225b 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 bb9d7e18179..aec670d3b04 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 f6a783f38f0..883ec5c95c1 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 27a352ab3bd..9786d97a0cd 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 543ad525b1a..6a2e4f57e6e 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*, ...); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4d3019e117f..22a33c33281 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-04-18 Tobias Burnus + + PR fortran/18918 + * gfortran.dg/coarray_16.f90: New. + 2011-04-18 Paul Thomas PR fortran/48462 diff --git a/gcc/testsuite/gfortran.dg/coarray_16.f90 b/gcc/testsuite/gfortran.dg/coarray_16.f90 new file mode 100644 index 00000000000..282e8706848 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_16.f90 @@ -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