From patchwork Sun Jun 29 12:03:11 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 365366 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]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id CCEA1140078 for ; Sun, 29 Jun 2014 22:03:29 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=tsAlnpLCkKeKCul8aTQJO+FVQ0OPm5I3Ys1ybYNPUDvtz2 /H/n7JOQA9U2/zIknDA+nPsIPBO7Ju1AHAqggS/5/fYWHtYRj2Y98PK880WBgwQG IgxOWnJzEsVNg7nVHfmUTnr+5FDtAo6yCDsb1nn6LvjNeR2EDQ+GEuTBIgPTA= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=IU7S8VApV+bSLP2UPkVZ9cZzUmM=; b=cdazDJqkog2RQ0zZvK7d np0T/ksoMXls9mVLhRSJp5s1wW/kyQusrMjQQS6T/i7LbtxpAU5QWRkoYSqCfqGe kUf3XTM6EUf+LpC7a9bM6NB45Rp9L8ZOpH4Wvpg4cZkQhtiyx2oLqYgxcp//qwg9 4MjKIpbij4Sqb7OilHSLg6o= Received: (qmail 8998 invoked by alias); 29 Jun 2014 12:03:21 -0000 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 Received: (qmail 8966 invoked by uid 89); 29 Jun 2014 12:03:19 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.0 required=5.0 tests=AWL, BAYES_00 autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mx01.qsc.de Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Sun, 29 Jun 2014 12:03:15 +0000 Received: from tux.net-b.de (port-92-194-168-45.dynamic.qsc.de [92.194.168.45]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by mx01.qsc.de (Postfix) with ESMTPSA id 8C0AF3CBC9; Sun, 29 Jun 2014 14:03:11 +0200 (CEST) Message-ID: <53B0007F.9080908@net-b.de> Date: Sun, 29 Jun 2014 14:03:11 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:24.0) Gecko/20100101 Thunderbird/24.5.0 MIME-Version: 1.0 To: gcc-patches , gfortran Subject: [Patch, Fortran] Coarray fixes for select type/associate and type of derived components This patch fixes some issues with polymorphic coarrays. I still have to fix at least one issue. Fixed by the patch: a) The temporary pointer generated with SELECT TYPE has to be a coarray. That's fixed with the resolve.c patch. The comment is also bogus: The comment is correct – and gfortran correctly detects coindexed variables as selector. However, in the code in question, the selector is not coindexed but the variable in the coindexed section is. b) It doesn't make sense to try to initialize the temporary pointer of SELECT TYPE (or ASSOCIATE), thus we have to exclude it also in trans-decl.c c) As the temporary variable is internally a pointer, the assert in trans-array.c also has to accept a pointer – even though coarrays with token in the descriptor can only be allocatable. But for code like "a(1)[1])", "a(1)" is not longer a pointer – and one ends up having an akind of unknown. Instead of adding all kind of values, I simply removed the assert. d) In trans-intrinsic.c, one has a similar issue. We now avoid an ICE by checking whether the variable is set before accessing it. e) For caf(:)[i]%a, we had the dtype of the descriptor of "caf" instead of "...%a". That's now fixed. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias PS: Still to be done for coarrays: Nonallocatable polymorphic coarray dummies. For those, the offset and the token is passed as additional argument – but that's not yet correctly handled with ASSOCIATE/SELECT TYPE. Also to be done are more type-conversion checks (beyond those which are implicitly checked by this patch) – and the handling of vector subscripts. 2014-06-29 Tobias Burnus * resolve.c (resolve_assoc_var): Fix corank setting. * trans-array.c (gfc_conv_descriptor_token): Change assert. for select-type temporaries. * trans-decl.c (generate_coarray_sym_init): Skip for attr.select_type_temporary. * trans-expr.c (gfc_conv_procedure_call): Fix for select-type temporaries. * trans-intrinsic.c (get_caf_token_offset): Ditto. (gfc_conv_intrinsic_caf_get, gfc_conv_intrinsic_caf_send): Set the correct dtype. * trans-types.h (gfc_get_dtype_rank_type): New. * trans-types.c (gfc_get_dtype_rank_type): Ditto. 2014-06-29 Tobias Burnus * gfortran.dg/coarray/coindexed_3.f90: New. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index ca20c29..15d8dab 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7912,10 +7912,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) sym->as = gfc_get_array_spec (); sym->as->rank = target->rank; sym->as->type = AS_DEFERRED; - - /* Target must not be coindexed, thus the associate-variable - has no corank. */ - sym->as->corank = 0; + sym->as->corank = gfc_get_corank (target); } /* Mark this as an associate variable. */ diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 5558217..0e01899 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -298,7 +298,6 @@ gfc_conv_descriptor_token (tree desc) type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE); gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB); field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index cbcd52d..93c59b1 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4670,7 +4670,8 @@ generate_coarray_sym_init (gfc_symbol *sym) tree tmp, size, decl, token; if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension - || sym->attr.use_assoc || !sym->attr.referenced) + || sym->attr.use_assoc || !sym->attr.referenced + || sym->attr.select_type_temporary) return; decl = sym->backend_decl; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7ee0206..dba51b0 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4813,7 +4813,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, caf_type = TREE_TYPE (caf_decl); if (GFC_DESCRIPTOR_TYPE_P (caf_type) - && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE) + && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE + || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER)) tmp = gfc_conv_descriptor_token (caf_decl); else if (DECL_LANG_SPECIFIC (caf_decl) && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index a1dfdfb..5aa5683 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1179,7 +1179,8 @@ get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr, /* Offset between the coarray base address and the address wanted. */ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)) - && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE) + && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE + || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER)) *offset = build_int_cst (gfc_array_index_type, 0); else if (DECL_LANG_SPECIFIC (caf_decl) && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE) @@ -1285,7 +1286,10 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind) ar->type = AR_FULL; } gfc_conv_expr_descriptor (&argse, array_expr); - + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that + has the wrong type if component references are done. */ + gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr), + gfc_get_dtype_rank_type (array_expr->rank, type)); if (has_vector) { vec = conv_caf_vector_subscript (&argse.pre, argse.expr, ar); @@ -1387,7 +1391,12 @@ conv_caf_send (gfc_code *code) { } lhs_se.want_pointer = 1; gfc_conv_expr_descriptor (&lhs_se, lhs_expr); - lhs_type = gfc_get_element_type (TREE_TYPE (TREE_TYPE (lhs_se.expr))); + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that + has the wrong type if component references are done. */ + lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); + tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); + gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), + gfc_get_dtype_rank_type (lhs_expr->rank, lhs_type)); if (has_vector) { vec = conv_caf_vector_subscript (&block, lhs_se.expr, ar); @@ -1440,6 +1449,7 @@ conv_caf_send (gfc_code *code) { vector bounds separately. */ gfc_array_ref *ar, ar2; bool has_vector = false; + tree tmp2; if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr)) { @@ -1452,6 +1462,12 @@ conv_caf_send (gfc_code *code) { } rhs_se.want_pointer = 1; gfc_conv_expr_descriptor (&rhs_se, rhs_expr); + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that + has the wrong type if component references are done. */ + tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr); + tmp2 = gfc_typenode_for_spec (&rhs_expr->ts); + gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp), + gfc_get_dtype_rank_type (rhs_expr->rank, tmp2)); if (has_vector) { rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, ar); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index bb930f9..e55e2d9 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1395,23 +1395,13 @@ gfc_get_desc_dim_type (void) unknown cases abort. */ tree -gfc_get_dtype (tree type) +gfc_get_dtype_rank_type (int rank, tree etype) { tree size; int n; HOST_WIDE_INT i; tree tmp; tree dtype; - tree etype; - int rank; - - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); - - if (GFC_TYPE_ARRAY_DTYPE (type)) - return GFC_TYPE_ARRAY_DTYPE (type); - - rank = GFC_TYPE_ARRAY_RANK (type); - etype = gfc_get_element_type (type); switch (TREE_CODE (etype)) { @@ -1477,6 +1467,26 @@ gfc_get_dtype (tree type) /* TODO: Check this is actually true, particularly when repacking assumed size parameters. */ + return dtype; +} + + +tree +gfc_get_dtype (tree type) +{ + tree dtype; + tree etype; + int rank; + + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); + + if (GFC_TYPE_ARRAY_DTYPE (type)) + return GFC_TYPE_ARRAY_DTYPE (type); + + rank = GFC_TYPE_ARRAY_RANK (type); + etype = gfc_get_element_type (type); + dtype = gfc_get_dtype_rank_type (rank, etype); + GFC_TYPE_ARRAY_DTYPE (type) = dtype; return dtype; } diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 5ed87c0..bd3e69c 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -97,6 +97,7 @@ int gfc_return_by_reference (gfc_symbol *); int gfc_is_nodesc_array (gfc_symbol *); /* Return the DTYPE for an array. */ +tree gfc_get_dtype_rank_type (int, tree); tree gfc_get_dtype (tree); tree gfc_get_ppc_type (gfc_component *); diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90 new file mode 100644 index 0000000..46488f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! +! Contributed by Reinhold Bader +! + +program pmup + implicit none + type t + integer :: b, a + end type t + + CLASS(*), allocatable :: a(:)[:] + integer :: ii + + !! --- ONE --- + allocate(real :: a(3)[*]) + IF (this_image() == num_images()) THEN + SELECT TYPE (a) + TYPE IS (real) + a(:)[1] = 2.0 + END SELECT + END IF + SYNC ALL + + IF (this_image() == 1) THEN + SELECT TYPE (a) + TYPE IS (real) + IF (ALL(A(:)[1] == 2.0)) THEN + !WRITE(*,*) 'OK' + ELSE + WRITE(*,*) 'FAIL' + call abort() + END IF + TYPE IS (t) + ii = a(1)[1]%a + call abort() + CLASS IS (t) + ii = a(1)[1]%a + call abort() + END SELECT + END IF + + !! --- TWO --- + deallocate(a) + allocate(t :: a(3)[*]) + IF (this_image() == num_images()) THEN + SELECT TYPE (a) + TYPE IS (t) + a(:)[1]%a = 4.0 + END SELECT + END IF + SYNC ALL + + IF (this_image() == 1) THEN + SELECT TYPE (a) + TYPE IS (real) + ii = a(1)[1] + call abort() + TYPE IS (t) + IF (ALL(A(:)[1]%a == 4.0)) THEN + !WRITE(*,*) 'OK' + ELSE + WRITE(*,*) 'FAIL' + call abort() + END IF + CLASS IS (t) + ii = a(1)[1]%a + call abort() + END SELECT + END IF +end program