From patchwork Sat Dec 16 18:28:37 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 179915 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a05:7300:24d3:b0:fb:cd0c:d3e with SMTP id r19csp369516dyi; Sat, 16 Dec 2023 10:29:05 -0800 (PST) X-Google-Smtp-Source: AGHT+IH9In1Kn1As8us6iYkDZWF+O/BDRX+hvPb9TDmWnZ0f3rYVcU1RmVAhSVXW5nFgsU+E2EH3 X-Received: by 2002:a05:620a:2451:b0:77e:fba3:4f02 with SMTP id h17-20020a05620a245100b0077efba34f02mr16334252qkn.88.1702751344817; Sat, 16 Dec 2023 10:29:04 -0800 (PST) ARC-Seal: i=2; a=rsa-sha256; t=1702751344; cv=pass; d=google.com; s=arc-20160816; b=JL388st0Rrt2fkwBt6f9yHFKaWDCZLdeKcHHnpHTVbnPH6juSvEy6/bcHYjHVB3Ir2 K4EN/YBL/eG6u5Z4OGN7E1DrUUos3T6ni6bQyRVizqFqrjDhyY2u6TwhHCShdV5vCZwE HxpA5NvXn1ceZxwMdSnDh0HwsraYnd2+IbokP7/T5m9h9shBWPE6rN9ax1UxKTIcKE6l Up+UBYIDxMY4ATEiLGrCeSb9uMdOhGU1lMiWku1ePcBBCcZonIIK+RA7TqAdlVI0aTan 4auRsjREl6xfMVS15k9I5YYS1jS4ViV1eqkMA9oTuEtpwh/K51DIrirCgqF9pBfYr76l 38fg== ARC-Message-Signature: i=2; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=errors-to:list-subscribe:list-help:list-post:list-archive :list-unsubscribe:list-id:precedence:ui-outboundreport:sensitivity :importance:date:subject:to:from:message-id:mime-version :dkim-signature:arc-filter:dmarc-filter:delivered-to; bh=aABbMDp2mA2trvw2icFSBdkgOQEC4drBGDTG5l8DhiY=; fh=+IEfvAe+9BRgPHWhQEl2uIBTtAiiGDh1ExRZeB5JJoc=; b=oIZyiY5Q6l/Rz5Gujslj/miQ2lZ3zXaxK1i6kQqepkVq1n7lAyAvMWKN65V9TRPNxV t3oTs8XFDhpDKE6Aa79xUz8EhyPH6NNohyXuaUqIdbcNWjuEX0s936I1TnBG4iOw4yaq 7l6ASvKnY237mRC/sGbDYWZg2pgJ2f96d4oeei4/kGtq0B0ZKL/mkhsyLG694rkVaBfN uMUIH72w1nzUoAmbJI3/5H6C/ozIL6mpiG7ZX9SFlnJa8Y18YEenJqzscxHgQoaojduW 0QWs178RhNsJL34+99GMagz1dnydjAz4VK1H/rFEHkM4R+q8q8IdNldgsSyHqp7OO1hH MDeg== ARC-Authentication-Results: i=2; mx.google.com; dkim=pass header.i=@gmx.de header.s=s31663417 header.b=JnNFPpp3; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=QUARANTINE sp=QUARANTINE dis=NONE) header.from=gmx.de Received: from server2.sourceware.org (server2.sourceware.org. [2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id dt17-20020a05620a479100b007757fdc429dsi20183154qkb.340.2023.12.16.10.29.04 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 16 Dec 2023 10:29:04 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) client-ip=2620:52:3:1:0:246e:9693:128c; Authentication-Results: mx.google.com; dkim=pass header.i=@gmx.de header.s=s31663417 header.b=JnNFPpp3; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=QUARANTINE sp=QUARANTINE dis=NONE) header.from=gmx.de Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 8491E3858C3A for ; Sat, 16 Dec 2023 18:29:04 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mout.gmx.net (mout.gmx.net [212.227.15.19]) by sourceware.org (Postfix) with ESMTPS id 45DC23858D28; Sat, 16 Dec 2023 18:28:39 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 45DC23858D28 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmx.de ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 45DC23858D28 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=212.227.15.19 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1702751321; cv=none; b=SFCLrXkSaRFHfJSCr53mvM7I/7O76agjCp/xhbovvpfm6ElU3W+C6pTee0/ALqsH1RqbgbzNd6rLxeJf4ybFLnR7Ns8jSUwkQd3DCwXx2kc9Vv376iqikFXEW+qQnJc5Uw/7oUuxG4p0qi8UvpI3pVWkWlGKJM4716WXlZg3qXE= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1702751321; c=relaxed/simple; bh=LbzJVaKhubNN/kvztbDAG0di8fH+J/3vbsrLMcB++L4=; h=DKIM-Signature:MIME-Version:Message-ID:From:To:Subject:Date; b=o6ULD8V0M9xQAnK0g5RGV5K25rHlV8qbgNrFgVo+79caOI+sZg54aHd8EHVWsjlbHcwttRM2D4Eag0SF7W3+44bO0wetpXNHuP+4s79xFGyY7VLKc8sCWhjRasc7EkZUSK3uL1+hrigi4TRhJkDzAJtuuXewTuuNaZHWtuVL6R8= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1702751318; x=1703356118; i=anlauf@gmx.de; bh=LbzJVaKhubNN/kvztbDAG0di8fH+J/3vbsrLMcB++L4=; h=X-UI-Sender-Class:From:To:Subject:Date; b=JnNFPpp3fXFnncHe7+KdmyJnn3noEdDmoJaNjWwqw9Rc3Vm52wqnNW8sfEiRilMk kXx4JWnFWiOYuFYOxAZTljz1o6qUhBoclihJSD3tpNXLON4m7wYAlvYnbUkbtnxdW +YDZGW69Kga0PnbBQxFEHy1oRiyMlkmalTktoGw4ksoKwIP2q1YPGd3HHazNTTxgC 86CbE2N7X68Ku10BaeJsBhHq5EG1cAc2DE82zRglYYbWqjfeYTUe6qOBtn7Wo3lk6 p3wWEB9l8D7z+hPeMqG2VLVaesp9/88QCuBFZr0btbThnUBicWnCLBlUoYAl3zxWx WzqJMk7HqtOpy6R2dw== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.232.146.50] ([79.232.146.50]) by web-mail.gmx.net (3c-app-gmx-bs38.server.lan [172.19.170.90]) (via HTTP); Sat, 16 Dec 2023 19:28:37 +0100 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: fix argument passing to CONTIGUOUS,TARGET dummy [PR97592] Date: Sat, 16 Dec 2023 19:28:37 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:GL9oc9HfFK5/99wmmr992cgVfHlCsSYn61mYXnNAXBpHlLCMGN5n37Q3BsDhv+ZZgdn8V skH+/dvAAWflAnjPWMf9C3pOIcmZ/cPHSaPsGEjMaeXUcoR4sbP0N9aMz6j9Uwgg/K1D7PB8Il32 BEKYw/P4z3575398DOymfOeNGQNUGm4vbhF+weKjXGhgMEBM0NkG+ddOU7K+ljEqu3rHu4vOMNtk 0QZXXpwdYzSMNqE56oDFTUTOZIjw3wMEbBmlgsNsy+YBTc735wbHbv8o4pfNXx6ub1uMHz1vCGcU Y8= UI-OutboundReport: notjunk:1;M01:P0:TDM0Vq6KdM4=;5PL8EoZCXCLQVyLm193hgqzM0nl bpHQZW4GgdFnuVraDMBoZVyNkbez5vMP8T+zCIHefM8d268rmQbQPjDrTCTGDsIWuaPw2MUlt pGuRf32yiPH3NCC7f+BHG/IfKfMVIELo8c0CHaqCZIVS+IsIDj27M63/C7RqgmuqpLHj+SD2K Hi1DsJQqQs6xApHypn2SNv8MXkUUQlI9IysAnxSpCRfXY36HZ3WEE9d9CSg2F1Nbvs1HIoghT NCtzP0CwS97RuwVUx3Em+Y08nIeKCsBlYHcUsOdQ5875eoSNXhF+n5VKgH7e9p+1KtIP+DDDL yb+5VhAkn044KhxSNk5TRk9uNZMz2JAB8+I5fopU7u8uFgqdeNeUip/dkOwlcqOF/OuGw7KS2 Wvam3o/3X9cA0Pz+7kASHt9rk+7ksZcgrbYLDDD/p7iW4BhQQPAqDb0e8FlXoB1hwqmJca6f4 Yl6HYpuvf0ZzfPbuxdry0aenYWami9na6SCrQfWyS8lFQmoq9dp9x8oA1gJSWs3/MRPfX/z8E QEUF/gFKNLg45tEWbaQvdlVklmylxJd8GfzMGU5kA0UZ8X4tyLL68praV4PAlPD1VxsDID9Z3 lhaB7z50mJjzjzelOkoiFEE6leJSVgYEPP+uiZZnXLL3a03msUG/+gWoGDlQE5QTKocL3KaXx rrhlEDJ80CCF84jwmQkC+SWh5n+lsZJK+f8t4INZgORI5gnDrSY11Icqy0/1Aem4rJ3RPTAkA eFZES1Ix5Mxtk1fWNxZ7H0nbSWTHxeLldFckAScLWz+ZDU99aFjM+z9LjaeSGTF5VkJ+8FffA nk19mTLsoc9cdfvhzQ4mKaG+ypnWBkgXwBwVdNngi1R+I= X-Spam-Status: No, score=-12.0 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1785464194002889594 X-GMAIL-MSGID: 1785464194002889594 Dear all, the attached simple patch fixes a (9+) regression for passing to a CONTIGUOUS,TARGET dummy an *effective argument* that is contiguous, although the actual argument is not simply-contiguous (it is a pointer without the CONTIGOUS attribute in the PR). Since a previous attempt for a patch lead to regressions in gfortran.dg/bind-c-contiguous-3.f90, which is rather dense, I decided to enhance the current testcase with various combinations of actual and dummy arguments that allow to study whether a _gfortran_internal_pack is generated in places where we want to. (_gfortran_internal_pack does not create a temporary when no packing is needed). Regtested on x86_64-pc-linux-gnu. OK for mainline? I would like to backport this - after a grace period - to at least 13-branch. Any objections here? Thanks, Harald From d8765bd669e501781672c0bec976b2f5fd7acff6 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Sat, 16 Dec 2023 19:14:55 +0100 Subject: [PATCH] Fortran: fix argument passing to CONTIGUOUS,TARGET dummy [PR97592] gcc/fortran/ChangeLog: PR fortran/97592 * trans-expr.cc (gfc_conv_procedure_call): For a contiguous dummy with the TARGET attribute, the effective argument may still be contiguous even if the actual argument is not simply-contiguous. Allow packing to be decided at runtime by _gfortran_internal_pack. gcc/testsuite/ChangeLog: PR fortran/97592 * gfortran.dg/contiguous_15.f90: New test. --- gcc/fortran/trans-expr.cc | 4 +- gcc/testsuite/gfortran.dg/contiguous_15.f90 | 234 ++++++++++++++++++++ 2 files changed, 237 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/contiguous_15.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index f4185db5b7f..218fede6a82 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -7124,7 +7124,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, INTENT_IN, fsym->attr.pointer); } else if (fsym && fsym->attr.contiguous - && !gfc_is_simply_contiguous (e, false, true) + && (fsym->attr.target + ? gfc_is_not_contiguous (e) + : !gfc_is_simply_contiguous (e, false, true)) && gfc_expr_is_variable (e)) { gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, diff --git a/gcc/testsuite/gfortran.dg/contiguous_15.f90 b/gcc/testsuite/gfortran.dg/contiguous_15.f90 new file mode 100644 index 00000000000..424eb080fd1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/contiguous_15.f90 @@ -0,0 +1,234 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/97592 - fix argument passing to CONTIGUOUS,TARGET dummy +! +! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(&b_2d" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(&p1" 3 "original" } } +! +! N.B.: there is no reliable count of _gfortran_internal_pack on temporaries parm.* + +program pr97592 + implicit none + integer :: i, k + integer, target :: a(10) + integer, pointer :: p1(:), p2(:), tgt(:), expect(:) + integer, pointer, contiguous :: cp(:) + integer, allocatable, target :: b(:) + + !---------------------- + ! Code from original PR + !---------------------- + call RemappingTest () + + !--------------------- + ! Additional 1-d tests + !--------------------- + a = [(i, i=1,size(a))] + b = a + + ! Set p1 to an actually contiguous pointer + p1(13:) => a(3::2) + print *, lbound (p1), ubound (p1), is_contiguous (p1) + + ! non-contiguous pointer actual argument + expect => p1 + call chk_cont (p1) + + expect => p1 + call chk_tgt_cont (p1) + + expect => p1 + call chk_ptr (p1, p2) + if (any (p2 /= p1)) stop 1 + + expect => p1 + call chk_tgt (p1, p2) + if (any (p2 /= p1)) stop 2 + + ! non-contiguous target actual argument + expect => b(3::2) + call chk_tgt_cont (b(3::2)) + + expect => b(3::2) + call chk_tgt (b(3::2), p2) + if (any (p2 /= p1)) stop 3 + + expect => b(3::2) + call chk_ptr (b(3::2), p2) + if (any (p2 /= p1)) stop 4 + + ! Set p1 to an actually contiguous pointer + cp(17:) => a(3:9:1) + p1 => cp + print *, lbound (cp), ubound (cp), is_contiguous (cp) + print *, lbound (p1), ubound (p1), is_contiguous (p1) + + expect => p1 + call chk_tgt (p1, p2) + if (any (p2 /= cp)) stop 31 + + expect => cp + call chk_tgt (cp, p2) + if (any (p2 /= cp)) stop 32 + + expect => cp + call chk_tgt_cont (cp, p2) + if (any (p2 /= cp)) stop 33 + + expect => cp + call chk_tgt_expl (cp, p2, size (cp)) + if (any (p2 /= cp)) stop 34 + + ! See F2018:15.5.2.4 and F2018:C.10.4 + expect => p1 + call chk_tgt_cont (p1, p2) +! print *, p2 + if (any (p2 /= cp)) stop 35 + + expect => p1 + call chk_tgt_expl (p1, p2, size (p1)) + if (any (p2 /= cp)) stop 36 + + expect => cp + call chk_ptr_cont (cp, p2) + if (any (p2 /= cp)) stop 37 + + ! Pass array section which is actually contigous + k = 1 + expect => cp(::k) + call chk_ptr (cp(::k), p2) + if (any (p2 /= cp(::k))) stop 38 + + expect => p1(::k) + call chk_tgt_cont (p1(::k), p2) + if (any (p2 /= p1(::k))) stop 39 + + expect => p1(::k) + call chk_tgt (p1(::k), p2) + if (any (p2 /= p1(::k))) stop 40 + + expect => p1(::k) + call chk_tgt_expl (p1(::k), p2, size (p1(::k))) + if (any (p2 /= p1(::k))) stop 41 + + expect => b(3::k) + call chk_tgt_cont (b(3::k), p2) + if (any (p2 /= b(3::k))) stop 42 + + expect => b(3::k) + call chk_tgt (b(3::k), p2) + if (any (p2 /= b(3::k))) stop 43 + + expect => b(3::k) + call chk_tgt_expl (b(3::k), p2, size (b(3::k))) + if (any (p2 /= b(3::k))) stop 44 + + if (any (a /= [(i, i=1,size(a))])) stop 66 + if (any (a /= b)) stop 77 + deallocate (b) + +contains + ! Contiguous pointer dummy + subroutine chk_ptr_cont (x, y) + integer, contiguous, pointer, intent(in) :: x(:) + integer, pointer, optional :: y(:) + print *, lbound (x), ubound (x) + if (present (y)) y => x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 10 + if (any (x /= expect)) stop 11 + if (lbound(expect,1) /= 1 .and. & + lbound(expect,1) /= lbound (x,1)) stop 20 + end if + end + + ! Pointer dummy + subroutine chk_ptr (x, y) + integer, pointer, intent(in) :: x(:) + integer, pointer, optional :: y(:) + print *, lbound (x), ubound (x) + if (present (y)) y => x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 12 + if (any (x /= expect)) stop 13 + if (lbound(expect,1) /= 1 .and. & + lbound(expect,1) /= lbound (x,1)) stop 22 + end if + end + + ! Dummy with target attribute + subroutine chk_tgt_cont (x, y) + integer, contiguous, target, intent(in) :: x(:) + integer, pointer, optional :: y(:) + if (present (y)) y => x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 14 + if (any (x /= expect)) stop 15 + end if + end + + subroutine chk_tgt (x, y) + integer, target, intent(in) :: x(:) + integer, pointer, optional :: y(:) + if (present (y)) y => x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 16 + if (any (x /= expect)) stop 17 + end if + end + + ! Explicit-shape dummy with target attribute + subroutine chk_tgt_expl (x, y, n) + integer, intent(in) :: n + integer, target, intent(in) :: x(n) + integer, pointer, optional :: y(:) + if (present (y)) y => x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 18 + if (any (x /= expect)) stop 19 + end if + end + + ! Dummy without pointer or target attribute + subroutine chk_cont (x) + integer, contiguous, intent(in) :: x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 23 + if (any (x /= expect)) stop 24 + end if + end + + !------------------------------------------------------------------------ + + subroutine RemappingTest () + real, pointer :: B_2D(:,:) + real, pointer :: B_3D(:,:,:) => NULL() + integer, parameter :: n1=4, n2=4, n3=3 + !-- Prepare B_2D + allocate (B_2D(n1*n2, n3)) + B_2D = - huge (1.0) + if (.not. is_contiguous (B_2D)) stop 101 + !-- Point B_3D to Storage + call SetPointer (B_2D, n1, n2, n3, B_3D) + !print *,"is_contiguous (B_3D) =", is_contiguous (B_3D) + if (.not. is_contiguous (B_3D)) stop 102 + !-- Set B_3D + B_3D = 2.0 + !-- See if the result is reflected in Storage + if (any (B_2D /= 2.0)) then + print *, "B_2D = ", B_2D !-- expect 2.0 for all elements + stop 103 + end if + print *,"RemappingTest passed" + end + + subroutine SetPointer (C_2D, n1, n2, n3, C_3D) + integer, intent(in) :: n1, n2, n3 + real, target, contiguous :: C_2D(:,:) + real, pointer :: C_3D(:,:,:) + intent(in) :: C_2D + C_3D(1:n1,1:n2,1:n3) => C_2D + end + +end -- 2.35.3