aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/trans-openmp.c192
-rw-r--r--gcc/gimplify.c12
-rw-r--r--gcc/testsuite/gfortran.dg/goacc/array-with-dt-1.f9011
-rw-r--r--gcc/testsuite/gfortran.dg/goacc/array-with-dt-3.f9014
-rw-r--r--gcc/testsuite/gfortran.dg/goacc/array-with-dt-4.f9018
-rw-r--r--gcc/testsuite/gfortran.dg/goacc/array-with-dt-5.f9012
-rw-r--r--gcc/testsuite/gfortran.dg/goacc/derived-chartypes-1.f903
-rw-r--r--gcc/testsuite/gfortran.dg/goacc/derived-chartypes-2.f903
-rw-r--r--gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f958
-rw-r--r--libgomp/testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90109
-rw-r--r--libgomp/testsuite/libgomp.oacc-fortran/update-dt-array.f9053
11 files changed, 344 insertions, 91 deletions
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 249b3de..67e370f 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -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:
diff --git a/gcc/gimplify.c b/gcc/gimplify.c
index d28fa19..caf25cc 100644
--- a/gcc/gimplify.c
+++ b/gcc/gimplify.c
@@ -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)
diff --git a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-1.f90 b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-1.f90
new file mode 100644
index 0000000..4a3ff0e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-1.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-3.f90 b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-3.f90
new file mode 100644
index 0000000..dcb6365
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-3.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-4.f90 b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-4.f90
new file mode 100644
index 0000000..637d5f5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-4.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-5.f90 b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-5.f90
new file mode 100644
index 0000000..900587b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-5.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/goacc/derived-chartypes-1.f90 b/gcc/testsuite/gfortran.dg/goacc/derived-chartypes-1.f90
index f7aafbf..e4d360e 100644
--- a/gcc/testsuite/gfortran.dg/goacc/derived-chartypes-1.f90
+++ b/gcc/testsuite/gfortran.dg/goacc/derived-chartypes-1.f90
@@ -1,6 +1,3 @@
-! This currently ICEs. Avoid that.
-! { dg-skip-if "PR98979" { *-*-* } }
-
type :: type1
character(len=35) :: a
end type type1
diff --git a/gcc/testsuite/gfortran.dg/goacc/derived-chartypes-2.f90 b/gcc/testsuite/gfortran.dg/goacc/derived-chartypes-2.f90
index e22fc67..cca6443 100644
--- a/gcc/testsuite/gfortran.dg/goacc/derived-chartypes-2.f90
+++ b/gcc/testsuite/gfortran.dg/goacc/derived-chartypes-2.f90
@@ -1,6 +1,3 @@
-! This currently ICEs. Avoid that.
-! { dg-skip-if "PR98979" { *-*-* } }
-
type :: type1
character(len=35,kind=4) :: a
end type type1
diff --git a/gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f95 b/gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f95
index e6cf09c..85a2e1d 100644
--- a/gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f95
+++ b/gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f95
@@ -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)
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90 b/libgomp/testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90
new file mode 100644
index 0000000..644ad1f
--- /dev/null
+++ b/libgomp/testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/update-dt-array.f90 b/libgomp/testsuite/libgomp.oacc-fortran/update-dt-array.f90
new file mode 100644
index 0000000..d796edd
--- /dev/null
+++ b/libgomp/testsuite/libgomp.oacc-fortran/update-dt-array.f90
@@ -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
generated by cgit v1.1 at 2025-05-31 03:39:44 +0000