FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran polymorphic class-type support for OpenACC

Browse source 
gcc/fortran/
	* openmp.c (resolve_oacc_data_clauses): Don't disallow allocatable
	polymorphic types for OpenACC.
	* trans-openmp.c (gfc_trans_omp_clauses): Support polymorphic class
	types.

	libgomp/
	* testsuite/libgomp.oacc-fortran/class-ptr-param.f95: New test.
	* testsuite/libgomp.oacc-fortran/classtypes-1.f95: New test.
	* testsuite/libgomp.oacc-fortran/classtypes-2.f95: New test.

From-SVN: r279631
This commit is contained in:
Julian Brown 2019-12-20 01:39:49 +00:00 • committed by Julian Brown
parent 02817027ca
commit 9be3ac5d63
7 changed files with 257 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View file

@ -1,3 +1,10 @@
2019-12-19 Julian Brown <julian@codesourcery.com>
* openmp.c (resolve_oacc_data_clauses): Don't disallow allocatable
polymorphic types for OpenACC.
* trans-openmp.c (gfc_trans_omp_clauses): Support polymorphic class
types.
2019-12-19 Julian Brown <julian@codesourcery.com>
* gfortran.h (gfc_omp_map_op): Add OMP_MAP_ATTACH, OMP_MAP_DETACH.

6
gcc/fortran/openmp.c
View file

@ -3929,12 +3929,6 @@ check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
static void
resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
{
if ((sym->ts.type == BT_ASSUMED && sym->attr.allocatable)
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& CLASS_DATA (sym)->attr.allocatable))
gfc_error ("ALLOCATABLE object %qs of polymorphic type "
"in %s clause at %L", sym->name, name, &loc);
check_symbol_not_pointer (sym, loc, name);
check_array_not_assumed (sym, loc, name);
}

69
gcc/fortran/trans-openmp.c
View file

