From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 8217 invoked by alias); 10 Jul 2011 19:56:47 -0000 Received: (qmail 8201 invoked by uid 22791); 10 Jul 2011 19:56:44 -0000 X-SWARE-Spam-Status: No, hits=-1.7 required=5.0 tests=AWL,BAYES_00,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; Sun, 10 Jul 2011 19:56:26 +0000 Received: from [192.168.178.22] (port-92-204-19-234.dynamic.qsc.de [92.204.19.234]) by mx01.qsc.de (Postfix) with ESMTP id 8FCB83CB94; Sun, 10 Jul 2011 21:56:24 +0200 (CEST) Message-ID: <4E1A03E8.3050706@net-b.de> Date: Sun, 10 Jul 2011 21:16:00 -0000 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.17) Gecko/20110414 SUSE/3.1.10 Thunderbird/3.1.10 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] Support allocatable *scalar* coarrays Content-Type: multipart/mixed; boundary="------------030803080401080901070805" Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org X-SW-Source: 2011-07/txt/msg00765.txt.bz2 This is a multi-part message in MIME format. --------------030803080401080901070805 Content-Type: text/plain; charset=ISO-8859-15; format=flowed Content-Transfer-Encoding: 7bit Content-length: 958 This patch implemented the trans*.c part of allocatable scalar coarrays; contrary to noncoarray allocatable scalars, they have cobounds and thus use an array descriptor. While there are still some bugs and minor omissions, gfortran slowly gets feature compile with regards to single-image coarrays support. Still to be done: Fixes to LOCK_TYPE constraint checks, polymorphic coarrays, some issues with coarray dummies, some issues with allocatable coarray components. The patch also works with -fcoarray=lib. However, the to-do list for libcaf is much longer. On the front-end side, there are additional issues with argument passing, deallocate, some minor allocate issues ("token"), and in particular calling the library for actual communication, for locking and for atomic access. Additionally, the message-processing loop in the library is still missing. The attached patch was build and regtested on x86-64-linux. OK for the trunk? Tobias --------------030803080401080901070805 Content-Type: text/x-patch; name="caf_alloc_scalar.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="caf_alloc_scalar.diff" Content-length: 16052 2011-07-10 Tobias Burnus * expr.c (gfc_ref_this_image): New function. (gfc_is_coindexed): Use it. * gfortran.h (gfc_ref_this_image): New prototype. * resolve.c (resolve_deallocate_expr, resolve_allocate_expr): Support alloc scalar coarrays. * trans-array.c (gfc_conv_array_ref, gfc_array_init_size, gfc_conv_descriptor_cosize, gfc_array_allocate, gfc_trans_deferred_array): Ditto. * trans-expr.c (gfc_conv_variable) Ditto.: * trans-stmt.c (gfc_trans_deallocate): Ditto. * trans-types.c (gfc_get_element_type, gfc_get_array_type_bounds gfc_get_array_descr_info): Ditto. 2011-07-10 Tobias Burnus * gfortran.dg/coarray_14.f90: Remove dg-error "sorry not implemented". * gfortran.dg/coarray_7.f90: Ditto. * gfortran.dg/coarray/scalar_alloc_1.f90: New. * gfortran.dg/coarray/scalar_alloc_2.f90: New. diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 6db0836..3bf1e94 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4126,18 +4126,28 @@ gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest) bool +gfc_ref_this_image (gfc_ref *ref) +{ + int n; + + gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0); + + for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) + return false; + + return true; +} + + +bool gfc_is_coindexed (gfc_expr *e) { gfc_ref *ref; for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - { - int n; - for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) - if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) - return true; - } + return !gfc_ref_this_image (ref); return false; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 328dfbe..eb01b0e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2733,6 +2733,7 @@ void gfc_expr_replace_comp (gfc_expr *, gfc_component *); bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **); +bool gfc_ref_this_image (gfc_ref *ref); bool gfc_is_coindexed (gfc_expr *); int gfc_get_corank (gfc_expr *); bool gfc_has_ultimate_allocatable (gfc_expr *); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b51ae96..07104b8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6460,7 +6460,9 @@ resolve_deallocate_expr (gfc_expr *e) switch (ref->type) { case REF_ARRAY: - if (ref->u.ar.type != AR_FULL) + if (ref->u.ar.type != AR_FULL + && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0 + && ref->u.ar.codimen && gfc_ref_this_image (ref))) allocatable = 0; break; @@ -6983,13 +6985,6 @@ check_symbols: goto failure; } - if (codimension && ar->as->rank == 0) - { - gfc_error ("Sorry, allocatable scalar coarrays are not yet supported " - "at %L", &e->where); - goto failure; - } - success: return SUCCESS; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index f4f79f9..4ec892b 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2623,12 +2623,20 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, if (ar->dimen == 0) { gcc_assert (ar->codimen); - if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)) - && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE) - se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - /* Use the actual tree type and not the wrapped coarray. */ - se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), se->expr); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) + se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr)); + else + { + if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)) + && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE) + se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + + /* Use the actual tree type and not the wrapped coarray. */ + se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), + se->expr); + } + return; } @@ -4139,7 +4147,11 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank) overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0); stride = stride * size; } + for (n = rank; n < rank+corank; n++) + (Set lcobound/ucobound as above.) element_size = sizeof (array element); + if (!rank) + return element_size stride = (size_t) stride; overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0); stride = stride * element_size; @@ -4309,6 +4321,10 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); /* Convert to size_t. */ element_size = fold_convert (size_type_node, tmp); + + if (rank == 0) + return element_size; + stride = fold_convert (size_type_node, stride); /* First check for overflow. Since an array of type character can @@ -4370,18 +4386,18 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) { tree tmp; tree pointer; - tree offset; + tree offset = NULL_TREE; tree size; tree msg; - tree error; + tree error = NULL_TREE; tree overflow; /* Boolean storing whether size calculation overflows. */ - tree var_overflow; + tree var_overflow = NULL_TREE; tree cond; stmtblock_t elseblock; gfc_expr **lower; gfc_expr **upper; gfc_ref *ref, *prev_ref = NULL; - bool allocatable, coarray; + bool allocatable, coarray, dimension; ref = expr->ref; @@ -4401,20 +4417,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) { allocatable = expr->symtree->n.sym->attr.allocatable; coarray = expr->symtree->n.sym->attr.codimension; + dimension = expr->symtree->n.sym->attr.dimension; } else { allocatable = prev_ref->u.c.component->attr.allocatable; coarray = prev_ref->u.c.component->attr.codimension; + dimension = prev_ref->u.c.component->attr.dimension; } - /* Return if this is a scalar coarray. */ - if ((!prev_ref && !expr->symtree->n.sym->attr.dimension) - || (prev_ref && !prev_ref->u.c.component->attr.dimension)) - { - gcc_assert (coarray); - return false; - } + if (!dimension) + gcc_assert (coarray); /* Figure out the size of the array. */ switch (ref->u.ar.type) @@ -4449,16 +4462,20 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, &se->pre, &overflow); + if (dimension) + { - var_overflow = gfc_create_var (integer_type_node, "overflow"); - gfc_add_modify (&se->pre, var_overflow, overflow); + var_overflow = gfc_create_var (integer_type_node, "overflow"); + gfc_add_modify (&se->pre, var_overflow, overflow); - /* Generate the block of code handling overflow. */ - msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const + /* Generate the block of code handling overflow. */ + msg = gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const ("Integer overflow when calculating the amount of " "memory to allocate")); - error = build_call_expr_loc (input_location, - gfor_fndecl_runtime_error, 1, msg); + error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error, + 1, msg); + } if (pstat != NULL_TREE && !integer_zerop (pstat)) { @@ -4495,14 +4512,20 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) gfc_add_expr_to_block (&elseblock, tmp); - cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - var_overflow, integer_zero_node)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - error, gfc_finish_block (&elseblock)); + if (dimension) + { + cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, var_overflow, integer_zero_node)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + error, gfc_finish_block (&elseblock)); + } + else + tmp = gfc_finish_block (&elseblock); gfc_add_expr_to_block (&se->pre, tmp); - gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset); + if (dimension) + gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset); if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) && expr->ts.u.derived->attr.alloc_comp) @@ -7446,7 +7469,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) gfc_add_expr_to_block (&cleanup, tmp); } - if (sym->attr.allocatable && sym->attr.dimension + if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) && !sym->attr.save && !sym->attr.result) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7383265..55a0fc4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -691,8 +691,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) } else if (!sym->attr.value) { - /* Dereference non-character scalar dummy arguments. */ - if (sym->attr.dummy && !sym->attr.dimension) + /* Dereference non-character scalar dummy arguments. */ + if (sym->attr.dummy && !sym->attr.dimension + && !(sym->attr.codimension && sym->attr.allocatable)) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); @@ -711,7 +712,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) && (sym->attr.dummy || sym->attr.function || sym->attr.result - || !sym->attr.dimension)) + || (!sym->attr.dimension + && (!sym->attr.codimension || !sym->attr.allocatable)))) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 88fdcd1..5aa0ca9 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5104,7 +5104,7 @@ gfc_trans_deallocate (gfc_code *code) se.descriptor_only = 1; gfc_conv_expr (&se, expr); - if (expr->rank) + if (expr->rank || gfc_expr_attr (expr).codimension) { if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) { diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 6d384be..d7f1dd5 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1125,8 +1125,9 @@ gfc_get_element_type (tree type) gcc_assert (TREE_CODE (element) == POINTER_TYPE); element = TREE_TYPE (element); - gcc_assert (TREE_CODE (element) == ARRAY_TYPE); - element = TREE_TYPE (element); + /* For arrays, which are not scalar coarrays. */ + if (TREE_CODE (element) == ARRAY_TYPE) + element = TREE_TYPE (element); } return element; @@ -1770,6 +1771,16 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, /* TODO: known offsets for descriptors. */ GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE; + if (dimen == 0) + { + arraytype = build_pointer_type (etype); + if (restricted) + arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT); + + GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; + return fat_type; + } + /* We define data as an array with the correct size if possible. Much better than doing pointer arithmetic. */ if (stride) @@ -2835,8 +2846,11 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); gcc_assert (POINTER_TYPE_P (etype)); etype = TREE_TYPE (etype); - gcc_assert (TREE_CODE (etype) == ARRAY_TYPE); - etype = TREE_TYPE (etype); + + /* If the type is not a scalar coarray. */ + if (TREE_CODE (etype) == ARRAY_TYPE) + etype = TREE_TYPE (etype); + /* Can't handle variable sized elements yet. */ if (int_size_in_bytes (etype) <= 0) return false; diff --git a/gcc/testsuite/gfortran.dg/coarray_14.f90 b/gcc/testsuite/gfortran.dg/coarray_14.f90 index 3e3f046..49188d6 100644 --- a/gcc/testsuite/gfortran.dg/coarray_14.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_14.f90 @@ -49,7 +49,7 @@ type t end type t type(t), allocatable :: a[:] allocate (t :: a) ! { dg-error "Coarray specification required in ALLOCATE statement" } -allocate (t :: a[*]) ! { dg-error "allocatable scalar coarrays are not yet supported" } +allocate (t :: a[*]) ! OK end program myTest ! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_7.f90 b/gcc/testsuite/gfortran.dg/coarray_7.f90 index 29af0d1..abbd64d 100644 --- a/gcc/testsuite/gfortran.dg/coarray_7.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_7.f90 @@ -90,7 +90,7 @@ type(t), allocatable :: b(:)[:], C[:] allocate(b(1)) ! { dg-error "Coarray specification" } allocate(a[3]%a(5)) ! { dg-error "Coindexed allocatable" } -allocate(c[*]) ! { dg-error "Sorry" } +allocate(c[*]) ! OK allocate(a%a(5)) ! OK end subroutine alloc @@ -151,9 +151,9 @@ subroutine allocateTest() integer :: n, q n = 1 q = 1 - allocate(a[q,*]) ! { dg-error "Sorry" } - allocate(b[q,*]) ! { dg-error "Sorry" } - allocate(c[q,*]) ! { dg-error "Sorry" } + allocate(a[q,*]) ! OK + allocate(b[q,*]) ! OK + allocate(c[q,*]) ! OK end subroutine allocateTest --- /dev/null 2011-07-10 08:01:05.659884893 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 2011-07-10 20:22:18.000000000 +0200 @@ -0,0 +1,50 @@ +! { dg-do run } +! +implicit none +integer, allocatable :: A[:], B[:,:] +integer :: n1, n2, n3 + +if (allocated (a)) call abort () +if (allocated (b)) call abort () + +allocate(a[*]) +a = 5 + this_image () +if (a[this_image ()] /= 5 + this_image ()) call abort + +a[this_image ()] = 8 - 2*this_image () +if (a[this_image ()] /= 8 - 2*this_image ()) call abort + +if (lcobound(a, dim=1) /= 1 .or. ucobound(a,dim=1) /= num_images()) & + call abort () +deallocate(a) + +allocate(a[4:*]) +a[this_image ()] = 8 - 2*this_image () + +if (lcobound(a, dim=1) /= 4 .or. ucobound(a,dim=1) /= 3 + num_images()) & + call abort () + +n1 = -1 +n2 = 5 +n3 = 3 +allocate (B[n1:n2, n3:*]) +if (any (lcobound(b) /= [-1, 3]) .or. lcobound(B, dim=2) /= n3) & + call abort() +call sub(A, B) + +if (allocated (a)) call abort () +if (.not.allocated (b)) call abort () + +! automatically deallocate "B" +contains + subroutine sub(x, y) + integer, allocatable :: x[:], y[:,:] + + if (any (lcobound(y) /= [-1, 3]) .or. lcobound(y, dim=2) /= n3) & + call abort() + if (lcobound(x, dim=1) /= 4 .or. ucobound(x,dim=1) /= 3 + num_images()) & + call abort () + if (x[this_image ()] /= 8 - 2*this_image ()) call abort + deallocate(x) + end subroutine sub +end --- /dev/null 2011-07-10 08:01:05.659884893 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_2.f90 2011-07-10 20:18:11.000000000 +0200 @@ -0,0 +1,60 @@ +! { dg-do run } +! +! Check whether registering allocatable coarrays works +! +type position + real :: x, y, z +end type position + +integer, allocatable :: a[:] +type(position), allocatable :: p[:] + +allocate(a[*]) +a = 7 + +allocate(p[*]) +p%x = 11 +p%y = 13 +p%z = 15 + +if (a /= 7) call abort() +a = 88 +if (a /= 88) call abort() + +if (p%x /= 11) call abort() +p%x = 17 +if (p%x /= 17) call abort() + + block + integer, allocatable :: b[:] + + allocate(b[*]) + b = 8494 + + if (b /= 8494) call abort() + end block + +if (a /= 88) call abort() +call test () +end + +subroutine test() + type velocity + real :: x, y, z + end type velocity + + real, allocatable :: z[:] + type(velocity), allocatable :: v[:] + + allocate(z[*]) + z = sqrt(2.0) + + allocate(v[*]) + v%x = 21 + v%y = 23 + v%z = 25 + + if (z /= sqrt(2.0)) call abort() + if (v%x /= 21) call abort() + +end subroutine test --------------030803080401080901070805--