OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

openacc: Fix lowering for derived-type mappings through array elements

Browse Source 
This patch fixes lowering of derived-type mappings which select elements
of arrays of derived types, and similar. These would previously lead
to ICEs.

With this change, OpenACC directives can pass through constructs that
are no longer recognized by the gimplifier, hence alterations are needed
there also.

gcc/fortran/
	* trans-openmp.c (gfc_trans_omp_clauses): Handle element selection
	for arrays of derived types.

gcc/
	* gimplify.c (gimplify_scan_omp_clauses): Handle ATTACH_DETACH
	for non-decls.

gcc/testsuite/
	* gfortran.dg/goacc/array-with-dt-1.f90: New test.
	* gfortran.dg/goacc/array-with-dt-3.f90: Likewise.
	* gfortran.dg/goacc/array-with-dt-4.f90: Likewise.
	* gfortran.dg/goacc/array-with-dt-5.f90: Likewise.
	* gfortran.dg/goacc/derived-chartypes-1.f90: Re-enable test.
	* gfortran.dg/goacc/derived-chartypes-2.f90: Likewise.
	* gfortran.dg/goacc/derived-classtypes-1.f95: Uncomment
	previously-broken directives.

libgomp/
	* testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90: New test.
	* testsuite/libgomp.oacc-fortran/update-dt-array.f90: Likewise.
This commit is contained in:
Julian Brown 2021-01-21 06:54:54 -08:00
parent 7768cadb42
commit d28f3da11d
11 changed files with 344 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

192
gcc/fortran/trans-openmp.c
View File

