From 3c260613f2e74d6639c4dbd43b018b6640ae8454 Mon Sep 17 00:00:00 2001
From: Julian Brown <julian@codesourcery.com>
Date: Wed, 20 Feb 2019 05:21:15 -0800
Subject: [PATCH 1/3] Support Fortran 2003 class pointers in OpenACC
gcc/
* gimplify.c (insert_struct_comp_map): Handle GOMP_MAP_ATTACH_DETACH.
(gimplify_scan_omp_clauses): Separate out handling of OACC_ENTER_DATA
and OACC_EXIT_DATA. Remove GOMP_MAP_POINTER and GOMP_MAP_TO_PSET
mappings, apart from those following GOMP_MAP_DECLARE_{,DE}ALLOCATE.
Handle GOMP_MAP_ATTACH_DETACH.
* tree-pretty-print.c (dump_omp_clause): Support GOMP_MAP_ATTACH_DETACH.
Print "bias" not "len" for attach/detach clause types.
include/
* gomp-constants.h (gomp_map_kind): Add GOMP_MAP_ATTACH_DETACH.
gcc/c/
* c-typeck.c (handle_omp_array_sections): Use GOMP_MAP_ATTACH_DETACH
for OpenACC attach/detach operations.
gcc/cp/
* semantics.c (handle_omp_array_sections): Likewise.
(finish_omp_clauses): Handle GOMP_MAP_ATTACH_DETACH.
gcc/fortran/
* openmp.c (resolve_oacc_data_clauses): Allow polymorphic allocatable
variables.
* trans-expr.c (gfc_conv_component_ref,
conv_parent_component_reference): Make global.
(gfc_auto_dereference_var): New function, broken out of...
(gfc_conv_variable): ...here. Call outlined function instead.
* trans-openmp.c (gfc_trans_omp_array_section): New function, broken out
of...
(gfc_trans_omp_clauses): ...here. Separate out OpenACC derived
type/polymorphic class pointer handling. Call above outlined function.
* trans.h (gfc_conv_component_ref, conv_parent_component_references,
gfc_auto_dereference_var): Add prototypes.
gcc/testsuite/
* c-c++-common/goacc/mdc-1.c: Update clause matching patterns.
libgomp/
* oacc-parallel.c (GOACC_enter_exit_data): Fix optional arguments for
changes to clause stripping in enter data/exit data directives.
* 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.
* testsuite/libgomp.oacc-fortran/derivedtype-1.f95: New test.
* testsuite/libgomp.oacc-fortran/derivedtype-2.f95: New test.
* testsuite/libgomp.oacc-fortran/multidim-slice.f95: New test.
---
gcc/ChangeLog.openacc | 10 +
gcc/c/ChangeLog.openacc | 5 +
gcc/c/c-typeck.c | 6 +-
gcc/cp/ChangeLog.openacc | 5 +
gcc/cp/semantics.c | 20 +-
gcc/fortran/ChangeLog.openacc | 15 +
gcc/fortran/openmp.c | 6 -
gcc/fortran/trans-expr.c | 184 ++++-----
gcc/fortran/trans-openmp.c | 382 +++++++++++++-----
gcc/fortran/trans.h | 9 +
gcc/gimplify.c | 67 ++-
gcc/testsuite/ChangeLog.openacc | 4 +
gcc/testsuite/c-c++-common/goacc/mdc-1.c | 16 +-
gcc/tree-pretty-print.c | 9 +
include/ChangeLog.openacc | 4 +
include/gomp-constants.h | 6 +-
libgomp/ChangeLog.openacc | 11 +
libgomp/oacc-parallel.c | 3 +-
.../libgomp.oacc-fortran/class-ptr-param.f95 | 34 ++
.../libgomp.oacc-fortran/classtypes-1.f95 | 48 +++
.../libgomp.oacc-fortran/classtypes-2.f95 | 106 +++++
.../libgomp.oacc-fortran/derivedtype-1.f95 | 30 ++
.../libgomp.oacc-fortran/derivedtype-2.f95 | 41 ++
.../libgomp.oacc-fortran/multidim-slice.f95 | 50 +++
24 files changed, 836 insertions(+), 235 deletions(-)
create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/class-ptr-param.f95
create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/classtypes-1.f95
create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/classtypes-2.f95
create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/derivedtype-1.f95
create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/derivedtype-2.f95
create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/multidim-slice.f95
@@ -1,3 +1,13 @@
+2019-07-10 Julian Brown <julian@codesourcery.com>
+
+ * gimplify.c (insert_struct_comp_map): Handle GOMP_MAP_ATTACH_DETACH.
+ (gimplify_scan_omp_clauses): Separate out handling of OACC_ENTER_DATA
+ and OACC_EXIT_DATA. Remove GOMP_MAP_POINTER and GOMP_MAP_TO_PSET
+ mappings, apart from those following GOMP_MAP_DECLARE_{,DE}ALLOCATE.
+ Handle GOMP_MAP_ATTACH_DETACH.
+ * tree-pretty-print.c (dump_omp_clause): Support GOMP_MAP_ATTACH_DETACH.
+ Print "bias" not "len" for attach/detach clause types.
+
2019-05-28 Julian Brown <julian@codesourcery.com>
* omp-low.c (mark_oacc_gangprivate): Add CTX parameter. Use to look up
@@ -1,3 +1,8 @@
+2019-07-10 Julian Brown <julian@codesourcery.com>
+
+ * c-typeck.c (handle_omp_array_sections): Use GOMP_MAP_ATTACH_DETACH
+ for OpenACC attach/detach operations.
+
2018-12-19 Julian Brown <julian@codesourcery.com>
Maciej W. Rozycki <macro@codesourcery.com>
@@ -13451,7 +13451,11 @@ handle_omp_array_sections (tree c, enum c_omp_region_type ort)
if (ort != C_ORT_OMP && ort != C_ORT_ACC)
OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER);
else if (TREE_CODE (t) == COMPONENT_REF)
- OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_ALWAYS_POINTER);
+ {
+ gomp_map_kind k = (ort == C_ORT_ACC) ? GOMP_MAP_ATTACH_DETACH
+ : GOMP_MAP_ALWAYS_POINTER;
+ OMP_CLAUSE_SET_MAP_KIND (c2, k);
+ }
else
OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_FIRSTPRIVATE_POINTER);
if (OMP_CLAUSE_MAP_KIND (c2) != GOMP_MAP_FIRSTPRIVATE_POINTER
@@ -1,3 +1,8 @@
+2019-07-10 Julian Brown <julian@codesourcery.com>
+
+ * semantics.c (handle_omp_array_sections): Likewise.
+ (finish_omp_clauses): Handle GOMP_MAP_ATTACH_DETACH.
+
2019-07-09 Andrew Stubbs <ams@codesourcery.com>
Backport from mainline:
@@ -5261,12 +5261,18 @@ handle_omp_array_sections (tree c, enum c_omp_region_type ort)
if ((ort & C_ORT_OMP_DECLARE_SIMD) != C_ORT_OMP && ort != C_ORT_ACC)
OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER);
else if (TREE_CODE (t) == COMPONENT_REF)
- OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_ALWAYS_POINTER);
+ {
+ gomp_map_kind k = (ort == C_ORT_ACC) ? GOMP_MAP_ATTACH_DETACH
+ : GOMP_MAP_ALWAYS_POINTER;
+ OMP_CLAUSE_SET_MAP_KIND (c2, k);
+ }
else if (REFERENCE_REF_P (t)
&& TREE_CODE (TREE_OPERAND (t, 0)) == COMPONENT_REF)
{
t = TREE_OPERAND (t, 0);
- OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_ALWAYS_POINTER);
+ gomp_map_kind k = (ort == C_ORT_ACC) ? GOMP_MAP_ATTACH_DETACH
+ : GOMP_MAP_ALWAYS_POINTER;
+ OMP_CLAUSE_SET_MAP_KIND (c2, k);
}
else
OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_FIRSTPRIVATE_POINTER);
@@ -7300,7 +7306,8 @@ finish_omp_clauses (tree clauses, enum c_omp_region_type ort)
break;
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_MAP
&& (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_POINTER
- || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER))
+ || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER
+ || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH_DETACH))
break;
if (DECL_P (t))
error_at (OMP_CLAUSE_LOCATION (c),
@@ -7439,7 +7446,12 @@ finish_omp_clauses (tree clauses, enum c_omp_region_type ort)
tree c2 = build_omp_clause (OMP_CLAUSE_LOCATION (c),
OMP_CLAUSE_MAP);
if (TREE_CODE (t) == COMPONENT_REF)
- OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_ALWAYS_POINTER);
+ {
+ gomp_map_kind k
+ = (ort == C_ORT_ACC) ? GOMP_MAP_ATTACH_DETACH
+ : GOMP_MAP_ALWAYS_POINTER;
+ OMP_CLAUSE_SET_MAP_KIND (c2, k);
+ }
else
OMP_CLAUSE_SET_MAP_KIND (c2,
GOMP_MAP_FIRSTPRIVATE_REFERENCE);
@@ -1,3 +1,18 @@
+2019-07-10 Julian Brown <julian@codesourcery.com>
+
+ * openmp.c (resolve_oacc_data_clauses): Allow polymorphic allocatable
+ variables.
+ * trans-expr.c (gfc_conv_component_ref,
+ conv_parent_component_reference): Make global.
+ (gfc_auto_dereference_var): New function, broken out of...
+ (gfc_conv_variable): ...here. Call outlined function instead.
+ * trans-openmp.c (gfc_trans_omp_array_section): New function, broken out
+ of...
+ (gfc_trans_omp_clauses): ...here. Separate out OpenACC derived
+ type/polymorphic class pointer handling. Call above outlined function.
+ * trans.h (gfc_conv_component_ref, conv_parent_component_references,
+ gfc_auto_dereference_var): Add prototypes.
+
2019-05-19 Julian Brown <julian@codesourcery.com>
* trans-openmp.c (gfc_omp_finish_clause): Guard addition of clauses for
@@ -3931,12 +3931,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);
}
@@ -2403,7 +2403,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
/* Convert a derived type component reference. */
-static void
+void
gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
{
gfc_component *c;
@@ -2493,7 +2493,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
/* This function deals with component references to components of the
parent type for derived type extensions. */
-static void
+void
conv_parent_component_references (gfc_se * se, gfc_ref * ref)
{
gfc_component *c;
@@ -2559,6 +2559,95 @@ conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
se->expr = res;
}
+/* Transparently dereference VAR if it is a pointer, reference, etc.
+ according to Fortran semantics. */
+
+tree
+gfc_auto_dereference_var (location_t loc, gfc_symbol *sym, tree var,
+ bool descriptor_only_p, bool is_classarray)
+{
+ /* Characters are entirely different from other types, they are treated
+ separately. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ /* Dereference character pointer dummy arguments
+ or results. */
+ if ((sym->attr.pointer || sym->attr.allocatable)
+ && (sym->attr.dummy
+ || sym->attr.function
+ || sym->attr.result))
+ var = build_fold_indirect_ref_loc (input_location, var);
+ }
+ else if (!sym->attr.value)
+ {
+ /* Dereference temporaries for class array dummy arguments. */
+ if (sym->attr.dummy && is_classarray
+ && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
+ {
+ if (!descriptor_only_p)
+ var = GFC_DECL_SAVED_DESCRIPTOR (var);
+
+ var = build_fold_indirect_ref_loc (input_location, var);
+ }
+
+ /* Dereference non-character scalar dummy arguments. */
+ if (sym->attr.dummy && !sym->attr.dimension
+ && !(sym->attr.codimension && sym->attr.allocatable)
+ && (sym->ts.type != BT_CLASS
+ || (!CLASS_DATA (sym)->attr.dimension
+ && !(CLASS_DATA (sym)->attr.codimension
+ && CLASS_DATA (sym)->attr.allocatable))))
+ var = build_fold_indirect_ref_loc (input_location, var);
+
+ /* Dereference scalar hidden result. */
+ if (flag_f2c && sym->ts.type == BT_COMPLEX
+ && (sym->attr.function || sym->attr.result)
+ && !sym->attr.dimension && !sym->attr.pointer
+ && !sym->attr.always_explicit)
+ var = build_fold_indirect_ref_loc (input_location, var);
+
+ /* Dereference non-character, non-class pointer variables.
+ These must be dummies, results, or scalars. */
+ if (!is_classarray
+ && (sym->attr.pointer || sym->attr.allocatable
+ || gfc_is_associate_pointer (sym)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
+ && (sym->attr.dummy
+ || sym->attr.function
+ || sym->attr.result
+ || (!sym->attr.dimension
+ && (!sym->attr.codimension || !sym->attr.allocatable))))
+ var = build_fold_indirect_ref_loc (input_location, var);
+ /* Now treat the class array pointer variables accordingly. */
+ else if (sym->ts.type == BT_CLASS
+ && sym->attr.dummy
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)
+ && ((CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.class_pointer))
+ var = build_fold_indirect_ref_loc (input_location, var);
+ /* And the case where a non-dummy, non-result, non-function,
+ non-allotable and non-pointer classarray is present. This case was
+ previously covered by the first if, but with introducing the
+ condition !is_classarray there, that case has to be covered
+ explicitly. */
+ else if (sym->ts.type == BT_CLASS
+ && !sym->attr.dummy
+ && !sym->attr.function
+ && !sym->attr.result
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)
+ && (sym->assoc
+ || !CLASS_DATA (sym)->attr.allocatable)
+ && !CLASS_DATA (sym)->attr.class_pointer)
+ var = build_fold_indirect_ref_loc (input_location, var);
+ }
+
+ return var;
+}
+
/* Return the contents of a variable. Also handles reference/pointer
variables (all Fortran pointer references are implicit). */
@@ -2665,94 +2754,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
return;
}
-
- /* Dereference the expression, where needed. Since characters
- are entirely different from other types, they are treated
- separately. */
- if (sym->ts.type == BT_CHARACTER)
- {
- /* Dereference character pointer dummy arguments
- or results. */
- if ((sym->attr.pointer || sym->attr.allocatable)
- && (sym->attr.dummy
- || sym->attr.function
- || sym->attr.result))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- }
- else if (!sym->attr.value)
- {
- /* Dereference temporaries for class array dummy arguments. */
- if (sym->attr.dummy && is_classarray
- && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
- {
- if (!se->descriptor_only)
- se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
-
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- }
-
- /* Dereference non-character scalar dummy arguments. */
- if (sym->attr.dummy && !sym->attr.dimension
- && !(sym->attr.codimension && sym->attr.allocatable)
- && (sym->ts.type != BT_CLASS
- || (!CLASS_DATA (sym)->attr.dimension
- && !(CLASS_DATA (sym)->attr.codimension
- && CLASS_DATA (sym)->attr.allocatable))))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- /* Dereference scalar hidden result. */
- if (flag_f2c && sym->ts.type == BT_COMPLEX
- && (sym->attr.function || sym->attr.result)
- && !sym->attr.dimension && !sym->attr.pointer
- && !sym->attr.always_explicit)
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- /* Dereference non-character, non-class pointer variables.
- These must be dummies, results, or scalars. */
- if (!is_classarray
- && (sym->attr.pointer || sym->attr.allocatable
- || gfc_is_associate_pointer (sym)
- || (sym->as && sym->as->type == AS_ASSUMED_RANK))
- && (sym->attr.dummy
- || sym->attr.function
- || sym->attr.result
- || (!sym->attr.dimension
- && (!sym->attr.codimension || !sym->attr.allocatable))))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- /* Now treat the class array pointer variables accordingly. */
- else if (sym->ts.type == BT_CLASS
- && sym->attr.dummy
- && (CLASS_DATA (sym)->attr.dimension
- || CLASS_DATA (sym)->attr.codimension)
- && ((CLASS_DATA (sym)->as
- && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
- || CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- /* And the case where a non-dummy, non-result, non-function,
- non-allotable and non-pointer classarray is present. This case was
- previously covered by the first if, but with introducing the
- condition !is_classarray there, that case has to be covered
- explicitly. */
- else if (sym->ts.type == BT_CLASS
- && !sym->attr.dummy
- && !sym->attr.function
- && !sym->attr.result
- && (CLASS_DATA (sym)->attr.dimension
- || CLASS_DATA (sym)->attr.codimension)
- && (sym->assoc
- || !CLASS_DATA (sym)->attr.allocatable)
- && !CLASS_DATA (sym)->attr.class_pointer)
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- }
+ /* Dereference the expression, where needed. */
+ se->expr = gfc_auto_dereference_var (input_location, sym, se->expr,
+ se->descriptor_only, is_classarray);
ref = expr->ref;
}
@@ -1937,6 +1937,92 @@ gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
static vec<tree, va_heap, vl_embed> *doacross_steps;
+
+/* Translate an array section or array element. */
+
+static void
+gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n,
+ tree decl, bool element, gomp_map_kind ptr_kind,
+ tree node, tree &node2, tree &node3, tree &node4)
+{
+ gfc_se se;
+ tree ptr, ptr2;
+
+ gfc_init_se (&se, NULL);
+
+ if (element)
+ {
+ gfc_conv_expr_reference (&se, n->expr);
+ gfc_add_block_to_block (block, &se.pre);
+ ptr = se.expr;
+ OMP_CLAUSE_SIZE (node)
+ = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
+ }
+ else
+ {
+ gfc_conv_expr_descriptor (&se, n->expr);
+ ptr = gfc_conv_array_data (se.expr);
+ tree type = TREE_TYPE (se.expr);
+ gfc_add_block_to_block (block, &se.pre);
+ OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr,
+ GFC_TYPE_ARRAY_RANK (type));
+ tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ elemsz = fold_convert (gfc_array_index_type, elemsz);
+ OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ OMP_CLAUSE_SIZE (node), elemsz);
+ }
+ gfc_add_block_to_block (block, &se.post);
+ ptr = fold_convert (build_pointer_type (char_type_node), ptr);
+ OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
+
+ if (POINTER_TYPE_P (TREE_TYPE (decl))
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
+ && ptr_kind == GOMP_MAP_POINTER)
+ {
+ 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);
+ }
+ ptr = fold_convert (sizetype, ptr);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ {
+ tree type = TREE_TYPE (decl);
+ ptr2 = gfc_conv_descriptor_data_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, ptr_kind);
+ OMP_CLAUSE_DECL (node3)
+ = gfc_conv_descriptor_data_get (decl);
+ if (ptr_kind == GOMP_MAP_ATTACH_DETACH)
+ STRIP_NOPS (OMP_CLAUSE_DECL (node3));
+ }
+ else
+ {
+ if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
+ ptr2 = build_fold_addr_expr (decl);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
+ ptr2 = decl;
+ }
+ node3 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind);
+ OMP_CLAUSE_DECL (node3) = decl;
+ }
+ ptr2 = fold_convert (sizetype, ptr2);
+ OMP_CLAUSE_SIZE (node3)
+ = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2);
+}
+
static tree
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
locus where, bool declare_simd = false)
@@ -2255,51 +2341,54 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
if (DECL_P (decl))
TREE_ADDRESSABLE (decl) = 1;
- gfc_ref *ref = n->expr ? n->expr->ref : NULL;
- symbol_attribute *sym_attr = &n->sym->attr;
- gomp_map_kind ptr_map_kind = GOMP_MAP_POINTER;
-
- if (ref && n->sym->ts.type == BT_DERIVED)
- {
- if (gfc_omp_privatize_by_reference (decl))
- decl = build_fold_indirect_ref (decl);
-
- for (; ref && ref->type == REF_COMPONENT; ref = ref->next)
- {
- tree field = ref->u.c.component->backend_decl;
- gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
- decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- decl, field, NULL_TREE);
- sym_attr = &ref->u.c.component->attr;
- }
-
- ptr_map_kind = GOMP_MAP_ALWAYS_POINTER;
- }
-
- if (ref == NULL || ref->u.ar.type == AR_FULL)
+ if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
{
- tree field = decl;
-
- while (TREE_CODE (field) == COMPONENT_REF)
- field = TREE_OPERAND (field, 1);
-
if (POINTER_TYPE_P (TREE_TYPE (decl))
&& n->u.map_op == OMP_MAP_FORCE_DEVICEPTR)
{
OMP_CLAUSE_DECL (node) = decl;
goto finalize_map_clause;
}
+ else 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 (field)
- || GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
- || GFC_DECL_CRAY_POINTEE (field)
- || GFC_DESCRIPTOR_TYPE_P
- (TREE_TYPE (TREE_TYPE (field)))))
+ && (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;
enum gomp_map_kind gmk = GOMP_MAP_POINTER;
- if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
+ if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
&& n->sym->attr.oacc_declare_create)
{
if (clauses->update_allocatable)
@@ -2319,7 +2408,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
{
node3 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
- OMP_CLAUSE_SET_MAP_KIND (node3, ptr_map_kind);
+ OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
OMP_CLAUSE_DECL (node3) = decl;
OMP_CLAUSE_SIZE (node3) = size_int (0);
decl = build_fold_indirect_ref (decl);
@@ -2332,7 +2421,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
tree type = TREE_TYPE (decl);
tree ptr;
- if (sym_attr->optional)
+ if (n->sym->attr.optional)
ptr = gfc_build_conditional_assign_expr (
block,
TREE_OPERAND (decl, 0),
@@ -2352,22 +2441,20 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
node3 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
- OMP_CLAUSE_SET_MAP_KIND (node3, ptr_map_kind);
+ OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
OMP_CLAUSE_DECL (node3)
= gfc_conv_descriptor_data_get (decl);
- if (ptr_map_kind == GOMP_MAP_ALWAYS_POINTER)
- STRIP_NOPS (OMP_CLAUSE_DECL (node3));
OMP_CLAUSE_SIZE (node3) = size_int (0);
/* We have to check for n->sym->attr.dimension because
of scalar coarrays. */
- if ((sym_attr->pointer || sym_attr->optional)
- && sym_attr->dimension)
+ if ((n->sym->attr.pointer || n->sym->attr.optional)
+ && n->sym->attr.dimension)
{
stmtblock_t cond_block;
tree size
= gfc_create_var (gfc_array_index_type, NULL);
- tree cond = sym_attr->optional
+ tree cond = n->sym->attr.optional
? TREE_OPERAND (decl, 0)
: gfc_conv_descriptor_data_get (decl);
@@ -2387,11 +2474,11 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node) = size;
}
- else if (sym_attr->dimension)
+ else if (n->sym->attr.dimension)
OMP_CLAUSE_SIZE (node)
= gfc_full_array_size (block, decl,
GFC_TYPE_ARRAY_RANK (type));
- if (sym_attr->dimension)
+ if (n->sym->attr.dimension)
{
tree elemsz
= TYPE_SIZE_UNIT (gfc_get_element_type (type));
@@ -2404,88 +2491,161 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
else
OMP_CLAUSE_DECL (node) = decl;
}
- else if (ref)
+ else if (n->expr
+ && n->expr->expr_type == EXPR_VARIABLE
+ && n->expr->ref->type == REF_COMPONENT)
{
- tree ptr, ptr2;
- gfc_init_se (&se, NULL);
- if (ref->u.ar.type == AR_ELEMENT)
- {
- gfc_conv_expr_reference (&se, n->expr);
- gfc_add_block_to_block (block, &se.pre);
- ptr = se.expr;
- OMP_CLAUSE_SIZE (node)
- = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
- }
+ 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;
+
+ 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_descriptor (&se, n->expr);
- ptr = gfc_conv_array_data (se.expr);
- tree type = TREE_TYPE (se.expr);
+ /* Last component is a scalar. */
+ gfc_conv_expr (&se, n->expr);
gfc_add_block_to_block (block, &se.pre);
- OMP_CLAUSE_SIZE (node)
- = gfc_full_array_size (block, se.expr,
- GFC_TYPE_ARRAY_RANK (type));
- tree elemsz
- = TYPE_SIZE_UNIT (gfc_get_element_type (type));
- elemsz = fold_convert (gfc_array_index_type, elemsz);
- OMP_CLAUSE_SIZE (node)
- = fold_build2 (MULT_EXPR, gfc_array_index_type,
- OMP_CLAUSE_SIZE (node), elemsz);
+ OMP_CLAUSE_DECL (node) = se.expr;
+ gfc_add_block_to_block (block, &se.post);
+ goto finalize_map_clause;
}
- gfc_add_block_to_block (block, &se.post);
- ptr = fold_convert (build_pointer_type (char_type_node),
- ptr);
- OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
- if (POINTER_TYPE_P (TREE_TYPE (decl))
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
+ se.expr
+ = gfc_auto_dereference_var (input_location, n->sym,
+ decl);
+
+ for (gfc_ref *ref = n->expr->ref;
+ ref && ref != lastcomp->next;
+ ref = ref->next)
{
- node4 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
- OMP_CLAUSE_SET_MAP_KIND (node4, ptr_map_kind);
- OMP_CLAUSE_DECL (node4) = decl;
- OMP_CLAUSE_SIZE (node4) = size_int (0);
- decl = build_fold_indirect_ref (decl);
+ if (ref->type == REF_COMPONENT)
+ {
+ if (ref->u.c.sym->attr.extension)
+ conv_parent_component_references (&se, ref);
+
+ gfc_conv_component_ref (&se, ref);
+ }
+ else
+ sorry ("unhandled derived-type component");
}
- ptr = fold_convert (sizetype, ptr);
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+
+ 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)
{
- tree type = TREE_TYPE (decl);
- ptr2 = gfc_conv_descriptor_data_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, ptr_map_kind);
- OMP_CLAUSE_DECL (node3)
- = gfc_conv_descriptor_data_get (decl);
- if (ptr_map_kind == GOMP_MAP_ALWAYS_POINTER)
- STRIP_NOPS (OMP_CLAUSE_DECL (node3));
+ if (sym_attr.allocatable || sym_attr.pointer)
+ {
+ 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);
+ OMP_CLAUSE_SIZE (node) = size;
+ node2 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node2,
+ GOMP_MAP_ATTACH_DETACH);
+ OMP_CLAUSE_DECL (node2) = data;
+ OMP_CLAUSE_SIZE (node2) = size_int (0);
+ }
+ else
+ {
+ OMP_CLAUSE_DECL (node) = decl;
+ OMP_CLAUSE_SIZE (node)
+ = TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ }
}
- else
+ else if (lastcomp->next
+ && lastcomp->next->type == REF_ARRAY
+ && lastcomp->next->u.ar.type == AR_FULL)
{
- if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
- ptr2 = build_fold_addr_expr (decl);
- else
+ /* Just pass the (auto-dereferenced) decl through for
+ bare attach and detach clauses. */
+ if (n->u.map_op == OMP_MAP_ATTACH
+ || n->u.map_op == OMP_MAP_DETACH)
{
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
- ptr2 = decl;
+ OMP_CLAUSE_DECL (node) = inner;
+ OMP_CLAUSE_SIZE (node) = size_zero_node;
+ goto finalize_map_clause;
}
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
- OMP_CLAUSE_SET_MAP_KIND (node3, ptr_map_kind);
- OMP_CLAUSE_DECL (node3) = decl;
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
+ {
+ tree type = TREE_TYPE (inner);
+ tree ptr = gfc_conv_descriptor_data_get (inner);
+ ptr = build_fold_indirect_ref (ptr);
+ OMP_CLAUSE_DECL (node) = ptr;
+ node2 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
+ OMP_CLAUSE_DECL (node2) = inner;
+ 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_conv_descriptor_data_get (inner);
+ STRIP_NOPS (OMP_CLAUSE_DECL (node3));
+ OMP_CLAUSE_SIZE (node3) = size_int (0);
+ int rank = GFC_TYPE_ARRAY_RANK (type);
+ OMP_CLAUSE_SIZE (node)
+ = gfc_full_array_size (block, inner, rank);
+ tree elemsz
+ = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ elemsz = fold_convert (gfc_array_index_type, elemsz);
+ OMP_CLAUSE_SIZE (node)
+ = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ OMP_CLAUSE_SIZE (node), elemsz);
+ }
+ else
+ OMP_CLAUSE_DECL (node) = inner;
+ }
+ else /* An array element or section. */
+ {
+ bool element
+ = (lastcomp->next
+ && lastcomp->next->type == REF_ARRAY
+ && lastcomp->next->u.ar.type == AR_ELEMENT);
+
+ gfc_trans_omp_array_section (block, n, inner, element,
+ GOMP_MAP_ATTACH_DETACH,
+ node, node2, node3, node4);
}
- ptr2 = fold_convert (sizetype, ptr2);
- OMP_CLAUSE_SIZE (node3)
- = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2);
- finalize_map_clause:;
}
- 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);
+ }
+
+ finalize_map_clause:
switch (n->u.map_op)
{
case OMP_MAP_ALLOC:
@@ -546,6 +546,15 @@ tree gfc_conv_expr_present (gfc_symbol *);
/* Convert a missing, dummy argument into a null or zero. */
void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec, int);
+/* Lowering of component references. */
+void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref);
+void conv_parent_component_references (gfc_se * se, gfc_ref * ref);
+
+/* Automatically dereference var. */
+tree gfc_auto_dereference_var (location_t, gfc_symbol *, tree,
+ bool desc_only = false,
+ bool is_classarray = false);
+
/* Generate code to allocate a string temporary. */
tree gfc_conv_string_tmp (gfc_se *, tree, tree);
/* Get the string length variable belonging to an expression. */
@@ -8126,8 +8126,10 @@ insert_struct_comp_map (enum tree_code code, tree c, tree struct_node,
GOMP_MAP_ALWAYS_POINTER though, i.e. a GOMP_MAP_TO_PSET. */
if (OMP_CLAUSE_CHAIN (prev_node) != c
&& OMP_CLAUSE_CODE (OMP_CLAUSE_CHAIN (prev_node)) == OMP_CLAUSE_MAP
- && (OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (prev_node))
- == GOMP_MAP_ALWAYS_POINTER))
+ && ((OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (prev_node))
+ == GOMP_MAP_ALWAYS_POINTER)
+ || (OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (prev_node))
+ == GOMP_MAP_ATTACH_DETACH)))
{
tree c4 = OMP_CLAUSE_CHAIN (prev_node);
tree c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
@@ -8673,8 +8675,6 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
case OMP_TARGET_DATA:
case OMP_TARGET_ENTER_DATA:
case OMP_TARGET_EXIT_DATA:
- case OACC_ENTER_DATA:
- case OACC_EXIT_DATA:
case OACC_HOST_DATA:
if (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_FIRSTPRIVATE_POINTER
|| (OMP_CLAUSE_MAP_KIND (c)
@@ -8683,6 +8683,21 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
mapped, but not the pointer to it. */
remove = true;
break;
+ case OACC_ENTER_DATA:
+ case OACC_EXIT_DATA:
+ if ((OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_POINTER
+ || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_TO_PSET
+ || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_FIRSTPRIVATE_POINTER
+ || (OMP_CLAUSE_MAP_KIND (c)
+ == GOMP_MAP_FIRSTPRIVATE_REFERENCE))
+ && !(prev_list_p
+ && OMP_CLAUSE_CODE (*prev_list_p) == OMP_CLAUSE_MAP
+ && ((OMP_CLAUSE_MAP_KIND (*prev_list_p)
+ == GOMP_MAP_DECLARE_ALLOCATE)
+ || (OMP_CLAUSE_MAP_KIND (*prev_list_p)
+ == GOMP_MAP_DECLARE_DEALLOCATE))))
+ remove = true;
+ break;
default:
break;
}
@@ -8770,7 +8785,7 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
tree decl_ref = NULL_TREE;
if ((region_type & ORT_ACC) != 0
&& TREE_CODE (*pd) == COMPONENT_REF
- && OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER
+ && OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH_DETACH
&& code != OACC_UPDATE)
{
while (TREE_CODE (decl) == COMPONENT_REF)
@@ -8812,7 +8827,14 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
mapped as a FIRSTPRIVATE_POINTER. */
OMP_CLAUSE_SET_MAP_KIND (c, k);
flags = GOVD_MAP | GOVD_SEEN | GOVD_EXPLICIT;
+ tree next_clause = OMP_CLAUSE_CHAIN (c);
if (k == GOMP_MAP_ATTACH
+ && code != OACC_ENTER_DATA
+ && (!next_clause
+ || (OMP_CLAUSE_CODE (next_clause) != OMP_CLAUSE_MAP)
+ || (OMP_CLAUSE_MAP_KIND (next_clause)
+ != GOMP_MAP_POINTER)
+ || OMP_CLAUSE_DECL (next_clause) != decl)
&& (!struct_deref_set
|| !struct_deref_set->contains (decl)))
{
@@ -8848,6 +8870,13 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
}
goto do_add_decl;
}
+ /* An "attach/detach" operation on an update directive should
+ behave as a GOMP_MAP_ALWAYS_POINTER. Beware that
+ unlike attach or detach map kinds, GOMP_MAP_ALWAYS_POINTER
+ depends on the previous mapping. */
+ if (code == OACC_UPDATE
+ && OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH_DETACH)
+ OMP_CLAUSE_SET_MAP_KIND (c, GOMP_MAP_ALWAYS_POINTER);
if (gimplify_expr (pd, pre_p, NULL, is_gimple_lvalue, fb_lvalue)
== GS_ERROR)
{
@@ -8856,6 +8885,8 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
}
if (DECL_P (decl)
&& OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_TO_PSET
+ && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_ATTACH
+ && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_DETACH
&& code != OACC_UPDATE)
{
if (error_operand_p (decl))
@@ -8877,7 +8908,8 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
break;
}
- if (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER)
+ if (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER
+ || OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH_DETACH)
{
/* Error recovery. */
if (prev_list_p == NULL)
@@ -8909,12 +8941,14 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
= splay_tree_lookup (ctx->variables, (splay_tree_key)decl);
bool ptr = (OMP_CLAUSE_MAP_KIND (c)
== GOMP_MAP_ALWAYS_POINTER);
+ bool attach_detach = (OMP_CLAUSE_MAP_KIND (c)
+ == GOMP_MAP_ATTACH_DETACH);
bool attach = OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH
|| OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_DETACH;
bool has_attachments = false;
/* For OpenACC, pointers in structs should trigger an
attach action. */
- if (ptr && (region_type & ORT_ACC) != 0)
+ if (attach_detach && (region_type & ORT_ACC) != 0)
{
/* Turning a GOMP_MAP_ALWAYS_POINTER clause into a
GOMP_MAP_ATTACH clause after we have detected a case
@@ -8946,7 +8980,7 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
if (struct_map_to_clause == NULL)
struct_map_to_clause = new hash_map<tree, tree>;
struct_map_to_clause->put (decl, l);
- if (ptr)
+ if (ptr || attach_detach)
{
insert_struct_comp_map (code, c, l, *prev_list_p,
NULL);
@@ -8972,7 +9006,9 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
OMP_CLAUSE_CHAIN (l) = c2;
}
flags = GOVD_MAP | GOVD_EXPLICIT;
- if (GOMP_MAP_ALWAYS_P (OMP_CLAUSE_MAP_KIND (c)) || ptr)
+ if (GOMP_MAP_ALWAYS_P (OMP_CLAUSE_MAP_KIND (c))
+ || ptr
+ || attach_detach)
flags |= GOVD_SEEN;
if (has_attachments)
flags |= GOVD_MAP_HAS_ATTACHMENTS;
@@ -8982,7 +9018,9 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
{
tree *osc = struct_map_to_clause->get (decl);
tree *sc = NULL, *scp = NULL;
- if (GOMP_MAP_ALWAYS_P (OMP_CLAUSE_MAP_KIND (c)) || ptr)
+ if (GOMP_MAP_ALWAYS_P (OMP_CLAUSE_MAP_KIND (c))
+ || ptr
+ || attach_detach)
n->value |= GOVD_SEEN;
sc = &OMP_CLAUSE_CHAIN (*osc);
if (*sc != c
@@ -8992,7 +9030,7 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
/* Here "prev_list_p" is the end of the inserted
alloc/release nodes after the struct node, OSC. */
for (; *sc != c; sc = &OMP_CLAUSE_CHAIN (*sc))
- if (ptr && sc == prev_list_p)
+ if ((ptr || attach_detach) && sc == prev_list_p)
break;
else if (TREE_CODE (OMP_CLAUSE_DECL (*sc))
!= COMPONENT_REF
@@ -9041,7 +9079,7 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
}
if (same_decl_offset_lt)
{
- if (ptr)
+ if (ptr || attach_detach)
scp = sc;
else
break;
@@ -9053,7 +9091,7 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
OMP_CLAUSE_SIZE (*osc)
= size_binop (PLUS_EXPR, OMP_CLAUSE_SIZE (*osc),
size_one_node);
- if (ptr)
+ if (ptr || attach_detach)
{
tree cl = insert_struct_comp_map (code, c, NULL,
*prev_list_p, scp);
@@ -9083,11 +9121,14 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
}
if (!remove
&& OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_ALWAYS_POINTER
+ && OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_ATTACH_DETACH
&& OMP_CLAUSE_MAP_KIND (c) != GOMP_MAP_TO_PSET
&& OMP_CLAUSE_CHAIN (c)
&& OMP_CLAUSE_CODE (OMP_CLAUSE_CHAIN (c)) == OMP_CLAUSE_MAP
&& ((OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (c))
== GOMP_MAP_ALWAYS_POINTER)
+ || (OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (c))
+ == GOMP_MAP_ATTACH_DETACH)
|| (OMP_CLAUSE_MAP_KIND (OMP_CLAUSE_CHAIN (c))
== GOMP_MAP_TO_PSET)))
prev_list_p = list_p;
@@ -1,3 +1,7 @@
+2019-07-10 Julian Brown <julian@codesourcery.com>
+
+ * c-c++-common/goacc/mdc-1.c: Update clause matching patterns.
+
2019-07-09 Andrew Stubbs <ams@codesourcery.com>
Backport from mainline:
@@ -43,13 +43,13 @@ t1 ()
}
/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.to:s .len: 32.." 1 "omplower" } } */
-/* { dg-final { scan-tree-dump-times "pragma omp target oacc_data map.tofrom:.z .len: 40.. map.struct:s .len: 1.. map.alloc:s.a .len: 8.. map.tofrom:._1 .len: 40.. map.attach:s.a .len: 0.." 1 "omplower" } } */
-/* { dg-final { scan-tree-dump-times "pragma omp target oacc_parallel map.force_present:s .len: 32.. map.attach:s.e .len: 8.." 1 "omplower" } } */
-/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.attach:a .len: 8.." 1 "omplower" } } */
-/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.detach:a .len: 8.." 1 "omplower" } } */
+/* { dg-final { scan-tree-dump-times "pragma omp target oacc_data map.tofrom:.z .len: 40.. map.struct:s .len: 1.. map.alloc:s.a .len: 8.. map.tofrom:._1 .len: 40.. map.attach:s.a .bias: 0.." 1 "omplower" } } */
+/* { dg-final { scan-tree-dump-times "pragma omp target oacc_parallel map.attach:s.e .bias: 8.. map.tofrom:s .len: 32" 1 "omplower" } } */
+/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.attach:a .bias: 8.." 1 "omplower" } } */
+/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.detach:a .bias: 8.." 1 "omplower" } } */
/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.to:a .len: 8.." 1 "omplower" } } */
-/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.force_present:s .len: 32.. map.detach:s.e .len: 8.." 1 "omplower" } } */
-/* { dg-final { scan-tree-dump-times "pragma omp target oacc_data map.force_present:s .len: 32.. map.attach:s.e .len: 8.." 1 "omplower" } } */
+/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.detach:s.e .bias: 8.." 1 "omplower" } } */
+/* { dg-final { scan-tree-dump-times "pragma omp target oacc_data map.attach:s.e .bias: 8.." 1 "omplower" } } */
/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data map.release:a .len: 8.." 1 "omplower" } } */
-/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data finalize map.force_detach:a .len: 8.." 1 "omplower" } } */
-/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data finalize map.force_present:s .len: 32.. map.force_detach:s.a .len: 8.." 1 "omplower" } } */
+/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data finalize map.force_detach:a .bias: 8.." 1 "omplower" } } */
+/* { dg-final { scan-tree-dump-times "pragma omp target oacc_enter_exit_data finalize map.force_detach:s.a .bias: 8.." 1 "omplower" } } */
@@ -871,6 +871,9 @@ dump_omp_clause (pretty_printer *pp, tree clause, int spc, dump_flags_t flags)
case GOMP_MAP_FORCE_DETACH:
pp_string (pp, "force_detach");
break;
+ case GOMP_MAP_ATTACH_DETACH:
+ pp_string (pp, "attach_detach");
+ break;
default:
gcc_unreachable ();
}
@@ -896,6 +899,12 @@ dump_omp_clause (pretty_printer *pp, tree clause, int spc, dump_flags_t flags)
gcc_assert (TREE_CODE (OMP_CLAUSE_SIZE (clause)) == TREE_LIST);
pp_string (pp, " [dimensions: ");
break;
+ case GOMP_MAP_ATTACH:
+ case GOMP_MAP_DETACH:
+ case GOMP_MAP_FORCE_DETACH:
+ case GOMP_MAP_ATTACH_DETACH:
+ pp_string (pp, " [bias: ");
+ break;
default:
pp_string (pp, " [len: ");
break;
@@ -1,3 +1,7 @@
+2019-07-10 Julian Brown <julian@codesourcery.com>
+
+ * gomp-constants.h (gomp_map_kind): Add GOMP_MAP_ATTACH_DETACH.
+
2018-12-20 Maciej W. Rozycki <macro@codesourcery.com>
* gomp-constants.h (GOMP_DEVICE_CURRENT): New macro.
@@ -171,7 +171,11 @@ enum gomp_map_kind
/* Do not map, but pointer assign a pointer instead. */
GOMP_MAP_FIRSTPRIVATE_POINTER = (GOMP_MAP_LAST | 1),
/* Do not map, but pointer assign a reference instead. */
- GOMP_MAP_FIRSTPRIVATE_REFERENCE = (GOMP_MAP_LAST | 2)
+ GOMP_MAP_FIRSTPRIVATE_REFERENCE = (GOMP_MAP_LAST | 2),
+ /* An attach or detach operation. Rewritten to the appropriate type during
+ gimplification, depending on directive (i.e. "enter data" or
+ parallel/kernels region vs. "exit data"). */
+ GOMP_MAP_ATTACH_DETACH = (GOMP_MAP_LAST | 3)
};
#define GOMP_MAP_COPY_TO_P(X) \
@@ -1,3 +1,14 @@
+2019-07-10 Julian Brown <julian@codesourcery.com>
+
+ * oacc-parallel.c (GOACC_enter_exit_data): Fix optional arguments for
+ changes to clause stripping in enter data/exit data directives.
+ * 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.
+ * testsuite/libgomp.oacc-fortran/derivedtype-1.f95: New test.
+ * testsuite/libgomp.oacc-fortran/derivedtype-2.f95: New test.
+ * testsuite/libgomp.oacc-fortran/multidim-slice.f95: New test.
+
2019-05-28 Julian Brown <julian@codesourcery.com>
* testsuite/libgomp.oacc-fortran/gangprivate-attrib-2.f90: New test.
@@ -550,7 +550,8 @@ GOACC_enter_exit_data (int flags_m, size_t mapnum,
break;
case GOMP_MAP_TO:
case GOMP_MAP_FORCE_TO:
- acc_copyin_async (hostaddrs[i], sizes[i], async);
+ if (hostaddrs[i])
+ acc_copyin_async (hostaddrs[i], sizes[i], async);
break;
case GOMP_MAP_STRUCT:
{
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -0,0 +1,30 @@
+! { dg-do run }
+
+program main
+ implicit none
+
+ type mytype
+ integer :: a, b, c
+ end type mytype
+
+ type(mytype) :: myvar
+ integer :: i
+
+ myvar%a = 0
+ myvar%b = 0
+ myvar%c = 0
+
+!$acc enter data copyin(myvar)
+
+!$acc parallel present(myvar)
+ myvar%a = 1
+ myvar%b = 2
+ myvar%c = 3
+!$acc end parallel
+
+!$acc exit data copyout(myvar)
+
+ if (myvar%a .ne. 1) stop 1
+ if (myvar%b .ne. 2) stop 2
+ if (myvar%c .ne. 3) stop 3
+end program main
new file mode 100644
@@ -0,0 +1,41 @@
+! { dg-do run }
+
+program main
+ implicit none
+
+ type tnest
+ integer :: ia, ib, ic
+ end type tnest
+
+ type mytype
+ type(tnest) :: nest
+ integer :: a, b, c
+ end type mytype
+
+ type(mytype) :: myvar
+ integer :: i
+
+ myvar%a = 0
+ myvar%b = 0
+ myvar%c = 0
+ myvar%nest%ia = 0
+ myvar%nest%ib = 0
+ myvar%nest%ic = 0
+
+!$acc enter data copyin(myvar%nest)
+
+!$acc parallel present(myvar%nest)
+ myvar%nest%ia = 4
+ myvar%nest%ib = 5
+ myvar%nest%ic = 6
+!$acc end parallel
+
+!$acc exit data copyout(myvar%nest)
+
+ if (myvar%a .ne. 0) stop 1
+ if (myvar%b .ne. 0) stop 2
+ if (myvar%c .ne. 0) stop 3
+ if (myvar%nest%ia .ne. 4) stop 4
+ if (myvar%nest%ib .ne. 5) stop 5
+ if (myvar%nest%ic .ne. 6) stop 6
+end program main
new file mode 100644
@@ -0,0 +1,50 @@
+! { dg-do run }
+
+program main
+ implicit none
+ real, allocatable :: myarr(:,:,:,:,:)
+ integer i, j, k, l, m
+
+ allocate(myarr(1:10,1:10,1:10,1:10,1:10))
+
+ do i=1,10
+ do j=1,10
+ do k=1,10
+ do l=1,10
+ do m=1,10
+ myarr(m,l,k,j,i) = i+j+k+l+m
+ end do
+ end do
+ end do
+ end do
+ end do
+
+ do i=1,10
+ !$acc data copy(myarr(:,:,:,:,i))
+ !$acc parallel loop collapse(4) present(myarr(:,:,:,:,i))
+ do j=1,10
+ do k=1,10
+ do l=1,10
+ do m=1,10
+ myarr(m,l,k,j,i) = myarr(m,l,k,j,i) + 1
+ end do
+ end do
+ end do
+ end do
+ !$acc end parallel loop
+ !$acc end data
+ end do
+
+ do i=1,10
+ do j=1,10
+ do k=1,10
+ do l=1,10
+ do m=1,10
+ if (myarr(m,l,k,j,i) .ne. i+j+k+l+m+1) stop 1
+ end do
+ end do
+ end do
+ end do
+ end do
+
+end program main
--
2.22.0
This patch provides initial support for Fortran 2003 polymorphic class pointers in OpenACC. This necessitated some rewriting of the lowering code in gfc_trans_omp_clauses, partly reverting some of the changes made by the earlier manual deep copy support. In the new code, I've tried to reuse existing lowering code in the Fortran front-end where appropriate. The main changes can be summarised thus: 1. Polymorphic class pointers can be used in OpenACC data-mapping clauses. Class descriptors (comprising a _data pointer and a _vptr virtual-table pointer) are mapped using GOMP_MAP_TO_PSET, in a similar way to the existing support for array descriptors. 2. For OpenACC, a new internal-only gomp_map_kind has been introduced when mapping derived-type pointer components, GOMP_MAP_ATTACH_DETACH, instead of hijacking GOMP_MAP_ALWAYS_POINTER for attach/detach operations then rewriting it in gimplify.c. This cleans up some code paths and hopefully self-documents better. 3. OpenACC "enter data" and "exit data" now have GOMP_MAP_POINTER and GOMP_MAP_PSET mappings removed during gimplification. In some circumstances, passing an array to a function/subroutine and then doing an "enter data" on it could leave dangling references to the function's stack, although the actual array data is defined outside the function. In any case, the pointer/pointer-set mappings don't seem to be necessary for OpenACC "enter data". Tested with offloading to nvptx. I will apply shortly (to the openacc-gcc-9-branch). Thanks, Julian ChangeLog gcc/ * gimplify.c (insert_struct_comp_map): Handle GOMP_MAP_ATTACH_DETACH. (gimplify_scan_omp_clauses): Separate out handling of OACC_ENTER_DATA and OACC_EXIT_DATA. Remove GOMP_MAP_POINTER and GOMP_MAP_TO_PSET mappings, apart from those following GOMP_MAP_DECLARE_{,DE}ALLOCATE. Handle GOMP_MAP_ATTACH_DETACH. * tree-pretty-print.c (dump_omp_clause): Support GOMP_MAP_ATTACH_DETACH. Print "bias" not "len" for attach/detach clause types. include/ * gomp-constants.h (gomp_map_kind): Add GOMP_MAP_ATTACH_DETACH. gcc/c/ * c-typeck.c (handle_omp_array_sections): Use GOMP_MAP_ATTACH_DETACH for OpenACC attach/detach operations. gcc/cp/ * semantics.c (handle_omp_array_sections): Likewise. (finish_omp_clauses): Handle GOMP_MAP_ATTACH_DETACH. gcc/fortran/ * openmp.c (resolve_oacc_data_clauses): Allow polymorphic allocatable variables. * trans-expr.c (gfc_conv_component_ref, conv_parent_component_reference): Make global. (gfc_auto_dereference_var): New function, broken out of... (gfc_conv_variable): ...here. Call outlined function instead. * trans-openmp.c (gfc_trans_omp_array_section): New function, broken out of... (gfc_trans_omp_clauses): ...here. Separate out OpenACC derived type/polymorphic class pointer handling. Call above outlined function. * trans.h (gfc_conv_component_ref, conv_parent_component_references, gfc_auto_dereference_var): Add prototypes. gcc/testsuite/ * c-c++-common/goacc/mdc-1.c: Update clause matching patterns. libgomp/ * oacc-parallel.c (GOACC_enter_exit_data): Fix optional arguments for changes to clause stripping in enter data/exit data directives. * 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. * testsuite/libgomp.oacc-fortran/derivedtype-1.f95: New test. * testsuite/libgomp.oacc-fortran/derivedtype-2.f95: New test. * testsuite/libgomp.oacc-fortran/multidim-slice.f95: New test.