From patchwork Thu Dec 15 14:23:50 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 131653 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 7F9ED1007D4 for ; Fri, 16 Dec 2011 01:24:34 +1100 (EST) Received: (qmail 9606 invoked by alias); 15 Dec 2011 14:24:27 -0000 Received: (qmail 9580 invoked by uid 22791); 15 Dec 2011 14:24:25 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 15 Dec 2011 14:23:53 +0000 Received: from [192.168.178.22] (port-92-204-92-59.dynamic.qsc.de [92.204.92.59]) by mx02.qsc.de (Postfix) with ESMTP id 6CBA1295ED; Thu, 15 Dec 2011 15:23:51 +0100 (CET) Message-ID: <4EEA02F6.3010007@net-b.de> Date: Thu, 15 Dec 2011 15:23:50 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:8.0) Gecko/20111105 Thunderbird/8.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: Re: [Patch, Fortran] Some fixes for polymorphic coarrays References: <4EE78BB3.8010007@net-b.de> In-Reply-To: <4EE78BB3.8010007@net-b.de> 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 Small patch update: The patch now includes also primary.c changes, which fix the DEALLOCATE issue with polymorphic scalar coarrays. OK for the trunk? Tobias On 12/13/2011 06:30 PM, Tobias Burnus wrote: > Two small fixes: > > a) There was an ICE when simplifying "THIS_IMAGE(caf)" (for > -fcoarray=single); solution: Simply use internally lcobound(), which > is identically (for a single image). > > b) There was an segfault of the compiled program when running > "this_image(caf)" where "caf" is a corank-1 coarray. Calculating the > extend of an assumed size array should be avoided ... > > The patch has been build and regtested on x86-64-linux. > OK for the trunk? > > Tobias > > PS: There are still some other issues with polymorphic coarrays, see > "Next steps" in > http://users.physik.fu-berlin.de/~tburnus/coarray/README.txt for a > list. For instance, there is an ICE if one tries to explicitly > deallocate scalar polymorphic coarrays. 2011-12-15 Tobias Burnus * primary.c (gfc_match_varspec): Match array spec for polymorphic coarrays. (gfc_match_rvalue): If a symbol of unknown flavor has a codimension, mark it as a variable. * simplify.c (gfc_simplify_image_index): Directly call simplify_cobound. * trans-intrinsic.c (trans_this_image): Fix handling of corank = 1 arrays. 2011-12-15 Tobias Burnus * gfortran.dg/coarray/poly_run_3.f90: New. diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 75c7e13..afc4684 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1821,7 +1821,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, && !(gfc_matching_procptr_assignment && sym->attr.flavor == FL_PROCEDURE)) || (sym->ts.type == BT_CLASS && sym->attr.class_ok - && CLASS_DATA (sym)->attr.dimension)) + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension))) { /* In EQUIVALENCE, we don't know yet whether we are seeing an array, character variable or array of character @@ -2894,10 +2895,10 @@ gfc_match_rvalue (gfc_expr **result) && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, sym->ns); - /* If the symbol has a dimension attribute, the expression is a + /* If the symbol has a (co)dimension attribute, the expression is a variable. */ - if (sym->attr.dimension) + if (sym->attr.dimension || sym->attr.codimension) { if (gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL) == FAILURE) @@ -2913,7 +2914,9 @@ gfc_match_rvalue (gfc_expr **result) break; } - if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) + if (sym->ts.type == BT_CLASS + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension)) { if (gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL) == FAILURE) diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index e82753a..282d88d 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -6227,10 +6227,6 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) gfc_expr * gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) { - gfc_ref *ref; - gfc_array_spec *as; - int d; - if (gfc_option.coarray != GFC_FCOARRAY_SINGLE) return NULL; @@ -6244,74 +6240,8 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) return result; } - gcc_assert (coarray->expr_type == EXPR_VARIABLE); - - /* Follow any component references. */ - as = coarray->symtree->n.sym->as; - for (ref = coarray->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - as = ref->u.ar.as; - - if (as->type == AS_DEFERRED) - return NULL; - - if (dim == NULL) - { - /* Multi-dimensional bounds. */ - gfc_expr *bounds[GFC_MAX_DIMENSIONS]; - gfc_expr *e; - - /* Simplify the bounds for each dimension. */ - for (d = 0; d < as->corank; d++) - { - bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0, - as, NULL, true); - if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) - { - int j; - - for (j = 0; j < d; j++) - gfc_free_expr (bounds[j]); - - return bounds[d]; - } - } - - /* Allocate the result expression. */ - e = gfc_get_expr (); - e->where = coarray->where; - e->expr_type = EXPR_ARRAY; - e->ts.type = BT_INTEGER; - e->ts.kind = gfc_default_integer_kind; - - e->rank = 1; - e->shape = gfc_get_shape (1); - mpz_init_set_ui (e->shape[0], as->corank); - - /* Create the constructor for this array. */ - for (d = 0; d < as->corank; d++) - gfc_constructor_append_expr (&e->value.constructor, - bounds[d], &e->where); - - return e; - } - else - { - /* A DIM argument is specified. */ - if (dim->expr_type != EXPR_CONSTANT) - return NULL; - - d = mpz_get_si (dim->value.integer); - - if (d < 1 || d > as->corank) - { - gfc_error ("DIM argument at %L is out of bounds", &dim->where); - return &gfc_bad_expr; - } - - return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, - true); - } + /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */ + return simplify_cobound (coarray, dim, NULL, 0); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 58112e3..5c964c1 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1054,6 +1054,11 @@ trans_this_image (gfc_se * se, gfc_expr *expr) one always has a dim_arg argument. m = this_images() - 1 + if (corank == 1) + { + sub(1) = m + lcobound(corank) + return; + } i = rank min_var = min (rank + corank - 2, rank + dim_arg - 1) for (;;) @@ -1070,15 +1075,29 @@ trans_this_image (gfc_se * se, gfc_expr *expr) : m + lcobound(corank) */ + /* this_image () - 1. */ + tmp = fold_convert (type, gfort_gvar_caf_this_image); + tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp, + build_int_cst (type, 1)); + if (corank == 1) + { + /* sub(1) = m + lcobound(corank). */ + lbound = gfc_conv_descriptor_lbound_get (desc, + build_int_cst (TREE_TYPE (gfc_array_index_type), + corank+rank-1)); + lbound = fold_convert (type, lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound); + + se->expr = tmp; + return; + } + m = gfc_create_var (type, NULL); ml = gfc_create_var (type, NULL); loop_var = gfc_create_var (integer_type_node, NULL); min_var = gfc_create_var (integer_type_node, NULL); /* m = this_image () - 1. */ - tmp = fold_convert (type, gfort_gvar_caf_this_image); - tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp, - build_int_cst (type, 1)); gfc_add_modify (&se->pre, m, tmp); /* min_var = min (rank + corank-2, rank + dim_arg - 1). */ --- /dev/null 2011-12-14 20:10:08.555534201 +0100 +++ gcc/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 2011-12-15 14:36:46.000000000 +0100 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Check that the bounds of polymorphic coarrays is +! properly handled. +! +type t +end type t +class(t), allocatable :: a(:)[:] +class(t), allocatable :: b[:], d[:] + +allocate(a(1)[*]) +if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) & + call abort () +if (any (lcobound(a) /= 1)) call abort() +if (any (ucobound(a) /= this_image())) call abort () +deallocate(a) + +allocate(b[*]) +if (this_image() == 1 .and. any (this_image(b) /= lcobound(b))) & + call abort () +if (any (lcobound(b) /= 1)) call abort() +if (any (ucobound(b) /= this_image())) call abort () +deallocate(b) + +allocate(a(1)[-10:*]) +if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) & + call abort () +if (any (lcobound(a) /= -10)) call abort() +if (any (ucobound(a) /= -11+this_image())) call abort () +deallocate(a) + +allocate(d[23:*]) +if (this_image() == 1 .and. any (this_image(d) /= lcobound(d))) & + call abort () +if (any (lcobound(d) /= 23)) call abort() +if (any (ucobound(d) /= 22+this_image())) call abort () +deallocate(d) + +end