* [Patch] Fortran/OpenMP: Fix optional dummy procedures [PR99171]
@ 2021-02-22 12:06 Tobias Burnus
2021-02-22 12:10 ` Jakub Jelinek
0 siblings, 1 reply; 2+ messages in thread
From: Tobias Burnus @ 2021-02-22 12:06 UTC (permalink / raw)
To: gcc-patches, fortran, Jakub Jelinek
[-- Attachment #1: Type: text/plain, Size: 621 bytes --]
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. – 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ünchen Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf
[-- Attachment #2: omp-dummy.diff --]
[-- Type: text/x-patch, Size: 12216 bytes --]
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
^ permalink raw reply [flat|nested] 2+ messages in thread
* Re: [Patch] Fortran/OpenMP: Fix optional dummy procedures [PR99171]
2021-02-22 12:06 [Patch] Fortran/OpenMP: Fix optional dummy procedures [PR99171] Tobias Burnus
@ 2021-02-22 12:10 ` Jakub Jelinek
0 siblings, 0 replies; 2+ messages in thread
From: Jakub Jelinek @ 2021-02-22 12:10 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc-patches, fortran
On Mon, Feb 22, 2021 at 01:06:56PM +0100, Tobias Burnus wrote:
> 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. – 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)?
Ok, thanks.
> 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(-)
Jakub
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2021-02-22 12:10 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-02-22 12:06 [Patch] Fortran/OpenMP: Fix optional dummy procedures [PR99171] Tobias Burnus
2021-02-22 12:10 ` Jakub Jelinek
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).