@ -2471,14 +2471,42 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
tree present = (gfc_omp_is_optional_argument (decl)
? gfc_omp_check_optional_argument (decl, true)
: NULL_TREE);
if (POINTER_TYPE_P (TREE_TYPE (decl))
&& (gfc_omp_privatize_by_reference (decl)
|| GFC_DECL_GET_SCALAR_POINTER (decl)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
|| GFC_DECL_CRAY_POINTEE (decl)
|| GFC_DESCRIPTOR_TYPE_P
(TREE_TYPE (TREE_TYPE (decl)))
|| n->sym->ts.type == BT_DERIVED))
if (n->sym->ts.type == BT_CLASS)
{
tree type = TREE_TYPE (decl);
if (n->sym->attr.optional)
sorry ("optional class parameter");
if (POINTER_TYPE_P (type))
{
node4 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
OMP_CLAUSE_DECL (node4) = decl;
OMP_CLAUSE_SIZE (node4) = size_int (0);
decl = build_fold_indirect_ref (decl);
}
tree ptr = gfc_class_data_get (decl);
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (node) = ptr;
OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl);
node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
OMP_CLAUSE_DECL (node2) = decl;
OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH_DETACH);
OMP_CLAUSE_DECL (node3) = gfc_class_data_get (decl);
OMP_CLAUSE_SIZE (node3) = size_int (0);
goto finalize_map_clause;
}
else if (POINTER_TYPE_P (TREE_TYPE (decl))
&& (gfc_omp_privatize_by_reference (decl)
|| GFC_DECL_GET_SCALAR_POINTER (decl)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
|| GFC_DECL_CRAY_POINTEE (decl)
|| GFC_DESCRIPTOR_TYPE_P
(TREE_TYPE (TREE_TYPE (decl)))
|| n->sym->ts.type == BT_DERIVED))
{
tree orig_decl = decl;
node4 = build_omp_clause (input_location,
@ -2645,11 +2673,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
symbol_attribute sym_attr;
sym_attr = lastcomp->u.c.component->attr;
if (lastcomp->u.c.component->ts.type == BT_CLASS)
sym_attr = CLASS_DATA (lastcomp->u.c.component)->attr;
else
sym_attr = lastcomp->u.c.component->attr;
gfc_init_se (&se, NULL);
if (!sym_attr.dimension
&& lastcomp->u.c.component->ts.type != BT_CLASS
&& lastcomp->u.c.component->ts.type != BT_DERIVED)
{
/* Last component is a scalar. */
@ -2679,13 +2711,24 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
tree inner = se.expr;
/* Last component is a derived type. */
if (lastcomp->u.c.component->ts.type == BT_DERIVED)
/* Last component is a derived type or class pointer. */
if (lastcomp->u.c.component->ts.type == BT_DERIVED
|| lastcomp->u.c.component->ts.type == BT_CLASS)
{
if (sym_attr.allocatable || sym_attr.pointer)
{
tree data = inner;
tree size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
tree data, size;
if (lastcomp->u.c.component->ts.type == BT_CLASS)
{
data = gfc_class_data_get (inner);
size = gfc_class_vtab_size_get (inner);
}
else /* BT_DERIVED. */
{
data = inner;
size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
}
OMP_CLAUSE_DECL (node)
= build_fold_indirect_ref (data);

6
libgomp/ChangeLog
View file

@ -1,3 +1,9 @@
2019-12-19 Julian Brown <julian@codesourcery.com>
* testsuite/libgomp.oacc-fortran/class-ptr-param.f95: New test.
* testsuite/libgomp.oacc-fortran/classtypes-1.f95: New test.
* testsuite/libgomp.oacc-fortran/classtypes-2.f95: New test.
2019-12-19 Julian Brown <julian@codesourcery.com>
Cesar Philippidis <cesar@codesourcery.com>

34
libgomp/testsuite/libgomp.oacc-fortran/class-ptr-param.f95 Normal file
View file

@ -0,0 +1,34 @@
! { dg-do run }
module typemod
type mytype
integer :: a
end type mytype
contains
subroutine mysub(c)
implicit none
class(mytype), allocatable :: c
!$acc parallel copy(c)
c%a = 5
!$acc end parallel
end subroutine mysub
end module typemod
program main
use typemod
implicit none
class(mytype), allocatable :: myvar
allocate(mytype :: myvar)
myvar%a = 0
call mysub(myvar)
if (myvar%a .ne. 5) stop 1
end program main

48
libgomp/testsuite/libgomp.oacc-fortran/classtypes-1.f95 Normal file
View file

@ -0,0 +1,48 @@
! { dg-do run }
module typemod
type :: typeimpl
real, pointer :: p(:) => null()
end type typeimpl
type :: basictype
class(typeimpl), pointer :: p => null()
end type basictype
type, extends(basictype) :: regulartype
character :: void
end type regulartype
end module typemod
program main
use typemod
implicit none
type(regulartype), pointer :: myvar
integer :: i
real :: j, k
allocate(myvar)
allocate(myvar%p)
allocate(myvar%p%p(1:100))
do i=1,100
myvar%p%p(i) = -1.0
end do
!$acc enter data copyin(myvar, myvar%p) create(myvar%p%p)
!$acc parallel loop present(myvar%p%p)
do i=1,100
myvar%p%p(i) = i * 2
end do
!$acc end parallel loop
!$acc exit data copyout(myvar%p%p) delete(myvar, myvar%p)
do i=1,100
if (myvar%p%p(i) .ne. i * 2) stop 1
end do
end program main

106
libgomp/testsuite/libgomp.oacc-fortran/classtypes-2.f95 Normal file
View file

@ -0,0 +1,106 @@
! { dg-do run }
module wrapper_mod
type compute
integer, allocatable :: block(:,:)
contains
procedure :: initialize
end type compute
type, extends(compute) :: cpu_compute
integer :: blocksize
contains
procedure :: setblocksize
end type cpu_compute
type, extends(compute) :: gpu_compute
integer :: numgangs
integer :: numworkers
integer :: vectorsize
integer, allocatable :: gpu_block(:,:)
contains
procedure :: setdims
end type gpu_compute
contains
subroutine initialize(c, length, width)
implicit none
class(compute) :: c
integer :: length
integer :: width
integer :: i
integer :: j
allocate (c%block(length, width))
do i=1,length
do j=1, width
c%block(i,j) = i + j
end do
end do
end subroutine initialize
subroutine setdims(c, g, w, v)
implicit none
class(gpu_compute) :: c
integer :: g
integer :: w
integer :: v
c%numgangs = g
c%numworkers = w
c%vectorsize = v
end subroutine setdims
subroutine setblocksize(c, bs)
implicit none
class(cpu_compute) :: c
integer :: bs
c%blocksize = bs
end subroutine setblocksize
end module wrapper_mod
program main
use wrapper_mod
implicit none
class(compute), allocatable, target :: mycomp
integer :: i, j
allocate(gpu_compute::mycomp)
call mycomp%initialize(1024,1024)
!$acc enter data copyin(mycomp)
select type (mycomp)
type is (cpu_compute)
call mycomp%setblocksize(32)
type is (gpu_compute)
call mycomp%setdims(32,32,32)
allocate(mycomp%gpu_block(1024,1024))
!$acc update device(mycomp)
!$acc parallel copyin(mycomp%block) copyout(mycomp%gpu_block)
!$acc loop gang worker vector collapse(2)
do i=1,1024
do j=1,1024
mycomp%gpu_block(i,j) = mycomp%block(i,j) + 1
end do
end do
!$acc end parallel
end select
!$acc exit data copyout(mycomp)
select type (g => mycomp)
type is (gpu_compute)
do i = 1, 1024
do j = 1, 1024
if (g%gpu_block(i,j) .ne. i + j + 1) stop 1
end do
end do
end select
deallocate(mycomp)
end program main