@@ -910,6 +910,8 @@ show_attr (symbol_attribute *attr, const char * module)
fputs (" PDT-STRING", dumpfile);
if (attr->omp_udr_artificial_var)
fputs (" OMP-UDR-ARTIFICIAL-VAR", dumpfile);
+ if (attr->omp_udm_artificial_var)
+ fputs (" OMP-UDM-ARTIFICIAL-VAR", dumpfile);
if (attr->omp_declare_target)
fputs (" OMP-DECLARE-TARGET", dumpfile);
if (attr->omp_declare_target_link)
@@ -1487,6 +1489,8 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
fputs ("always,present,tofrom:", dumpfile); break;
case OMP_MAP_DELETE: fputs ("delete:", dumpfile); break;
case OMP_MAP_RELEASE: fputs ("release:", dumpfile); break;
+ case OMP_MAP_POINTER_ONLY: fputs ("pointeronly:", dumpfile); break;
+ case OMP_MAP_UNSET: fputs ("unset:", dumpfile); break;
default: break;
}
else if (list_type == OMP_LIST_LINEAR && n->u.linear.old_modifier)
@@ -136,6 +136,9 @@ gfc_get_sarif_source_language (const char *)
#undef LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR
#undef LANG_HOOKS_OMP_CLAUSE_DTOR
#undef LANG_HOOKS_OMP_FINISH_CLAUSE
+#undef LANG_HOOKS_OMP_FINISH_MAPPER_CLAUSES
+#undef LANG_HOOKS_OMP_EXTRACT_MAPPER_DIRECTIVE
+#undef LANG_HOOKS_OMP_MAP_ARRAY_SECTION
#undef LANG_HOOKS_OMP_ALLOCATABLE_P
#undef LANG_HOOKS_OMP_SCALAR_TARGET_P
#undef LANG_HOOKS_OMP_SCALAR_P
@@ -176,6 +179,10 @@ gfc_get_sarif_source_language (const char *)
#define LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR gfc_omp_clause_linear_ctor
#define LANG_HOOKS_OMP_CLAUSE_DTOR gfc_omp_clause_dtor
#define LANG_HOOKS_OMP_FINISH_CLAUSE gfc_omp_finish_clause
+#define LANG_HOOKS_OMP_FINISH_MAPPER_CLAUSES gfc_omp_finish_mapper_clauses
+#define LANG_HOOKS_OMP_EXTRACT_MAPPER_DIRECTIVE \
+ gfc_omp_extract_mapper_directive
+#define LANG_HOOKS_OMP_MAP_ARRAY_SECTION gfc_omp_map_array_section
#define LANG_HOOKS_OMP_ALLOCATABLE_P gfc_omp_allocatable_p
#define LANG_HOOKS_OMP_SCALAR_P gfc_omp_scalar_p
#define LANG_HOOKS_OMP_SCALAR_TARGET_P gfc_omp_scalar_target_p
@@ -272,8 +272,9 @@ enum gfc_statement
ST_OMP_TASKWAIT, ST_OMP_TASKYIELD, ST_OMP_CANCEL, ST_OMP_CANCELLATION_POINT,
ST_OMP_TASKGROUP, ST_OMP_END_TASKGROUP, ST_OMP_SIMD, ST_OMP_END_SIMD,
ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD,
- ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_REDUCTION,
- ST_OMP_TARGET, ST_OMP_END_TARGET, ST_OMP_TARGET_DATA, ST_OMP_END_TARGET_DATA,
+ ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_MAPPER,
+ ST_OMP_DECLARE_REDUCTION, ST_OMP_TARGET, ST_OMP_END_TARGET,
+ ST_OMP_TARGET_DATA, ST_OMP_END_TARGET_DATA,
ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET, ST_OMP_DECLARE_VARIANT,
ST_OMP_TEAMS, ST_OMP_END_TEAMS, ST_OMP_DISTRIBUTE, ST_OMP_END_DISTRIBUTE,
ST_OMP_DISTRIBUTE_SIMD, ST_OMP_END_DISTRIBUTE_SIMD,
@@ -996,6 +997,10 @@ typedef struct
!$OMP DECLARE REDUCTION. */
unsigned omp_udr_artificial_var:1;
+ /* This is a placeholder variable used in an !$OMP DECLARE MAPPER
+ directive. */
+ unsigned omp_udm_artificial_var:1;
+
/* Mentioned in OMP DECLARE TARGET. */
unsigned omp_declare_target:1;
unsigned omp_declare_target_link:1;
@@ -1315,7 +1320,9 @@ enum gfc_omp_map_op
OMP_MAP_PRESENT_TOFROM,
OMP_MAP_ALWAYS_PRESENT_TO,
OMP_MAP_ALWAYS_PRESENT_FROM,
- OMP_MAP_ALWAYS_PRESENT_TOFROM
+ OMP_MAP_ALWAYS_PRESENT_TOFROM,
+ OMP_MAP_POINTER_ONLY,
+ OMP_MAP_UNSET
};
enum gfc_omp_defaultmap
@@ -1375,6 +1382,7 @@ typedef struct gfc_omp_namelist
union
{
struct gfc_omp_namelist_udr *udr;
+ struct gfc_omp_namelist_udm *udm;
gfc_namespace *ns;
gfc_expr *allocator;
struct gfc_symbol *traits_sym;
@@ -1565,6 +1573,7 @@ typedef struct gfc_omp_clauses
struct gfc_expr *message;
struct gfc_omp_assumptions *assume;
const char *critical_name;
+ gfc_namespace *ns;
enum gfc_omp_default_sharing default_sharing;
enum gfc_omp_atomic_op atomic_op;
enum gfc_omp_defaultmap defaultmap[OMP_DEFAULTMAP_CAT_NUM];
@@ -1735,6 +1744,38 @@ typedef struct gfc_omp_namelist_udr
gfc_omp_namelist_udr;
#define gfc_get_omp_namelist_udr() XCNEW (gfc_omp_namelist_udr)
+
+typedef struct gfc_omp_udm
+{
+ struct gfc_omp_udm *next;
+ locus where; /* Where the !$omp declare mapper construct occurred. */
+
+ const char *mapper_id;
+ gfc_typespec ts;
+
+ struct gfc_symbol *var_sym;
+ struct gfc_namespace *mapper_ns;
+
+ /* We probably don't need a whole gfc_omp_clauses here. We only use the
+ OMP_LIST_MAP clause list. */
+ gfc_omp_clauses *clauses;
+
+ tree backend_decl;
+}
+gfc_omp_udm;
+#define gfc_get_omp_udm() XCNEW (gfc_omp_udm)
+
+typedef struct gfc_omp_namelist_udm
+{
+ /* Used to store mapper_id before resolution. */
+ const char *mapper_id;
+
+ bool multiple_elems_p;
+ struct gfc_omp_udm *udm;
+}
+gfc_omp_namelist_udm;
+#define gfc_get_omp_namelist_udm() XCNEW (gfc_omp_namelist_udm)
+
/* The gfc_st_label structure is a BBT attached to a namespace that
records the usage of statement labels within that space. */
@@ -2066,6 +2107,7 @@ typedef struct gfc_symtree
gfc_common_head *common;
gfc_typebound_proc *tb;
gfc_omp_udr *omp_udr;
+ gfc_omp_udm *omp_udm;
}
n;
}
@@ -2109,6 +2151,8 @@ typedef struct gfc_namespace
gfc_symtree *common_root;
/* Tree containing all the OpenMP user defined reductions. */
gfc_symtree *omp_udr_root;
+ /* Tree containing all the OpenMP user defined mappers. */
+ gfc_symtree *omp_udm_root;
/* Tree containing type-bound procedures. */
gfc_symtree *tb_sym_root;
@@ -2228,6 +2272,9 @@ typedef struct gfc_namespace
/* Set to 1 for !$OMP DECLARE REDUCTION namespaces. */
unsigned omp_udr_ns:1;
+ /* Set to 1 for !$OMP DECLARE MAPPER namespaces. */
+ unsigned omp_udm_ns:1;
+
/* Set to 1 for !$ACC ROUTINE namespaces. */
unsigned oacc_routine:1;
@@ -3187,6 +3234,7 @@ enum toc_directive
{
TOC_OPENMP,
TOC_OPENMP_DECLARE_SIMD,
+ TOC_OPENMP_DECLARE_MAPPER,
TOC_OPENMP_EXIT_DATA,
TOC_OPENACC,
TOC_OPENACC_DECLARE
@@ -3637,9 +3685,13 @@ void gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list);
void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
+void gfc_free_omp_udm (gfc_omp_udm *);
gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
void gfc_resolve_omp_allocate (gfc_namespace *, gfc_omp_namelist *);
void gfc_resolve_omp_assumptions (gfc_omp_assumptions *);
+gfc_omp_udm *gfc_omp_udm_find (gfc_symtree *, gfc_typespec *);
+gfc_omp_udm *gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id,
+ gfc_typespec *ts);
void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool);
void gfc_resolve_omp_local_vars (gfc_namespace *);
@@ -3647,6 +3699,10 @@ void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *);
void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
void gfc_resolve_omp_declare_simd (gfc_namespace *);
void gfc_resolve_omp_udrs (gfc_symtree *);
+void gfc_resolve_omp_udms (gfc_symtree *);
+void gfc_omp_instantiate_mappers (gfc_code *, gfc_omp_clauses *,
+ toc_directive = TOC_OPENMP,
+ int = OMP_LIST_MAP);
void gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *);
void gfc_omp_restore_state (struct gfc_omp_saved_state *);
void gfc_free_expr_list (gfc_expr_list *);
@@ -3896,6 +3952,7 @@ bool gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *,
/* trans.cc */
void gfc_generate_code (gfc_namespace *);
void gfc_generate_module_code (gfc_namespace *);
+location_t gfc_get_location (locus *);
/* trans-intrinsic.cc */
bool gfc_inline_intrinsic_function_p (gfc_expr *);
@@ -5539,6 +5539,9 @@ void
gfc_free_omp_namelist (gfc_omp_namelist *name, int list)
{
bool free_ns = (list == OMP_LIST_AFFINITY || list == OMP_LIST_DEPEND);
+ bool free_mapper = (list == OMP_LIST_MAP
+ || list == OMP_LIST_TO
+ || list == OMP_LIST_FROM);
bool free_align_allocator = (list == OMP_LIST_ALLOCATE);
bool free_mem_traits_space = (list == OMP_LIST_USES_ALLOCATORS);
gfc_omp_namelist *n;
@@ -5556,7 +5559,9 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, int list)
gfc_free_expr (name->u2.allocator);
else if (free_mem_traits_space)
{ } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */
- else if (name->u2.udr)
+ else if (free_mapper && name->u2.udm)
+ free (name->u2.udm);
+ else if (!free_mapper && name->u2.udr)
{
if (name->u2.udr->combiner)
gfc_free_statement (name->u2.udr->combiner);
@@ -158,6 +158,7 @@ match gfc_match_omp_barrier (void);
match gfc_match_omp_cancel (void);
match gfc_match_omp_cancellation_point (void);
match gfc_match_omp_critical (void);
+match gfc_match_omp_declare_mapper (void);
match gfc_match_omp_declare_reduction (void);
match gfc_match_omp_declare_simd (void);
match gfc_match_omp_declare_target (void);
@@ -2081,7 +2081,8 @@ enum ab_attribute
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
- AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET,
+ AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY,
+ AB_OMP_DECLARE_MAPPER_VAR, AB_OMP_DECLARE_TARGET,
AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
@@ -2149,6 +2150,7 @@ static const mstring attr_bits[] =
minit ("CLASS_POINTER", AB_CLASS_POINTER),
minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
+ minit ("OMP_DECLARE_MAPPER_VAR", AB_OMP_DECLARE_MAPPER_VAR),
minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY),
minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE),
@@ -2369,6 +2371,8 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
if (attr->vtab)
MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
+ if (attr->omp_udm_artificial_var)
+ MIO_NAME (ab_attribute) (AB_OMP_DECLARE_MAPPER_VAR, attr_bits);
if (attr->omp_declare_target)
MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
if (attr->array_outer_dependency)
@@ -2626,6 +2630,17 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_VTAB:
attr->vtab = 1;
break;
+ case AB_OMP_DECLARE_MAPPER_VAR:
+ attr->omp_udm_artificial_var = 1;
+ /* For the placeholder variable used in an !$OMP DECLARE MAPPER,
+ we don't know if the final clauses will reference used
+ variables or not, yet. Make sure the clause list doesn't get
+ skipped in trans-openmp.cc by forcing the variable referenced
+ attribute true here (else on reading the module, the symbol is
+ created with "referenced" false, and nothing else sets it to
+ true). */
+ attr->referenced = 1;
+ break;
case AB_OMP_DECLARE_TARGET:
attr->omp_declare_target = 1;
break;
@@ -5134,6 +5149,135 @@ load_omp_udrs (void)
}
+/* We only need some of the enumeration values of gfc_omp_map_op for mapping
+ ops in the "!$omp declare mapper" clause list. */
+
+static const mstring omp_map_clause_ops[] =
+{
+ minit ("ALLOC", OMP_MAP_ALLOC),
+ minit ("TO", OMP_MAP_TO),
+ minit ("FROM", OMP_MAP_FROM),
+ minit ("TOFROM", OMP_MAP_TOFROM),
+ minit ("ALWAYS_TO", OMP_MAP_ALWAYS_TO),
+ minit ("ALWAYS_FROM", OMP_MAP_ALWAYS_FROM),
+ minit ("ALWAYS_TOFROM", OMP_MAP_ALWAYS_TOFROM),
+ minit ("POINTER_ONLY", OMP_MAP_POINTER_ONLY),
+ minit ("UNSET", OMP_MAP_UNSET),
+ minit (NULL, -1)
+};
+
+
+/* Whether a namelist in an "!$omp declare mapper" maps a single element or
+ multiple elements. */
+
+static const mstring omp_map_cardinality[] =
+{
+ minit ("SINGLE", 0),
+ minit ("MULTIPLE", 1),
+ minit (NULL, -1)
+};
+
+/* This function loads OpenMP user-defined mappers. */
+
+static void
+load_omp_udms (void)
+{
+ mio_lparen ();
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ const char *mapper_id = NULL;
+ gfc_symtree *st;
+
+ mio_lparen ();
+ gfc_omp_udm *udm = gfc_get_omp_udm ();
+
+ require_atom (ATOM_INTEGER);
+ pointer_info *udmpi = get_integer (atom_int);
+ associate_integer_pointer (udmpi, udm);
+
+ mio_pool_string (&mapper_id);
+
+ /* Note: for a derived-type typespec, we might not have loaded the
+ "u.derived" symbol yet. Defer checking duplicates until
+ check_omp_declare_mappers is called after loading all symbols. */
+ mio_typespec (&udm->ts);
+
+ if (mapper_id == NULL)
+ mapper_id = gfc_get_string ("%s", "");
+
+ st = gfc_find_symtree (gfc_current_ns->omp_udm_root, mapper_id);
+
+ pointer_info *p = mio_symbol_ref (&udm->var_sym);
+ pointer_info *q = get_integer (p->u.rsym.ns);
+
+ udm->where = gfc_current_locus;
+ udm->mapper_id = mapper_id;
+ udm->mapper_ns = gfc_get_namespace (gfc_current_ns, 1);
+ udm->mapper_ns->proc_name = gfc_current_ns->proc_name;
+ udm->mapper_ns->omp_udm_ns = 1;
+
+ associate_integer_pointer (q, udm->mapper_ns);
+
+ gfc_omp_namelist *clauses = NULL;
+ gfc_omp_namelist **clausep = &clauses;
+
+ mio_lparen ();
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ /* Read each map clause. */
+ gfc_omp_namelist *n = gfc_get_omp_namelist ();
+
+ mio_lparen ();
+
+ n->u.map_op = (gfc_omp_map_op) mio_name (0, omp_map_clause_ops);
+ mio_symbol_ref (&n->sym);
+ mio_expr (&n->expr);
+
+ mio_lparen ();
+
+ if (peek_atom () != ATOM_RPAREN)
+ {
+ n->u2.udm = gfc_get_omp_namelist_udm ();
+ mio_pool_string (&n->u2.udm->mapper_id);
+
+ if (n->u2.udm->mapper_id == NULL)
+ n->u2.udm->mapper_id = gfc_get_string ("%s", "");
+
+ n->u2.udm->multiple_elems_p = mio_name (0, omp_map_cardinality);
+ mio_pointer_ref (&n->u2.udm->udm);
+ }
+
+ mio_rparen ();
+
+ n->where = gfc_current_locus;
+
+ mio_rparen ();
+
+ *clausep = n;
+ clausep = &n->next;
+ }
+ mio_rparen ();
+
+ udm->clauses = gfc_get_omp_clauses ();
+ udm->clauses->lists[OMP_LIST_MAP] = clauses;
+
+ if (st)
+ {
+ udm->next = st->n.omp_udm;
+ st->n.omp_udm = udm;
+ }
+ else
+ {
+ st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id);
+ st->n.omp_udm = udm;
+ }
+
+ mio_rparen ();
+ }
+ mio_rparen ();
+}
+
+
/* Recursive function to traverse the pointer_info tree and load a
needed symbol. We return nonzero if we load a symbol and stop the
traversal, because the act of loading can alter the tree. */
@@ -5324,12 +5468,44 @@ check_for_ambiguous (gfc_symtree *st, pointer_info *info)
}
+static void
+check_omp_declare_mappers (gfc_symtree *st)
+{
+ if (!st)
+ return;
+
+ check_omp_declare_mappers (st->left);
+ check_omp_declare_mappers (st->right);
+
+ gfc_omp_udm **udmp = &st->n.omp_udm;
+ gfc_symtree tmp_st;
+
+ while (*udmp)
+ {
+ gfc_omp_udm *udm = *udmp;
+ tmp_st.n.omp_udm = udm->next;
+ gfc_omp_udm *prev_udm = gfc_omp_udm_find (&tmp_st, &udm->ts);
+ if (prev_udm)
+ {
+ gfc_error ("Ambiguous !$OMP DECLARE MAPPER from module %s at %L",
+ udm->ts.u.derived->module, &udm->where);
+ gfc_error ("Previous !$OMP DECLARE MAPPER from module %s at %L",
+ prev_udm->ts.u.derived->module, &prev_udm->where);
+ /* Delete the duplicate. */
+ *udmp = (*udmp)->next;
+ }
+ else
+ udmp = &(*udmp)->next;
+ }
+}
+
+
/* Read a module file. */
static void
read_module (void)
{
- module_locus operator_interfaces, user_operators, omp_udrs;
+ module_locus operator_interfaces, user_operators, omp_udrs, omp_udms;
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1];
int i;
@@ -5356,6 +5532,10 @@ read_module (void)
get_module_locus (&omp_udrs);
skip_list ();
+ /* Skip OpenMP UDMs. */
+ get_module_locus (&omp_udms);
+ skip_list ();
+
mio_lparen ();
/* Create the fixup nodes for all the symbols. */
@@ -5690,6 +5870,10 @@ read_module (void)
set_module_locus (&omp_udrs);
load_omp_udrs ();
+ /* Load OpenMP user defined mappers. */
+ set_module_locus (&omp_udms);
+ load_omp_udms ();
+
/* At this point, we read those symbols that are needed but haven't
been loaded yet. If one symbol requires another, the other gets
marked as NEEDED if its previous state was UNUSED. */
@@ -5722,6 +5906,9 @@ read_module (void)
module_name);
}
+ /* Check "omp declare mappers" for duplicates from different modules. */
+ check_omp_declare_mappers (gfc_current_ns->omp_udm_root);
+
/* Clean up symbol nodes that were never loaded, create references
to hidden symbols. */
@@ -6100,6 +6287,66 @@ write_omp_udrs (gfc_symtree *st)
}
+static void
+write_omp_udm (gfc_omp_udm *udm)
+{
+ /* If "!$omp declare mapper" type is private, don't write it. */
+ if (!gfc_check_symbol_access (udm->ts.u.derived))
+ return;
+
+ mio_lparen ();
+ /* We need this pointer ref to identify this mapper so that other mappers
+ can refer to it. */
+ mio_pointer_ref (&udm);
+ mio_pool_string (&udm->mapper_id);
+ mio_typespec (&udm->ts);
+
+ if (udm->var_sym->module == NULL)
+ udm->var_sym->module = module_name;
+
+ mio_symbol_ref (&udm->var_sym);
+ mio_lparen ();
+ gfc_omp_namelist *n;
+ for (n = udm->clauses->lists[OMP_LIST_MAP]; n; n = n->next)
+ {
+ mio_lparen ();
+
+ mio_name (n->u.map_op, omp_map_clause_ops);
+ mio_symbol_ref (&n->sym);
+ mio_expr (&n->expr);
+
+ mio_lparen ();
+
+ if (n->u2.udm)
+ {
+ mio_pool_string (&n->u2.udm->mapper_id);
+ mio_name (n->u2.udm->multiple_elems_p, omp_map_cardinality);
+ mio_pointer_ref (&n->u2.udm->udm);
+ }
+
+ mio_rparen ();
+
+ mio_rparen ();
+ }
+ mio_rparen ();
+ mio_rparen ();
+}
+
+
+static void
+write_omp_udms (gfc_symtree *st)
+{
+ if (st == NULL)
+ return;
+
+ write_omp_udms (st->left);
+ gfc_omp_udm *udm;
+ for (udm = st->n.omp_udm; udm; udm = udm->next)
+ write_omp_udm (udm);
+ write_omp_udms (st->right);
+}
+
+
/* Type for the temporary tree used when writing secondary symbols. */
struct sorted_pointer_info
@@ -6361,6 +6608,12 @@ write_module (void)
write_char ('\n');
write_char ('\n');
+ mio_lparen ();
+ write_omp_udms (gfc_current_ns->omp_udm_root);
+ mio_rparen ();
+ write_char ('\n');
+ write_char ('\n');
+
/* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written.
Sometimes writing one symbol will cause another to need to be
@@ -335,6 +335,19 @@ gfc_free_omp_udr (gfc_omp_udr *omp_udr)
}
+/* Free an !$omp declare mapper. */
+
+void
+gfc_free_omp_udm (gfc_omp_udm *omp_udm)
+{
+ if (omp_udm)
+ {
+ gfc_free_omp_udm (omp_udm->next);
+ gfc_free_namespace (omp_udm->mapper_ns);
+ free (omp_udm);
+ }
+}
+
static gfc_omp_udr *
gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
{
@@ -1854,6 +1867,44 @@ gfc_match_dupl_atomic (bool not_dupl, const char *name)
"clause at %L");
}
+
+/* Search upwards though namespace NS and its parents to find an
+ !$omp declare mapper named MAPPER_ID, for typespec TS. */
+
+gfc_omp_udm *
+gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id, gfc_typespec *ts)
+{
+ gfc_symtree *st;
+
+ if (ns == NULL)
+ ns = gfc_current_ns;
+
+ do
+ {
+ gfc_omp_udm *omp_udm;
+
+ st = gfc_find_symtree (ns->omp_udm_root, mapper_id);
+
+ if (st != NULL)
+ {
+ for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
+ if (gfc_compare_types (&omp_udm->ts, ts))
+ return omp_udm;
+ }
+
+ /* Don't escape an interface block. */
+ if (ns && !ns->has_import_set
+ && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ break;
+
+ ns = ns->parent;
+ }
+ while (ns != NULL);
+
+ return NULL;
+}
+
+
/* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
clauses that are allowed for a particular directive. */
@@ -1861,7 +1912,8 @@ static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
bool first = true, bool needs_space = true,
bool openacc = false, bool context_selector = false,
- bool openmp_target = false)
+ bool openmp_target = false,
+ gfc_omp_map_op default_map_op = OMP_MAP_TOFROM)
{
bool error = false;
gfc_omp_clauses *c = gfc_get_omp_clauses ();
@@ -3012,9 +3064,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
int always_modifier = 0;
int close_modifier = 0;
int present_modifier = 0;
+ int mapper_modifier = 0;
locus second_always_locus = old_loc2;
locus second_close_locus = old_loc2;
+ locus second_mapper_locus = old_loc2;
locus second_present_locus = old_loc2;
+ char mapper_id[GFC_MAX_SYMBOL_LEN + 1] = { '\0' };
for (;;)
{
@@ -3034,12 +3089,22 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
if (present_modifier++ == 1)
second_present_locus = current_locus;
}
+ else if (gfc_match ("mapper ( ") == MATCH_YES)
+ {
+ if (mapper_modifier++ == 1)
+ second_mapper_locus = current_locus;
+ m = gfc_match (" %n ) ", mapper_id);
+ if (m != MATCH_YES)
+ goto error;
+ if (strcmp (mapper_id, "default") == 0)
+ mapper_id[0] = '\0';
+ }
else
break;
gfc_match (", ");
}
- gfc_omp_map_op map_op = OMP_MAP_TOFROM;
+ gfc_omp_map_op map_op = default_map_op;
int always_present_modifier
= always_modifier && present_modifier;
@@ -3070,6 +3135,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
gfc_current_locus = old_loc2;
always_modifier = 0;
close_modifier = 0;
+ mapper_modifier = 0;
}
if (always_modifier > 1)
@@ -3090,6 +3156,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
&second_present_locus);
break;
}
+ if (mapper_modifier > 1)
+ {
+ gfc_error ("too many %<mapper%> modifiers at %L",
+ &second_mapper_locus);
+ break;
+ }
head = NULL;
if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
@@ -3098,7 +3170,15 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
{
gfc_omp_namelist *n;
for (n = *head; n; n = n->next)
- n->u.map_op = map_op;
+ {
+ n->u.map_op = map_op;
+ if (mapper_id[0] != '\0')
+ {
+ n->u2.udm = gfc_get_omp_namelist_udm ();
+ n->u2.udm->mapper_id
+ = gfc_get_string ("%s", mapper_id);
+ }
+ }
continue;
}
gfc_current_locus = old_loc;
@@ -4978,6 +5058,153 @@ gfc_match_omp_declare_simd (void)
}
+/* Find a matching "!$omp declare mapper" for typespec TS in symtree ST. */
+
+gfc_omp_udm *
+gfc_omp_udm_find (gfc_symtree *st, gfc_typespec *ts)
+{
+ gfc_omp_udm *omp_udm;
+
+ if (st == NULL)
+ return NULL;
+
+ for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
+ if ((omp_udm->ts.type == BT_DERIVED || omp_udm->ts.type == BT_CLASS)
+ && (ts->type == BT_DERIVED || ts->type == BT_CLASS)
+ && strcmp (omp_udm->ts.u.derived->name, ts->u.derived->name) == 0)
+ return omp_udm;
+
+ return NULL;
+}
+
+
+match
+gfc_match_omp_declare_mapper (void)
+{
+ match m;
+ gfc_typespec ts;
+ char mapper_id[GFC_MAX_SYMBOL_LEN + 1];
+ char var[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_namespace *mapper_ns = NULL;
+ gfc_symtree *var_st;
+ gfc_symtree *st;
+ gfc_omp_udm *omp_udm = NULL, *prev_udm = NULL;
+ locus where = gfc_current_locus;
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ return MATCH_ERROR;
+
+ locus old_locus = gfc_current_locus;
+
+ m = gfc_match (" %n : ", mapper_id);
+
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ /* As a special case, a mapper named "default" and an unnamed mapper are
+ both the default mapper for a given type. */
+ if (strcmp (mapper_id, "default") == 0)
+ mapper_id[0] = '\0';
+
+ if (gfc_peek_ascii_char () == ':')
+ {
+ /* If we see '::', the user did not name the mapper, and instead we just
+ saw the type. So backtrack and try parsing as a type instead. */
+ mapper_id[0] = '\0';
+ gfc_current_locus = old_locus;
+ }
+
+ /* This accepts 't' but not e.g. 'type(t)'. Is that correct? */
+ m = gfc_match_type_spec (&ts);
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (ts.type != BT_DERIVED)
+ {
+ gfc_error_now ("!$OMP DECLARE MAPPER with non-derived type at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" :: ") != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match_name (var) != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match_char (')') != MATCH_YES)
+ return MATCH_ERROR;
+
+ st = gfc_find_symtree (gfc_current_ns->omp_udm_root, mapper_id);
+
+ /* Now we need to set up a new namespace, and create a new sym_tree for our
+ dummy variable so we can use it in the following list of mapping
+ clauses. */
+
+ gfc_current_ns = mapper_ns = gfc_get_namespace (gfc_current_ns, 1);
+ mapper_ns->proc_name = mapper_ns->parent->proc_name;
+ mapper_ns->omp_udm_ns = 1;
+
+ gfc_get_sym_tree (var, mapper_ns, &var_st, false);
+ var_st->n.sym->ts = ts;
+ var_st->n.sym->attr.omp_udm_artificial_var = 1;
+ var_st->n.sym->attr.flavor = FL_VARIABLE;
+ gfc_commit_symbols ();
+
+ gfc_omp_clauses *clauses = NULL;
+
+ m = gfc_match_omp_clauses (&clauses, omp_mask (OMP_CLAUSE_MAP), true, true,
+ false, false, OMP_MAP_UNSET);
+ if (m != MATCH_YES)
+ goto failure;
+
+ omp_udm = gfc_get_omp_udm ();
+ omp_udm->next = NULL;
+ omp_udm->where = where;
+ omp_udm->mapper_id = gfc_get_string ("%s", mapper_id);
+ omp_udm->ts = ts;
+ omp_udm->var_sym = var_st->n.sym;
+ omp_udm->mapper_ns = mapper_ns;
+ omp_udm->clauses = clauses;
+
+ gfc_current_ns = mapper_ns->parent;
+
+ prev_udm = gfc_omp_udm_find (st, &ts);
+ if (prev_udm)
+ {
+ gfc_error_now ("Redefinition of !$OMP DECLARE MAPPER at %L", &where);
+ gfc_error_now ("Previous !$OMP DECLARE MAPPER at %L", &prev_udm->where);
+ }
+ else if (st)
+ {
+ omp_udm->next = st->n.omp_udm;
+ st->n.omp_udm = omp_udm;
+ }
+ else
+ {
+ st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id);
+ st->n.omp_udm = omp_udm;
+ }
+
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after !$OMP DECLARE MAPPER at %C");
+ gfc_current_locus = where;
+ return MATCH_ERROR;
+ }
+
+ return MATCH_YES;
+
+failure:
+ if (mapper_ns)
+ gfc_current_ns = mapper_ns->parent;
+ gfc_free_omp_udm (omp_udm);
+
+ gfc_clear_error ();
+
+ return MATCH_ERROR;
+}
+
+
static bool
match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
{
@@ -7315,7 +7542,7 @@ gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
}
/* Check OMP_CLAUSES for duplicate symbols and various other constraints.
- Helper function for resolve_omp_clauses. */
+ Helper function for resolve_omp_clauses and resolve_omp_mapper_clauses. */
static void
omp_verify_clauses_symbol_dups (gfc_code *code, gfc_omp_clauses *omp_clauses,
@@ -7710,7 +7937,8 @@ omp_verify_clauses_symbol_dups (gfc_code *code, gfc_omp_clauses *omp_clauses,
}
/* Check that the parameter of a MAP, TO and FROM clause N meets certain
- constraints. Helper function for resolve_omp_clauses. */
+ constraints. Helper function for resolve_omp_clauses and
+ resolve_omp_mapper_clauses. */
static bool
omp_verify_map_motion_clauses (gfc_code *code, int list, const char *name,
@@ -7973,6 +8201,11 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
if (omp_clauses->order_concurrent && omp_clauses->ordered)
gfc_error ("ORDER clause must not be used together ORDERED at %L",
&code->loc);
+ /* If we're invoking any declared mappers as a result of these clauses, we may
+ need to know the namespace their directive was originally defined within in
+ order to resolve clauses again after substitution. Record it here. */
+ if (ns)
+ omp_clauses->ns = ns;
if (omp_clauses->if_expr)
{
gfc_expr *expr = omp_clauses->if_expr;
@@ -8359,6 +8592,36 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
if (!omp_verify_map_motion_clauses (code, list, name, n,
openacc))
break;
+ if (list == OMP_LIST_MAP
+ || list == OMP_LIST_TO
+ || list == OMP_LIST_FROM)
+ {
+ gfc_typespec *ts;
+
+ if (n->expr)
+ ts = &n->expr->ts;
+ else
+ ts = &n->sym->ts;
+
+ const char *mapper_id
+ = n->u2.udm ? n->u2.udm->mapper_id : "";
+
+ gfc_omp_udm *udm = gfc_find_omp_udm (gfc_current_ns,
+ mapper_id, ts);
+ if (mapper_id[0] != '\0' && !udm)
+ gfc_error ("User-defined mapper %qs not found at %L",
+ mapper_id, &n->where);
+ else if (udm)
+ {
+ if (!n->u2.udm)
+ {
+ n->u2.udm = gfc_get_omp_namelist_udm ();
+ gcc_assert (mapper_id[0] == '\0');
+ n->u2.udm->mapper_id = mapper_id;
+ }
+ n->u2.udm->udm = udm;
+ }
+ }
}
if (list != OMP_LIST_DEPEND)
@@ -8963,6 +9226,47 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
}
+/* This very simplified version of the above function is for use after mapper
+ instantiation. It avoids dealing with anything other than basic
+ verification for map/to/from clauses. */
+
+static void
+resolve_omp_mapper_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
+ gfc_namespace *ns)
+{
+ gfc_omp_namelist *n;
+ int list;
+
+ omp_verify_clauses_symbol_dups (code, omp_clauses, ns, false);
+
+ for (list = OMP_LIST_MAP; list <= OMP_LIST_FROM; list++)
+ if ((n = omp_clauses->lists[list]) != NULL)
+ {
+ const char *name = NULL;
+ switch (list)
+ {
+ case OMP_LIST_MAP:
+ if (name == NULL)
+ name = "MAP";
+ /* Fallthrough. */
+ case OMP_LIST_TO:
+ if (name == NULL)
+ name = "TO";
+ /* Fallthrough. */
+ case OMP_LIST_FROM:
+ if (name == NULL)
+ name = "FROM";
+ for (; n != NULL; n = n->next)
+ if (!omp_verify_map_motion_clauses (code, list, name, n, false))
+ break;
+ break;
+ default:
+ ;
+ }
+ }
+}
+
+
/* Return true if SYM is ever referenced in EXPR except in the SE node. */
static bool
@@ -10799,11 +11103,11 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_WORKSHARE:
case EXEC_OMP_DEPOBJ:
if (code->ext.omp_clauses)
- resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
+ resolve_omp_clauses (code, code->ext.omp_clauses, ns);
break;
case EXEC_OMP_TARGET_UPDATE:
if (code->ext.omp_clauses)
- resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
+ resolve_omp_clauses (code, code->ext.omp_clauses, ns);
if (code->ext.omp_clauses == NULL
|| (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
&& code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
@@ -10999,3 +11303,471 @@ gfc_resolve_omp_udrs (gfc_symtree *st)
for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
gfc_resolve_omp_udr (omp_udr);
}
+
+static enum gfc_omp_map_op
+omp_split_map_op (enum gfc_omp_map_op op, bool *force_p, bool *always_p,
+ bool *present_p)
+{
+ *force_p = *always_p = *present_p = false;
+
+ switch (op)
+ {
+ case OMP_MAP_FORCE_ALLOC:
+ case OMP_MAP_FORCE_TO:
+ case OMP_MAP_FORCE_FROM:
+ case OMP_MAP_FORCE_TOFROM:
+ case OMP_MAP_FORCE_PRESENT:
+ *force_p = true;
+ break;
+ case OMP_MAP_ALWAYS_TO:
+ case OMP_MAP_ALWAYS_FROM:
+ case OMP_MAP_ALWAYS_TOFROM:
+ *always_p = true;
+ break;
+ case OMP_MAP_ALWAYS_PRESENT_TO:
+ case OMP_MAP_ALWAYS_PRESENT_FROM:
+ case OMP_MAP_ALWAYS_PRESENT_TOFROM:
+ *always_p = true;
+ /* Fallthrough. */
+ case OMP_MAP_PRESENT_ALLOC:
+ case OMP_MAP_PRESENT_TO:
+ case OMP_MAP_PRESENT_FROM:
+ case OMP_MAP_PRESENT_TOFROM:
+ *present_p = true;
+ break;
+ default:
+ ;
+ }
+
+ switch (op)
+ {
+ case OMP_MAP_ALLOC:
+ case OMP_MAP_FORCE_ALLOC:
+ case OMP_MAP_PRESENT_ALLOC:
+ return OMP_MAP_ALLOC;
+ case OMP_MAP_TO:
+ case OMP_MAP_FORCE_TO:
+ case OMP_MAP_ALWAYS_TO:
+ case OMP_MAP_PRESENT_TO:
+ case OMP_MAP_ALWAYS_PRESENT_TO:
+ return OMP_MAP_TO;
+ case OMP_MAP_FROM:
+ case OMP_MAP_FORCE_FROM:
+ case OMP_MAP_ALWAYS_FROM:
+ case OMP_MAP_PRESENT_FROM:
+ case OMP_MAP_ALWAYS_PRESENT_FROM:
+ return OMP_MAP_FROM;
+ case OMP_MAP_TOFROM:
+ case OMP_MAP_FORCE_TOFROM:
+ case OMP_MAP_ALWAYS_TOFROM:
+ case OMP_MAP_PRESENT_TOFROM:
+ case OMP_MAP_ALWAYS_PRESENT_TOFROM:
+ return OMP_MAP_TOFROM;
+ default:
+ ;
+ }
+ return op;
+}
+
+static enum gfc_omp_map_op
+omp_join_map_op (enum gfc_omp_map_op op, bool force_p, bool always_p,
+ bool present_p)
+{
+ gcc_assert (!force_p || !(always_p || present_p));
+
+ switch (op)
+ {
+ case OMP_MAP_ALLOC:
+ if (force_p)
+ return OMP_MAP_FORCE_ALLOC;
+ else if (present_p)
+ return OMP_MAP_PRESENT_ALLOC;
+ break;
+
+ case OMP_MAP_TO:
+ if (force_p)
+ return OMP_MAP_FORCE_TO;
+ else if (always_p && present_p)
+ return OMP_MAP_ALWAYS_PRESENT_TO;
+ else if (always_p)
+ return OMP_MAP_ALWAYS_TO;
+ else if (present_p)
+ return OMP_MAP_PRESENT_TO;
+ break;
+
+ case OMP_MAP_FROM:
+ if (force_p)
+ return OMP_MAP_FORCE_FROM;
+ else if (always_p && present_p)
+ return OMP_MAP_ALWAYS_PRESENT_FROM;
+ else if (always_p)
+ return OMP_MAP_ALWAYS_FROM;
+ else if (present_p)
+ return OMP_MAP_PRESENT_FROM;
+ break;
+
+ case OMP_MAP_TOFROM:
+ if (force_p)
+ return OMP_MAP_FORCE_TOFROM;
+ else if (always_p && present_p)
+ return OMP_MAP_ALWAYS_PRESENT_TOFROM;
+ else if (always_p)
+ return OMP_MAP_ALWAYS_TOFROM;
+ else if (present_p)
+ return OMP_MAP_PRESENT_TOFROM;
+ break;
+
+ default:
+ ;
+ }
+
+ return op;
+}
+
+/* Map kind decay (OpenMP 5.2, 5.8.8 "declare mapper Directive"). Return the
+ map kind to use given MAPPER_KIND specified in the mapper and INVOKED_AS
+ specified on the clause that invokes the mapper. See also
+ c-family/c-omp.cc:omp_map_decayed_kind. */
+
+static enum gfc_omp_map_op
+omp_map_decayed_kind (enum gfc_omp_map_op mapper_kind,
+ enum gfc_omp_map_op invoked_as, bool exit_p)
+{
+ if (invoked_as == OMP_MAP_RELEASE || invoked_as == OMP_MAP_DELETE)
+ return invoked_as;
+
+ bool force_p, always_p, present_p;
+
+ invoked_as = omp_split_map_op (invoked_as, &force_p, &always_p, &present_p);
+ gfc_omp_map_op decay_to;
+
+ switch (mapper_kind)
+ {
+ case OMP_MAP_ALLOC:
+ if (exit_p && invoked_as == OMP_MAP_FROM)
+ decay_to = OMP_MAP_RELEASE;
+ else
+ decay_to = OMP_MAP_ALLOC;
+ break;
+
+ case OMP_MAP_TO:
+ if (invoked_as == OMP_MAP_FROM)
+ decay_to = exit_p ? OMP_MAP_RELEASE : OMP_MAP_ALLOC;
+ else if (invoked_as == OMP_MAP_ALLOC)
+ decay_to = OMP_MAP_ALLOC;
+ else
+ decay_to = OMP_MAP_TO;
+ break;
+
+ case OMP_MAP_FROM:
+ if (invoked_as == OMP_MAP_ALLOC || invoked_as == OMP_MAP_TO)
+ decay_to = OMP_MAP_ALLOC;
+ else
+ decay_to = OMP_MAP_FROM;
+ break;
+
+ case OMP_MAP_TOFROM:
+ case OMP_MAP_UNSET:
+ decay_to = invoked_as;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ return omp_join_map_op (decay_to, force_p, always_p, present_p);
+}
+
+static const char *
+omp_basic_map_kind_name (enum gfc_omp_map_op op)
+{
+ switch (op)
+ {
+ case OMP_MAP_ALLOC:
+ return "ALLOC";
+ case OMP_MAP_TO:
+ return "TO";
+ case OMP_MAP_FROM:
+ return "FROM";
+ case OMP_MAP_TOFROM:
+ return "TOFROM";
+ case OMP_MAP_RELEASE:
+ return "RELEASE";
+ case OMP_MAP_DELETE:
+ return "DELETE";
+ default:
+ gcc_unreachable ();
+ }
+}
+
+static gfc_symtree *gfc_subst_replace;
+static gfc_ref *gfc_subst_prepend_ref;
+
+static bool
+gfc_subst_in_expr_1 (gfc_expr *expr, gfc_symbol *search, int *)
+{
+ /* The base-object for component accesses may be stored in expr->symtree.
+ If it's the symbol for our "declare mapper" placeholder variable,
+ substitute it. */
+ if (expr->symtree && expr->symtree->n.sym == search)
+ {
+ gfc_ref **lastptr = NULL;
+ expr->symtree = gfc_subst_replace;
+
+ if (!gfc_subst_prepend_ref)
+ return false;
+
+ gfc_ref *prepend_ref = gfc_copy_ref (gfc_subst_prepend_ref);
+
+ for (gfc_ref *walk = prepend_ref; walk; walk = walk->next)
+ lastptr = &walk->next;
+
+ *lastptr = expr->ref;
+ expr->ref = prepend_ref;
+ }
+
+ return false;
+}
+
+static void
+gfc_subst_in_expr (gfc_expr *expr, gfc_symbol *search, gfc_symtree *replace,
+ gfc_ref *prepend_ref)
+{
+ gfc_subst_replace = replace;
+ gfc_subst_prepend_ref = prepend_ref;
+ gfc_traverse_expr (expr, search, gfc_subst_in_expr_1, 0);
+}
+
+static void
+gfc_subst_mapper_var (gfc_symbol **out_sym, gfc_expr **out_expr,
+ gfc_symbol *orig_sym, gfc_expr *orig_expr,
+ gfc_symbol *dummy_var,
+ gfc_symbol *templ_sym, gfc_expr *templ_expr)
+{
+ gfc_ref *orig_ref = orig_expr ? orig_expr->ref : NULL;
+ gfc_symtree *orig_st = gfc_find_symtree (orig_sym->ns->sym_root,
+ orig_sym->name);
+
+ if (dummy_var == templ_sym)
+ *out_sym = orig_sym;
+ else
+ *out_sym = templ_sym;
+
+ if (templ_expr)
+ {
+ *out_expr = gfc_copy_expr (templ_expr);
+ gfc_subst_in_expr (*out_expr, dummy_var, orig_st, orig_ref);
+ }
+ else if (orig_expr)
+ *out_expr = gfc_copy_expr (orig_expr);
+ else
+ *out_expr = NULL;
+}
+
+static gfc_omp_namelist **
+gfc_omp_instantiate_mapper (gfc_omp_namelist **outlistp,
+ gfc_omp_namelist *clause,
+ gfc_omp_map_op outer_map_op, gfc_omp_udm *udm,
+ toc_directive cd, int list)
+{
+ /* Here "sym" and "expr" describe the clause as written, to be substituted
+ for the dummy variable in the mapper definition. */
+ struct gfc_symbol *sym = clause->sym;
+ struct gfc_expr *expr = clause->expr;
+ gfc_omp_namelist *mapper_clause = udm->clauses->lists[OMP_LIST_MAP];
+ bool pointer_needed_p = false;
+
+ if (expr)
+ {
+ gfc_ref *lastref = expr->ref, *lastcomp = NULL;
+
+ for (; lastref->next; lastref = lastref->next)
+ if (lastref->type == REF_COMPONENT)
+ lastcomp = lastref;
+
+ if (lastref
+ && lastref->type == REF_ARRAY
+ && (lastref->u.ar.type == AR_SECTION
+ || lastref->u.ar.type == AR_FULL))
+ {
+ mpz_t elems;
+ bool multiple_elems_p = false;
+
+ if (gfc_array_size (expr, &elems))
+ {
+ HOST_WIDE_INT nelems = gfc_mpz_get_hwi (elems);
+ if (nelems > 1)
+ multiple_elems_p = true;
+ }
+ else
+ multiple_elems_p = true;
+
+ if (multiple_elems_p && clause->u2.udm)
+ {
+ clause->u2.udm->multiple_elems_p = true;
+ *outlistp = clause;
+ return &(*outlistp)->next;
+ }
+ }
+
+ if (lastcomp
+ && lastcomp->type == REF_COMPONENT
+ && (lastcomp->u.c.component->attr.pointer
+ || lastcomp->u.c.component->attr.allocatable))
+ pointer_needed_p = true;
+ }
+
+ if (pointer_needed_p)
+ {
+ /* If we're instantiating a mapper via a pointer, we need to map that
+ pointer as well as mapping the entities explicitly listed in the
+ mapper definition. Create a node for that. */
+ gfc_omp_namelist *new_clause = gfc_get_omp_namelist ();
+ new_clause->sym = sym;
+ new_clause->expr = gfc_copy_expr (expr);
+ /* We want the pointer itself: cut off any further accessors after the
+ last component reference (e.g. array indices). */
+ gfc_ref *lastcomp = NULL;
+ for (gfc_ref *lastref = new_clause->expr->ref;
+ lastref;
+ lastref = lastref->next)
+ if (lastref->type == REF_COMPONENT)
+ lastcomp = lastref;
+ gcc_assert (lastcomp != NULL);
+ lastcomp->next = NULL;
+ new_clause->u.map_op = OMP_MAP_POINTER_ONLY;
+ *outlistp = new_clause;
+ outlistp = &new_clause->next;
+ }
+
+ for (; mapper_clause; mapper_clause = mapper_clause->next)
+ {
+ gfc_omp_namelist *new_clause = gfc_get_omp_namelist ();
+
+ gfc_subst_mapper_var (&new_clause->sym, &new_clause->expr,
+ sym, expr, udm->var_sym, mapper_clause->sym,
+ mapper_clause->expr);
+
+ enum gfc_omp_map_op map_clause_op = mapper_clause->u.map_op;
+ enum gfc_omp_map_op new_kind
+ = omp_map_decayed_kind (map_clause_op, outer_map_op,
+ (cd == TOC_OPENMP_EXIT_DATA
+ || list == OMP_LIST_FROM));
+ if (list == OMP_LIST_FROM || list == OMP_LIST_TO)
+ {
+ switch (new_kind)
+ {
+ case OMP_MAP_PRESENT_FROM:
+ case OMP_MAP_PRESENT_TO:
+ new_clause->u.present_modifier = true;
+ /* Fallthrough. */
+ case OMP_MAP_FROM:
+ case OMP_MAP_TO:
+ break;
+ default:
+ {
+ bool present_p, force_p, always_p;
+ gfc_omp_map_op basic_kind
+ = omp_split_map_op (map_clause_op, &force_p, &always_p,
+ &present_p);
+ free (new_clause);
+ gfc_warning (0, "Dropping incompatible %qs mapper clause at %C",
+ omp_basic_map_kind_name (basic_kind));
+ inform (gfc_get_location (&mapper_clause->where),
+ "Defined here");
+ continue;
+ }
+ }
+ }
+ else
+ new_clause->u.map_op = new_kind;
+
+ new_clause->where = clause->where;
+
+ if (mapper_clause->u2.udm
+ && mapper_clause->u2.udm->udm != udm)
+ {
+ gfc_omp_udm *inner_udm = mapper_clause->u2.udm->udm;
+ outlistp = gfc_omp_instantiate_mapper (outlistp, new_clause,
+ outer_map_op, inner_udm, cd,
+ list);
+ }
+ else
+ {
+ *outlistp = new_clause;
+ outlistp = &new_clause->next;
+ }
+ }
+
+ return outlistp;
+}
+
+void
+gfc_omp_instantiate_mappers (gfc_code *code, gfc_omp_clauses *clauses,
+ toc_directive cd, int list)
+{
+ gfc_omp_namelist *clause = clauses->lists[list];
+ gfc_omp_namelist **clausep = &clauses->lists[list];
+ bool invoked_mappers = false;
+
+ for (; clause; clause = *clausep)
+ {
+ if (clause->u2.udm)
+ {
+ gfc_omp_map_op outer_map_op;
+
+ switch (list)
+ {
+ case OMP_LIST_TO:
+ outer_map_op = clause->u.present_modifier ? OMP_MAP_PRESENT_TO
+ : OMP_MAP_TO;
+ break;
+ case OMP_LIST_FROM:
+ outer_map_op = clause->u.present_modifier ? OMP_MAP_PRESENT_FROM
+ : OMP_MAP_FROM;
+ break;
+ case OMP_LIST_MAP:
+ outer_map_op = clause->u.map_op;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ clausep = gfc_omp_instantiate_mapper (clausep, clause, outer_map_op,
+ clause->u2.udm->udm, cd, list);
+ *clausep = clause->next;
+ invoked_mappers = true;
+ }
+ else
+ clausep = &clause->next;
+ }
+
+ if (invoked_mappers)
+ {
+ gfc_namespace *old_ns = gfc_current_ns;
+ if (clauses->ns)
+ gfc_current_ns = clauses->ns;
+ resolve_omp_mapper_clauses (code, clauses, gfc_current_ns);
+ gfc_current_ns = old_ns;
+ }
+}
+
+/* Resolve !$omp declare mapper constructs. */
+
+static void
+gfc_resolve_omp_udm (gfc_omp_udm *omp_udm)
+{
+ resolve_omp_clauses (NULL, omp_udm->clauses, omp_udm->mapper_ns);
+}
+
+void
+gfc_resolve_omp_udms (gfc_symtree *st)
+{
+ gfc_omp_udm *omp_udm;
+
+ if (st == NULL)
+ return;
+ gfc_resolve_omp_udms (st->left);
+ gfc_resolve_omp_udms (st->right);
+ for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
+ gfc_resolve_omp_udm (omp_udm);
+}
@@ -945,6 +945,8 @@ decode_omp_directive (void)
matchs ("assume", gfc_match_omp_assume, ST_OMP_ASSUME);
break;
case 'd':
+ matchdo ("declare mapper", gfc_match_omp_declare_mapper,
+ ST_OMP_DECLARE_MAPPER);
matchds ("declare reduction", gfc_match_omp_declare_reduction,
ST_OMP_DECLARE_REDUCTION);
matchds ("declare simd", gfc_match_omp_declare_simd,
@@ -1877,8 +1879,9 @@ next_statement (void)
the specification part. */
#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
- case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
- case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \
+ case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_MAPPER: \
+ case ST_OMP_DECLARE_REDUCTION: case ST_OMP_DECLARE_VARIANT: \
+ case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \
case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* Block end statements. Errors associated with interchanging these
@@ -2527,6 +2530,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
case ST_OMP_CRITICAL:
p = "!$OMP CRITICAL";
break;
+ case ST_OMP_DECLARE_MAPPER:
+ p = "!$OMP DECLARE MAPPER";
+ break;
case ST_OMP_DECLARE_REDUCTION:
p = "!$OMP DECLARE REDUCTION";
break;
@@ -18010,6 +18010,8 @@ resolve_types (gfc_namespace *ns)
gfc_resolve_omp_udrs (ns->omp_udr_root);
+ gfc_resolve_omp_udms (ns->omp_udm_root);
+
ns->types_resolved = 1;
gfc_current_ns = old_ns;
@@ -3880,6 +3880,21 @@ free_omp_udr_tree (gfc_symtree * omp_udr_tree)
free (omp_udr_tree);
}
+/* Similar, for !$omp declare mappers. */
+
+static void
+free_omp_udm_tree (gfc_symtree *omp_udm_tree)
+{
+ if (omp_udm_tree == NULL)
+ return;
+
+ free_omp_udm_tree (omp_udm_tree->left);
+ free_omp_udm_tree (omp_udm_tree->right);
+
+ gfc_free_omp_udm (omp_udm_tree->n.omp_udm);
+ free (omp_udm_tree);
+}
+
/* Recursive function that deletes an entire tree and all the user
operator nodes that it contains. */
@@ -4054,6 +4069,7 @@ gfc_free_namespace (gfc_namespace *&ns)
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
free_omp_udr_tree (ns->omp_udr_root);
+ free_omp_udm_tree (ns->omp_udm_root);
free_tb_tree (ns->tb_sym_root);
free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
@@ -88,6 +88,11 @@ static stmtblock_t caf_init_block;
tree gfc_static_ctors;
+/* The namespace in which to look up "declare mapper" mappers (in
+ trans-openmp.cc:gfc_trans_omp_target). This is somewhat grubby. */
+
+gfc_namespace *omp_declare_mapper_ns;
+
/* Whether we've seen a symbol from an IEEE module in the namespace. */
static int seen_ieee_symbol;
@@ -639,9 +644,12 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
function scope. */
if (current_function_decl != NULL_TREE)
{
- if (sym->ns->proc_name
- && (sym->ns->proc_name->backend_decl == current_function_decl
- || sym->result == sym))
+ if (sym->ns->omp_udm_ns)
+ /* ...except for in omp declare mappers, which are special. */
+ pushdecl (decl);
+ else if (sym->ns->proc_name
+ && (sym->ns->proc_name->backend_decl == current_function_decl
+ || sym->result == sym))
gfc_add_decl_to_function (decl);
else if (sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_LABEL)
@@ -4661,6 +4669,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
if (sym->assoc)
continue;
+ if (sym->attr.omp_udm_artificial_var)
+ continue;
+
/* Set the vptr of unlimited polymorphic pointer variables so that
they do not cause segfaults in select type, when the selector
is an intrinsic type. */
@@ -7678,6 +7689,16 @@ gfc_generate_function_code (gfc_namespace * ns)
gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym);
}
+ {
+ tree dm_saved_parent_function_decls = saved_parent_function_decls;
+ saved_parent_function_decls = saved_function_decls;
+ /* NOTE: Decls referenced in a mapper (other than the placeholder variable)
+ may be added to "saved_parent_function_decls". */
+ gfc_trans_omp_declare_mappers (ns->omp_udm_root);
+ saved_function_decls = saved_parent_function_decls;
+ saved_parent_function_decls = dm_saved_parent_function_decls;
+ }
+
gfc_generate_contained_functions (ns);
has_coarray_vars = false;
@@ -7746,9 +7767,15 @@ gfc_generate_function_code (gfc_namespace * ns)
finish_oacc_declare (ns, sym, false);
+ /* Record the namespace for looking up OpenMP declare mappers in. */
+ omp_declare_mapper_ns = ns;
+
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
+ /* Unset this to avoid accidentally using a stale pointer. */
+ omp_declare_mapper_ns = NULL;
+
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
|| (sym->result && sym->result != sym
&& sym->result->ts.type == BT_DERIVED
@@ -49,6 +49,7 @@ along with GCC; see the file COPYING3. If not see
#define GCC_DIAG_STYLE __gcc_gfc__
#include "attribs.h"
#include "function.h"
+#include "tree-iterator.h"
int ompws_flags;
@@ -2553,6 +2554,107 @@ gfc_trans_omp_array_section (stmtblock_t *block, toc_directive cd,
ptr, ptr2);
}
+/* CLAUSES is a list of clauses resulting from an "omp declare mapper"
+ instantiation in gimplify.cc. In some cases we don't know if we need to
+ create any extra mapping nodes as a result of mapper expansion until after
+ substitution has taken place, so do that now. */
+
+tree
+gfc_omp_finish_mapper_clauses (tree clauses)
+{
+ tree *clausep = &clauses;
+
+ while (*clausep)
+ {
+ tree n = *clausep;
+
+ if (OMP_CLAUSE_CODE (n) != OMP_CLAUSE_MAP)
+ {
+ clausep = &OMP_CLAUSE_CHAIN (*clausep);
+ continue;
+ }
+
+ tree decl = OMP_CLAUSE_DECL (n);
+
+ switch (OMP_CLAUSE_MAP_KIND (n))
+ {
+ case GOMP_MAP_ALLOC:
+ case GOMP_MAP_TO:
+ case GOMP_MAP_FROM:
+ case GOMP_MAP_TOFROM:
+ case GOMP_MAP_ALWAYS_TO:
+ case GOMP_MAP_ALWAYS_FROM:
+ case GOMP_MAP_ALWAYS_TOFROM:
+ {
+ if ((TREE_CODE (decl) == INDIRECT_REF
+ || (TREE_CODE (decl) == MEM_REF
+ && integer_zerop (TREE_OPERAND (decl, 1))))
+ && DECL_P (TREE_OPERAND (decl, 0)))
+ {
+ tree ptr = TREE_OPERAND (decl, 0);
+ /* A DECL_P pointer arising from a mapper expansion needs a
+ GOMP_MAP_POINTER after it. */
+ tree pnode = build_omp_clause (OMP_CLAUSE_LOCATION (n),
+ OMP_CLAUSE_MAP);
+ /* Should this ever be FIRSTPRIVATE_POINTER or
+ FIRSTPRIVATE_REFERENCE? */
+ OMP_CLAUSE_SET_MAP_KIND (pnode, GOMP_MAP_POINTER);
+ OMP_CLAUSE_DECL (pnode) = ptr;
+ OMP_CLAUSE_SIZE (pnode) = size_zero_node;
+ OMP_CLAUSE_CHAIN (pnode) = OMP_CLAUSE_CHAIN (n);
+ OMP_CLAUSE_CHAIN (n) = pnode;
+ clausep = &OMP_CLAUSE_CHAIN (pnode);
+ continue;
+ }
+ }
+ break;
+
+ default:
+ ;
+ }
+
+ clausep = &OMP_CLAUSE_CHAIN (*clausep);
+ }
+
+ return clauses;
+}
+
+tree
+gfc_omp_extract_mapper_directive (tree fndecl)
+{
+ tree body = DECL_SAVED_TREE (fndecl);
+
+ if (TREE_CODE (body) == BIND_EXPR)
+ body = BIND_EXPR_BODY (body);
+
+ if (TREE_CODE (body) == OMP_DECLARE_MAPPER)
+ return body;
+
+ if (TREE_CODE (body) != STATEMENT_LIST)
+ return error_mark_node;
+
+ tree_stmt_iterator tsi;
+ for (tsi = tsi_start (body); !tsi_end_p (tsi); tsi_next (&tsi))
+ {
+ tree stmt = tsi_stmt (tsi);
+ if (TREE_CODE (stmt) == OMP_DECLARE_MAPPER)
+ {
+ gcc_assert (tsi_one_before_end_p (tsi));
+ return stmt;
+ }
+ }
+
+ return error_mark_node;
+}
+
+tree
+gfc_omp_map_array_section (location_t, tree section)
+{
+ /* For Fortran, detection of attempts to use array sections or full arrays
+ whose elements are mapped with a mapper happens elsewhere. */
+ return section;
+}
+
static tree
handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block)
{
@@ -2685,6 +2787,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
{
bool declare_simd = (cd == TOC_OPENMP_DECLARE_SIMD);
bool openacc = (cd >= TOC_OPENACC);
+ bool declare_mapper = (cd == TOC_OPENMP_DECLARE_MAPPER);
bool omp_exit_data = (cd == TOC_OPENMP_EXIT_DATA);
tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c;
tree iterator = NULL_TREE;
@@ -3209,6 +3312,12 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
case OMP_MAP_FORCE_DEVICEPTR:
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR);
break;
+ case OMP_MAP_POINTER_ONLY:
+ OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC);
+ break;
+ case OMP_MAP_UNSET:
+ OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_UNSET);
+ break;
default:
gcc_unreachable ();
}
@@ -3676,8 +3785,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
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 if (ref->next)
+ {
+ gfc_error ("cannot map array in expression "
+ "at %C");
+ OMP_CLAUSE_DECL (node) = error_mark_node;
+ OMP_CLAUSE_SIZE (node) = NULL_TREE;
+ node2 = NULL_TREE;
+ goto finalize_map_clause;
+ }
}
else
sorry ("unhandled expression type");
@@ -3704,6 +3820,17 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node) = size_zero_node;
goto finalize_map_clause;
}
+ else if (n->u.map_op == OMP_MAP_POINTER_ONLY)
+ {
+ /* A descriptor must be copied to the target. */
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
+ OMP_CLAUSE_SET_MAP_KIND (node,
+ GOMP_MAP_ALWAYS_TO);
+ OMP_CLAUSE_DECL (node) = inner;
+ OMP_CLAUSE_SIZE (node)
+ = TYPE_SIZE_UNIT (TREE_TYPE (inner));
+ goto finalize_map_clause;
+ }
gfc_omp_namelist *n2
= openacc ? NULL : clauses->lists[OMP_LIST_MAP];
@@ -3804,6 +3931,16 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node) = size_zero_node;
goto finalize_map_clause;
}
+ else if (n->u.map_op == OMP_MAP_POINTER_ONLY)
+ {
+ /* A descriptor must be copied to the target. */
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
+ OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO);
+ OMP_CLAUSE_DECL (node) = inner;
+ OMP_CLAUSE_SIZE (node)
+ = TYPE_SIZE_UNIT (TREE_TYPE (inner));
+ goto finalize_map_clause;
+ }
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
{
@@ -3938,6 +4075,14 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
}
if (drop_mapping)
continue;
+
+ if (n->u2.udm && n->u2.udm->multiple_elems_p)
+ {
+ gfc_error ("cannot map non-unit size array "
+ "with mapper at %C");
+ node2 = NULL_TREE;
+ goto finalize_map_clause;
+ }
}
node3 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
@@ -3978,15 +4123,77 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
finalize_map_clause:
- omp_clauses = gfc_trans_add_clause (node, omp_clauses);
- if (node2)
- omp_clauses = gfc_trans_add_clause (node2, omp_clauses);
- if (node3)
- omp_clauses = gfc_trans_add_clause (node3, omp_clauses);
- if (node4)
- omp_clauses = gfc_trans_add_clause (node4, omp_clauses);
- if (node5)
- omp_clauses = gfc_trans_add_clause (node5, omp_clauses);
+ /* If we're processing an "omp declare mapper" directive, group
+ together multiple nodes used for some given map clause using
+ GOMP_MAP_MAPPING_GROUP. These are then either flattened or
+ appropriately transformed if they cause a nested mapper to be
+ invoked. */
+
+ if (declare_mapper)
+ {
+ tree cl, container;
+
+ if (node2 || node3 || node4 || node5)
+ cl = tree_cons (node, NULL_TREE, NULL_TREE);
+ else
+ cl = node;
+
+ if (node2)
+ cl = tree_cons (node2, NULL_TREE, cl);
+ if (node3)
+ cl = tree_cons (node3, NULL_TREE, cl);
+ if (node4)
+ cl = tree_cons (node4, NULL_TREE, cl);
+ if (node5)
+ cl = tree_cons (node5, NULL_TREE, cl);
+
+ if (node != cl)
+ {
+ cl = nreverse (cl);
+
+ container = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (container,
+ GOMP_MAP_MAPPING_GROUP);
+ OMP_CLAUSE_DECL (container) = cl;
+ }
+ else
+ container = cl;
+
+ if (n->u2.udm
+ && n->u2.udm->udm->mapper_id
+ && n->u2.udm->udm->mapper_id[0] != '\0')
+ {
+ tree push = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (push, GOMP_MAP_PUSH_MAPPER_NAME);
+ OMP_CLAUSE_DECL (push)
+ = get_identifier (n->u2.udm->udm->mapper_id);
+ tree pop = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (pop, GOMP_MAP_POP_MAPPER_NAME);
+ OMP_CLAUSE_DECL (pop) = null_pointer_node;
+ omp_clauses = gfc_trans_add_clause (push, omp_clauses);
+ omp_clauses = gfc_trans_add_clause (container,
+ omp_clauses);
+ omp_clauses = gfc_trans_add_clause (pop, omp_clauses);
+ }
+ else
+ omp_clauses = gfc_trans_add_clause (container, omp_clauses);
+ }
+ else
+ {
+ omp_clauses = gfc_trans_add_clause (node, omp_clauses);
+
+ if (node2)
+ omp_clauses = gfc_trans_add_clause (node2, omp_clauses);
+ if (node3)
+ omp_clauses = gfc_trans_add_clause (node3, omp_clauses);
+ if (node4)
+ omp_clauses = gfc_trans_add_clause (node4, omp_clauses);
+ if (node5)
+ omp_clauses = gfc_trans_add_clause (node5, omp_clauses);
+ }
}
break;
case OMP_LIST_TO:
@@ -7568,6 +7775,158 @@ gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa,
return gfc_finish_block (&block);
}
+/* Code callback for gfc_code_walker. */
+
+static int
+gfc_record_mapper_bindings_code_fn (gfc_code **, int *, void *)
+{
+ return 0;
+}
+
+template <>
+struct default_hash_traits <omp_name_type<gfc_typespec *>>
+ : typed_noop_remove <omp_name_type<gfc_typespec *>>
+{
+ GTY((skip)) typedef omp_name_type<gfc_typespec *> value_type;
+ GTY((skip)) typedef omp_name_type<gfc_typespec *> compare_type;
+
+ static hashval_t
+ hash (omp_name_type<gfc_typespec *> p)
+ {
+ tree typenode = gfc_typenode_for_spec (p.type);
+ return p.name ? iterative_hash_expr (p.name, TYPE_UID (typenode))
+ : TYPE_UID (typenode);
+ }
+
+ static const bool empty_zero_p = true;
+
+ static bool
+ is_empty (omp_name_type<gfc_typespec *> p)
+ {
+ return p.type == NULL;
+ }
+
+ static bool
+ is_deleted (omp_name_type<gfc_typespec *>)
+ {
+ return false;
+ }
+
+ static bool
+ equal (const omp_name_type<gfc_typespec *> &a,
+ const omp_name_type<gfc_typespec *> &b)
+ {
+ if (a.name == NULL_TREE && b.name == NULL_TREE)
+ return a.type == b.type;
+ else if (a.name == NULL_TREE || b.name == NULL_TREE)
+ return false;
+ else
+ return a.name == b.name && gfc_compare_types (a.type, b.type);
+ }
+
+ static void
+ mark_empty (omp_name_type<gfc_typespec *> &e)
+ {
+ e.type = NULL;
+ }
+};
+
+
+extern gfc_namespace *omp_declare_mapper_ns;
+
+/* Conceptually similar to c-omp.cc:c_omp_find_nested_mappers, but using
+ Fortran typespec to idenfify mappers. */
+
+static void
+gfc_find_nested_mappers (omp_mapper_list<gfc_typespec *> *mlist,
+ gfc_omp_udm *udm)
+{
+ gfc_omp_namelist *ns = udm->clauses->lists[OMP_LIST_MAP];
+
+ for (; ns; ns = ns->next)
+ {
+ if (ns->u2.udm && ns->u2.udm->udm != udm)
+ {
+ gfc_omp_udm *nested_udm = ns->u2.udm->udm;
+ tree mapper_id
+ = (nested_udm->mapper_id ? get_identifier (nested_udm->mapper_id)
+ : NULL_TREE);
+ mlist->add_mapper (mapper_id, &nested_udm->ts,
+ nested_udm->backend_decl);
+ gfc_find_nested_mappers (mlist, nested_udm);
+ }
+ }
+}
+
+/* Expr callback for gfc_code_walker. */
+
+static int
+gfc_record_mapper_bindings_expr_fn (gfc_expr **exprp, int *, void *data)
+{
+ gfc_typespec *ts = NULL;
+ omp_mapper_list<gfc_typespec *> *mlist
+ = (omp_mapper_list<gfc_typespec *> *) data;
+
+ if ((*exprp)->symtree)
+ {
+ gfc_symbol *sym = (*exprp)->symtree->n.sym;
+ if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
+ ts = &sym->ts;
+ }
+ else if ((*exprp)->base_expr)
+ {
+ gfc_expr *base_expr = (*exprp)->base_expr;
+ if (base_expr->ts.type == BT_DERIVED || base_expr->ts.type == BT_CLASS)
+ ts = &base_expr->ts;
+ }
+
+ if (!ts)
+ return 0;
+
+ gfc_omp_udm *udm = gfc_find_omp_udm (omp_declare_mapper_ns, "", ts);
+
+ if (udm)
+ {
+ mlist->add_mapper (NULL_TREE, &udm->ts, udm->backend_decl);
+ gfc_find_nested_mappers (mlist, udm);
+ }
+
+ return 0;
+}
+
+static void
+gfc_record_mapper_bindings (tree *clauses, gfc_code *code)
+{
+ hash_set<omp_name_type<gfc_typespec *>> seen_types;
+ auto_vec<tree> mappers;
+ omp_mapper_list<gfc_typespec *> mlist (&seen_types, &mappers);
+
+ gfc_code_walker (&code, gfc_record_mapper_bindings_code_fn,
+ gfc_record_mapper_bindings_expr_fn, (void *) &mlist);
+
+ unsigned int i;
+ tree mapperfn;
+ FOR_EACH_VEC_ELT (mappers, i, mapperfn)
+ {
+ tree mapper = gfc_omp_extract_mapper_directive (mapperfn);
+ if (mapper == error_mark_node)
+ continue;
+ tree mapper_name = OMP_DECLARE_MAPPER_ID (mapper);
+ tree decl = OMP_DECLARE_MAPPER_DECL (mapper);
+
+ if (mapper_name && IDENTIFIER_POINTER (mapper_name)[0] == '\0')
+ mapper_name = NULL_TREE;
+
+ tree c = build_omp_clause (input_location, OMP_CLAUSE__MAPPER_BINDING_);
+ OMP_CLAUSE__MAPPER_BINDING__ID (c) = mapper_name;
+ OMP_CLAUSE__MAPPER_BINDING__DECL (c) = decl;
+ OMP_CLAUSE__MAPPER_BINDING__MAPPER (c) = mapperfn;
+
+ OMP_CLAUSE_CHAIN (c) = *clauses;
+ *clauses = c;
+ }
+}
+
static tree
gfc_trans_omp_target (gfc_code *code)
{
@@ -7578,14 +7937,18 @@ gfc_trans_omp_target (gfc_code *code)
gfc_start_block (&block);
gfc_split_omp_clauses (code, clausesa);
if (flag_openmp)
- omp_clauses
- = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
- code->loc);
+ {
+ gfc_omp_clauses *target_clauses = &clausesa[GFC_OMP_SPLIT_TARGET];
+ gfc_omp_instantiate_mappers (code, target_clauses);
+ omp_clauses = gfc_trans_omp_clauses (&block, target_clauses,
+ code->loc);
+ }
switch (code->op)
{
case EXEC_OMP_TARGET:
pushlevel ();
stmt = gfc_trans_omp_code (code->block->next, true);
+ gfc_record_mapper_bindings (&omp_clauses, code->block->next);
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
break;
case EXEC_OMP_TARGET_PARALLEL:
@@ -7598,6 +7961,7 @@ gfc_trans_omp_target (gfc_code *code)
= gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL],
code->loc);
stmt = gfc_trans_omp_code (code->block->next, true);
+ gfc_record_mapper_bindings (&omp_clauses, code->block->next);
stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
inner_clauses);
gfc_add_expr_to_block (&iblock, stmt);
@@ -7855,8 +8219,9 @@ gfc_trans_omp_target_data (gfc_code *code)
tree stmt, omp_clauses;
gfc_start_block (&block);
- omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
- code->loc);
+ gfc_omp_clauses *target_data_clauses = code->ext.omp_clauses;
+ gfc_omp_instantiate_mappers (code, target_data_clauses);
+ omp_clauses = gfc_trans_omp_clauses (&block, target_data_clauses, code->loc);
stmt = gfc_trans_omp_code (code->block->next, true);
stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET_DATA,
void_type_node, stmt, omp_clauses);
@@ -7871,7 +8236,9 @@ gfc_trans_omp_target_enter_data (gfc_code *code)
tree stmt, omp_clauses;
gfc_start_block (&block);
- omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+ gfc_omp_clauses *target_enter_data_clauses = code->ext.omp_clauses;
+ gfc_omp_instantiate_mappers (code, target_enter_data_clauses);
+ omp_clauses = gfc_trans_omp_clauses (&block, target_enter_data_clauses,
code->loc);
stmt = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node,
omp_clauses);
@@ -7886,7 +8253,10 @@ gfc_trans_omp_target_exit_data (gfc_code *code)
tree stmt, omp_clauses;
gfc_start_block (&block);
- omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+ gfc_omp_clauses *target_exit_data_clauses = code->ext.omp_clauses;
+ gfc_omp_instantiate_mappers (code, target_exit_data_clauses,
+ TOC_OPENMP_EXIT_DATA);
+ omp_clauses = gfc_trans_omp_clauses (&block, target_exit_data_clauses,
code->loc, TOC_OPENMP_EXIT_DATA);
stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node,
omp_clauses);
@@ -8476,3 +8846,112 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
}
}
}
+
+static tree
+gfc_trans_omp_mapper_name (const char *mapper_id, gfc_typespec *ts)
+{
+ /* Enough space for "<mapper_id>:CLASS(<typename>)" + '\0'. */
+ char buffer[2 * GFC_MAX_SYMBOL_LEN + 9];
+ const char *type_name = gfc_typename (ts);
+ if (!mapper_id)
+ mapper_id = "default";
+ snprintf (buffer, sizeof (buffer), "omp declare mapper %s:%s", mapper_id,
+ type_name);
+ return get_identifier (buffer);
+}
+
+/* Translate our internal representation of an uninstantiated OpenMP
+ "declare mapper" into a form that can be consumed by the middle-end. */
+
+static void
+gfc_trans_omp_declare_mapper (gfc_omp_udm *udm)
+{
+ tree mapper_name = gfc_trans_omp_mapper_name (udm->mapper_id, &udm->ts);
+ tree fn;
+ tree saved_fn_decl = current_function_decl;
+ tree decl, decls;
+
+ if (saved_fn_decl)
+ push_function_context ();
+
+ tree tmp = build_function_type_list (void_type_node, NULL_TREE);
+ fn = build_decl (input_location, FUNCTION_DECL, mapper_name, tmp);
+
+ DECL_ARTIFICIAL (fn) = 1;
+ DECL_EXTERNAL (fn) = 1;
+ DECL_DECLARED_INLINE_P (fn) = 1;
+ DECL_IGNORED_P (fn) = 1;
+ SET_DECL_ASSEMBLER_NAME (fn, get_identifier ("<udm>"));
+ DECL_ATTRIBUTES (fn)
+ = tree_cons (get_identifier ("gnu_inline"), NULL_TREE,
+ DECL_ATTRIBUTES (fn));
+
+ decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
+ DECL_ARTIFICIAL (decl) = 1;
+ DECL_IGNORED_P (decl) = 1;
+ DECL_CONTEXT (decl) = fn;
+ DECL_RESULT (fn) = decl;
+
+ pushdecl (fn);
+ current_function_decl = fn;
+
+ allocate_struct_function (fn, false);
+
+ pushlevel ();
+
+ stmtblock_t block;
+ gfc_init_block (&block);
+
+ tree mapper_id = udm->mapper_id ? get_identifier (udm->mapper_id) : NULL_TREE;
+ tree type = gfc_typenode_for_spec (&udm->ts);
+ tree var = gfc_get_symbol_decl (udm->var_sym);
+
+ DECL_CONTEXT (var) = fn;
+ /* Normally a "use"-related variable will get the DECL_EXTERN flag set, but
+ we don't want that here because it interferes with rewriting the decl. */
+ DECL_EXTERNAL (var) = 0;
+
+ tree maplist = gfc_trans_omp_clauses (&block, udm->clauses, udm->where,
+ TOC_OPENMP_DECLARE_MAPPER);
+
+ tree stmt = make_node (OMP_DECLARE_MAPPER);
+ TREE_TYPE (stmt) = type;
+ OMP_DECLARE_MAPPER_ID (stmt) = mapper_id;
+ OMP_DECLARE_MAPPER_DECL (stmt) = var;
+ OMP_DECLARE_MAPPER_CLAUSES (stmt) = maplist;
+
+ gfc_add_expr_to_block (&block, stmt);
+ DECL_SAVED_TREE (fn) = gfc_finish_block (&block);
+ decls = getdecls ();
+ poplevel (1, 1);
+ BLOCK_SUPERCONTEXT (DECL_INITIAL (fn)) = fn;
+
+ DECL_SAVED_TREE (fn) = fold_build3_loc (input_location, BIND_EXPR,
+ void_type_node, decls,
+ DECL_SAVED_TREE (fn),
+ DECL_INITIAL (fn));
+ dump_function (TDI_original, fn);
+
+ udm->backend_decl = fn;
+
+ set_cfun (NULL);
+
+ if (saved_fn_decl)
+ {
+ pop_function_context ();
+ current_function_decl = saved_fn_decl;
+ }
+}
+
+void
+gfc_trans_omp_declare_mappers (gfc_symtree *omp_udm_root)
+{
+ if (!omp_udm_root)
+ return;
+
+ gfc_trans_omp_declare_mappers (omp_udm_root->left);
+ gfc_trans_omp_declare_mappers (omp_udm_root->right);
+
+ for (gfc_omp_udm *udm = omp_udm_root->n.omp_udm; udm; udm = udm->next)
+ gfc_trans_omp_declare_mapper (udm);
+}
@@ -71,6 +71,7 @@ tree gfc_trans_deallocate (gfc_code *);
tree gfc_trans_omp_directive (gfc_code *);
void gfc_trans_omp_declare_simd (gfc_namespace *);
void gfc_trans_omp_declare_variant (gfc_namespace *);
+void gfc_trans_omp_declare_mappers (gfc_symtree *);
tree gfc_trans_oacc_directive (gfc_code *);
tree gfc_trans_oacc_declare (gfc_namespace *);
@@ -831,6 +831,9 @@ tree gfc_omp_clause_assign_op (tree, tree, tree);
tree gfc_omp_clause_linear_ctor (tree, tree, tree, tree);
tree gfc_omp_clause_dtor (tree, tree);
void gfc_omp_finish_clause (tree, gimple_seq *, bool);
+tree gfc_omp_finish_mapper_clauses (tree);
+tree gfc_omp_extract_mapper_directive (tree);
+tree gfc_omp_map_array_section (location_t, tree);
bool gfc_omp_allocatable_p (tree);
bool gfc_omp_scalar_p (tree, bool);
bool gfc_omp_scalar_target_p (tree);
@@ -69,6 +69,7 @@ along with GCC; see the file COPYING3. If not see
#include "omp-offload.h"
#include "context.h"
#include "tree-nested.h"
+#include "dwarf2out.h"
/* Hash set of poisoned variables in a bind expr. */
static hash_set<tree> *asan_poisoned_variables = NULL;
@@ -8900,6 +8901,26 @@ omp_map_clause_descriptor_p (tree c)
return false;
}
+/* Try to find a (Fortran) array descriptor given a data pointer PTR, i.e.
+ return "foo.descr" from "foo.descr.data". */
+
+static tree
+omp_maybe_get_descriptor_from_ptr (tree ptr)
+{
+ struct array_descr_info info;
+
+ if (TREE_CODE (ptr) != COMPONENT_REF)
+ return NULL_TREE;
+
+ ptr = TREE_OPERAND (ptr, 0);
+
+ if (lang_hooks.types.get_array_descr_info
+ && lang_hooks.types.get_array_descr_info (TREE_TYPE (ptr), &info))
+ return ptr;
+
+ return NULL_TREE;
+}
+
/* For a set of mappings describing an array section pointed to by a struct
(or derived type, etc.) component, create an "alloc" or "release" node to
insert into a list following a GOMP_MAP_STRUCT node. For some types of
@@ -8921,14 +8942,22 @@ static tree
build_omp_struct_comp_nodes (enum tree_code code, tree grp_start, tree grp_end,
tree *extra_node)
{
+ tree descr = omp_maybe_get_descriptor_from_ptr (OMP_CLAUSE_DECL (grp_end));
enum gomp_map_kind mkind
= (code == OMP_TARGET_EXIT_DATA || code == OACC_EXIT_DATA)
- ? GOMP_MAP_RELEASE : GOMP_MAP_ALLOC;
+ ? GOMP_MAP_RELEASE : descr ? GOMP_MAP_ALWAYS_TO : GOMP_MAP_ALLOC;
gcc_assert (grp_start != grp_end);
tree c2 = build_omp_clause (OMP_CLAUSE_LOCATION (grp_end), OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c2, mkind);
+ if (descr)
+ {
+ OMP_CLAUSE_DECL (c2) = unshare_expr (descr);
+ OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (TREE_TYPE (descr));
+ *extra_node = NULL_TREE;
+ return c2;
+ }
OMP_CLAUSE_DECL (c2) = unshare_expr (OMP_CLAUSE_DECL (grp_end));
OMP_CLAUSE_CHAIN (c2) = NULL_TREE;
tree grp_mid = NULL_TREE;
@@ -11724,6 +11753,60 @@ omp_mapper_copy_decl (tree var, copy_body_data *cb)
return var;
}
+/* If we have a TREE_LIST representing an unprocessed mapping group (e.g. from
+ a "declare mapper" definition emitted by the Fortran FE), return the node
+ for the data being mapped. */
+
+static tree
+omp_mapping_group_data (tree group)
+{
+ gcc_assert (TREE_CODE (group) == TREE_LIST);
+ /* Use the first member of the group for substitution. */
+ return TREE_PURPOSE (group);
+}
+
+/* Return the final node of a mapping_group GROUP (represented as a tree list),
+ or NULL_TREE if it's not an attach_detach node. */
+
+static tree
+omp_mapping_group_ptr (tree group)
+{
+ gcc_assert (TREE_CODE (group) == TREE_LIST);
+
+ while (TREE_CHAIN (group))
+ group = TREE_CHAIN (group);
+
+ tree node = TREE_PURPOSE (group);
+
+ gcc_assert (OMP_CLAUSE_CODE (node) == OMP_CLAUSE_MAP);
+
+ if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_ATTACH_DETACH)
+ return node;
+
+ return NULL_TREE;
+}
+
+/* Return the pointer set (GOMP_MAP_TO_PSET) of a mapping_group node GROUP,
+ represented by a tree list, or NULL_TREE if there isn't one. */
+
+static tree
+omp_mapping_group_pset (tree group)
+{
+ gcc_assert (TREE_CODE (group) == TREE_LIST);
+
+ if (!TREE_CHAIN (group))
+ return NULL_TREE;
+
+ group = TREE_CHAIN (group);
+
+ tree node = TREE_PURPOSE (group);
+
+ if (omp_map_clause_descriptor_p (node))
+ return node;
+
+ return NULL_TREE;
+}
+
static tree *
omp_instantiate_mapper (gimple_seq *pre_p,
hash_map<omp_name_type<tree>, tree> *implicit_mappers,
@@ -11743,8 +11826,138 @@ omp_instantiate_mapper (gimple_seq *pre_p,
"bind" expression in the pre_p sequence). */
hash_map<tree, tree> extraction_map;
- extraction_map.put (dummy_var, expr);
- extraction_map.put (expr, expr);
+ if (TREE_CODE (mapperfn) == FUNCTION_DECL
+ && TREE_CODE (DECL_SAVED_TREE (mapperfn)) == BIND_EXPR)
+ {
+ tree body = NULL_TREE, bind = DECL_SAVED_TREE (mapperfn);
+ copy_body_data id;
+ hash_map<tree, tree> decl_map;
+
+ /* The "decl map" maps declarations in the definition of the mapper
+ function into new declarations in the current function. These are
+ local to the bind in which they are expanded, so we copy them out to
+ temporaries in the enclosing function scope, and use those temporaries
+ in the mapper expansion (see "extraction_map" above). (This also
+ allows a mapper to be invoked for multiple variables). */
+
+ memset (&id, 0, sizeof (id));
+ /* The source function isn't always mapperfn: e.g. for C++ mappers
+ defined within functions, the mapper decl is created in a scope
+ within that function, rather than in mapperfn. So, that containing
+ function is the one we need to copy from. */
+ id.src_fn = DECL_CONTEXT (dummy_var);
+ id.dst_fn = current_function_decl;
+ id.src_cfun = DECL_STRUCT_FUNCTION (mapperfn);
+ id.decl_map = &decl_map;
+ id.copy_decl = copy_decl_no_change;
+ id.transform_call_graph_edges = CB_CGE_DUPLICATE;
+ id.transform_new_cfg = true;
+
+ walk_tree (&bind, copy_tree_body_r, &id, NULL);
+
+ body = BIND_EXPR_BODY (bind);
+
+ extraction_map.put (dummy_var, expr);
+ extraction_map.put (expr, expr);
+
+ if (DECL_P (expr))
+ mark_addressable (expr);
+
+ tree dummy_var_remapped, *remapped_var_p = decl_map.get (dummy_var);
+ if (remapped_var_p)
+ dummy_var_remapped = *remapped_var_p;
+ else
+ internal_error ("failed to remap mapper variable");
+
+ hash_map<tree, tree> mapper_map;
+ mapper_map.put (dummy_var_remapped, expr);
+
+ /* Now we need to make two adjustments to the inlined bind: we have to
+ substitute the dummy variable for the expression in the clause
+ triggering this mapper instantiation, and we need to remove the
+ (remapped) decl from the bind's decl list. */
+
+ if (TREE_CODE (body) == STATEMENT_LIST)
+ {
+ copy_body_data id2;
+ memset (&id2, 0, sizeof (id2));
+ id2.src_fn = current_function_decl;
+ id2.dst_fn = current_function_decl;
+ id2.src_cfun = cfun;
+ id2.decl_map = &mapper_map;
+ id2.copy_decl = omp_mapper_copy_decl;
+ id2.transform_call_graph_edges = CB_CGE_DUPLICATE;
+ id2.transform_new_cfg = true;
+
+ tree_stmt_iterator tsi;
+ for (tsi = tsi_start (body); !tsi_end_p (tsi); tsi_next (&tsi))
+ {
+ tree* stmtp = tsi_stmt_ptr (tsi);
+ if (TREE_CODE (*stmtp) == OMP_DECLARE_MAPPER)
+ *stmtp = NULL_TREE;
+ else if (TREE_CODE (*stmtp) == DECL_EXPR
+ && DECL_EXPR_DECL (*stmtp) == dummy_var_remapped)
+ *stmtp = NULL_TREE;
+ else
+ walk_tree (stmtp, remap_mapper_decl_1, &id2, NULL);
+ }
+
+ tsi = tsi_last (body);
+
+ for (hash_map<tree, tree>::iterator ti = decl_map.begin ();
+ ti != decl_map.end ();
+ ++ti)
+ {
+ tree tmp, var = (*ti).first, inlined = (*ti).second;
+
+ if (var == dummy_var || var == inlined || !DECL_P (var))
+ continue;
+
+ if (!is_gimple_reg (var))
+ {
+ const char *decl_name
+ = IDENTIFIER_POINTER (DECL_NAME (var));
+ tmp = create_tmp_var (TREE_TYPE (var), decl_name);
+ }
+ else
+ tmp = create_tmp_var (TREE_TYPE (var));
+
+ /* We have three versions of the decl here. VAR is the version
+ as represented in the function defining the "declare mapper",
+ and in the clause list attached to the OMP_DECLARE_MAPPER
+ directive within that function. INLINED is the variable that
+ has been localised to a bind within the function where the
+ mapper is being instantiated (i.e. current_function_decl).
+ TMP is the variable that we copy the values created in that
+ block to. */
+
+ extraction_map.put (var, tmp);
+ extraction_map.put (tmp, tmp);
+
+ tree asgn = build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp, inlined);
+ tsi_link_after (&tsi, asgn, TSI_CONTINUE_LINKING);
+ }
+ }
+
+ /* We've replaced the "dummy variable" of the declare mapper definition
+ with a localised version in a bind expr in the current function. We
+ have just rewritten all references to that, so remove the decl. */
+
+ for (tree *decl = &BIND_EXPR_VARS (bind); *decl;)
+ {
+ if (*decl == dummy_var_remapped)
+ *decl = DECL_CHAIN (*decl);
+ else
+ decl = &DECL_CHAIN (*decl);
+ }
+
+ gimplify_bind_expr (&bind, pre_p);
+ }
+ else
+ {
+ extraction_map.put (dummy_var, expr);
+ extraction_map.put (expr, expr);
+ }
/* This copy_body_data is only used to remap the decls in the
OMP_DECLARE_MAPPER tree node expansion itself. All relevant decls should
@@ -11776,6 +11989,85 @@ omp_instantiate_mapper (gimple_seq *pre_p,
}
tree decl = OMP_CLAUSE_DECL (clause);
+
+ if (map_kind == GOMP_MAP_MAPPING_GROUP)
+ {
+ tree data = omp_mapping_group_data (decl);
+ tree group_type = TREE_TYPE (OMP_CLAUSE_DECL (data));
+
+ group_type = TYPE_MAIN_VARIANT (group_type);
+
+ nested_mapper_p = implicit_mappers->get ({ mapper_name, group_type });
+
+ if (nested_mapper_p && *nested_mapper_p != mapperfn)
+ {
+ tree unshared = unshare_expr (data);
+ map_kind = OMP_CLAUSE_MAP_KIND (data);
+ walk_tree (&unshared, remap_mapper_decl_1, &id, NULL);
+ tree ptr = omp_mapping_group_ptr (decl);
+
+ /* !!! When ptr is NULL, we're discarding the other nodes in the
+ mapping group. Is that always OK? */
+
+ if (ptr)
+ {
+ /* This behaviour is Fortran-specific. That's fine for now
+ because only Fortran is using GOMP_MAP_MAPPING_GROUP, but
+ may need revisiting if that ever changes. */
+ gcc_assert (lang_GNU_Fortran ());
+
+ /* We're invoking a (nested) mapper from CLAUSE, which was a
+ pointer to a derived type. The elements of the derived
+ type are handled by the mapper, but we need to map the
+ actual pointer as well. Create an ALLOC node to do
+ that.
+ If we have an array descriptor, we want to copy it to the
+ target, so instead use an ALWAYS_TO mapping and copy the
+ descriptor itself rather than the data pointer. */
+
+ tree pset = omp_mapping_group_pset (decl);
+ tree ptr_unshared = unshare_expr (pset ? pset : ptr);
+ walk_tree (&ptr_unshared, remap_mapper_decl_1, &id, NULL);
+
+ tree node = build_omp_clause (OMP_CLAUSE_LOCATION (clause),
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node, pset ? GOMP_MAP_ALWAYS_TO
+ : GOMP_MAP_ALLOC);
+ OMP_CLAUSE_DECL (node) = OMP_CLAUSE_DECL (ptr_unshared);
+ OMP_CLAUSE_SIZE (node)
+ = TYPE_SIZE_UNIT (TREE_TYPE (OMP_CLAUSE_DECL (node)));
+
+ *mapper_clauses_p = node;
+ mapper_clauses_p = &OMP_CLAUSE_CHAIN (node);
+ }
+
+ if (map_kind == GOMP_MAP_UNSET)
+ map_kind = outer_kind;
+
+ mapper_clauses_p
+ = omp_instantiate_mapper (pre_p, implicit_mappers,
+ *nested_mapper_p,
+ OMP_CLAUSE_DECL (unshared), map_kind,
+ mapper_clauses_p);
+ }
+ else
+ /* No nested mapper, so process each element of the mapping
+ group. */
+ for (tree cp = OMP_CLAUSE_DECL (clause); cp; cp = TREE_CHAIN (cp))
+ {
+ tree node = unshare_expr (TREE_PURPOSE (cp));
+ walk_tree (&node, remap_mapper_decl_1, &id, NULL);
+
+ if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_UNSET)
+ OMP_CLAUSE_SET_MAP_KIND (node, outer_kind);
+
+ *mapper_clauses_p = node;
+ mapper_clauses_p = &OMP_CLAUSE_CHAIN (node);
+ }
+
+ continue;
+ }
+
tree unshared, type;
bool nonunit_array_with_mapper = false;
new file mode 100644
@@ -0,0 +1,71 @@
+! { dg-do compile }
+
+! Basic "!$omp declare mapper" parsing tests.
+
+module mymod
+type s
+ integer :: c
+ integer :: d(99)
+ integer, dimension(100,100) :: e
+end type s
+
+!$omp declare mapper (s :: x) map(tofrom: x%c, x%d)
+!$omp declare mapper (withaname : s :: x) map(from: x%d(2:30))
+!$omp declare mapper (withaname2 : s :: x) map(from: x%d(5))
+!$omp declare mapper (named: s :: x) map(tofrom: x%e(:,3))
+!$omp declare mapper (named2: s :: x) map(tofrom: x%e(5,:))
+
+end module mymod
+
+program myprog
+use mymod, only: s
+type t
+ integer :: a
+ integer :: b
+end type t
+
+type u
+ integer :: q
+end type u
+
+type deriv
+ integer :: arr(100)
+ integer :: len
+end type deriv
+
+type(t) :: y
+type(s) :: z
+type(u) :: p
+type(deriv) :: d
+integer, dimension(100,100) :: i2d
+
+!$omp declare mapper (t :: x) map(tofrom: x%a) map(y%b)
+!$omp declare mapper (named: t :: x) map(tofrom: x%a) map(y%b)
+!$omp declare mapper (integer :: x) ! { dg-error "\\\!\\\$OMP DECLARE MAPPER with non-derived type" }
+
+!$omp declare mapper (deriv :: x) map(tofrom: x%len) &
+!$omp & map(tofrom: x%arr(:))
+
+!$omp target map(tofrom: z%e(:,5))
+!$omp end target
+
+!$omp target map(mapper(named), tofrom: y)
+!$omp end target
+
+!$omp target
+y%a = y%b
+!$omp end target
+
+d%len = 10
+
+!$omp target
+d%arr(5) = 13
+!$omp end target
+
+!$omp target map(tofrom: z)
+!$omp end target
+
+!$omp target map(mapper(withaname), from: z) map(tofrom:p%q)
+!$omp end target
+
+end program myprog
new file mode 100644
@@ -0,0 +1,26 @@
+program myprog
+type T
+integer :: arr1(10)
+integer :: arr2(10)
+end type T
+
+type U
+integer :: arr1(10)
+end type U
+
+type V
+integer :: arr1(10)
+end type V
+
+!$omp declare mapper (default: T :: x) map(to:x%arr1) map(from:x%arr2) ! { dg-error "Previous \\\!\\\$OMP DECLARE MAPPER" }
+!$omp declare mapper (T :: x) map(to:x%arr1) ! { dg-error "Redefinition of \\\!\\\$OMP DECLARE MAPPER" }
+
+! Check what happens if we're SHOUTING too.
+!$omp declare mapper (default: U :: x) map(to:x%arr1) ! { dg-error "Previous \\\!\\\$OMP DECLARE MAPPER" }
+!$omp declare mapper (DEFAULT: U :: x) map(to:x%arr1) ! { dg-error "Redefinition of \\\!\\\$OMP DECLARE MAPPER" }
+
+! Or if we're using a keyword (which should be fine).
+!$omp declare mapper (V :: x) map(alloc:x%arr1)
+!$omp declare mapper (integer : V :: x) map(tofrom:x%arr1(:))
+
+end program myprog
new file mode 100644
@@ -0,0 +1,61 @@
+! { dg-do compile }
+! { dg-options "-fopenmp -fdump-tree-gimple" }
+
+type t
+integer, pointer :: arrcomp(:)
+integer :: b, c, d
+end type t
+
+type(t) :: myvar
+integer, target :: tgtarr(1:100)
+
+!$omp declare mapper (t :: x) map(to: x%arrcomp) map(alloc: x%b) &
+!$omp & map(from: x%c) map(tofrom: x%d)
+
+myvar%arrcomp => tgtarr
+
+!$omp target enter data map(to: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(struct:myvar \[len: 4\]\) map\(to:myvar\.arrcomp \[pointer set, len: [0-9]+\]\) map\(alloc:myvar\.b \[len: [0-9]+\]\) map\(alloc:myvar\.c \[len: 4\]\) map\(to:myvar\.d \[len: [0-9]+\]\) map\(to:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:myvar\.arrcomp\.data \[bias: 0\]\)} 1 "gimple" } }
+
+!$omp target exit data map(from: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(release:myvar\.b \[len: [0-9]+\]\) map\(from:myvar\.c \[len: [0-9]+\]\) map\(from:myvar\.d \[len: [0-9]+\]\) map\(release:myvar\.arrcomp \[len: [0-9]+\]\) map\(detach:myvar\.arrcomp\.data \[bias: 0\]\) map\(release:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\)} 1 "gimple" } }
+
+
+!$omp target enter data map(alloc: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(struct:myvar \[len: 4\]\) map\(to:myvar\.arrcomp \[pointer set, len: [0-9]+\]\) map\(alloc:myvar\.b \[len: [0-9]+\]\) map\(alloc:myvar\.c \[len: [0-9]+\]\) map\(alloc:myvar\.d \[len: [0-9]+\]\) map\(alloc:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:myvar\.arrcomp\.data \[bias: 0\]\)} 1 "gimple" } }
+
+!$omp target exit data map(release: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(release:myvar\.b \[len: [0-9]+\]\) map\(release:myvar\.c \[len: [0-9]+\]\) map\(release:myvar\.d \[len: [0-9]+\]\) map\(release:myvar\.arrcomp \[len: [0-9]+\]\) map\(detach:myvar\.arrcomp\.data \[bias: 0\]\) map\(release:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\)} 1 "gimple" } }
+
+
+!$omp target enter data map(present, to: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(force_present:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:myvar\.arrcomp\.data \[bias: 0\]\) map\(struct:myvar \[len: 4\]\) map\(to:myvar\.arrcomp \[pointer set, len: [0-9]+\]\) map\(force_present:myvar\.b \[len: [0-9]+\]\) map\(force_present:myvar\.c \[len: [0-9]+\]\) map\(force_present:myvar\.d \[len: [0-9]+\]\)} 1 "gimple" } }
+
+!$omp target exit data map(present, from: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(release:myvar\.b \[len: [0-9]+\]\) map\(force_present:myvar\.c \[len: [0-9]+\]\) map\(force_present:myvar\.d \[len: [0-9]+\]\) map\(release:myvar\.arrcomp \[len: [0-9]+\]\) map\(detach:myvar\.arrcomp\.data \[bias: 0\]\) map\(release:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\)} 1 "gimple" } }
+
+
+!$omp target enter data map(always, to: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(struct:myvar \[len: 4\]\) map\(to:myvar\.arrcomp \[pointer set, len: [0-9]+\]\) map\(alloc:myvar\.b \[len: [0-9]+\]\) map\(alloc:myvar\.c \[len: [0-9]+\]\) map\(always,to:myvar\.d \[len: [0-9]+\]\) map\(always,to:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:myvar\.arrcomp\.data \[bias: 0\]\)} 1 "gimple" } }
+
+!$omp target exit data map(always, from: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(release:myvar\.b \[len: [0-9]+\]\) map\(always,from:myvar\.c \[len: [0-9]+\]\) map\(always,from:myvar\.d \[len: [0-9]+\]\) map\(release:myvar\.arrcomp \[len: [0-9]+\]\) map\(detach:myvar\.arrcomp\.data \[bias: 0\]\) map\(release:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\)} 1 "gimple" } }
+
+
+!$omp target enter data map(always, present, to: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(struct:myvar \[len: 4\]\) map\(to:myvar\.arrcomp \[pointer set, len: [0-9]+\]\) map\(force_present:myvar\.b \[len: [0-9]+\]\) map\(force_present:myvar\.c \[len: [0-9]+\]\) map\(always,present,to:myvar\.d \[len: [0-9]+\]\) map\(always,present,to:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:myvar\.arrcomp\.data \[bias: 0\]\)} 1 "gimple" } }
+
+!$omp target exit data map(always, present, from: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(release:myvar\.b \[len: [0-9]+\]\) map\(always,present,from:myvar\.c \[len: [0-9]+\]\) map\(always,present,from:myvar\.d \[len: [0-9]+\]\) map\(release:myvar\.arrcomp \[len: [0-9]+\]\) map\(detach:myvar\.arrcomp\.data \[bias: 0\]\) map\(release:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\)} 1 "gimple" } }
+
+end
new file mode 100644
@@ -0,0 +1,63 @@
+! { dg-do compile }
+! { dg-options "-fopenmp -fdump-tree-gimple" }
+! FIXME: Since this test has scan-tree-dump-times checks, it's easier to just
+! skip it until the 'allocatable' component mapping support is done.
+! { dg-skip-if "missing 'allocatable' component mapping support" { *-*-* } }
+
+type t
+integer, allocatable :: arrcomp(:)
+integer :: b, c, d
+end type t
+
+type(t) :: myvar
+
+!$omp declare mapper (t :: x) map(to: x%arrcomp) map(alloc: x%b) &
+!$omp & map(from: x%c) map(tofrom: x%d)
+
+allocate (myvar%arrcomp(1:100))
+
+!$omp target enter data map(to: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(struct:myvar \[len: 4\]\) map\(to:myvar\.arrcomp \[pointer set, len: [0-9]+\]\) map\(alloc:myvar\.b \[len: [0-9]+\]\) map\(alloc:myvar\.c \[len: 4\]\) map\(to:myvar\.d \[len: [0-9]+\]\) map\(to:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:myvar\.arrcomp\.data \[bias: 0\]\)} 1 "gimple" } }
+
+!$omp target exit data map(from: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(release:myvar\.b \[len: [0-9]+\]\) map\(from:myvar\.c \[len: [0-9]+\]\) map\(from:myvar\.d \[len: [0-9]+\]\) map\(release:myvar\.arrcomp \[len: [0-9]+\]\) map\(detach:myvar\.arrcomp\.data \[bias: 0\]\) map\(release:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\)} 1 "gimple" } }
+
+
+!$omp target enter data map(alloc: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(struct:myvar \[len: 4\]\) map\(to:myvar\.arrcomp \[pointer set, len: [0-9]+\]\) map\(alloc:myvar\.b \[len: [0-9]+\]\) map\(alloc:myvar\.c \[len: [0-9]+\]\) map\(alloc:myvar\.d \[len: [0-9]+\]\) map\(alloc:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:myvar\.arrcomp\.data \[bias: 0\]\)} 1 "gimple" } }
+
+!$omp target exit data map(release: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(release:myvar\.b \[len: [0-9]+\]\) map\(release:myvar\.c \[len: [0-9]+\]\) map\(release:myvar\.d \[len: [0-9]+\]\) map\(release:myvar\.arrcomp \[len: [0-9]+\]\) map\(detach:myvar\.arrcomp\.data \[bias: 0\]\) map\(release:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\)} 1 "gimple" } }
+
+
+!$omp target enter data map(present, to: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(force_present:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:myvar\.arrcomp\.data \[bias: 0\]\) map\(struct:myvar \[len: 4\]\) map\(to:myvar\.arrcomp \[pointer set, len: [0-9]+\]\) map\(force_present:myvar\.b \[len: [0-9]+\]\) map\(force_present:myvar\.c \[len: [0-9]+\]\) map\(force_present:myvar\.d \[len: [0-9]+\]\)} 1 "gimple" } }
+
+!$omp target exit data map(present, from: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(release:myvar\.b \[len: [0-9]+\]\) map\(force_present:myvar\.c \[len: [0-9]+\]\) map\(force_present:myvar\.d \[len: [0-9]+\]\) map\(release:myvar\.arrcomp \[len: [0-9]+\]\) map\(detach:myvar\.arrcomp\.data \[bias: 0\]\) map\(release:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\)} 1 "gimple" } }
+
+
+!$omp target enter data map(always, to: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(struct:myvar \[len: 4\]\) map\(to:myvar\.arrcomp \[pointer set, len: [0-9]+\]\) map\(alloc:myvar\.b \[len: [0-9]+\]\) map\(alloc:myvar\.c \[len: [0-9]+\]\) map\(always,to:myvar\.d \[len: [0-9]+\]\) map\(always,to:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:myvar\.arrcomp\.data \[bias: 0\]\)} 1 "gimple" } }
+
+!$omp target exit data map(always, from: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(release:myvar\.b \[len: [0-9]+\]\) map\(always,from:myvar\.c \[len: [0-9]+\]\) map\(always,from:myvar\.d \[len: [0-9]+\]\) map\(release:myvar\.arrcomp \[len: [0-9]+\]\) map\(detach:myvar\.arrcomp\.data \[bias: 0\]\) map\(release:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\)} 1 "gimple" } }
+
+
+!$omp target enter data map(always, present, to: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(struct:myvar \[len: 4\]\) map\(to:myvar\.arrcomp \[pointer set, len: [0-9]+\]\) map\(force_present:myvar\.b \[len: [0-9]+\]\) map\(force_present:myvar\.c \[len: [0-9]+\]\) map\(always,present,to:myvar\.d \[len: [0-9]+\]\) map\(always,present,to:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:myvar\.arrcomp\.data \[bias: 0\]\)} 1 "gimple" } }
+
+!$omp target exit data map(always, present, from: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(release:myvar\.b \[len: [0-9]+\]\) map\(always,present,from:myvar\.c \[len: [0-9]+\]\) map\(always,present,from:myvar\.d \[len: [0-9]+\]\) map\(release:myvar\.arrcomp \[len: [0-9]+\]\) map\(detach:myvar\.arrcomp\.data \[bias: 0\]\) map\(release:MEM <integer\(kind=4\)\[0:\]> \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\)} 1 "gimple" } }
+
+end
new file mode 100644
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! { dg-options "-fopenmp -fdump-tree-gimple" }
+
+type t
+integer :: a, b, c, d
+end type t
+
+type(t) :: myvar
+
+!$omp declare mapper (t :: x) map(to: x%a) map(alloc: x%b) &
+!$omp & map(from: x%c) map(tofrom: x%d)
+
+!$omp target data map(to: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(struct:myvar \[len: 4\]\) map\(to:myvar\.a \[len: [0-9]+\]\) map\(alloc:myvar\.b \[len: [0-9]+\]\) map\(alloc:myvar\.c \[len: [0-9]+\]\) map\(to:myvar\.d \[len: [0-9]+\]\)} 1 "gimple" } }
+
+!$omp end target data
+
+!$omp target data map(alloc: myvar)
+
+! { dg-final { scan-tree-dump-times {map\(struct:myvar \[len: 4\]\) map\(alloc:myvar\.a \[len: [0-9]+\]\) map\(alloc:myvar\.b \[len: [0-9]+\]\) map\(alloc:myvar\.c \[len: [0-9]+\]\) map\(alloc:myvar\.d \[len: [0-9]+\]\)} 1 "gimple" } }
+
+!$omp end target data
+
+end
new file mode 100644
@@ -0,0 +1,29 @@
+! { dg-do compile }
+
+type t
+integer, pointer :: arr(:)
+end type t
+
+!$omp declare mapper(even: T :: tv) map(tv%arr(2::2))
+
+type(t) :: var
+integer, target :: tgtarr(100)
+
+var%arr => tgtarr
+
+var%arr = 0
+
+! You can't do this, the mapper specifies a noncontiguous access.
+!$omp target enter data map(mapper(even), to: var)
+! { dg-error {Stride should not be specified for array section in MAP clause} "" { target *-*-* } .-1 }
+
+var%arr = 1
+
+! But this is fine. (Re-enabled by a later patch.)
+!!$omp target update to(mapper(even): var)
+
+! As 'enter data'.
+!$omp target exit data map(mapper(even), delete: var)
+! { dg-error {Stride should not be specified for array section in MAP clause} "" { target *-*-* } .-1 }
+
+end
new file mode 100644
@@ -0,0 +1,34 @@
+! { dg-do compile }
+
+type t
+integer, allocatable :: arr(:)
+end type t
+
+!$omp declare mapper(even: T :: tv) map(tv%arr(2::2))
+! { dg-error "List item 'tv' with allocatable components is not permitted in map clause" "" { target *-*-* } .-1 }
+
+type(t) :: var
+
+allocate(var%arr(100))
+
+var%arr = 0
+
+! When 'allocatable' component mapping is complete, only the stride errors
+! should be raised below.
+
+! You can't do this, the mapper specifies a noncontiguous access.
+!$omp target enter data map(mapper(even), to: var)
+! { dg-error {Stride should not be specified for array section in MAP clause} "" { xfail *-*-* } .-1 }
+! { dg-error "List item 'var' with allocatable components is not permitted in map clause" "" { target *-*-* } .-2 }
+
+var%arr = 1
+
+! But this is fine. (Re-enabled by later patch.)
+!!$omp target update to(mapper(even): var)
+
+! As 'enter data'.
+!$omp target exit data map(mapper(even), delete: var)
+! { dg-error {Stride should not be specified for array section in MAP clause} "" { xfail *-*-* } .-1 }
+! { dg-error "List item 'var' with allocatable components is not permitted in map clause" "" { target *-*-* } .-2 }
+
+end
new file mode 100644
@@ -0,0 +1,22 @@
+! { dg-do compile }
+
+! Check duplicate clause detection after mapper expansion.
+
+type t
+integer :: x
+end type t
+
+real(4) :: unrelated
+type(t) :: tvar
+
+!$omp declare mapper (t :: var) map(unrelated) map(var%x)
+
+tvar%x = 0
+unrelated = 5
+
+!$omp target firstprivate(unrelated) map(tofrom: tvar)
+! { dg-error "Symbol .unrelated. present on both data and map clauses" "" { target *-*-* } .-1 }
+tvar%x = unrelated
+!$omp end target
+
+end
new file mode 100644
@@ -0,0 +1,35 @@
+! { dg-do compile }
+
+type t
+integer :: x, y
+integer, pointer :: arr(:)
+end type t
+
+type(t) :: var
+integer, target :: tgtarr(20)
+
+var%arr => tgtarr
+
+var%arr = 0
+
+! If we ask for a named mapper that hasn't been defined, an error should be
+! raised. This isn't a *syntax* error, so the !$omp target..!$omp end target
+! block should still be parsed correctly.
+!$omp target map(mapper(arraymapper), tofrom: var)
+! { dg-error "User-defined mapper .arraymapper. not found" "" { target *-*-* } .-1 }
+var%arr(5) = 5
+!$omp end target
+
+! OTOH, this is a syntax error, and the offload block is not recognized.
+!$omp target map(
+! { dg-error "Syntax error in OpenMP variable list" "" { target *-*-* } .-1 }
+var%arr(6) = 6
+!$omp end target
+! { dg-error "Unexpected !.OMP END TARGET statement" "" { target *-*-* } .-1 }
+
+! ...but not for the specific name 'default'.
+!$omp target map(mapper(default), tofrom: var)
+var%arr(5) = 5
+!$omp end target
+
+end
new file mode 100644
@@ -0,0 +1,36 @@
+! { dg-do compile }
+
+type t
+integer :: x, y
+integer, allocatable :: arr(:)
+end type t
+
+type(t) :: var
+
+allocate(var%arr(1:20))
+
+var%arr = 0
+
+! If we ask for a named mapper that hasn't been defined, an error should be
+! raised. This isn't a *syntax* error, so the !$omp target..!$omp end target
+! block should still be parsed correctly.
+!$omp target map(mapper(arraymapper), tofrom: var)
+! { dg-error "User-defined mapper .arraymapper. not found" "" { target *-*-* } .-1 }
+! { dg-error "List item 'var' with allocatable components is not permitted in map clause" "" { target *-*-* } .-2 }
+var%arr(5) = 5
+!$omp end target
+
+! OTOH, this is a syntax error, and the offload block is not recognized.
+!$omp target map(
+! { dg-error "Syntax error in OpenMP variable list" "" { target *-*-* } .-1 }
+var%arr(6) = 6
+!$omp end target
+! { dg-error "Unexpected !.OMP END TARGET statement" "" { target *-*-* } .-1 }
+
+! ...but not for the specific name 'default'.
+!$omp target map(mapper(default), tofrom: var)
+! { dg-error "List item 'var' with allocatable components is not permitted in map clause" "" { target *-*-* } .-1 }
+var%arr(5) = 5
+!$omp end target
+
+end
new file mode 100644
@@ -0,0 +1,45 @@
+! { dg-do compile }
+
+! Check duplicate mapper detection in module reader.
+
+module mod1
+type S
+integer, dimension(:), pointer :: arr
+end type S
+!$omp declare mapper (S :: v) map(to: v%arr) map(tofrom:v%arr(1))
+end module mod1
+
+module mod2
+type S
+character :: c
+integer, dimension(:), pointer :: arr
+end type S
+!$omp declare mapper (S :: v) map(to: v%arr) map(tofrom:v%arr(:))
+
+type(S) :: svar
+
+contains
+
+subroutine setup
+allocate(svar%arr(10))
+end subroutine setup
+
+subroutine teardown
+deallocate(svar%arr)
+end subroutine teardown
+
+end module mod2
+
+program myprog
+use mod1 ! { dg-error "Previous \\\!\\\$OMP DECLARE MAPPER from module mod1" }
+use mod2 ! { dg-error "Ambiguous \\\!\\\$OMP DECLARE MAPPER from module mod2" }
+
+call setup
+
+!$omp target
+svar%arr(1) = svar%arr(1) + 1
+!$omp end target
+
+call teardown
+
+end program myprog
@@ -1024,6 +1024,9 @@ dump_omp_clause (pretty_printer *pp, tree clause, int spc, dump_flags_t flags)
case GOMP_MAP_POP_MAPPER_NAME:
pp_string (pp, "pop_mapper");
break;
+ case GOMP_MAP_MAPPING_GROUP:
+ pp_string (pp, "mapping_group");
+ break;
default:
gcc_unreachable ();
}
@@ -215,7 +215,10 @@ enum gomp_map_kind
GOMP_MAP_UNSET = (GOMP_MAP_LAST | 8),
/* Used to record the name of a named mapper. */
GOMP_MAP_PUSH_MAPPER_NAME = (GOMP_MAP_LAST | 9),
- GOMP_MAP_POP_MAPPER_NAME = (GOMP_MAP_LAST | 10)
+ GOMP_MAP_POP_MAPPER_NAME = (GOMP_MAP_LAST | 10),
+ /* Used to hold a TREE_LIST of grouped nodes in an 'omp declare mapper'
+ definition (only for Fortran at present). */
+ GOMP_MAP_MAPPING_GROUP = (GOMP_MAP_LAST | 11)
};
#define GOMP_MAP_COPY_TO_P(X) \
new file mode 100644
@@ -0,0 +1,40 @@
+! { dg-do run }
+
+program myprog
+type t
+ integer, dimension (8) :: arr1
+end type t
+type u
+ type(t), dimension (:), pointer :: tarr
+end type u
+
+type(u) :: myu
+type(t), dimension (12), target :: myarray
+
+!$omp declare mapper (t :: x) map(x%arr1(1:4))
+!$omp declare mapper (u :: x) map(to: x%tarr) map(x%tarr(1))
+
+myu%tarr => myarray
+
+myu%tarr(1)%arr1(1) = 1
+
+! We can't do this: we have a mapper for "t" elements, and this implicitly maps
+! the whole array.
+!!$omp target map(tofrom:myu%tarr)
+!myu%tarr(1)%arr1(1) = myu%tarr(1)%arr1(1) + 1
+!!$omp end target
+
+! ...but we can do this, because we're just mapping an element of the "t"
+! array. We still need to map the actual "myu%tarr" descriptor.
+!$omp target map(to:myu%tarr) map(myu%tarr(1)%arr1(1:4))
+myu%tarr(1)%arr1(1) = myu%tarr(1)%arr1(1) + 1
+!$omp end target
+
+!$omp target
+myu%tarr(1)%arr1(1) = myu%tarr(1)%arr1(1) + 1
+!$omp end target
+
+if (myu%tarr(1)%arr1(1).ne.3) stop 1
+
+end program myprog
+
new file mode 100644
@@ -0,0 +1,38 @@
+! { dg-do run }
+
+program myprog
+type t
+ integer, dimension (8) :: arr1
+end type t
+type u
+ type(t) :: t_elem
+end type u
+
+type(u) :: myu
+
+!$omp declare mapper (t :: x) map(x%arr1(5:8))
+!$omp declare mapper (tmapper: t :: x) map(x%arr1(1:4))
+!$omp declare mapper (u :: x) map(mapper(tmapper), tofrom: x%t_elem)
+
+myu%t_elem%arr1(1) = 1
+myu%t_elem%arr1(5) = 1
+
+! Different ways of invoking nested mappers, named vs. unnamed
+
+!$omp target map(tofrom:myu%t_elem)
+myu%t_elem%arr1(5) = myu%t_elem%arr1(5) + 1
+!$omp end target
+
+!$omp target map(tofrom:myu)
+myu%t_elem%arr1(1) = myu%t_elem%arr1(1) + 1
+!$omp end target
+
+!$omp target
+myu%t_elem%arr1(1) = myu%t_elem%arr1(1) + 1
+!$omp end target
+
+if (myu%t_elem%arr1(1).ne.3) stop 1
+if (myu%t_elem%arr1(5).ne.2) stop 2
+
+end program myprog
+
new file mode 100644
@@ -0,0 +1,33 @@
+! { dg-do run }
+
+program myprog
+type t
+ integer, dimension (8) :: arr1
+end type t
+type u
+ type(t) :: t_elem
+end type u
+
+type(u) :: myu
+
+!$omp declare mapper (tmapper: t :: x) map(x%arr1(1:4))
+!$omp declare mapper (u :: x) map(mapper(tmapper), tofrom: x%t_elem)
+
+myu%t_elem%arr1(1) = 1
+
+!$omp target map(tofrom:myu%t_elem)
+myu%t_elem%arr1(1) = myu%t_elem%arr1(1) + 1
+!$omp end target
+
+!$omp target map(tofrom:myu)
+myu%t_elem%arr1(1) = myu%t_elem%arr1(1) + 1
+!$omp end target
+
+!$omp target
+myu%t_elem%arr1(1) = myu%t_elem%arr1(1) + 1
+!$omp end target
+
+if (myu%t_elem%arr1(1).ne.4) stop 1
+
+end program myprog
+
new file mode 100644
@@ -0,0 +1,49 @@
+! { dg-do run }
+
+module mymod
+type S
+integer :: a
+integer :: b
+integer :: c
+end type S
+
+!$omp declare mapper (S :: x) map(x%c)
+end module mymod
+
+program myprog
+use mymod
+type T
+integer :: a
+integer :: b
+integer :: c
+end type T
+
+type(S) :: mys
+type(T) :: myt
+
+!$omp declare mapper (T :: x) map(x%b)
+
+myt%a = 0
+myt%b = 0
+myt%c = 0
+mys%a = 0
+mys%b = 0
+mys%c = 0
+
+!$omp target
+myt%b = myt%b + 1
+!$omp end target
+
+!$omp target
+mys%c = mys%c + 1
+!$omp end target
+
+!$omp target
+myt%b = myt%b + 2
+mys%c = mys%c + 3
+!$omp end target
+
+if (myt%b.ne.3) stop 1
+if (mys%c.ne.4) stop 2
+
+end program myprog
new file mode 100644
@@ -0,0 +1,24 @@
+! { dg-do run }
+
+program myprog
+
+type A
+character(len=20) :: string1
+character(len=:), pointer :: string2
+end type A
+
+!$omp declare mapper (A :: x) map(to:x%string1) map(from:x%string2)
+
+type(A) :: var
+
+allocate(character(len=20) :: var%string2)
+
+var%string1 = "hello world"
+
+!$omp target map(to:var%string1) map(from:var%string2)
+var%string2 = var%string1
+!$omp end target
+
+if (var%string2.ne."hello world") stop 1
+
+end program myprog
new file mode 100644
@@ -0,0 +1,92 @@
+! { dg-do run }
+
+program myprog
+
+type A
+integer :: x
+integer :: y(20)
+integer, dimension(:), pointer :: z
+end type A
+
+integer, target :: arr1(20), arr2(20)
+type(A) :: p, q
+
+p%y = 0
+q%y = 0
+
+p%z => arr1
+q%z => arr2
+
+call mysub (p, q)
+
+if (p%z(1).ne.1) stop 1
+if (q%z(1).ne.1) stop 2
+
+p%y = 0
+q%y = 0
+p%z = 0
+q%z = 0
+
+call mysub2 (p, q)
+
+if (p%z(1).ne.1) stop 3
+if (q%z(1).ne.1) stop 4
+
+p%y = 0
+q%y = 0
+p%z = 0
+q%z = 0
+
+call mysub3 (p, q)
+
+if (p%z(1).ne.1) stop 5
+if (q%z(1).ne.1) stop 6
+
+contains
+
+subroutine mysub(arg1, arg2)
+implicit none
+type(A), intent(inout) :: arg1
+type(A), intent(inout) :: arg2
+
+!$omp declare mapper (A :: x) map(always, to:x) map(tofrom:x%z(:))
+
+!$omp target
+arg1%y(1) = arg1%y(1) + 1
+arg1%z = arg1%y
+arg2%y(1) = arg2%y(1) + 1
+arg2%z = arg2%y
+!$omp end target
+end subroutine mysub
+
+subroutine mysub2(arg1, arg2)
+implicit none
+type(A), intent(inout) :: arg1
+type(A), intent(inout) :: arg2
+
+!$omp declare mapper (A :: x) map(to:x) map(from:x%z(:))
+
+!$omp target
+arg1%y(1) = arg1%y(1) + 1
+arg1%z = arg1%y
+arg2%y(1) = arg2%y(1) + 1
+arg2%z = arg2%y
+!$omp end target
+end subroutine mysub2
+
+subroutine mysub3(arg1, arg2)
+implicit none
+type(A), intent(inout) :: arg1
+type(A), intent(inout) :: arg2
+
+!$omp declare mapper (A :: x) map(to:x) map(from:x%z(:))
+
+!$omp target map(arg1, arg2)
+arg1%y(1) = arg1%y(1) + 1
+arg1%z = arg1%y
+arg2%y(1) = arg2%y(1) + 1
+arg2%z = arg2%y
+!$omp end target
+end subroutine mysub3
+
+end program myprog
new file mode 100644
@@ -0,0 +1,46 @@
+! { dg-do run }
+
+module mymod
+type F
+integer :: a, b, c
+integer, dimension(10) :: d
+end type F
+
+type G
+integer :: x, y
+type(F), pointer :: myf
+integer :: z
+end type G
+
+! Check that nested mappers work inside modules.
+
+!$omp declare mapper (F :: f) map(to: f%b) map(f%d)
+!$omp declare mapper (G :: g) map(tofrom: g%myf)
+
+end module mymod
+
+program myprog
+use mymod
+
+type(F), target :: ftmp
+type(G) :: gvar
+
+gvar%myf => ftmp
+
+gvar%myf%d = 0
+
+!$omp target map(gvar%myf)
+gvar%myf%d(1) = gvar%myf%d(1) + 1
+!$omp end target
+
+!$omp target map(gvar)
+gvar%myf%d(1) = gvar%myf%d(1) + 1
+!$omp end target
+
+!$omp target
+gvar%myf%d(1) = gvar%myf%d(1) + 1
+!$omp end target
+
+if (gvar%myf%d(1).ne.3) stop 1
+
+end program myprog
new file mode 100644
@@ -0,0 +1,29 @@
+! { dg-do run }
+
+program myprog
+type F
+integer :: a, b, c
+integer, dimension(10) :: d
+end type F
+
+type(F), pointer :: myf
+
+!$omp declare mapper (F :: f) map(f%d)
+
+allocate(myf)
+
+myf%d = 0
+
+!$omp target map(myf)
+myf%d(1) = myf%d(1) + 1
+!$omp end target
+
+!$omp target
+myf%d(1) = myf%d(1) + 1
+!$omp end target
+
+if (myf%d(1).ne.2) stop 1
+
+deallocate(myf)
+
+end program myprog
new file mode 100644
@@ -0,0 +1,32 @@
+! { dg-do run }
+
+program myprog
+type s
+ integer :: c
+ integer :: d(99)
+end type s
+
+type t
+ type(s) :: mys
+end type t
+
+type u
+ type(t) :: myt
+end type u
+
+type(u) :: myu
+
+!$omp declare mapper (t :: x) map(tofrom: x%mys%c) map(x%mys%d(1:x%mys%c))
+
+myu%myt%mys%c = 1
+myu%myt%mys%d = 0
+
+!$omp target map(tofrom: myu%myt)
+myu%myt%mys%d(1) = myu%myt%mys%d(1) + 1
+myu%myt%mys%c = myu%myt%mys%c + 2
+!$omp end target
+
+if (myu%myt%mys%d(1).ne.1) stop 1
+if (myu%myt%mys%c.ne.3) stop 2
+
+end program myprog
new file mode 100644
@@ -0,0 +1,29 @@
+! { dg-do run }
+
+program myprog
+type F
+integer :: a, b, c
+integer, dimension(10) :: d
+end type F
+
+type(F), allocatable :: myf
+
+!$omp declare mapper (F :: f) map(f)
+
+allocate(myf)
+
+myf%d = 0
+
+!$omp target map(myf)
+myf%d(1) = myf%d(1) + 1
+!$omp end target
+
+!$omp target
+myf%d(1) = myf%d(1) + 1
+!$omp end target
+
+if (myf%d(1).ne.2) stop 1
+
+deallocate(myf)
+
+end program myprog
new file mode 100644
@@ -0,0 +1,25 @@
+! { dg-do run }
+
+program myprog
+
+type A
+character(len=20) :: string1
+character(len=:), pointer :: string2
+end type A
+
+!$omp declare mapper (A :: x) map(to:x%string1) map(from:x%string2)
+
+type(A) :: var
+character(len=20), target :: tgtstring
+
+var%string2 => tgtstring
+
+var%string1 = "hello world"
+
+!$omp target
+var%string2 = var%string1
+!$omp end target
+
+if (var%string2.ne."hello world") stop 1
+
+end program myprog
new file mode 100644
@@ -0,0 +1,26 @@
+! NOTE: Make this a run test after 'allocatable' map support is committed.
+! { dg-do compile }
+
+program myprog
+
+type A
+character(len=20) :: string1
+character(len=:), allocatable :: string2
+end type A
+
+!$omp declare mapper (A :: x) map(to:x%string1) map(from:x%string2)
+! { dg-error "List item 'x' with allocatable components is not permitted in map clause" "" { target *-*-* } .-1 }
+
+type(A) :: var
+
+allocate(character(len=20) :: var%string2)
+
+var%string1 = "hello world"
+
+!$omp target
+var%string2 = var%string1
+!$omp end target
+
+if (var%string2.ne."hello world") stop 1
+
+end program myprog
new file mode 100644
@@ -0,0 +1,33 @@
+program myprog
+type s
+ integer :: c
+ integer :: d(99)
+end type s
+
+type t
+ type(s) :: mys
+end type t
+
+type u
+ type(t) :: myt
+end type u
+
+type(u) :: myu
+
+!$omp declare mapper (s :: x) map(tofrom: x%c, x%d(1:x%c))
+!$omp declare mapper (t :: x) map(tofrom: x%mys)
+!$omp declare mapper (u :: x) map(tofrom: x%myt)
+
+myu%myt%mys%c = 1
+myu%myt%mys%d = 0
+
+! Nested mappers.
+
+!$omp target map(tofrom: myu)
+myu%myt%mys%d(1) = myu%myt%mys%d(1) + 1
+!$omp end target
+
+if (myu%myt%mys%c.ne.1) stop 1
+if (myu%myt%mys%d(1).ne.1) stop 2
+
+end program myprog
new file mode 100644
@@ -0,0 +1,25 @@
+! { dg-do run }
+
+type t
+integer :: x, y
+integer, pointer :: arr(:)
+end type t
+
+!$omp declare mapper (t :: x) map(x%arr)
+
+type(t) :: var
+integer, target :: tgtarr(20)
+
+var%arr => tgtarr
+
+var%arr = 0
+
+! The mapper named literally 'default' should be the default mapper, i.e.
+! the same as the unnamed mapper defined above.
+!$omp target map(mapper(default), tofrom: var)
+var%arr(5) = 5
+!$omp end target
+
+if (var%arr(5).ne.5) stop 1
+
+end
new file mode 100644
@@ -0,0 +1,27 @@
+! NOTE: Make this a 'run' test once allocatable component mappings are fixed.
+! { dg-do compile }
+
+type t
+integer :: x, y
+integer, allocatable :: arr(:)
+end type t
+
+!$omp declare mapper (t :: x) map(x%arr)
+! { dg-error "List item 'x' with allocatable components is not permitted in map clause" "" { target *-*-* } .-1 }
+
+type(t) :: var
+
+allocate(var%arr(1:20))
+
+var%arr = 0
+
+! The mapper named literally 'default' should be the default mapper, i.e.
+! the same as the unnamed mapper defined above.
+!$omp target map(mapper(default), tofrom: var)
+! { dg-error "List item 'var' with allocatable components is not permitted in map clause" "" { target *-*-* } .-1 }
+var%arr(5) = 5
+!$omp end target
+
+if (var%arr(5).ne.5) stop 1
+
+end
new file mode 100644
@@ -0,0 +1,41 @@
+! { dg-do run }
+
+program myprog
+type s
+ integer :: c
+ integer, pointer :: d(:)
+end type s
+
+type t
+ type(s) :: mys
+end type t
+
+type u
+ type(t) :: myt
+end type u
+
+type(u) :: myu
+integer, target :: tgtarr(20)
+
+! Here, the mappers are declared out of order, but earlier ones can still
+! trigger mappers defined later. Implementation-wise, this happens during
+! resolution, but from the user perspective it appears to happen at
+! instantiation time -- at which point all mappers are visible. I think
+! that makes sense.
+!$omp declare mapper (u :: x) map(tofrom: x%myt)
+!$omp declare mapper (t :: x) map(tofrom: x%mys)
+!$omp declare mapper (s :: x) map(tofrom: x%c, x%d(1:x%c))
+
+myu%myt%mys%d => tgtarr
+
+myu%myt%mys%c = 1
+myu%myt%mys%d = 0
+
+!$omp target map(tofrom: myu)
+myu%myt%mys%d(1) = myu%myt%mys%d(1) + 1
+!$omp end target
+
+! Note: we only mapped the first element of the array 'd'.
+if (myu%myt%mys%d(1).ne.1) stop 1
+
+end program myprog
new file mode 100644
@@ -0,0 +1,45 @@
+! NOTE: Make this a 'run' test once allocatable component mappings are fixed.
+! { dg-do compile }
+
+program myprog
+type s
+ integer :: c
+ integer, allocatable :: d(:)
+end type s
+
+type t
+ type(s) :: mys
+end type t
+
+type u
+ type(t) :: myt
+end type u
+
+type(u) :: myu
+
+! Here, the mappers are declared out of order, but earlier ones can still
+! trigger mappers defined later. Implementation-wise, this happens during
+! resolution, but from the user perspective it appears to happen at
+! instantiation time -- at which point all mappers are visible. I think
+! that makes sense.
+!$omp declare mapper (u :: x) map(tofrom: x%myt)
+! { dg-error "List item 'x' with allocatable components is not permitted in map clause" "" { target *-*-* } .-1 }
+!$omp declare mapper (t :: x) map(tofrom: x%mys)
+! { dg-error "List item 'x' with allocatable components is not permitted in map clause" "" { target *-*-* } .-1 }
+!$omp declare mapper (s :: x) map(tofrom: x%c, x%d(1:x%c))
+! { dg-error "List item 'x' with allocatable components is not permitted in map clause" "" { target *-*-* } .-1 }
+
+allocate(myu%myt%mys%d(1:20))
+
+myu%myt%mys%c = 1
+myu%myt%mys%d = 0
+
+!$omp target map(tofrom: myu)
+! { dg-error "List item 'myu' with allocatable components is not permitted in map clause" "" { target *-*-* } .-1 }
+myu%myt%mys%d(1) = myu%myt%mys%d(1) + 1
+!$omp end target
+
+! Note: we only mapped the first element of the array 'd'.
+if (myu%myt%mys%d(1).ne.1) stop 1
+
+end program myprog
new file mode 100644
@@ -0,0 +1,28 @@
+! { dg-do run }
+
+program myprog
+type bounds
+ integer :: lo
+ integer :: hi
+end type bounds
+
+integer, allocatable :: myarr(:)
+type(bounds) :: b
+
+! Use the placeholder variable, but not at the top level.
+!$omp declare mapper (bounds :: x) map(tofrom: myarr(x%lo:x%hi))
+
+allocate (myarr(1:100))
+
+b%lo = 4
+b%hi = 6
+
+myarr = 0
+
+!$omp target map(tofrom: b)
+myarr(5) = myarr(5) + 1
+!$omp end target
+
+if (myarr(5).ne.1) stop 1
+
+end program myprog
new file mode 100644
@@ -0,0 +1,29 @@
+! { dg-do run }
+
+program myprog
+type s
+ integer :: a
+ integer :: b
+end type s
+
+type t
+ type(s) :: mys
+end type t
+
+type(t) :: myt
+
+! Identity mapper
+
+!$omp declare mapper (s :: x) map(tofrom: x)
+!$omp declare mapper (t :: x) map(tofrom: x%mys)
+
+myt%mys%a = 0
+myt%mys%b = 0
+
+!$omp target map(tofrom: myt)
+myt%mys%a = myt%mys%a + 1
+!$omp end target
+
+if (myt%mys%a.ne.1) stop 1
+
+end program myprog
new file mode 100644
@@ -0,0 +1,115 @@
+! { dg-do run }
+
+program myprog
+type t
+ integer, dimension (8) :: arr1
+end type t
+type u
+ integer, dimension (9) :: arr1
+end type u
+type v
+ integer, dimension (10) :: arr1
+end type v
+type w
+ integer, dimension (11) :: arr1
+end type w
+type y
+ integer, dimension(:), pointer :: ptr1
+end type y
+type z
+ integer, dimension(:), pointer :: ptr1
+end type z
+
+!$omp declare mapper (t::x) map(tofrom:x%arr1)
+!$omp declare mapper (u::x) map(tofrom:x%arr1(:))
+!$omp declare mapper (v::x) map(always,tofrom:x%arr1(1:3))
+!$omp declare mapper (w::x) map(tofrom:x%arr1(1))
+!$omp declare mapper (y::x) map(tofrom:x%ptr1)
+!$omp declare mapper (z::x) map(to:x%ptr1) map(tofrom:x%ptr1(1:3))
+
+type(t) :: myt
+type(u) :: myu
+type(v) :: myv
+type(w) :: myw
+type(y) :: myy
+integer, target, dimension(8) :: arrtgt
+type(z) :: myz
+integer, target, dimension(8) :: arrtgt2
+
+myy%ptr1 => arrtgt
+myz%ptr1 => arrtgt2
+
+myt%arr1 = 0
+
+!$omp target map(myt)
+myt%arr1(1) = myt%arr1(1) + 1
+!$omp end target
+
+!$omp target
+myt%arr1(1) = myt%arr1(1) + 1
+!$omp end target
+
+if (myt%arr1(1).ne.2) stop 1
+
+myu%arr1 = 0
+
+!$omp target map(tofrom:myu%arr1(:))
+myu%arr1(1) = myu%arr1(1) + 1
+!$omp end target
+
+!$omp target
+myu%arr1(1) = myu%arr1(1) + 1
+!$omp end target
+
+if (myu%arr1(1).ne.2) stop 2
+
+myv%arr1 = 0
+
+!$omp target map(always,tofrom:myv%arr1(1:3))
+myv%arr1(1) = myv%arr1(1) + 1
+!$omp end target
+
+!$omp target
+myv%arr1(1) = myv%arr1(1) + 1
+!$omp end target
+
+if (myv%arr1(1).ne.2) stop 3
+
+myw%arr1 = 0
+
+!$omp target map(tofrom:myw%arr1(1))
+myw%arr1(1) = myw%arr1(1) + 1
+!$omp end target
+
+!$omp target
+myw%arr1(1) = myw%arr1(1) + 1
+!$omp end target
+
+if (myw%arr1(1).ne.2) stop 4
+
+myy%ptr1 = 0
+
+!$omp target map(tofrom:myy%ptr1)
+myy%ptr1(1) = myy%ptr1(1) + 1
+!$omp end target
+
+!$omp target map(to:myy%ptr1) map(tofrom:myy%ptr1(1:2))
+myy%ptr1(1) = myy%ptr1(1) + 1
+!$omp end target
+
+!$omp target
+myy%ptr1(1) = myy%ptr1(1) + 1
+!$omp end target
+
+if (myy%ptr1(1).ne.3) stop 5
+
+myz%ptr1(1) = 0
+
+!$omp target
+myz%ptr1(1) = myz%ptr1(1) + 1
+!$omp end target
+
+if (myz%ptr1(1).ne.1) stop 6
+
+end program myprog
+
new file mode 100644
@@ -0,0 +1,27 @@
+! { dg-do run }
+
+type t
+ integer, dimension (8) :: arr1
+end type t
+type u
+ type(t), dimension (:), pointer :: tarr
+end type u
+
+type(u) :: myu
+type(t), dimension (1), target :: myarray
+
+!$omp declare mapper (named: t :: x) map(x%arr1(1:4))
+!$omp declare mapper (u :: x) map(to: x%tarr) map(mapper(named), tofrom: x%tarr(1))
+
+myu%tarr => myarray
+myu%tarr(1)%arr1 = 0
+
+! Unnamed mapper invoking named mapper
+
+!$omp target
+myu%tarr(1)%arr1(1) = myu%tarr(1)%arr1(1) + 1
+!$omp end target
+
+if (myu%tarr(1)%arr1(1).ne.1) stop 1
+
+end