From patchwork Thu May 5 06:07:30 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 94204 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 56A3D1007EF for ; Thu, 5 May 2011 16:08:12 +1000 (EST) Received: (qmail 21629 invoked by alias); 5 May 2011 06:08:07 -0000 Received: (qmail 21613 invoked by uid 22791); 5 May 2011 06:08:04 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, 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; Thu, 05 May 2011 06:07:31 +0000 Received: from [192.168.178.22] (port-92-204-45-85.dynamic.qsc.de [92.204.45.85]) by mx01.qsc.de (Postfix) with ESMTP id 647DC3CD9E; Thu, 5 May 2011 08:07:30 +0200 (CEST) Message-ID: <4DC23EA2.9070206@net-b.de> Date: Thu, 05 May 2011 08:07:30 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.14) Gecko/20110221 SUSE/3.1.8 Thunderbird/3.1.8 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] Support scalar coarrays in this_image/ucobound/image_index 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 Before, scalar coarrays were not supported in the coindex intrinsics as they did not have - on tree level - cobounds attached to them. This patch adds them. Additionally, it fixes the algorithm of this_image, which seemingly only worked by chance for the test case; hopefully it now works always correctly. Note: Allocatable scalar coarrays remain unsupported for the moment. Is the patch OK for the trunk? Tobias 2011-05-05 Tobias Burnus PR fortran/18918 * trans-array.c (gfc_walk_variable_expr): Continue walking for scalar coarrays. * trans-intrinsic.c (convert_element_to_coarray_ref): New function. (trans_this_image, trans_image_index, conv_intrinsic_cobound): Use it. (trans_this_image): Fix algorithm. * trans-types.c (gfc_get_element_type, gfc_get_array_descriptor_base, gfc_sym_type): Handle scalar coarrays. 2011-05-05 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray/this_image_2.f90: New. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a7e5f81..1a4ab39 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7443,7 +7443,7 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) ar = &ref->u.ar; - if (ar->as->rank == 0) + if (ar->as->rank == 0 && ref->next != NULL) { /* Scalar coarray. */ continue; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 6554df0..fa5d3cf 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -921,6 +921,24 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) } +/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an + AR_FULL, suitable for the scalarizer. */ + +static void +convert_element_to_coarray_ref (gfc_expr *expr) +{ + gfc_ref *ref; + + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->next == NULL + && ref->u.ar.codimen) + { + ref->u.ar.type = AR_FULL; + break; + } +} + + static void trans_this_image (gfc_se * se, gfc_expr *expr) { @@ -951,6 +969,8 @@ trans_this_image (gfc_se * se, gfc_expr *expr) /* Obtain the descriptor of the COARRAY. */ gfc_init_se (&argse, NULL); + if (expr->value.function.actual->expr->rank == 0) + convert_element_to_coarray_ref (expr->value.function.actual->expr); ss = gfc_walk_expr (expr->value.function.actual->expr); gcc_assert (ss != gfc_ss_terminator); ss->data.info.codimen = corank; @@ -970,7 +990,7 @@ trans_this_image (gfc_se * se, gfc_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]); + build_int_cst (TREE_TYPE (dim_arg), 1)); gfc_advance_se_ss_chain (se); } else @@ -1016,7 +1036,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr) m = this_images() - 1 i = rank - min_var = min (corank - 2, dim_arg) + min_var = min (rank + corank - 2, rank + dim_arg - 1) for (;;) { extent = gfc_extent(i) @@ -1042,10 +1062,13 @@ trans_this_image (gfc_se * se, gfc_expr *expr) build_int_cst (type, 1)); gfc_add_modify (&se->pre, m, tmp); - /* min_var = min (rank+corank-2, dim_arg). */ + /* min_var = min (rank + corank-2, rank + dim_arg - 1). */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, + fold_convert (integer_type_node, dim_arg), + build_int_cst (integer_type_node, rank - 1)); 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)); + tmp); gfc_add_modify (&se->pre, min_var, tmp); /* i = rank. */ @@ -1102,9 +1125,9 @@ trans_this_image (gfc_se * se, gfc_expr *expr) 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])); + fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, dim_arg, + build_int_cst (TREE_TYPE (dim_arg), rank-1))); lbound = fold_convert (type, lbound); tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml, @@ -1133,6 +1156,8 @@ trans_image_index (gfc_se * se, gfc_expr *expr) /* Obtain the descriptor of the COARRAY. */ gfc_init_se (&argse, NULL); + if (expr->value.function.actual->expr->rank == 0) + convert_element_to_coarray_ref (expr->value.function.actual->expr); ss = gfc_walk_expr (expr->value.function.actual->expr); gcc_assert (ss != gfc_ss_terminator); ss->data.info.codimen = corank; @@ -1457,6 +1482,8 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); corank = gfc_get_corank (arg->expr); + if (expr->value.function.actual->expr->rank == 0) + convert_element_to_coarray_ref (expr->value.function.actual->expr); ss = gfc_walk_expr (arg->expr); gcc_assert (ss != gfc_ss_terminator); ss->data.info.codimen = corank; diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index cc82037..22a2c5b 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1205,7 +1205,7 @@ gfc_get_element_type (tree type) int gfc_is_nodesc_array (gfc_symbol * sym) { - gcc_assert (sym->attr.dimension); + gcc_assert (sym->attr.dimension || sym->attr.codimension); /* We only want local arrays. */ if (sym->attr.pointer || sym->attr.allocatable) @@ -1598,7 +1598,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; int idx = 2 * (codimen + dimen - 1) + restricted; - gcc_assert (dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS); + gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS); if (gfc_array_descriptor_base[idx]) return gfc_array_descriptor_base[idx]; @@ -1996,7 +1996,7 @@ gfc_sym_type (gfc_symbol * sym) if (!restricted) type = gfc_nonrestricted_type (type); - if (sym->attr.dimension) + if (sym->attr.dimension || sym->attr.codimension) { if (gfc_is_nodesc_array (sym)) { --- /dev/null 2011-05-03 23:04:54.143891387 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray/this_image_2.f90 2011-05-04 22:56:45.000000000 +0200 @@ -0,0 +1,125 @@ +! { dg-do run } +! +! PR fortran/18918 +! +! Version for scalar coarrays +! +! 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[2:2, 3:4, 7:*] +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 + +contains + +subroutine test_image_index +implicit none +integer :: index1, index2, index3 +logical :: one + +integer, save :: d(2)[-1:3, *] +integer, save :: e(2)[-1:-1, 3:*] + +one = num_images() == 1 + +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() + +end subroutine test_image_index + +end