@ -2675,6 +2675,32 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
tree decl = gfc_trans_omp_variable (n->sym, false);
if (DECL_P (decl))
TREE_ADDRESSABLE (decl) = 1;
gfc_ref *lastref = NULL;
if (n->expr)
for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY)
lastref = ref;
bool allocatable = false, pointer = false;
if (lastref && lastref->type == REF_COMPONENT)
{
gfc_component *c = lastref->u.c.component;
if (c->ts.type == BT_CLASS)
{
pointer = CLASS_DATA (c)->attr.class_pointer;
allocatable = CLASS_DATA (c)->attr.allocatable;
}
else
{
pointer = c->attr.pointer;
allocatable = c->attr.allocatable;
}
}
if (n->expr == NULL
|| (n->expr->ref->type == REF_ARRAY
&& n->expr->ref->u.ar.type == AR_FULL))
@ -2911,74 +2937,79 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
}
else if (n->expr
&& n->expr->expr_type == EXPR_VARIABLE
&& n->expr->ref->type == REF_COMPONENT)
&& n->expr->ref->type == REF_ARRAY
&& !n->expr->ref->next)
{
gfc_ref *lastcomp;
for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
lastcomp = ref;
symbol_attribute sym_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;
/* An array element or array section which is not part of a
derived type, etc. */
bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
gfc_trans_omp_array_section (block, n, decl, element,
GOMP_MAP_POINTER, node, node2,
node3, node4);
}
else if (n->expr
&& n->expr->expr_type == EXPR_VARIABLE
&& (n->expr->ref->type == REF_COMPONENT
|| n->expr->ref->type == REF_ARRAY)
&& lastref
&& lastref->type == REF_COMPONENT
&& lastref->u.c.component->ts.type != BT_CLASS
&& lastref->u.c.component->ts.type != BT_DERIVED
&& !lastref->u.c.component->attr.dimension)
{
/* Derived type access with last component being a scalar. */
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)
gfc_conv_expr (&se, n->expr);
gfc_add_block_to_block (block, &se.pre);
/* For BT_CHARACTER a pointer is returned. */
OMP_CLAUSE_DECL (node)
= POINTER_TYPE_P (TREE_TYPE (se.expr))
? build_fold_indirect_ref (se.expr) : se.expr;
gfc_add_block_to_block (block, &se.post);
if (pointer || allocatable)
{
/* Last component is a scalar. */
gfc_conv_expr (&se, n->expr);
gfc_add_block_to_block (block, &se.pre);
/* For BT_CHARACTER a pointer is returned. */
OMP_CLAUSE_DECL (node)
node2 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
gomp_map_kind kind
= (openacc ? GOMP_MAP_ATTACH_DETACH
: GOMP_MAP_ALWAYS_POINTER);
OMP_CLAUSE_SET_MAP_KIND (node2, kind);
OMP_CLAUSE_DECL (node2)
= POINTER_TYPE_P (TREE_TYPE (se.expr))
? build_fold_indirect_ref (se.expr) : se.expr;
gfc_add_block_to_block (block, &se.post);
if (sym_attr.pointer || sym_attr.allocatable)
? se.expr
: gfc_build_addr_expr (NULL, se.expr);
OMP_CLAUSE_SIZE (node2) = size_int (0);
if (!openacc
&& n->expr->ts.type == BT_CHARACTER
&& n->expr->ts.deferred)
{
node2 = build_omp_clause (input_location,
gcc_assert (se.string_length);
tree tmp
= gfc_get_char_type (n->expr->ts.kind);
OMP_CLAUSE_SIZE (node)
= fold_build2 (MULT_EXPR, size_type_node,
fold_convert (size_type_node,
se.string_length),
TYPE_SIZE_UNIT (tmp));
node3 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node2,
openacc
? GOMP_MAP_ATTACH_DETACH
: GOMP_MAP_ALWAYS_POINTER);
OMP_CLAUSE_DECL (node2)
= POINTER_TYPE_P (TREE_TYPE (se.expr))
? se.expr : gfc_build_addr_expr (NULL, se.expr);
OMP_CLAUSE_SIZE (node2) = size_int (0);
if (!openacc
&& n->expr->ts.type == BT_CHARACTER
&& n->expr->ts.deferred)
{
gcc_assert (se.string_length);
tree tmp = gfc_get_char_type (n->expr->ts.kind);
OMP_CLAUSE_SIZE (node)
= fold_build2 (MULT_EXPR, size_type_node,
fold_convert (size_type_node,
se.string_length),
TYPE_SIZE_UNIT (tmp));
node3 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO);
OMP_CLAUSE_DECL (node3) = se.string_length;
OMP_CLAUSE_SIZE (node3)
= TYPE_SIZE_UNIT (gfc_charlen_type_node);
}
OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO);
OMP_CLAUSE_DECL (node3) = se.string_length;
OMP_CLAUSE_SIZE (node3)
= TYPE_SIZE_UNIT (gfc_charlen_type_node);
}
goto finalize_map_clause;
}
}
else if (n->expr
&& n->expr->expr_type == EXPR_VARIABLE
&& (n->expr->ref->type == REF_COMPONENT
|| n->expr->ref->type == REF_ARRAY))
{
gfc_init_se (&se, NULL);
se.expr = gfc_maybe_dereference_var (n->sym, decl);
for (gfc_ref *ref = n->expr->ref;
ref && ref != lastcomp->next;
ref = ref->next)
for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT)
{
@ -2987,24 +3018,30 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
gfc_conv_component_ref (&se, ref);
}
else if (ref->type == REF_ARRAY)
{
if (ref->u.ar.type == AR_ELEMENT && ref->next)
gfc_conv_array_ref (&se, &ref->u.ar, n->expr,
&n->expr->where);
else
gcc_assert (!ref->next);
}
else
sorry ("unhandled derived-type component");
sorry ("unhandled expression type");
}
tree inner = se.expr;
/* 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 (lastref->type == REF_COMPONENT
&& (lastref->u.c.component->ts.type == BT_DERIVED
|| lastref->u.c.component->ts.type == BT_CLASS))
{
bool pointer
= (lastcomp->u.c.component->ts.type == BT_CLASS
? sym_attr.class_pointer : sym_attr.pointer);
if (pointer || (openacc && sym_attr.allocatable))
if (pointer || (openacc && allocatable))
{
tree data, size;
if (lastcomp->u.c.component->ts.type == BT_CLASS)
if (lastref->u.c.component->ts.type == BT_CLASS)
{
data = gfc_class_data_get (inner);
gcc_assert (POINTER_TYPE_P (TREE_TYPE (data)));
@ -3035,9 +3072,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
= TYPE_SIZE_UNIT (TREE_TYPE (inner));
}
}
else if (lastcomp->next
&& lastcomp->next->type == REF_ARRAY
&& lastcomp->next->u.ar.type == AR_FULL)
else if (lastref->type == REF_ARRAY
&& lastref->u.ar.type == AR_FULL)
{
/* Just pass the (auto-dereferenced) decl through for
bare attach and detach clauses. */
@ -3131,27 +3167,21 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
else
OMP_CLAUSE_DECL (node) = inner;
}
else /* An array element or section. */
else if (lastref->type == REF_ARRAY)
{
bool element
= (lastcomp->next
&& lastcomp->next->type == REF_ARRAY
&& lastcomp->next->u.ar.type == AR_ELEMENT);
/* An array element or section. */
bool element = lastref->u.ar.type == AR_ELEMENT;
gomp_map_kind kind = (openacc ? GOMP_MAP_ATTACH_DETACH
: GOMP_MAP_ALWAYS_POINTER);
gfc_trans_omp_array_section (block, n, inner, element,
kind, node, node2, node3,
node4);
}
else
gcc_unreachable ();
}
else /* An array element or array section. */
{
bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
gfc_trans_omp_array_section (block, n, decl, element,
GOMP_MAP_POINTER, node, node2,
node3, node4);
}
else
sorry ("unhandled expression");
finalize_map_clause:

