Fortran: Update use_device_ptr for OpenMP 5.1 [PR105318]
OpenMP 5.1 added has_device_addr and relaxed the restrictions for
use_device_ptr, including processing non-type(c_ptr) arguments as
if has_device_addr was used. (There is a semantic difference.)
For completeness, the likewise change was done for 'use_device_ptr',
where non-type(c_ptr) arguments now use use_device_addr.
Finally, a warning for 'device(omp_{initial,invalid}_device)' was
silenced on the way as affecting the new testcase.
PR fortran/105318
gcc/fortran/ChangeLog:
* openmp.cc (resolve_omp_clauses): Update is_device_ptr restrictions
for OpenMP 5.1 and map to has_device_addr where applicable; map
use_device_ptr to use_device_addr where applicable.
Silence integer-range warning for device(omp_{initial,invalid}_device).
libgomp/ChangeLog:
* testsuite/libgomp.fortran/is_device_ptr-2.f90: New test.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/is_device_ptr-1.f90: Remove dg-error.
* gfortran.dg/gomp/is_device_ptr-2.f90: Likewise.
* gfortran.dg/gomp/is_device_ptr-3.f90: Update tree-scan-dump.
This commit is contained in:
Tobias Burnus
parent
9b8ffbb8a0
commit
10a1161049
5 changed files with 215 additions and 27 deletions
|
|
@ -6511,7 +6511,7 @@ static void
|
|||
resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
|
||||
gfc_namespace *ns, bool openacc = false)
|
||||
{
|
||||
gfc_omp_namelist *n;
|
||||
gfc_omp_namelist *n, *last;
|
||||
gfc_expr_list *el;
|
||||
int list;
|
||||
int ifc;
|
||||
|
|
@ -7369,30 +7369,58 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
|
|||
}
|
||||
break;
|
||||
case OMP_LIST_IS_DEVICE_PTR:
|
||||
for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
|
||||
last = NULL;
|
||||
for (n = omp_clauses->lists[list]; n != NULL; )
|
||||
{
|
||||
if (!n->sym->attr.dummy)
|
||||
gfc_error ("Non-dummy object %qs in %s clause at %L",
|
||||
n->sym->name, name, &n->where);
|
||||
if (n->sym->attr.allocatable
|
||||
|| (n->sym->ts.type == BT_CLASS
|
||||
&& CLASS_DATA (n->sym)->attr.allocatable))
|
||||
gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
|
||||
n->sym->name, name, &n->where);
|
||||
if (n->sym->attr.pointer
|
||||
|| (n->sym->ts.type == BT_CLASS
|
||||
&& CLASS_DATA (n->sym)->attr.pointer))
|
||||
gfc_error ("POINTER object %qs in %s clause at %L",
|
||||
n->sym->name, name, &n->where);
|
||||
if (n->sym->attr.value)
|
||||
gfc_error ("VALUE object %qs in %s clause at %L",
|
||||
n->sym->name, name, &n->where);
|
||||
if (n->sym->ts.type == BT_DERIVED
|
||||
&& n->sym->ts.u.derived->ts.is_iso_c
|
||||
&& code->op != EXEC_OMP_TARGET)
|
||||
/* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
|
||||
gfc_error ("List item %qs in %s clause at %L must be of "
|
||||
"TYPE(C_PTR)", n->sym->name, name, &n->where);
|
||||
else if (n->sym->ts.type != BT_DERIVED
|
||||
|| !n->sym->ts.u.derived->ts.is_iso_c)
|
||||
{
|
||||
/* For TARGET, non-C_PTR are deprecated and handled as
|
||||
has_device_addr. */
|
||||
gfc_omp_namelist *n2 = n;
|
||||
n = n->next;
|
||||
if (last)
|
||||
last->next = n;
|
||||
else
|
||||
omp_clauses->lists[list] = n;
|
||||
n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
|
||||
omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
|
||||
continue;
|
||||
}
|
||||
last = n;
|
||||
n = n->next;
|
||||
}
|
||||
break;
|
||||
case OMP_LIST_HAS_DEVICE_ADDR:
|
||||
case OMP_LIST_USE_DEVICE_PTR:
|
||||
case OMP_LIST_USE_DEVICE_ADDR:
|
||||
/* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */
|
||||
break;
|
||||
case OMP_LIST_USE_DEVICE_PTR:
|
||||
/* Non-C_PTR are deprecated and handled as use_device_ADDR. */
|
||||
last = NULL;
|
||||
for (n = omp_clauses->lists[list]; n != NULL; )
|
||||
{
|
||||
gfc_omp_namelist *n2 = n;
|
||||
if (n->sym->ts.type != BT_DERIVED
|
||||
|| !n->sym->ts.u.derived->ts.is_iso_c)
|
||||
{
|
||||
n = n->next;
|
||||
if (last)
|
||||
last->next = n;
|
||||
else
|
||||
omp_clauses->lists[list] = n;
|
||||
n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
|
||||
omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
|
||||
continue;
|
||||
}
|
||||
last = n;
|
||||
n = n->next;
|
||||
}
|
||||
break;
|
||||
default:
|
||||
for (; n != NULL; n = n->next)
|
||||
|
|
@ -7758,7 +7786,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
|
|||
&omp_clauses->num_teams_lower->where,
|
||||
&omp_clauses->num_teams_upper->where);
|
||||
if (omp_clauses->device)
|
||||
resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE");
|
||||
resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
|
||||
if (omp_clauses->filter)
|
||||
resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
|
||||
if (omp_clauses->hint)
|
||||
|
|
|
|||
|
|
@ -7,16 +7,16 @@ subroutine test(b,c,d)
|
|||
|
||||
integer, target :: a(5)
|
||||
|
||||
!$omp target is_device_ptr(a) ! { dg-error "Non-dummy object .a. in IS_DEVICE_PTR clause" }
|
||||
!$omp target is_device_ptr(a) ! Valid since OpenMP 5.1
|
||||
!$omp end target
|
||||
|
||||
!$omp target is_device_ptr(b) ! { dg-error "VALUE object .b. in IS_DEVICE_PTR clause" }
|
||||
!$omp target is_device_ptr(b) ! Valid since OpenMP 5.1
|
||||
!$omp end target
|
||||
|
||||
!$omp target is_device_ptr(c) ! { dg-error "POINTER object .c. in IS_DEVICE_PTR clause" }
|
||||
!$omp target is_device_ptr(c) ! Valid since OpenMP 5.1
|
||||
!$omp end target
|
||||
|
||||
!$omp target is_device_ptr(d) ! { dg-error "ALLOCATABLE object .d. in IS_DEVICE_PTR clause" }
|
||||
!$omp target is_device_ptr(d) ! Valid since OpenMP 5.1
|
||||
!$omp end target
|
||||
|
||||
!$omp target data map(a) use_device_addr(a) ! Should be okay
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ subroutine abc(cc)
|
|||
!$omp target enter data map(to: cc, dd)
|
||||
|
||||
!$omp target data use_device_addr(cc) use_device_ptr(dd)
|
||||
!$omp target is_device_ptr(cc, dd) ! { dg-error "Non-dummy object 'dd' in IS_DEVICE_PTR clause at" }
|
||||
!$omp target is_device_ptr(cc, dd) ! Valid since OpenMP 5.1
|
||||
if (cc /= 131 .or. dd /= 484) stop 1
|
||||
cc = 44
|
||||
dd = 45
|
||||
|
|
|
|||
|
|
@ -23,5 +23,6 @@ contains
|
|||
|
||||
end program main
|
||||
|
||||
! { dg-final { scan-tree-dump "is_device_ptr\\(a\\)" "gimple" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(a\\)" "gimple" } }
|
||||
! { dg-final { scan-tree-dump-not "has_device_addr\\(b\\)" "gimple" } }
|
||||
! { dg-final { scan-tree-dump-not "is_device_ptr\\(b\\)" "gimple" } }
|
||||
|
|
|
|||
159
libgomp/testsuite/libgomp.fortran/is_device_ptr-2.f90
Normal file
159
libgomp/testsuite/libgomp.fortran/is_device_ptr-2.f90
Normal file
|
|
@ -0,0 +1,159 @@
|
|||
! { dg-additional-options "-fdump-tree-original" }
|
||||
!
|
||||
! Since OpenMP 5.1, non-TYPE(c_ptr) arguments to is_device_ptr
|
||||
! map to has_device_ptr - check this!
|
||||
!
|
||||
! PR fortran/105318
|
||||
!
|
||||
module m
|
||||
use iso_c_binding, only: c_ptr, c_loc, c_f_pointer, c_associated
|
||||
implicit none (type, external)
|
||||
contains
|
||||
subroutine one (as, ar, asp, arp, asa, ara, cptr_a)
|
||||
integer, target :: AS, AR(5)
|
||||
integer, pointer :: ASP, ARP(:)
|
||||
integer, allocatable :: ASA, ARA(:)
|
||||
|
||||
type(c_ptr) :: cptr_a
|
||||
|
||||
!$omp target is_device_ptr(as, ar, asp, arp, asa, ara, cptr_a)
|
||||
if (.not. c_associated (cptr_a, c_loc(as))) stop 18
|
||||
if (as /= 5) stop 19
|
||||
if (any (ar /= [1,2,3,4,5])) stop 20
|
||||
if (asp /= 9) stop 21
|
||||
if (any (arp /= [2,4,6])) stop 22
|
||||
!$omp end target
|
||||
end
|
||||
|
||||
subroutine two (cptr_v)
|
||||
type(c_ptr), value :: cptr_v
|
||||
integer, pointer :: xx
|
||||
|
||||
xx => null()
|
||||
!$omp target is_device_ptr(cptr_v)
|
||||
if (.not. c_associated (cptr_v)) stop 23
|
||||
call c_f_pointer (cptr_v, xx)
|
||||
if (xx /= 5) stop 24
|
||||
xx => null()
|
||||
!$omp end target
|
||||
end
|
||||
|
||||
subroutine three (os, or, osp, orp, osa, ora, cptr_o)
|
||||
integer, optional, target :: OS, OR(5)
|
||||
integer, optional, pointer :: OSP, ORP(:)
|
||||
integer, optional, allocatable :: OSA, ORA(:)
|
||||
|
||||
type(c_ptr) :: cptr_o
|
||||
|
||||
!$omp target is_device_ptr(os, or, osp, orp, osa, ora, cptr_o)
|
||||
if (.not. c_associated (cptr_o, c_loc(os))) stop 25
|
||||
if (os /= 5) stop 26
|
||||
if (any (or /= [1,2,3,4,5])) stop 27
|
||||
if (osp /= 9) stop 28
|
||||
if (any (orp /= [2,4,6])) stop 29
|
||||
!$omp end target
|
||||
end
|
||||
|
||||
subroutine four(NVS, NVSO)
|
||||
use omp_lib, only: omp_initial_device, omp_invalid_device
|
||||
integer, value :: NVS
|
||||
integer, optional, value :: NVSO
|
||||
integer :: NS, NR(5)
|
||||
logical, volatile :: false_
|
||||
|
||||
false_ = .false.
|
||||
|
||||
!$omp target is_device_ptr (NS, NR, NVS, NVSO) device(omp_initial_device)
|
||||
NVS = 5
|
||||
NVSO = 5
|
||||
NS = 5
|
||||
NR(1) = 7
|
||||
!$omp end target
|
||||
|
||||
if (false_) then
|
||||
!$omp target device(omp_invalid_device)
|
||||
!$omp end target
|
||||
end if
|
||||
end subroutine
|
||||
|
||||
end module m
|
||||
|
||||
program main
|
||||
use iso_c_binding, only: c_ptr, c_loc, c_f_pointer, c_associated
|
||||
use m
|
||||
implicit none (type, external)
|
||||
|
||||
integer, target :: IS, IR(5)
|
||||
integer, pointer :: ISP, IRP(:)
|
||||
integer, allocatable :: ISA, IRA(:)
|
||||
integer :: xxx, xxxx
|
||||
|
||||
type(c_ptr) :: cptr_i
|
||||
|
||||
is = 5
|
||||
ir = [1,2,3,4,5]
|
||||
allocate(ISP, source=9)
|
||||
allocate(IRP, source=[2,4,6])
|
||||
|
||||
!$omp target data map(is, ir, isp, irp, isa, ira) &
|
||||
!$omp& use_device_ptr(is, ir, isp, irp, isa, ira)
|
||||
|
||||
cptr_i = c_loc(is)
|
||||
!$omp target is_device_ptr(is, ir, isp, irp, isa, ira, cptr_i)
|
||||
if (.not. c_associated (cptr_i, c_loc(is))) stop 30
|
||||
if (is /= 5) stop 31
|
||||
if (any (ir /= [1,2,3,4,5])) stop 32
|
||||
if (isp /= 9) stop 33
|
||||
if (any (irp /= [2,4,6])) stop 34
|
||||
!$omp end target
|
||||
|
||||
call one (is, ir, isp, irp, isa, ira, cptr_i)
|
||||
call two (cptr_i)
|
||||
call three (is, ir, isp, irp, isa, ira, cptr_i)
|
||||
|
||||
!$omp end target data
|
||||
|
||||
call four(xxx, xxxx)
|
||||
end
|
||||
|
||||
! { dg-final { scan-tree-dump-not "use_device_ptr" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(ira\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(isa\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(irp\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(isp\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(ir\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(is\\)" "original" } }
|
||||
|
||||
! { dg-final { scan-tree-dump-not "use_device_addr\\(cptr" "original" } }
|
||||
! { dg-final { scan-tree-dump-not "use_device_ptr\\(o" "original" } }
|
||||
! { dg-final { scan-tree-dump-not "use_device_ptr\\(a" "original" } }
|
||||
! { dg-final { scan-tree-dump-not "use_device_ptr\\(i" "original" } }
|
||||
|
||||
! { dg-final { scan-tree-dump "is_device_ptr\\(cptr_o\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(ora\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(osa\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(orp\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(osp\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(or\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(os\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "is_device_ptr\\(cptr_v\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "is_device_ptr\\(cptr_a\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(ara\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(asa\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(arp\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(asp\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(ar\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(as\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(is\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(ir\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(isp\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(irp\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(isa\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "use_device_addr\\(ira\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "is_device_ptr\\(cptr_i\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(ira\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(isa\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(irp\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(isp\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(ir\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "has_device_addr\\(is\\)" "original" } }
|
||||
Loading…
Add table
Reference in a new issue