From patchwork Fri Oct 14 21:18:15 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 58870 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 197D83860751 for ; Fri, 14 Oct 2022 21:18:46 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa3.mentor.iphmx.com (esa3.mentor.iphmx.com [68.232.137.180]) by sourceware.org (Postfix) with ESMTPS id 4CA093858D38; Fri, 14 Oct 2022 21:18:28 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 4CA093858D38 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com X-IronPort-AV: E=Sophos;i="5.95,185,1661846400"; d="diff'?scan'208";a="84614106" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa3.mentor.iphmx.com with ESMTP; 14 Oct 2022 13:18:26 -0800 IronPort-SDR: KVY0ZdPcqYhSPWUW/ABRHRQDxk51mfUPcjljofCZ7mEP1277xcFUuhXtt3f0w+82RrxxpJvl0u 6lKFKKBB3znmgYfPwT4UdR7acnUsiKwAfEUHM+eJ+PWDrXvREAwurLeQ0FZ4ySqgYLfNNAvB9o m/ggt7vqkwKrcahJP9s+C3rG8by5dBI1h83GrqUeDun29hQXTyhYN8Bqr1nRQkMOUkhl7fNBsW LXjzmBBYyFFVw/t3QRsObdpRv93XcCJf2tKXKezXYTDKcDxNXiyQibgwWFXYk+c/y7XxQyKAE/ HZE= Message-ID: Date: Fri, 14 Oct 2022 23:18:15 +0200 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:102.0) Gecko/20100101 Thunderbird/102.3.3 Content-Language: en-US To: gcc-patches , fortran From: Tobias Burnus Subject: [Patch] Fortran: Fixes for kind=4 characters strings [PR107266] X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-13.mgc.mentorg.com (139.181.222.13) To svr-ies-mbx-12.mgc.mentorg.com (139.181.222.12) X-Spam-Status: No, score=-11.4 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.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) 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" Long introduction - but the patch is rather simple: Don't use kind=1 as type where kind=4 should be used. Looooong introduction + background, feel free to skip. ---------------------------- This popped up for libgomp/testsuite/libgomp.fortran/struct-elem-map-1.f90 which uses kind=4 characters – if Sandra's "Fortran: delinearize multi-dimensional array accesses" patch is applied. Patch: https://gcc.gnu.org/pipermail/gcc-patches/2020-December/562230.html Used for OG11: https://gcc.gnu.org/pipermail/gcc-patches/2021-November/584716.html On the OG12 alias devel/omp/gcc-12 vendor branch, it is used: https://gcc.gnu.org/g:39a8c371fda6136cf77c74895a00b136409e0ba3 * * * For mainline, I did not observe a wrong-code issue at runtime, still: void frobc (character(kind=4)[1:*_a] * & restrict a, ... ... static void frobc (character(kind=1) * & restrict, ... feels odd, i.e. having the definition as kind=4 and the declaration as kind=1. With the patch, it becomes: static void frobc (character(kind=4) * & restrict, character(kind=4) * &, ... * * * For the following, questionable code (→ PR107266), it is even worse: character(kind=4) function f(x) bind(C) character(kind=4), value :: x end this gives the following, which has the wrong ABI: character(kind=1) f (character(kind=1) x) { (void) 0; } With the patch, it becomes: character(kind=4) f (character(kind=4) x) * * * I think that all only exercises the trans-type.cc patch; the trans-expr.cc code gets called – as an assert shows, but I fail to get a dump where this goes wrong. However, for struct-elem-map-1.f90 with mainline or with OG12 and the patch: #pragma omp target map(tofrom:var.uni2[40 / 20] [len: 20]) while on OG12 without the attached patch: #pragma omp target map(tofrom:var.uni2[40 / 5] [len: 5]) where the problem is that TYPE_SIZE_UNIT is wrong. Whether this only affects OG12 due to the delinearizer patch or some code on mainline as well, I don't know. Still, I think it should be fixed ... ---------------------------- 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: Fixes for kind=4 characters strings [PR107266] PR fortran/107266 gcc/fortran/ * trans-expr.cc (gfc_conv_string_parameter): Use passed type to honor character kind. * trans-types.cc (gfc_sym_type): Honor character kind. * trans-decl.cc (gfc_conv_cfi_to_gfc): Fix handling kind=4 character strings. gcc/testsuite/ * gfortran.dg/char4_decl.f90: New test. * gfortran.dg/char4_decl-2.f90: New test. gcc/fortran/trans-decl.cc | 10 ++--- gcc/fortran/trans-expr.cc | 12 +++--- gcc/fortran/trans-types.cc | 2 +- gcc/testsuite/gfortran.dg/char4_decl-2.f90 | 59 ++++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/char4_decl.f90 | 52 ++++++++++++++++++++++++++ 5 files changed, 123 insertions(+), 12 deletions(-) diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 5d16d640322..4b570c3551a 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -7378,13 +7378,13 @@ done: /* Set string length for len=:, only. */ if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length) { - tmp = sym->ts.u.cl->backend_decl; + tmp2 = gfc_get_cfi_desc_elem_len (cfi); + tmp = fold_convert (TREE_TYPE (tmp2), sym->ts.u.cl->backend_decl); if (sym->ts.kind != 1) tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - sym->ts.u.cl->backend_decl, tmp); - tmp2 = gfc_get_cfi_desc_elem_len (cfi); - gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp)); + TREE_TYPE (tmp2), tmp, + build_int_cst (TREE_TYPE (tmp2), sym->ts.kind)); + gfc_add_modify (&block, tmp2, tmp); } if (!sym->attr.dimension) diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 1551a2e4df4..e7b9211f17e 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -10374,15 +10374,15 @@ gfc_conv_string_parameter (gfc_se * se) || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) { + type = TREE_TYPE (se->expr); if (TREE_CODE (se->expr) != INDIRECT_REF) - { - type = TREE_TYPE (se->expr); - se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr); - } + se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr); else { - type = gfc_get_character_type_len (gfc_default_character_kind, - se->string_length); + if (TREE_CODE (type) == ARRAY_TYPE) + type = TREE_TYPE (type); + type = gfc_get_character_type_len_for_eltype (type, + se->string_length); type = build_pointer_type (type); se->expr = gfc_build_addr_expr (type, se->expr); } diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index c062a5b29d7..fdce56defec 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -2314,7 +2314,7 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c) && sym->ns->proc_name->attr.is_bind_c) || (sym->ts.deferred && (!sym->ts.u.cl || !sym->ts.u.cl->backend_decl)))) - type = gfc_character1_type_node; + type = gfc_get_char_type (sym->ts.kind); else type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension); diff --git a/gcc/testsuite/gfortran.dg/char4_decl-2.f90 b/gcc/testsuite/gfortran.dg/char4_decl-2.f90 new file mode 100644 index 00000000000..3eeadd64981 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char4_decl-2.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } + +! In this program shall be no kind=1, +! except for the 'argv' of the 'main' program. + +! PR fortran/107266 + +! { dg-final { scan-tree-dump-times "kind=1" 1 "original" } } +! { dg-final { scan-tree-dump-times "character\\(kind=1\\) \\* \\* argv\\)" 1 "original" } } + + +! { dg-final { scan-tree-dump-times "character\\(kind=4\\) f \\(character\\(kind=4\\) x\\)" 1 "original" } } + +character(kind=4) function f(x) bind(C) + character(kind=4), value :: x +end + +program testit + implicit none (type, external) + character (kind=4, len=:), allocatable :: aa + character (kind=4, len=:), pointer :: pp + + pp => NULL () + + call frobf (aa, pp) + if (.not. allocated (aa)) stop 101 + if (aa .ne. 4_'foo') stop 102 + if (.not. associated (pp)) stop 103 + if (pp .ne. 4_'bar') stop 104 + + pp => NULL () + + call frobc (aa, pp) + if (.not. allocated (aa)) stop 101 + if (aa .ne. 4_'frog') stop 102 + if (.not. associated (pp)) stop 103 + if (pp .ne. 4_'toad') stop 104 + + + contains + + subroutine frobf (a, p) Bind(C) + character (kind=4, len=:), allocatable :: a + character (kind=4, len=:), pointer :: p + allocate (character(kind=4, len=3) :: p) + a = 4_'foo' + p = 4_'bar' + end subroutine + + subroutine frobc (a, p) Bind(C) + character (kind=4, len=:), allocatable :: a + character (kind=4, len=:), pointer :: p + allocate (character(kind=4, len=4) :: p) + a = 4_'frog' + p = 4_'toad' + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/char4_decl.f90 b/gcc/testsuite/gfortran.dg/char4_decl.f90 new file mode 100644 index 00000000000..ab7b372d731 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char4_decl.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } + +! In this program shall be no kind=1, +! except for the 'argv' of the 'main' program. + +! Related PR fortran/107266 + +! { dg-final { scan-tree-dump-times "kind=1" 1 "original" } } +! { dg-final { scan-tree-dump-times "character\\(kind=1\\) \\* \\* argv\\)" 1 "original" } } + +program testit + implicit none (type, external) + character (kind=4, len=:), allocatable :: aa + character (kind=4, len=:), pointer :: pp + + pp => NULL () + + call frobf (aa, pp) + if (.not. allocated (aa)) stop 101 + if (aa .ne. 4_'foo') stop 102 + if (.not. associated (pp)) stop 103 + if (pp .ne. 4_'bar') stop 104 + + pp => NULL () + + call frobc (aa, pp) + if (.not. allocated (aa)) stop 101 + if (aa .ne. 4_'frog') stop 102 + if (.not. associated (pp)) stop 103 + if (pp .ne. 4_'toad') stop 104 + + + contains + + subroutine frobf (a, p) + character (kind=4, len=:), allocatable :: a + character (kind=4, len=:), pointer :: p + allocate (character(kind=4, len=3) :: p) + a = 4_'foo' + p = 4_'bar' + end subroutine + + subroutine frobc (a, p) + character (kind=4, len=:), allocatable :: a + character (kind=4, len=:), pointer :: p + allocate (character(kind=4, len=4) :: p) + a = 4_'frog' + p = 4_'toad' + end subroutine + +end program