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))
}
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)
{
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)));
= 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. */
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:
--- /dev/null
+! { 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
projects / gcc.git / commitdiff