From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from esa3.mentor.iphmx.com (esa3.mentor.iphmx.com [68.232.137.180]) by sourceware.org (Postfix) with ESMTPS id 33A693894430; Mon, 22 Feb 2021 12:07:04 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 33A693894430 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=mentor.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=Tobias_Burnus@mentor.com IronPort-SDR: XxC2HOdyfGpwaKPE/RjHm4kmCt7I2A20fTo26FABXtlbHyy6BQSAQ0bjlXgvXQFb1MYXtDvl3E ymx5Cdq6pWuLJ/XbESCwMEmpYK0Ul08yi0856bT6VEcg/mJejJ12KBMrdgSzIqDyLWwrsxbv9U iBbNMjdf2Ja3jUMkrNiUPWbmbV4GqHSdnupWaaBhIaCNYQM5u/xSnOGMHwvxfI6CoyGF31/Q4A edVmW73Z83OCZkRc8rcj6SAoAaYj8rkwU1p4ZjYje6ug1Q+9wc18PsAeYuFd9q1p/T7QGLH8ES 5YE= X-IronPort-AV: E=Sophos;i="5.81,197,1610438400"; d="diff'?scan'208";a="58351421" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa3.mentor.iphmx.com with ESMTP; 22 Feb 2021 04:07:02 -0800 IronPort-SDR: Nw1tLrtkY5JDU/L+PvLAz2KXtA2DaVFAFJHDhga39J9TgROWGyjV/MdJHielouvaBXJO63xoCy KS0xv+Q3rC/gvzaO1fC+EGzpU6obLk53Ro5xFN75KaZxPd2YKycWYBoxsq/zxtb5307QYNSgfV IA7/SumvCT7vLhefd6LTPeNlqCIez6ddDOSJQGShs9ZBZ5hN5AZCV/CAp9p2UJHtCF+svirlb9 eLLNSC22PqDsUYm15g6n807cyD+suaQXHGNMXvPTrBASCTYzmq+rq8JE+ORyV4ijZSLLpE5IQs SeM= To: gcc-patches , fortran , Jakub Jelinek From: Tobias Burnus Subject: [Patch] Fortran/OpenMP: Fix optional dummy procedures [PR99171] Message-ID: <1c1cee8a-e27b-05ec-be49-73cee8326af7@mentor.com> Date: Mon, 22 Feb 2021 13:06:56 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.7.1 MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="------------9AAD168974B4CAD9CE3D7B47" Content-Language: en-US X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) To svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) X-Spam-Status: No, score=-12.6 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: fortran@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Fortran mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Mon, 22 Feb 2021 12:07:06 -0000 --------------9AAD168974B4CAD9CE3D7B47 Content-Type: text/plain; charset="utf-8"; format=flowed Content-Transfer-Encoding: quoted-printable Normal dummy arguments get some additional redirection if they are OPTIONAL; however, that's not the case for dummy procedures. That was shown by a simple 'procedure(), optional :: proc' example in the PR. =E2=80=93 The fix is as simple. However, I thought it still makes sense to test all combinations of procedure pointer (incl. c_funptr) with optional and pointer... OK for mainline and GCC 10 (it is a 10/11 regression)? Tobias ----------------- Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 M=C3=BCnchen R= egistergericht M=C3=BCnchen HRB 106955, Gesch=C3=A4ftsf=C3=BChrer: Thomas H= eurung, Frank Th=C3=BCrauf --------------9AAD168974B4CAD9CE3D7B47 Content-Type: text/x-patch; charset="UTF-8"; name="omp-dummy.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="omp-dummy.diff" Fortran/OpenMP: Fix optional dummy procedures [PR99171] gcc/fortran/ChangeLog: PR fortran/99171 * trans-openmp.c (gfc_omp_is_optional_argument): Regard optional dummy procs as nonoptional as no special treatment is needed. libgomp/ChangeLog: PR fortran/99171 * testsuite/libgomp.fortran/dummy-procs-1.f90: New test. gcc/fortran/trans-openmp.c | 5 +- .../testsuite/libgomp.fortran/dummy-procs-1.f90 | 393 +++++++++++++++++++++ 2 files changed, 397 insertions(+), 1 deletion(-) diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 67e370f8b57..349df1cc346 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -64,7 +64,9 @@ gfc_omp_is_allocatable_or_ptr (const_tree decl) /* True if the argument is an optional argument; except that false is also returned for arguments with the value attribute (nonpointers) and for assumed-shape variables (decl is a local variable containing arg->data). - Note that pvoid_type_node is for 'type(c_ptr), value. */ + Note that for 'procedure(), optional' the value false is used as that's + always a pointer and no additional indirection is used. + Note that pvoid_type_node is for 'type(c_ptr), value' (and c_funloc). */ static bool gfc_omp_is_optional_argument (const_tree decl) @@ -73,6 +75,7 @@ gfc_omp_is_optional_argument (const_tree decl) && DECL_LANG_SPECIFIC (decl) && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) + && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) != FUNCTION_TYPE && GFC_DECL_OPTIONAL_ARGUMENT (decl)); } diff --git a/libgomp/testsuite/libgomp.fortran/dummy-procs-1.f90 b/libgomp/testsuite/libgomp.fortran/dummy-procs-1.f90 new file mode 100644 index 00000000000..fcb17ce69a9 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/dummy-procs-1.f90 @@ -0,0 +1,393 @@ +! { dg-do run } +! +! PR fortran/99171 +! +! Check dummy procedure arguments, especially optional ones +! +module m + use iso_c_binding + implicit none (type, external) + integer :: cnt + integer :: cnt2 +contains + subroutine proc() + cnt = cnt + 1 + end subroutine + + subroutine proc2() + cnt2 = cnt2 + 1 + end subroutine + + subroutine check(my_proc) + procedure(proc) :: my_proc + cnt = 42 + call my_proc() + if (cnt /= 43) stop 1 + + !$omp parallel + call my_proc() + !$omp end parallel + if (cnt <= 43) stop 2 + end + + subroutine check_opt(my_proc) + procedure(proc), optional :: my_proc + logical :: is_present + is_present = present(my_proc) + cnt = 55 + if (present (my_proc)) then + call my_proc() + if (cnt /= 56) stop 3 + endif + + !$omp parallel + if (is_present .neqv. present (my_proc)) stop 4 + if (present (my_proc)) then + call my_proc() + if (cnt <= 56) stop 5 + end if + !$omp end parallel + if (is_present) then + if (cnt <= 56) stop 6 + else if (cnt /= 55) then + stop 7 + end if + end + + subroutine check_ptr(my_proc) + procedure(proc), pointer :: my_proc + logical :: is_assoc + integer :: mycnt + is_assoc = associated (my_proc) + + cnt = 10 + cnt2 = 20 + if (associated (my_proc)) then + call my_proc() + if (cnt /= 11 .or. cnt2 /= 20) stop 8 + endif + + !$omp parallel + if (is_assoc .neqv. associated (my_proc)) stop 9 + if (associated (my_proc)) then + if (.not. associated (my_proc, proc)) stop 10 + call my_proc() + if (cnt <= 11 .or. cnt2 /= 20) stop 11 + else if (cnt /= 10 .or. cnt2 /= 20) then + stop 12 + end if + !$omp end parallel + if (is_assoc .neqv. associated (my_proc)) stop 13 + if (associated (my_proc)) then + if (cnt <= 11 .or. cnt2 /= 20) stop 14 + else if (is_assoc .and. (cnt /= 11 .or. cnt2 /= 20)) then + stop 15 + end if + + cnt = 30 + cnt2 = 40 + mycnt = 0 + !$omp parallel shared(mycnt) + !$omp critical + my_proc => proc2 + if (.not.associated (my_proc, proc2)) stop 17 + mycnt = mycnt + 1 + call my_proc() + if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 18 + !$omp end critical + !$omp end parallel + if (.not.associated (my_proc, proc2)) stop 19 + if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 20 + end + + subroutine check_ptr_opt(my_proc) + procedure(proc), pointer, optional :: my_proc + logical :: is_assoc, is_present + integer :: mycnt + is_assoc = .false. + is_present = present(my_proc) + + cnt = 10 + cnt2 = 20 + if (present (my_proc)) then + is_assoc = associated (my_proc) + if (associated (my_proc)) then + call my_proc() + if (cnt /= 11 .or. cnt2 /= 20) stop 21 + endif + end if + + !$omp parallel + if (is_present .neqv. present (my_proc)) stop 22 + if (present (my_proc)) then + if (is_assoc .neqv. associated (my_proc)) stop 23 + if (associated (my_proc)) then + if (.not. associated (my_proc, proc)) stop 24 + call my_proc() + if (cnt <= 11 .or. cnt2 /= 20) stop 25 + else if (cnt /= 10 .or. cnt2 /= 20) then + stop 26 + end if + end if + !$omp end parallel + if (present (my_proc)) then + if (is_assoc .neqv. associated (my_proc)) stop 27 + if (associated (my_proc)) then + if (cnt <= 11 .or. cnt2 /= 20) stop 28 + else if (is_assoc .and. (cnt /= 11 .or. cnt2 /= 20)) then + stop 29 + end if + end if + + cnt = 30 + cnt2 = 40 + mycnt = 0 + !$omp parallel shared(mycnt) + if (is_present .neqv. present (my_proc)) stop 30 + !$omp critical + if (present (my_proc)) then + my_proc => proc2 + if (.not.associated (my_proc, proc2)) stop 31 + mycnt = mycnt + 1 + call my_proc() + if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 32 + end if + !$omp end critical + !$omp end parallel + if (present (my_proc)) then + if (.not.associated (my_proc, proc2)) stop 33 + if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 34 + end if + end + + ! ---------------------- + + subroutine cfun_check(my_cfun) + type(c_funptr) :: my_cfun + procedure(proc), pointer :: pptr + logical :: has_cfun + + has_cfun = c_associated (my_cfun) + pptr => null() + cnt = 42 + call c_f_procpointer (my_cfun, pptr) + if (has_cfun) then + call pptr() + if (cnt /= 43) stop 35 + end if + + pptr => null() + !$omp parallel + if (has_cfun .neqv. c_associated (my_cfun)) stop 36 + !$omp critical + call c_f_procpointer (my_cfun, pptr) + !$omp end critical + if (has_cfun) then + call pptr() + if (cnt <= 43) stop 37 + else + if (associated (pptr)) stop 38 + end if + !$omp end parallel + end + + subroutine cfun_check_opt(my_cfun) + type(c_funptr), optional :: my_cfun + procedure(proc), pointer :: pptr + logical :: has_cfun, is_present + + has_cfun = .false. + is_present = present (my_cfun) + if (is_present) has_cfun = c_associated (my_cfun) + + cnt = 1 + pptr => null() + !$omp parallel + if (is_present .neqv. present (my_cfun)) stop 39 + if (is_present) then + if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 40 + !$omp critical + call c_f_procpointer (my_cfun, pptr) + !$omp end critical + if (has_cfun) then + call pptr() + if (cnt <= 1) stop 41 + else + if (associated (pptr)) stop 42 + end if + end if + !$omp end parallel + end + + subroutine cfun_check_ptr(my_cfun) + type(c_funptr), pointer :: my_cfun + procedure(proc), pointer :: pptr + logical :: has_cfun, is_assoc + + has_cfun = .false. + is_assoc = associated (my_cfun) + if (is_assoc) has_cfun = c_associated (my_cfun) + + cnt = 1 + pptr => null() + !$omp parallel + if (is_assoc .neqv. associated (my_cfun)) stop 43 + if (is_assoc) then + if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 44 + !$omp critical + call c_f_procpointer (my_cfun, pptr) + !$omp end critical + if (has_cfun) then + call pptr() + if (cnt <= 1) stop 45 + else + if (associated (pptr)) stop 46 + end if + end if + !$omp end parallel + + cnt = 42 + cnt2 = 1 + pptr => null() + !$omp parallel + if (is_assoc .neqv. associated (my_cfun)) stop 47 + if (is_assoc) then + !$omp critical + my_cfun = c_funloc (proc2) + call c_f_procpointer (my_cfun, pptr) + !$omp end critical + if (.not. associated (pptr, proc2)) stop 48 + if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 49 + call pptr() + if (cnt /= 42 .or. cnt2 <= 1) stop 50 + end if + !$omp end parallel + if (is_assoc) then + if (.not. associated (pptr, proc2)) stop 51 + if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 52 + else + if (associated (pptr)) stop 53 + end if + end + + subroutine cfun_check_ptr_opt (my_cfun) + type(c_funptr), pointer, optional :: my_cfun + procedure(proc), pointer :: pptr + logical :: is_present, has_cfun, is_assoc + + has_cfun = .false. + is_assoc = .false. + is_present = present (my_cfun) + if (is_present) then + is_assoc = associated (my_cfun) + if (is_assoc) has_cfun = c_associated (my_cfun) + end if + + cnt = 1 + pptr => null() + !$omp parallel + if (is_present .neqv. present (my_cfun)) stop 54 + if (is_present) then + if (is_assoc .neqv. associated (my_cfun)) stop 55 + if (is_assoc) then + if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 56 + !$omp critical + call c_f_procpointer (my_cfun, pptr) + !$omp end critical + if (has_cfun) then + call pptr() + if (cnt <= 1) stop 57 + else + if (associated (pptr)) stop 58 + end if + end if + end if + !$omp end parallel + + cnt = 42 + cnt2 = 1 + pptr => null() + !$omp parallel + if (is_present .neqv. present (my_cfun)) stop 59 + if (is_present) then + if (is_assoc .neqv. associated (my_cfun)) stop 60 + if (is_assoc) then + !$omp critical + my_cfun = c_funloc (proc2) + call c_f_procpointer (my_cfun, pptr) + !$omp end critical + if (.not. associated (pptr, proc2)) stop 61 + if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 62 + call pptr() + if (cnt /= 42 .or. cnt2 <= 1) stop 63 + end if + end if + !$omp end parallel + if (is_present .and. is_assoc) then + if (.not. associated (pptr, proc2)) stop 64 + if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 65 + else + if (associated (pptr)) stop 66 + end if + end +end module m + + + +program main + use m + implicit none (type, external) + procedure(proc), pointer :: pptr + type(c_funptr), target :: cfun + type(c_funptr), pointer :: cfun_ptr + + call check(proc) + call check_opt() + call check_opt(proc) + + pptr => null() + call check_ptr(pptr) + pptr => proc + call check_ptr(pptr) + + call check_ptr_opt() + pptr => null() + call check_ptr_opt(pptr) + pptr => proc + call check_ptr_opt(pptr) + + ! ------------------- + pptr => null() + + cfun = c_funloc (pptr) + call cfun_check(cfun) + + cfun = c_funloc (proc) + call cfun_check(cfun) + + call cfun_check_opt() + + cfun = c_funloc (pptr) + call cfun_check_opt(cfun) + + cfun = c_funloc (proc) + call cfun_check_opt(cfun) + + ! - - - - + cfun_ptr => null() + call cfun_check_ptr (cfun_ptr) + + cfun = c_funloc (proc) + cfun_ptr => cfun + call cfun_check_ptr (cfun_ptr) + + ! - - - - + call cfun_check_ptr_opt () + + cfun_ptr => null() + call cfun_check_ptr_opt (cfun_ptr) + + cfun = c_funloc (proc) + cfun_ptr => cfun + call cfun_check_ptr_opt (cfun_ptr) +end program --------------9AAD168974B4CAD9CE3D7B47--