12
gcc/gimplify.c
View File

@ -9413,6 +9413,18 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
}
}
}
else if ((code == OACC_ENTER_DATA
|| code == OACC_EXIT_DATA
|| code == OACC_DATA
|| code == OACC_PARALLEL
|| code == OACC_KERNELS
|| code == OACC_SERIAL)
&& OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH_DETACH)
{
gomp_map_kind k = (code == OACC_EXIT_DATA
? GOMP_MAP_DETACH : GOMP_MAP_ATTACH);
OMP_CLAUSE_SET_MAP_KIND (c, k);
}
if (gimplify_expr (pd, pre_p, NULL, is_gimple_lvalue, fb_lvalue)
== GS_ERROR)

11
gcc/testsuite/gfortran.dg/goacc/array-with-dt-1.f90 Normal file
View File

@ -0,0 +1,11 @@
type t
integer, allocatable :: A(:,:)
end type t
type(t), allocatable :: b(:)
!$acc update host(b)
!$acc update host(b(:))
!$acc update host(b(1)%A)
!$acc update host(b(1)%A(:,:))
end

14
gcc/testsuite/gfortran.dg/goacc/array-with-dt-3.f90 Normal file
View File

@ -0,0 +1,14 @@
type t2
integer :: A(200,200)
end type t2
type t
integer, allocatable :: A(:,:)
end type t
type(t2),allocatable :: c(:)
type(t), allocatable :: d(:)
!$acc exit data delete(c(1)%A)
!$acc exit data delete(d(1)%A)
end

18
gcc/testsuite/gfortran.dg/goacc/array-with-dt-4.f90 Normal file
View File

@ -0,0 +1,18 @@
type t4
integer, allocatable :: quux(:)
end type t4
type t3
type(t4), pointer :: qux(:)
end type t3
type t2
type(t3), allocatable :: bar(:)
end type t2
type t
type(t2), allocatable :: foo(:)
end type t
type(t), allocatable :: c(:)
!$acc enter data copyin(c(5)%foo(4)%bar(3)%qux(2)%quux(:))
!$acc exit data delete(c(5)%foo(4)%bar(3)%qux(2)%quux(:))
end

12
gcc/testsuite/gfortran.dg/goacc/array-with-dt-5.f90 Normal file
View File

@ -0,0 +1,12 @@
type t2
integer :: bar
end type t2
type t
type(t2), pointer :: foo
end type t
type(t) :: c
!$acc enter data copyin(c%foo)
end

3
gcc/testsuite/gfortran.dg/goacc/derived-chartypes-1.f90
View File

@ -1,6 +1,3 @@
! This currently ICEs. Avoid that.
! { dg-skip-if "PR98979" { *-*-* } }
type :: type1
character(len=35) :: a
end type type1

3
gcc/testsuite/gfortran.dg/goacc/derived-chartypes-2.f90
View File

@ -1,6 +1,3 @@
! This currently ICEs. Avoid that.
! { dg-skip-if "PR98979" { *-*-* } }
type :: type1
character(len=35,kind=4) :: a
end type type1

8
gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f95
View File

@ -71,7 +71,7 @@ class(type7), allocatable :: acshiela
!$acc enter data copyin(bar)
!$acc enter data copyin(bar%b)
!$acc enter data copyin(qux)
!!$acc enter data copyin(qux%c)
!$acc enter data copyin(qux%c)
!$acc enter data copyin(quux)
!$acc enter data copyin(quux%d)
!$acc enter data copyin(fred)
@ -86,7 +86,7 @@ class(type7), allocatable :: acshiela
!$acc enter data copyin(pbar)
!$acc enter data copyin(pbar%b)
!$acc enter data copyin(pqux)
!!$acc enter data copyin(pqux%c)
!$acc enter data copyin(pqux%c)
!$acc enter data copyin(pquux)
!$acc enter data copyin(pquux%d)
!$acc enter data copyin(pfred)
@ -101,7 +101,7 @@ class(type7), allocatable :: acshiela
!$acc enter data copyin(cbar)
!$acc enter data copyin(cbar%b)
!$acc enter data copyin(cqux)
!!$acc enter data copyin(cqux%c)
!$acc enter data copyin(cqux%c)
!$acc enter data copyin(cquux)
!$acc enter data copyin(cquux%d)
!$acc enter data copyin(cfred)
@ -116,7 +116,7 @@ class(type7), allocatable :: acshiela
!$acc enter data copyin(acbar)
!$acc enter data copyin(acbar%b)
!$acc enter data copyin(acqux)
!!$acc enter data copyin(acqux%c)
!$acc enter data copyin(acqux%c)
!$acc enter data copyin(acquux)
!$acc enter data copyin(acquux%d)
!$acc enter data copyin(acfred)

