From patchwork Tue Sep 21 12:26:34 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 45213 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 291593857C7E for ; Tue, 21 Sep 2021 12:27:14 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa4.mentor.iphmx.com (esa4.mentor.iphmx.com [68.232.137.252]) by sourceware.org (Postfix) with ESMTPS id 22A213858C3A; Tue, 21 Sep 2021 12:26:44 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 22A213858C3A Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: Sy7Fpi0GtnkD6NJrkulhKLqLz9i4cQ/kG1XppAePjaVdv99AgPQW0EerCs1AXORApwe89gOl4E OA9jRvmto8lhdPYZMM4r7eNqj1986+QvWngmngl/lgd7WOJuFR06RHs1Cwrxxyx/UhGzpwiHwl 4S3IfeUbeKSmq4zhX0H59xDC4HRaKyQr6QC9N6tvuNwEm2KjgW54BLHqsVi0FsZVveNvSMzzL3 mNubuojV6aPjSwUK2mScy45fUmcKzBFwqmxe/oXy13CRs2L0WWv3Vb/cwX6HP52i/WK87JPTzU x7kByHTi6p24m1ugVP84jvAu X-IronPort-AV: E=Sophos;i="5.85,311,1624348800"; d="diff'?scan'208";a="66286762" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa4.mentor.iphmx.com with ESMTP; 21 Sep 2021 04:26:42 -0800 IronPort-SDR: GdM8SArMBrBuEfS6qxBqqDlXogvwFbx5kM9/C23FP7BYipd6KLjwYQol8p9gHi+cwqYEmdTeM4 8Hm1B5jO8DNlabwsf5OZZ1PLRZjkOvPnW6ykHXQR3inR95264SxyZOmOd4MOClQO+lNNWYzONX YlOGudKtE60nlb0aBdJGdMSJ6+yEl517eC08/XvcHexOo37pBeEgaajRXQt8FWXApFlCw49wFs agyXZZcfLKBF+owiKPaqzYU8rI5smpEEYgrecijytyTWHU63DhNXic1j/1Vx9HNKtoSwUO/pix 5To= To: gcc-patches , fortran , Thomas Koenig , Harald Anlauf , Paul Richard Thomas From: Tobias Burnus Subject: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070] Message-ID: <53d84639-36ea-15e0-fecc-359007294dc0@codesourcery.com> Date: Tue, 21 Sep 2021 14:26:34 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.14.0 MIME-Version: 1.0 Content-Language: en-US X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-05.mgc.mentorg.com (139.181.222.5) To svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) X-Spam-Status: No, score=-11.6 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_SHORT, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch requires the previously mentioned simple-loop-gen patch, which also still needs to be reviewed: https://gcc.gnu.org/pipermail/gcc-patches/2021-September/579576.html For the xfailed part of the new testcase, the updated array descriptor is needed, but I think leaving it as xfailed for now - and reviewing this patch first makes more sense. size(a,dim=i) of an array is simply: a.dim[i].ubound - a.dim[i].lbound + 1 except that the result is always >= 0, i.e. a(5:-10) has size 0. Assumed-size arrays like as(5, -3:*) can be passed to assumed-rank arrays – but, obviously, the upper bound is unknown. Without BIND(C), the standard is quiet how those get transported but: ubound(as,dim=2) == size(as,dim=2) == -1 However, for ..., allocatable :: c(:,:) allocate (c(5,-4:-1)) the size(c,dim=2) is surely 4 and not -1. Thus, when passing it to a subroutine foo(x) ..., allocatable :: x(..) it should also come out as size(x, dim=2) == 4. To make the distinction, the allocatable/pointer attribute of the dummy can be used – as an assumed-size array cannot be allocatable. That's what is used in trans-intrinsic.c/trans-array.c – and the main reason I started to generate inline code for the array size. (Given that it permits optimizations and is a trivial code, I also think that it makes sense in general.) But even when doing so, it still did not work properly as when calling call foo(d) the bounds where not always reset such that the caller could still receive ubound(d,dim=last_dim) == -1 - in the case it just happened to be -1, be it for a zero-sized array or because the lbounds just happend to be -1 or smaller. That's taken care of in trans-expr.c. OK for mainline? Tobias ----------------- Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955 Fortran: Fix assumed-size to assumed-rank passing [PR94070] This code inlines the size0 and size1 libgfortran calls, the former is still used by libgfortan itself (and by old code). Besides permitting more optimizations, it also permits to handle assumed-rank dummies better: If the dummy argument is a nonpointer/nonallocatable, an assumed-size actual arg is repesented by having ubound == -1 for the last dimension. However, for allocatable/pointers, this value can also exist. Hence, the dummy arg attr has to be honored. For that reason, when calling an assumed-rank procedure with nonpointer, nonallocatable dummy arguments, the bounds have to be updated to avoid the case ubound == -1 for the last dimension. PR fortran/94070 gcc/fortran/ChangeLog: * trans-array.c (gfc_tree_array_size): New function to find size inline (whole array or one dimension). (array_parameter_size): Use it, take stmt_block as arg. (gfc_conv_array_parameter): Update call. * trans-array.h (gfc_tree_array_size): Add prototype. * trans-expr.c (gfc_conv_procedure_call): Update bounds of pointer/allocatable actual args to nonallocatable/nonpointer dummies to be one based. * trans-intrinsic.c (gfc_conv_intrinsic_shape): Fix case for assumed rank with allocatable/pointer dummy. (gfc_conv_intrinsic_size): Update to use inline function. libgfortran/ChangeLog: * intrinsics/size.c (size0, size1): Comment that now not used by newer compiler code. libgomp/ChangeLog: * testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Update expected dg-note output. gcc/testsuite/ChangeLog: * gfortran.dg/c-interop/cf-out-descriptor-6.f90: Remove xfail. * gfortran.dg/c-interop/size.f90: Remove xfail. * gfortran.dg/intrinsic_size_3.f90: * gfortran.dg/transpose_optimization_2.f90: * gfortran.dg/assumed_rank_22.f90: New test. * gfortran.dg/assumed_rank_22_aux.c: New test. gcc/fortran/trans-array.c | 165 ++++++++++++++++---- gcc/fortran/trans-array.h | 2 + gcc/fortran/trans-expr.c | 43 +++++- gcc/fortran/trans-intrinsic.c | 119 ++++++--------- gcc/testsuite/gfortran.dg/assumed_rank_22.f90 | 167 +++++++++++++++++++++ gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c | 68 +++++++++ .../gfortran.dg/c-interop/cf-out-descriptor-6.f90 | 2 +- gcc/testsuite/gfortran.dg/c-interop/size.f90 | 2 +- gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 | 2 +- .../gfortran.dg/transpose_optimization_2.f90 | 2 +- libgfortran/intrinsics/size.c | 4 + .../libgomp.oacc-fortran/privatized-ref-2.f90 | 13 +- 12 files changed, 476 insertions(+), 113 deletions(-) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0d013defdbb..b8061f37772 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7901,31 +7901,143 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_cleanup_loop (&loop); } + +/* Calculate the array size (number of elements); if dim != NULL_TREE, + return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */ +tree +gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim) +{ + if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + { + gcc_assert (dim == NULL_TREE); + return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); + } + tree size, tmp, rank = NULL_TREE, cond = NULL_TREE; + symbol_attribute attr = gfc_expr_attr (expr); + gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); + if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) + || !dim) + { + if (expr->rank < 0) + rank = fold_convert (signed_char_type_node, + gfc_conv_descriptor_rank (desc)); + else + rank = build_int_cst (signed_char_type_node, expr->rank); + } + + if (dim || expr->rank == 1) + { + if (!dim) + dim = gfc_index_zero_node; + tree ubound = gfc_conv_descriptor_ubound_get (desc, dim); + tree lbound = gfc_conv_descriptor_lbound_get (desc, dim); + + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + /* if (!allocatable && !pointer && assumed rank) + size = (idx == rank && ubound[rank-1] == -1 ? -1 : size; + else + size = max (0, size); */ + size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + size, gfc_index_zero_node); + if (!attr.pointer && !attr.allocatable + && as && as->type == AS_ASSUMED_RANK) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, + rank, build_int_cst (signed_char_type_node, 1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + fold_convert (signed_char_type_node, dim), + tmp); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_ubound_get (desc, dim), + build_int_cst (gfc_array_index_type, -1)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + cond, tmp); + tmp = build_int_cst (gfc_array_index_type, -1); + size = build3_loc (input_location, COND_EXPR, gfc_array_index_type, + cond, tmp, size); + } + return size; + } + + /* size = 1. */ + size = gfc_create_var (gfc_array_index_type, "size"); + gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1)); + tree extent = gfc_create_var (gfc_array_index_type, "extent"); + + stmtblock_t cond_block, loop_body; + gfc_init_block (&cond_block); + gfc_init_block (&loop_body); + + /* Loop: for (i = 0; i < rank; ++i). */ + tree idx = gfc_create_var (signed_char_type_node, "idx"); + /* Loop body. */ + /* #if (assumed-rank + !allocatable && !pointer) + if (idx == rank - 1 && dim[idx].ubound == -1) + extent = -1; + else + #endif + extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1 + if (extent < 0) + extent = 0 + size *= extent. */ + cond = NULL_TREE; + if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, + rank, build_int_cst (signed_char_type_node, 1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + idx, tmp); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_ubound_get (desc, idx), + build_int_cst (gfc_array_index_type, -1)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + cond, tmp); + } + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, idx), + gfc_conv_descriptor_lbound_get (desc, idx)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + gfc_add_modify (&cond_block, extent, tmp); + tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + extent, gfc_index_zero_node); + tmp = build3_v (COND_EXPR, tmp, + fold_build2_loc (input_location, MODIFY_EXPR, + gfc_array_index_type, + extent, gfc_index_zero_node), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&cond_block, tmp); + tmp = gfc_finish_block (&cond_block); + if (cond) + tmp = build3_v (COND_EXPR, cond, + fold_build2_loc (input_location, MODIFY_EXPR, + gfc_array_index_type, extent, + build_int_cst (gfc_array_index_type, -1)), + tmp); + gfc_add_expr_to_block (&loop_body, tmp); + /* size *= extent. */ + gfc_add_modify (&loop_body, size, + fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, extent)); + /* Generate loop. */ + gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR, + build_int_cst (TREE_TYPE (idx), 1), + gfc_finish_block (&loop_body)); + return size; +} + /* Helper function for gfc_conv_array_parameter if array size needs to be computed. */ static void -array_parameter_size (tree desc, gfc_expr *expr, tree *size) +array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size) { tree elem; - if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); - else if (expr->rank > 1) - *size = build_call_expr_loc (input_location, - gfor_fndecl_size0, 1, - gfc_build_addr_expr (NULL, desc)); - else - { - tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node); - tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node); - - *size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - *size, gfc_index_one_node); - *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, - *size, gfc_index_zero_node); - } + *size = gfc_tree_array_size (block, desc, expr, NULL); elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, *size, fold_convert (gfc_array_index_type, elem)); @@ -8035,7 +8147,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, else se->expr = gfc_build_addr_expr (NULL_TREE, tmp); if (size) - array_parameter_size (tmp, expr, size); + array_parameter_size (&se->pre, tmp, expr, size); return; } @@ -8047,7 +8159,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, tmp = se->expr; } if (size) - array_parameter_size (tmp, expr, size); + array_parameter_size (&se->pre, tmp, expr, size); se->expr = gfc_conv_array_data (tmp); return; } @@ -8122,7 +8234,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION) se->string_length = expr->ts.u.cl->backend_decl; if (size) - array_parameter_size (se->expr, expr, size); + array_parameter_size (&se->pre, se->expr, expr, size); se->expr = gfc_conv_array_data (se->expr); return; } @@ -8132,7 +8244,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, /* Result of the enclosing function. */ gfc_conv_expr_descriptor (se, expr); if (size) - array_parameter_size (se->expr, expr, size); + array_parameter_size (&se->pre, se->expr, expr, size); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE @@ -8149,9 +8261,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, gfc_conv_expr_descriptor (se, expr); if (size) - array_parameter_size (build_fold_indirect_ref_loc (input_location, - se->expr), - expr, size); + array_parameter_size (&se->pre, + build_fold_indirect_ref_loc (input_location, + se->expr), + expr, size); } /* Deallocate the allocatable components of structures that are diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index e4d443d7118..85ff2161191 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -39,6 +39,8 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *); /* Generate entry and exit code for g77 calling convention arrays. */ void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *); +tree gfc_tree_array_size (stmtblock_t *, tree, gfc_expr *, tree); + tree gfc_full_array_size (stmtblock_t *, tree, int); tree gfc_duplicate_allocatable (tree, tree, tree, int, tree); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 4a81f4695d9..c3e44999047 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6450,6 +6450,29 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.force_tmp = 1; } + /* Special case for assumed-rank arrays: when passing an + argument to a nonallocatable/nonpointer dummy, the bounds have + to be reset as otherwise a last-dim ubound of -1 is + indistinguishable from an assumed-size array in the callee. */ + if (!sym->attr.is_bind_c && e && fsym && fsym->as + && fsym->as->type == AS_ASSUMED_RANK + && e->rank != -1 + && e->expr_type == EXPR_VARIABLE + && ((fsym->ts.type == BT_CLASS + && !CLASS_DATA (fsym)->attr.class_pointer + && !CLASS_DATA (fsym)->attr.allocatable) + || (fsym->ts.type != BT_CLASS + && !fsym->attr.pointer && !fsym->attr.allocatable))) + { + /* Change AR_FULL to a (:,:,:) ref to force bounds update. */ + gfc_ref *ref; + for (ref = e->ref; ref->next; ref = ref->next) + ; + if (ref->u.ar.type == AR_FULL + && ref->u.ar.as->type != AS_ASSUMED_SIZE) + ref->u.ar.type = AR_SECTION; + } + if (sym->attr.is_bind_c && e && (is_CFI_desc (fsym, NULL) || assumed_length_string)) /* Implement F2018, 18.3.6, list item (5), bullet point 2. */ @@ -6510,16 +6533,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym, sym->name, NULL); - /* Unallocated allocatable arrays and unassociated pointer arrays - need their dtype setting if they are argument associated with - assumed rank dummies, unless already assumed rank. */ + /* Special case for assumed-rank arrays. */ if (!sym->attr.is_bind_c && e && fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK && e->rank != -1) { - if (gfc_expr_attr (e).pointer + if ((gfc_expr_attr (e).pointer || gfc_expr_attr (e).allocatable) - set_dtype_for_unallocated (&parmse, e); + && ((fsym->ts.type == BT_CLASS + && (CLASS_DATA (fsym)->attr.class_pointer + || CLASS_DATA (fsym)->attr.allocatable)) + || (fsym->ts.type != BT_CLASS + && (fsym->attr.pointer || fsym->attr.allocatable)))) + { + /* Unallocated allocatable arrays and unassociated pointer + arrays need their dtype setting if they are argument + associated with assumed rank dummies. However, if the + dummy is nonallocate/nonpointer, the user may not + pass those. Hence, it can be skipped. */ + set_dtype_for_unallocated (&parmse, e); + } else if (e->expr_type == EXPR_VARIABLE && e->ref && e->ref->u.ar.type == AR_FULL diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 42a995be348..bca2b3f8726 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -6697,6 +6697,8 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr) gfc_expr *e; gfc_array_spec *as; gfc_ss *ss; + symbol_attribute attr; + tree result_desc = se->expr; /* Remove the KIND argument, if present. */ s = expr->value.function.actual; @@ -6707,17 +6709,25 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr) gfc_conv_intrinsic_funcall (se, expr); - as = gfc_get_full_arrayspec_from_expr (s->expr);; - ss = gfc_walk_expr (s->expr); - /* According to F2018 16.9.172, para 5, an assumed rank entity, argument associated with an assumed size array, has the ubound of the final dimension set to -1 and SHAPE must return this. */ - if (as && as->type == AS_ASSUMED_RANK - && se->expr && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)) - && ss && ss->info->type == GFC_SS_SECTION) + + as = gfc_get_full_arrayspec_from_expr (s->expr); + if (!as || as->type != AS_ASSUMED_RANK) + return; + attr = gfc_expr_attr (s->expr); + ss = gfc_walk_expr (s->expr); + if (attr.pointer || attr.allocatable + || !ss || ss->info->type != GFC_SS_SECTION) + return; + if (se->expr) + result_desc = se->expr; + if (POINTER_TYPE_P (TREE_TYPE (result_desc))) + result_desc = build_fold_indirect_ref_loc (input_location, result_desc); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (result_desc))) { - tree desc, rank, minus_one, cond, ubound, tmp; + tree rank, minus_one, cond, ubound, tmp; stmtblock_t block; gfc_se ase; @@ -6745,8 +6755,7 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr) /* Obtain the last element of the result from the library shape intrinsic and set it to -1 if that is the value of ubound. */ - desc = se->expr; - tmp = gfc_conv_array_data (desc); + tmp = gfc_conv_array_data (result_desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); tmp = gfc_build_array_ref (tmp, rank, NULL, NULL); @@ -6758,7 +6767,6 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr) build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, cond); } - } static void @@ -7968,8 +7976,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) gfc_actual_arglist *actual; tree arg1; tree type; - tree fncall0; - tree fncall1; + tree size; gfc_se argse; gfc_expr *e; gfc_symbol *sym = NULL; @@ -8046,37 +8053,31 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) /* For functions that return a class array conv_expr_descriptor is not able to get the descriptor right. Therefore this special case. */ gfc_conv_expr_reference (&argse, e); - argse.expr = gfc_build_addr_expr (NULL_TREE, - gfc_class_data_get (argse.expr)); + argse.expr = gfc_class_data_get (argse.expr); } else if (sym && sym->backend_decl) { gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl))); - argse.expr = sym->backend_decl; - argse.expr = gfc_build_addr_expr (NULL_TREE, - gfc_class_data_get (argse.expr)); + argse.expr = gfc_class_data_get (sym->backend_decl); } else - { - argse.want_pointer = 1; - gfc_conv_expr_descriptor (&argse, actual->expr); - } + gfc_conv_expr_descriptor (&argse, actual->expr); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - arg1 = gfc_evaluate_now (argse.expr, &se->pre); - - /* Build the call to size0. */ - fncall0 = build_call_expr_loc (input_location, - gfor_fndecl_size0, 1, arg1); + arg1 = argse.expr; actual = actual->next; - if (actual->expr) { + stmtblock_t block; + gfc_init_block (&block); gfc_init_se (&argse, NULL); gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&block, &argse.pre); + tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + argse.expr, gfc_index_one_node); + size = gfc_tree_array_size (&block, arg1, e, tmp); /* Unusually, for an intrinsic, size does not exclude an optional arg2, so we must test for it. */ @@ -8084,59 +8085,35 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) && actual->expr->symtree->n.sym->attr.dummy && actual->expr->symtree->n.sym->attr.optional) { - tree tmp; - /* Build the call to size1. */ - fncall1 = build_call_expr_loc (input_location, - gfor_fndecl_size1, 2, - arg1, argse.expr); - + tree cond; + stmtblock_t block2; + gfc_init_block (&block2); gfc_init_se (&argse, NULL); argse.want_pointer = 1; argse.data_not_needed = 1; gfc_conv_expr (&argse, actual->expr); gfc_add_block_to_block (&se->pre, &argse.pre); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - argse.expr, null_pointer_node); - tmp = gfc_evaluate_now (tmp, &se->pre); - se->expr = fold_build3_loc (input_location, COND_EXPR, - pvoid_type_node, tmp, fncall1, fncall0); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + argse.expr, null_pointer_node); + cond = gfc_evaluate_now (cond, &se->pre); + /* 'block2' contains the arg2 absent case, 'block' the arg2 present + case; size_var can be used in both blocks. */ + tree size_var = gfc_tree_array_size (&block2, arg1, e, NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (size_var), size_var, size); + gfc_add_expr_to_block (&block, tmp); + tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block), + gfc_finish_block (&block2)); + gfc_add_expr_to_block (&se->pre, tmp); + size = size_var; } else - { - se->expr = NULL_TREE; - argse.expr = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - argse.expr, gfc_index_one_node); - } - } - else if (expr->value.function.actual->expr->rank == 1) - { - argse.expr = gfc_index_zero_node; - se->expr = NULL_TREE; + gfc_add_block_to_block (&se->pre, &block); } else - se->expr = fncall0; - - if (se->expr == NULL_TREE) - { - tree ubound, lbound; - - arg1 = build_fold_indirect_ref_loc (input_location, - arg1); - ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr); - lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr); - se->expr = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - se->expr = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - se->expr, gfc_index_one_node); - se->expr = fold_build2_loc (input_location, MAX_EXPR, - gfc_array_index_type, se->expr, - gfc_index_zero_node); - } - + size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE); type = gfc_typenode_for_spec (&expr->ts); - se->expr = convert (type, se->expr); + se->expr = convert (type, size); } diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_22.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_22.f90 new file mode 100644 index 00000000000..d03569bf88c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_22.f90 @@ -0,0 +1,167 @@ +! { dg-do run } +! { dg-additional-sources assumed_rank_22_aux.c } +! +! FIXME: wrong extend in array descriptor, see C file. +! { dg-output "c_assumed - 40 - OK" { xfail *-*-* } } +! { dg-output "c_assumed - 100 - OK" { xfail *-*-* } } +! +! PR fortran/94070 +! +! Contributed by Tobias Burnus +! and José Rui Faustino de Sousa +! +program main + implicit none + integer :: A(5,4,2) + integer, allocatable :: B(:,:,:) + integer :: C(5,4,-2:-1) + + interface + subroutine c_assumed (x, num) bind(C) + integer :: x(..) + integer, value :: num + end subroutine + subroutine c_allocated (x) bind(C) + integer, allocatable :: x(..) + end subroutine + end interface + + allocate (B(-1:3,4,-1:-1)) + + call caller (a) ! num=0: assumed-size + call test (b, num=20) ! full array + call test (b(:,:,0:-1), num=40) ! zero-sized array + call test (c, num=60) + call test (c(:,:,:-1), num=80) ! full-size slice + call test (c(:,:,1:-1), num=100) !zero-size array + + call test_alloc(b) + + call c_assumed (b, num=20) + call c_assumed (b(:,:,0:-1), num=40) + call c_assumed (c, num=60) + call c_assumed (c(:,:,:-1), num=80) + call c_assumed (c(:,:,1:-1), num=100) + + call c_allocated (b) +contains + subroutine caller(y) + integer :: y(-1:3,4,*) + call test(y, num=0) + call c_assumed (y, num=0) + end + subroutine test (x, num) + integer :: x(..), num + + ! SIZE (x) + if (num == 0) then + if (size (x) /= -20) stop 1 + elseif (num == 20) then + if (size (x) /= 20) stop 21 + elseif (num == 40) then + if (size (x) /= 0) stop 41 + elseif (num == 60) then + if (size (x) /= 40) stop 61 + elseif (num == 80) then + if (size (x) /= 40) stop 81 + elseif (num == 100) then + if (size (x) /= 0) stop 101 + else + stop 99 ! Invalid num + endif + + ! SIZE (x, dim=...) + if (size (x, dim=1) /= 5) stop num + 2 + if (size (x, dim=2) /= 4) stop num + 3 + + if (num == 0) then + if (size (x, dim=3) /= -1) stop 4 + elseif (num == 20) then + if (size (x, dim=3) /= 1) stop 24 + elseif (num == 40) then + if (size (x, dim=3) /= 0) stop 44 + elseif (num == 60) then + if (size (x, dim=3) /= 2) stop 64 + elseif (num == 80) then + if (size (x, dim=3) /= 2) stop 84 + elseif (num == 100) then + if (size (x, dim=3) /= 0) stop 104 + endif + + ! SHAPE (x) + if (num == 0) then + if (any (shape (x) /= [5, 4, -1])) stop 5 + elseif (num == 20) then + if (any (shape (x) /= [5, 4, 1])) stop 25 + elseif (num == 40) then + if (any (shape (x) /= [5, 4, 0])) stop 45 + elseif (num == 60) then + if (any (shape (x) /= [5, 4, 2])) stop 65 + elseif (num == 80) then + if (any (shape (x) /= [5, 4, 2])) stop 85 + elseif (num == 100) then + if (any (shape (x) /= [5, 4, 0])) stop 105 + endif + + ! LBOUND (X) + if (any (lbound (x) /= [1, 1, 1])) stop num + 6 + + ! LBOUND (X, dim=...) + if (lbound (x, dim=1) /= 1) stop num + 7 + if (lbound (x, dim=2) /= 1) stop num + 8 + if (lbound (x, dim=3) /= 1) stop num + 9 + + ! UBOUND (X) + if (num == 0) then + if (any (ubound (x) /= [5, 4, -1])) stop 11 + elseif (num == 20) then + if (any (ubound (x) /= [5, 4, 1])) stop 31 + elseif (num == 40) then + if (any (ubound (x) /= [5, 4, 0])) stop 51 + elseif (num == 60) then + if (any (ubound (x) /= [5, 4, 2])) stop 71 + elseif (num == 80) then + if (any (ubound (x) /= [5, 4, 2])) stop 91 + elseif (num == 100) then + if (any (ubound (x) /= [5, 4, 0])) stop 111 + endif + + ! UBOUND (X, dim=...) + if (ubound (x, dim=1) /= 5) stop num + 12 + if (ubound (x, dim=2) /= 4) stop num + 13 + if (num == 0) then + if (ubound (x, dim=3) /= -1) stop 14 + elseif (num == 20) then + if (ubound (x, dim=3) /= 1) stop 34 + elseif (num == 40) then + if (ubound (x, dim=3) /= 0) stop 54 + elseif (num == 60) then + if (ubound (x, dim=3) /= 2) stop 74 + elseif (num == 80) then + if (ubound (x, dim=3) /= 2) stop 94 + elseif (num == 100) then + if (ubound (x, dim=3) /= 0) stop 114 + endif + end + + subroutine test_alloc (x) + integer, allocatable :: x(..) + + if (size (x) /= 20) stop 61 + if (size (x, dim=1) /= 5) stop 62 + if (size (x, dim=2) /= 4) stop 63 + if (size (x, dim=3) /= 1) stop 64 + + if (any (shape (x) /= [5, 4, 1])) stop 65 + + if (any (lbound (x) /= [-1, 1, -1])) stop 66 + if (lbound (x, dim=1) /= -1) stop 77 + if (lbound (x, dim=2) /= 1) stop 78 + if (lbound (x, dim=3) /= -1) stop 79 + + if (any (ubound (x) /= [3, 4, -1])) stop 80 + if (ubound (x, dim=1) /= 3) stop 92 + if (ubound (x, dim=2) /= 4) stop 93 + if (ubound (x, dim=3) /= -1) stop 94 + end +end diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c b/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c new file mode 100644 index 00000000000..2fbf83d649a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c @@ -0,0 +1,68 @@ +/* Called by assumed_rank_22.f90. */ + +#include +#include + +void +c_assumed (CFI_cdesc_t *x, int num) +{ + assert (num == 0 || num == 20 || num == 40 || num == 60 || num == 80 + || num == 100); + assert (x->elem_len == sizeof (int)); + assert (x->rank == 3); + assert (x->type == CFI_type_int32_t); + + assert (x->attribute == CFI_attribute_other); + assert (x->dim[0].lower_bound == 0); + assert (x->dim[1].lower_bound == 0); + assert (x->dim[2].lower_bound == 0); + assert (x->dim[0].extent == 5); + assert (x->dim[1].extent == 4); + if (num == 0) + assert (x->dim[2].extent == -1); + else if (num == 20) + assert (x->dim[2].extent == 1); + else if (num == 40) + { + /* FIXME: - dg-output = 'c_assumed ... OK' checked in .f90 file. */ + /* assert (x->dim[2].extent == 0); */ + if (x->dim[2].extent == 0) + __builtin_printf ("c_assumed - 40 - OK\n"); + else + __builtin_printf ("ERROR: c_assumed num=%d: " + "x->dim[2].extent = %d != 0\n", + num, x->dim[2].extent); + } + else if (num == 60) + assert (x->dim[2].extent == 2); + else if (num == 80) + assert (x->dim[2].extent == 2); + else if (num == 100) + { + /* FIXME: - dg-output = 'c_assumed ... OK' checked in .f90 file. */ + /* assert (x->dim[2].extent == 0); */ + if (x->dim[2].extent == 0) + __builtin_printf ("c_assumed - 100 - OK\n"); + else + __builtin_printf ("ERROR: c_assumed num=%d: " + "x->dim[2].extent = %d != 0\n", + num, x->dim[2].extent); + } + else + assert (0); +} + +void +c_allocated (CFI_cdesc_t *x) +{ + assert (x->elem_len == sizeof (int)); + assert (x->rank == 3); + assert (x->type == CFI_type_int32_t); + assert (x->attribute == CFI_attribute_allocatable); + assert (x->dim[0].lower_bound == -1); + assert (x->dim[1].lower_bound == 1); + assert (x->dim[2].lower_bound == -1); + assert (x->dim[0].extent == 5); + assert (x->dim[1].extent == 4); + assert (x->dim[2].extent == 1); +} diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90 index b1a8c53b3e8..bc19a71efa7 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90 @@ -1,5 +1,5 @@ ! Reported as pr94070. -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! { dg-additional-sources "cf-out-descriptor-6-c.c dump-descriptors.c" } ! { dg-additional-options "-g" } ! diff --git a/gcc/testsuite/gfortran.dg/c-interop/size.f90 b/gcc/testsuite/gfortran.dg/c-interop/size.f90 index 6c6699701bf..58b32b0d5e7 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/size.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/size.f90 @@ -1,5 +1,5 @@ ! Reported as pr94070. -! { dg-do run { xfail *-*-* } } +! { dg-do run } ! ! TS 29113 ! 6.4.2 SIZE diff --git a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 index 923cbc3473d..afdf9b34d4b 100644 --- a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 +++ b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 @@ -22,4 +22,4 @@ program bug stop end program bug -! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <\\(D.\[0-9\]+->dim.0..ubound - D.\[0-9\]+->dim.0..lbound\\) \\+ 1, 0>;" 1 "original" } } +! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <\\(a.dim.0..ubound - a.dim.0..lbound\\) \\+ 1, 0>;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 index c49cd421058..54271b12bfa 100644 --- a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 +++ b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 @@ -60,5 +60,5 @@ end ! ! The check below for temporaries gave 14 and 33 for "parm" and "atmp". ! -! { dg-final { scan-tree-dump-times "parm" 72 "original" } } +! { dg-final { scan-tree-dump-times "parm" 76 "original" } } ! { dg-final { scan-tree-dump-times "atmp" 13 "original" } } diff --git a/libgfortran/intrinsics/size.c b/libgfortran/intrinsics/size.c index e9d93861eff..f1a60ba7209 100644 --- a/libgfortran/intrinsics/size.c +++ b/libgfortran/intrinsics/size.c @@ -25,6 +25,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include "libgfortran.h" +/* Note: This function is only used internally in libgfortran and old FE code, + new code generates the code inline. */ index_type size0 (const array_t * array) { @@ -47,6 +49,8 @@ iexport(size0); extern index_type size1 (const array_t * array, index_type dim); export_proto(size1); +/* Note: This function it is unused in libgfortran itself and the FE no longer + call it; however, old code might still call it. */ index_type size1 (const array_t * array, index_type dim) { diff --git a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 index baaee02b82c..2ff60226109 100644 --- a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 +++ b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 @@ -71,17 +71,16 @@ contains ! { dg-note {variable 'offset\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute } ! { dg-note {variable 'S\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute } ! { dg-note {variable 'test\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute } - ! { dg-note {variable 'parm\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_compute$c_compute } - ! { dg-note {variable 'parm\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_compute$c_compute } - ! { dg-note {variable 'parm\.[0-9]+' adjusted for OpenACC privatization level: 'gang'} "" { target { ! { openacc_host_selected || openacc_nvidia_accel_selected } } } l_compute$c_compute } + ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute } ! { dg-note {variable 'A\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: static} "" { target *-*-* } l_compute$c_compute } array = [(-2*i, i = 1, size(array))] !$acc loop gang private(array) ! { dg-line l_loop[incr c_loop] } - ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop } - ! { dg-note {variable 'array\.[0-9]+' in 'private' clause is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_loop$c_loop } - ! { dg-note {variable 'array\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_loop$c_loop } - ! { dg-note {variable 'array\.[0-9]+' adjusted for OpenACC privatization level: 'gang'} "" { target { ! { openacc_host_selected || openacc_nvidia_accel_selected } } } l_loop$c_loop } + ! { dg-message {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop } + ! { dg-message {variable 'array\.[0-9]+' in 'private' clause is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_loop$c_loop } + ! { dg-message {variable 'array\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_loop$c_loop } + ! { dg-message {sorry, unimplemented: target cannot support alloca} PR65181 { target openacc_nvidia_accel_selected } l_loop$c_loop } + do i = 1, 10 array(i) = 9*i end do