109
libgomp/testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90 Normal file
View File

@ -0,0 +1,109 @@
! { dg-do run }
type type1
integer, allocatable :: arr1(:,:)
end type type1
type type2
type(type1) :: t1
end type type2
type type3
type(type2) :: t2(20)
end type type3
type type4
type(type3), allocatable :: t3(:)
end type type4
integer :: i, j, k
type(type4), allocatable :: var1(:)
type(type4) :: var2
type(type3) :: var3
allocate(var1(1:20))
do i=1,20
allocate(var1(i)%t3(1:20))
do j=1,20
do k=1,20
allocate(var1(i)%t3(j)%t2(k)%t1%arr1(1:20,1:20))
end do
end do
end do
allocate(var2%t3(1:20))
do i=1,20
do j=1,20
allocate(var2%t3(i)%t2(j)%t1%arr1(1:20,1:20))
end do
end do
do i=1,20
do j=1,20
do k=1,20
var1(i)%t3(j)%t2(k)%t1%arr1(:,:) = 0
end do
var2%t3(i)%t2(j)%t1%arr1(:,:) = 0
end do
end do
!$acc enter data copyin(var2%t3(4)%t2(3)%t1%arr1(:,:))
!$acc enter data copyin(var1(5)%t3(4)%t2(3)%t1%arr1(:,:))
var2%t3(4)%t2(3)%t1%arr1(:,:) = 5
var1(5)%t3(4)%t2(3)%t1%arr1(:,:) = 4
!$acc update device(var2%t3(4)%t2(3)%t1%arr1)
!$acc update device(var1(5)%t3(4)%t2(3)%t1%arr1)
!$acc exit data copyout(var1(5)%t3(4)%t2(3)%t1%arr1(:,:))
!$acc exit data copyout(var2%t3(4)%t2(3)%t1%arr1(:,:))
do i=1,20
do j=1,20
do k=1,20
if (i.eq.5 .and. j.eq.4 .and. k.eq.3) then
if (any(var1(i)%t3(j)%t2(k)%t1%arr1 .ne. 4)) stop 1
else
if (any(var1(i)%t3(j)%t2(k)%t1%arr1 .ne. 0)) stop 2
end if
end do
if (i.eq.4 .and. j.eq.3) then
if (any(var2%t3(i)%t2(j)%t1%arr1 .ne. 5)) stop 3
else
if (any(var2%t3(i)%t2(j)%t1%arr1 .ne. 0)) stop 4
end if
end do
end do
do i=1,20
allocate(var3%t2(i)%t1%arr1(1:20, 1:20))
var3%t2(i)%t1%arr1(:,:) = 0
end do
!$acc enter data copyin(var3)
!$acc enter data copyin(var3%t2(:))
!$acc enter data copyin(var3%t2(5)%t1)
!$acc data copyin(var3%t2(5)%t1%arr1)
!$acc serial present(var3%t2(5)%t1%arr1)
var3%t2(5)%t1%arr1(:,:) = 6
!$acc end serial
!$acc update host(var3%t2(5)%t1%arr1)
!$acc end data
!$acc exit data delete(var3%t2(5)%t1)
!$acc exit data delete(var3%t2)
!$acc exit data delete(var3)
do i=1,20
if (i.eq.5) then
if (any(var3%t2(i)%t1%arr1.ne.6)) stop 5
else
if (any(var3%t2(i)%t1%arr1.ne.0)) stop 6
end if
end do
end

53
libgomp/testsuite/libgomp.oacc-fortran/update-dt-array.f90 Normal file
View File

@ -0,0 +1,53 @@
! { dg-do run }
program myprog
type mytype
integer, allocatable :: myarr(:,:)
end type mytype
integer :: i
type(mytype), allocatable :: typearr(:)
allocate(typearr(1:100))
do i=1,100
allocate(typearr(i)%myarr(1:100,1:100))
end do
do i=1,100
typearr(i)%myarr(:,:) = 0
end do
!$acc enter data copyin(typearr)
do i=1,100
!$acc enter data copyin(typearr(i)%myarr)
end do
i=33
typearr(i)%myarr(:,:) = 50
!$acc update device(typearr(i)%myarr(:,:))
do i=1,100
!$acc exit data copyout(typearr(i)%myarr)
end do
!$acc exit data delete(typearr)
do i=1,100
if (i.eq.33) then
if (any(typearr(i)%myarr.ne.50)) stop 1
else
if (any(typearr(i)%myarr.ne.0)) stop 2
end if
end do
do i=1,100
deallocate(typearr(i)%myarr)
end do
deallocate(typearr)
end program myprog