@@ -895,6 +895,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)
@@ -1469,6 +1471,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)
@@ -139,6 +139,9 @@ gfc_get_sarif_source_language (const char *)
#undef LANG_HOOKS_OMP_DEEP_MAPPING
#undef LANG_HOOKS_OMP_DEEP_MAPPING_P
#undef LANG_HOOKS_OMP_DEEP_MAPPING_CNT
+#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
@@ -182,6 +185,10 @@ gfc_get_sarif_source_language (const char *)
#define LANG_HOOKS_OMP_DEEP_MAPPING gfc_omp_deep_mapping
#define LANG_HOOKS_OMP_DEEP_MAPPING_P gfc_omp_deep_mapping_p
#define LANG_HOOKS_OMP_DEEP_MAPPING_CNT gfc_omp_deep_mapping_cnt
+#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,
@@ -997,6 +998,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;
@@ -1318,7 +1323,9 @@ enum gfc_omp_map_op
OMP_MAP_ALWAYS_PRESENT_FROM,
OMP_MAP_ALWAYS_PRESENT_TOFROM,
OMP_MAP_DECLARE_ALLOCATE,
- OMP_MAP_DECLARE_DEALLOCATE
+ OMP_MAP_DECLARE_DEALLOCATE,
+ OMP_MAP_POINTER_ONLY,
+ OMP_MAP_UNSET
};
enum gfc_omp_defaultmap
@@ -1377,6 +1384,7 @@ typedef struct gfc_omp_namelist
union
{
struct gfc_omp_namelist_udr *udr;
+ struct gfc_omp_namelist_udm *udm;
gfc_namespace *ns;
struct gfc_omp_namelist *duplicate_of;
} u2;
@@ -1751,6 +1759,35 @@ 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
+{
+ 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. */
@@ -2084,6 +2121,7 @@ typedef struct gfc_symtree
gfc_common_head *common;
gfc_typebound_proc *tb;
gfc_omp_udr *omp_udr;
+ gfc_omp_udm *omp_udm;
}
n;
}
@@ -2127,6 +2165,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;
@@ -2245,6 +2285,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;
@@ -3627,7 +3670,7 @@ void gfc_free_iterator (gfc_iterator *, int);
void gfc_free_forall_iterator (gfc_forall_iterator *);
void gfc_free_alloc_list (gfc_alloc *);
void gfc_free_namelist (gfc_namelist *);
-void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool);
+void gfc_free_omp_namelist (gfc_omp_namelist *, int = OMP_LIST_NUM);
void gfc_free_equiv (gfc_equiv *);
void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *);
void gfc_free_data (gfc_data *);
@@ -3649,8 +3692,12 @@ 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_metadirective_clauses (gfc_omp_metadirective_clause *);
+void gfc_free_omp_udm (gfc_omp_udm *);
gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
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 *);
@@ -3658,6 +3705,7 @@ 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_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 *);
@@ -5534,8 +5534,11 @@ gfc_free_namelist (gfc_namelist *name)
/* Free an OpenMP namelist structure. */
void
-gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align)
+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);
+ bool free_align = (list == OMP_LIST_ALLOCATE);
gfc_omp_namelist *n;
for (; name; name = n)
@@ -5545,7 +5548,9 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align)
gfc_free_expr (name->u.align);
if (free_ns)
gfc_free_namespace (name->u2.ns);
- 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_begin_metadirective (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,130 @@ 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 ();
+ 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 +5463,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 +5527,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 +5865,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 +5901,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 +6282,65 @@ 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_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 +6602,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
@@ -197,9 +197,7 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
gfc_free_expr (c->num_workers_expr);
gfc_free_expr (c->vector_length_expr);
for (i = 0; i < OMP_LIST_NUM; i++)
- gfc_free_omp_namelist (c->lists[i],
- i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND,
- i == OMP_LIST_ALLOCATE);
+ gfc_free_omp_namelist (c->lists[i], i);
gfc_free_expr_list (c->wait_list);
gfc_free_expr_list (c->tile_list);
gfc_free_expr_list (c->tile_sizes);
@@ -362,6 +360,19 @@ gfc_free_omp_metadirective_clauses (gfc_omp_metadirective_clause *clause)
}
}
+/* 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)
{
@@ -568,7 +579,7 @@ syntax:
gfc_error ("Syntax error in OpenMP variable list at %C");
cleanup:
- gfc_free_omp_namelist (head, false, false);
+ gfc_free_omp_namelist (head);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
@@ -658,7 +669,7 @@ syntax:
gfc_error ("Syntax error in OpenMP variable list at %C");
cleanup:
- gfc_free_omp_namelist (head, false, false);
+ gfc_free_omp_namelist (head);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
@@ -767,7 +778,7 @@ syntax:
gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
cleanup:
- gfc_free_omp_namelist (head, false, false);
+ gfc_free_omp_namelist (head);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
@@ -1593,7 +1604,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
*head = NULL;
gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
buffer, &old_loc);
- gfc_free_omp_namelist (n, false, false);
+ gfc_free_omp_namelist (n, list_idx);
}
else
for (n = *head; n; n = n->next)
@@ -2368,13 +2379,52 @@ 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. */
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 openmp_target = false)
+ bool openacc = 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 ();
@@ -2432,7 +2482,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
{
- gfc_free_omp_namelist (*head, false, false);
+ gfc_free_omp_namelist (*head);
gfc_current_locus = old_loc;
*head = NULL;
break;
@@ -3383,7 +3433,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
end_colon = true;
else if (gfc_match (" )") != MATCH_YES)
{
- gfc_free_omp_namelist (*head, false, false);
+ gfc_free_omp_namelist (*head);
gfc_current_locus = old_loc;
*head = NULL;
break;
@@ -3394,7 +3444,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
{
if (gfc_match (" %e )", &step) != MATCH_YES)
{
- gfc_free_omp_namelist (*head, false, false);
+ gfc_free_omp_namelist (*head);
gfc_current_locus = old_loc;
*head = NULL;
goto error;
@@ -3491,7 +3541,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
if (has_error)
{
- gfc_free_omp_namelist (*head, false, false);
+ gfc_free_omp_namelist (*head);
*head = NULL;
goto error;
}
@@ -3533,9 +3583,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 (;;)
{
@@ -3555,12 +3608,20 @@ 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;
+ }
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;
@@ -3591,6 +3652,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)
@@ -3611,6 +3673,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],
@@ -3619,7 +3687,23 @@ 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;
+
+ gfc_typespec *ts;
+ if (n->expr)
+ ts = &n->expr->ts;
+ else
+ ts = &n->sym->ts;
+
+ gfc_omp_udm *udm
+ = gfc_find_omp_udm (gfc_current_ns, mapper_id, ts);
+ if (udm)
+ {
+ n->u2.udm = gfc_get_omp_namelist_udm ();
+ n->u2.udm->udm = udm;
+ }
+ }
continue;
}
gfc_current_locus = old_loc;
@@ -5356,14 +5440,14 @@ gfc_match_omp_flush (void)
{
gfc_error ("List specified together with memory order clause in FLUSH "
"directive at %C");
- gfc_free_omp_namelist (list, false, false);
+ gfc_free_omp_namelist (list);
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
- gfc_free_omp_namelist (list, false, false);
+ gfc_free_omp_namelist (list);
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
@@ -5414,6 +5498,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)
{
@@ -8133,9 +8364,13 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
n->sym->reduc_mark = 0;
if (n->sym->attr.flavor == FL_VARIABLE
|| n->sym->attr.proc_pointer
- || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
+ || (!code
+ && !ns->omp_udm_ns
+ && (!n->sym->attr.dummy || n->sym->ns != ns)))
{
- if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
+ if (!code
+ && !ns->omp_udm_ns
+ && (!n->sym->attr.dummy || n->sym->ns != ns))
gfc_error ("Variable %qs is not a dummy argument at %L",
n->sym->name, &n->where);
continue;
@@ -8406,7 +8641,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
{
prev->next = n->next;
n->next = NULL;
- gfc_free_omp_namelist (n, false, true);
+ gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
n = prev->next;
}
continue;
@@ -8685,7 +8920,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
like it may not be.
And OpenMP's 'target update' permits strides for
the to/from clause. */
- if (code->op != EXEC_OACC_UPDATE
+ if (code
+ && code->op != EXEC_OACC_UPDATE
&& code->op != EXEC_OMP_TARGET_UPDATE
&& list != OMP_LIST_CACHE
&& list != OMP_LIST_DEPEND
@@ -8794,7 +9030,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
&& n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array %qs in %s clause at %L",
n->sym->name, name, &n->where);
- if (list == OMP_LIST_MAP && !openacc)
+ if (code && list == OMP_LIST_MAP && !openacc)
switch (code->op)
{
case EXEC_OMP_TARGET:
@@ -12705,3 +12941,24 @@ gfc_oacc_annotate_loops_in_kernels_regions (gfc_namespace *ns)
for (ns = ns->contained; ns; ns = ns->sibling)
gfc_oacc_annotate_loops_in_kernels_regions (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);
+}
@@ -939,6 +939,10 @@ decode_omp_directive (void)
matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
break;
case 'd':
+ matchds ("declare mapper", gfc_match_omp_declare_mapper,
+ ST_OMP_DECLARE_MAPPER);
+ matchds ("declare reduction", gfc_match_omp_declare_reduction,
+ ST_OMP_DECLARE_REDUCTION);
matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ);
matchs ("distribute parallel do simd",
gfc_match_omp_distribute_parallel_do_simd,
@@ -1798,9 +1802,10 @@ 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_ASSUMES: \
- case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
+ case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_MAPPER: \
+ case ST_OMP_DECLARE_REDUCTION: case ST_OMP_DECLARE_VARIANT: \
+ case ST_OMP_ASSUMES: case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: \
+ case ST_OACC_DECLARE
/* OpenMP statements that are followed by a structured block. */
@@ -2488,6 +2493,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;
@@ -17991,6 +17991,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;
@@ -289,7 +289,7 @@ gfc_free_statement (gfc_code *p)
break;
case EXEC_OMP_FLUSH:
- gfc_free_omp_namelist (p->ext.omp_namelist, false, false);
+ gfc_free_omp_namelist (p->ext.omp_namelist);
break;
case EXEC_OMP_BARRIER:
@@ -3888,6 +3888,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. */
@@ -4062,6 +4077,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;
@@ -642,9 +647,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)
@@ -4675,6 +4683,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;
+
if (sym->ts.type == BT_DERIVED
&& sym->ts.u.derived
&& sym->ts.u.derived->attr.pdt_type)
@@ -7669,6 +7680,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;
@@ -7737,9 +7758,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
@@ -58,6 +58,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;
@@ -3854,15 +3855,28 @@ gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
static vec<tree, va_heap, vl_embed> *doacross_steps;
+/* Control clause translation per-directive for gfc_trans_omp_clauses. */
+
+enum toc_directive
+{
+ TOC_OPENMP,
+ TOC_OPENMP_DECLARE_SIMD,
+ TOC_OPENMP_DECLARE_MAPPER,
+ TOC_OPENMP_EXIT_DATA,
+ TOC_OPENACC,
+ TOC_OPENACC_DECLARE
+};
/* Translate an array section or array element. */
static void
-gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op,
+gfc_trans_omp_array_section (stmtblock_t *block, toc_directive cd,
gfc_omp_namelist *n, tree decl, bool element,
- bool openmp, gomp_map_kind ptr_kind, tree &node,
+ gomp_map_kind ptr_kind, tree &node,
tree &node2, tree &node3, tree &node4)
{
+ bool openmp = (cd < TOC_OPENACC);
+ bool omp_exit_data = (cd == TOC_OPENMP_EXIT_DATA);
gfc_se se;
tree ptr, ptr2;
tree elemsz = NULL_TREE;
@@ -3926,7 +3940,7 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op,
if (POINTER_TYPE_P (TREE_TYPE (decl))
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
&& ptr_kind == GOMP_MAP_POINTER
- && op != EXEC_OMP_TARGET_EXIT_DATA
+ && !omp_exit_data
&& OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_RELEASE
&& OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_DELETE)
@@ -3945,8 +3959,7 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op,
gomp_map_kind map_kind;
if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE)
map_kind = OMP_CLAUSE_MAP_KIND (node);
- else if (op == EXEC_OMP_TARGET_EXIT_DATA
- || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE)
+ else if (omp_exit_data || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE)
map_kind = GOMP_MAP_RELEASE;
else
map_kind = GOMP_MAP_TO;
@@ -3965,11 +3978,10 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op,
OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE
|| OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE
- || op == EXEC_OMP_TARGET_EXIT_DATA)
+ || omp_exit_data)
{
- gomp_map_kind map_kind
- = (op == EXEC_OMP_TARGET_EXIT_DATA) ? GOMP_MAP_RELEASE
- : OMP_CLAUSE_MAP_KIND (node);
+ gomp_map_kind map_kind = omp_exit_data ? GOMP_MAP_RELEASE
+ : OMP_CLAUSE_MAP_KIND (node);
OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
OMP_CLAUSE_RELEASE_DESCRIPTOR (node2) = 1;
}
@@ -4019,6 +4031,107 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op,
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)
{
@@ -4147,9 +4260,12 @@ get_symbol_rooted_namelist (hash_map<gfc_symbol *,
static tree
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
- locus where, bool declare_simd = false,
- bool openacc = false, gfc_exec_op op = EXEC_NOP)
+ locus where, toc_directive cd = TOC_OPENMP)
{
+ 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;
tree tree_block = NULL_TREE;
@@ -4610,7 +4726,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
Such variables are handled by augmenting allocate/deallocate
statements elsewhere (with
"acc enter data declare_allocate(...)", etc.). */
- if (op == EXEC_OACC_DECLARE
+ if (cd == TOC_OPENACC_DECLARE
&& n->u.map_op == OMP_MAP_ALLOC
&& n->sym->attr.allocatable
&& n->sym->attr.oacc_declare_create)
@@ -4731,6 +4847,12 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
case OMP_MAP_DECLARE_DEALLOCATE:
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DECLARE_DEALLOCATE);
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 ();
}
@@ -4774,7 +4896,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
&& n->sym->ts.deferred
&& n->sym->attr.omp_declare_target
&& (always_modifier || n->sym->attr.pointer)
- && op != EXEC_OMP_TARGET_EXIT_DATA
+ && !omp_exit_data
&& n->u.map_op != OMP_MAP_DELETE
&& n->u.map_op != OMP_MAP_RELEASE)
{
@@ -4853,17 +4975,17 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
NULL_TREE));
}
/* For descriptor types, the unmapping happens below. */
- if (op != EXEC_OMP_TARGET_EXIT_DATA
+ if (!omp_exit_data
|| !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
{
node4 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
if (gmk == GOMP_MAP_POINTER
- && op == EXEC_OMP_TARGET_EXIT_DATA
+ && omp_exit_data
&& n->u.map_op == OMP_MAP_DELETE)
gmk = GOMP_MAP_DELETE;
else if (gmk == GOMP_MAP_POINTER
- && op == EXEC_OMP_TARGET_EXIT_DATA)
+ && omp_exit_data)
gmk = GOMP_MAP_RELEASE;
tree size;
if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE)
@@ -4881,10 +5003,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
{
- if (op == EXEC_OMP_TARGET_EXIT_DATA
- && n->u.map_op == OMP_MAP_DELETE)
+ if (omp_exit_data && n->u.map_op == OMP_MAP_DELETE)
gmk = GOMP_MAP_DELETE;
- else if (op == EXEC_OMP_TARGET_EXIT_DATA)
+ else if (omp_exit_data)
gmk = GOMP_MAP_RELEASE;
else
gmk = GOMP_MAP_POINTER;
@@ -4916,14 +5037,13 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
if (n->u.map_op == OMP_MAP_DELETE)
map_kind = GOMP_MAP_DELETE;
- else if (op == EXEC_OMP_TARGET_EXIT_DATA
- || n->u.map_op == OMP_MAP_RELEASE)
+ else if (omp_exit_data || n->u.map_op == OMP_MAP_RELEASE)
map_kind = GOMP_MAP_RELEASE;
else
map_kind = GOMP_MAP_TO_PSET;
OMP_CLAUSE_SET_MAP_KIND (node2, map_kind);
- if (op != EXEC_OMP_TARGET_EXIT_DATA
+ if (!omp_exit_data
&& n->u.map_op != OMP_MAP_DELETE
&& n->u.map_op != OMP_MAP_RELEASE)
{
@@ -5150,9 +5270,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
&& !(POINTER_TYPE_P (type)
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))))
k = GOMP_MAP_FIRSTPRIVATE_POINTER;
- gfc_trans_omp_array_section (block, op, n, decl, element,
- !openacc, k, node, node2,
- node3, node4);
+ gfc_trans_omp_array_section (block, cd, n, decl, element,
+ k, node, node2, node3, node4);
}
else if (n->expr
&& n->expr->expr_type == EXPR_VARIABLE
@@ -5212,7 +5331,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
gomp_map_kind kind;
if (n->u.map_op == OMP_MAP_DELETE)
kind = GOMP_MAP_DELETE;
- else if (op == EXEC_OMP_TARGET_EXIT_DATA)
+ else if (omp_exit_data)
kind = GOMP_MAP_RELEASE;
else
kind = GOMP_MAP_TO;
@@ -5272,8 +5391,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");
@@ -5300,6 +5426,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];
@@ -5416,6 +5553,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)))
{
@@ -5438,7 +5585,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
else if (n->u.map_op == OMP_MAP_RELEASE
|| n->u.map_op == OMP_MAP_DELETE)
;
- else if (op == EXEC_OMP_TARGET_EXIT_DATA)
+ else if (omp_exit_data)
map_kind = GOMP_MAP_RELEASE;
if (!openacc
&& n->expr->ts.type == BT_CHARACTER
@@ -5548,6 +5695,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);
@@ -5576,9 +5731,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
/* An array element or section. */
bool element = lastref->u.ar.type == AR_ELEMENT;
gomp_map_kind kind = GOMP_MAP_ATTACH_DETACH;
- gfc_trans_omp_array_section (block, op, n, inner, element,
- !openacc, kind, node, node2,
- node3, node4);
+ gfc_trans_omp_array_section (block, cd, n, inner, element,
+ kind, node, node2, node3,
+ node4);
}
else
gcc_unreachable ();
@@ -5588,15 +5743,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:
@@ -6573,7 +6790,7 @@ gfc_trans_oacc_construct (gfc_code *code)
gfc_start_block (&block);
oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
- code->loc, false, true);
+ code->loc, TOC_OPENACC);
pushlevel ();
stmt = gfc_trans_omp_code (code->block->next, true);
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
@@ -6612,8 +6829,8 @@ gfc_trans_oacc_executable_directive (gfc_code *code)
}
gfc_start_block (&block);
- oacc_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc,
- false, true, code->op);
+ oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+ code->loc, TOC_OPENACC);
stmt = build1_loc (input_location, construct_code, void_type_node,
oacc_clauses);
gfc_add_expr_to_block (&block, stmt);
@@ -7118,9 +7335,9 @@ gfc_trans_omp_allocate (gfc_code *code)
gfc_start_block (&block);
stmt = make_node (OMP_ALLOCATE);
TREE_TYPE (stmt) = void_type_node;
+ /* Previously passed declare_simd=false, openacc=true? */
OMP_ALLOCATE_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, clauses,
- code->loc, false,
- true);
+ code->loc);
if (code->next == NULL && code->block == NULL
&& code->resolved_sym != NULL)
OMP_ALLOCATE_KIND_FREE (stmt) = 1;
@@ -7940,7 +8157,7 @@ gfc_trans_oacc_combined_directive (gfc_code *code)
if (construct_code == OACC_KERNELS)
construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
- code->loc, false, true);
+ code->loc, TOC_OPENACC);
}
if (!loop_clauses.seq)
pblock = █
@@ -9367,6 +9584,349 @@ gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa,
return gfc_finish_block (&block);
}
+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_trans_omp_instantiate_mapper (gfc_omp_namelist **outlistp,
+ gfc_omp_namelist *clause, gfc_omp_udm *udm)
+{
+ /* 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];
+ gfc_omp_map_op outer_map_op = clause->u.map_op;
+ 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);
+
+ if (mapper_clause->u.map_op == OMP_MAP_UNSET)
+ new_clause->u.map_op = outer_map_op;
+ else
+ new_clause->u.map_op = mapper_clause->u.map_op;
+
+ 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_trans_omp_instantiate_mapper (outlistp, new_clause,
+ inner_udm);
+ }
+ else
+ {
+ *outlistp = new_clause;
+ outlistp = &new_clause->next;
+ }
+ }
+
+ return outlistp;
+}
+
+static void
+gfc_trans_omp_instantiate_mappers (gfc_omp_clauses *clauses)
+{
+ gfc_omp_namelist *clause = clauses->lists[OMP_LIST_MAP];
+ gfc_omp_namelist **clausep = &clauses->lists[OMP_LIST_MAP];
+
+ for (; clause; clause = *clausep)
+ {
+ if (clause->u2.udm)
+ {
+ clausep = gfc_trans_omp_instantiate_mapper (clausep,
+ clause,
+ clause->u2.udm->udm);
+ *clausep = clause->next;
+ }
+ else
+ clausep = &clause->next;
+ }
+}
+
+/* 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)
{
@@ -9377,14 +9937,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_trans_omp_instantiate_mappers (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:
@@ -9397,6 +9961,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);
@@ -9688,7 +10253,7 @@ gfc_trans_omp_target_exit_data (gfc_code *code)
gfc_start_block (&block);
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
- code->loc, false, false, code->op);
+ code->loc, TOC_OPENMP_EXIT_DATA);
stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node,
omp_clauses);
gfc_add_expr_to_block (&block, stmt);
@@ -9887,8 +10452,7 @@ gfc_trans_oacc_declare (gfc_code *code)
gfc_start_block (&block);
oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses,
- code->loc, false, true,
- EXEC_OACC_DECLARE);
+ code->loc, TOC_OPENACC_DECLARE);
stmt = gfc_trans_omp_code (code->block->next, true);
if (oacc_clauses)
stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
@@ -10099,7 +10663,8 @@ gfc_trans_omp_declare_simd (gfc_namespace *ns)
gfc_omp_declare_simd *ods;
for (ods = ns->omp_declare_simd; ods; ods = ods->next)
{
- tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
+ tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where,
+ TOC_OPENMP_DECLARE_SIMD);
tree fndecl = ns->proc_name->backend_decl;
if (c != NULL_TREE)
c = tree_cons (NULL_TREE, c, NULL_TREE);
@@ -10167,7 +10732,8 @@ gfc_trans_omp_set_selector (gfc_omp_set_selector *gfc_selectors, locus where,
break;
case CTX_PROPERTY_SIMD:
properties = gfc_trans_omp_clauses (NULL, otp->clauses,
- where, true);
+ where,
+ TOC_OPENMP_DECLARE_SIMD);
break;
default:
gcc_unreachable ();
@@ -10384,3 +10950,112 @@ bool gfc_skip_omp_metadirective_clause (gfc_omp_metadirective_clause *clause)
return omp_context_selector_matches (selector, true) == 0;
}
+
+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);
+}
+
+/* Here we need to translate the internal representation of an 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);
+}
@@ -72,6 +72,7 @@ tree gfc_trans_omp_directive (gfc_code *);
void gfc_trans_omp_declare_simd (gfc_namespace *);
void gfc_trans_omp_declare_variant (gfc_namespace *);
tree gfc_trans_omp_metadirective (gfc_code *code);
+void gfc_trans_omp_declare_mappers (gfc_symtree *);
tree gfc_trans_oacc_directive (gfc_code *);
tree gfc_trans_oacc_declare (gfc_namespace *);
@@ -829,6 +829,9 @@ bool gfc_omp_deep_mapping_p (const gimple *, tree);
tree gfc_omp_deep_mapping_cnt (const gimple *, tree, gimple_seq *);
void gfc_omp_deep_mapping (const gimple *, tree, unsigned HOST_WIDE_INT, tree,
tree, tree, tree, tree, gimple_seq *);
+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;
@@ -8932,6 +8933,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
@@ -8953,14 +8974,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;
@@ -11703,6 +11732,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,
@@ -11722,8 +11805,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
@@ -11755,6 +11968,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,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
@@ -1133,6 +1133,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 ();
}
@@ -240,7 +240,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,24 @@
+! { dg-do run }
+
+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)
+
+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,36 @@
+! { 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
+
+! Here, the mappers are declared out of order, so later ones are not 'seen' by
+! earlier ones. Is that right?
+!$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%c = 1
+myu%myt%mys%d = 0
+
+!$omp target map(tofrom: myu)
+myu%myt%mys%d(5) = myu%myt%mys%d(5) + 1
+!$omp end target
+
+! Note: we used the default mapper, not the 's' mapper, so we mapped the
+! whole array 'd'.
+if (myu%myt%mys%d(5).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
This patch implements "omp declare mapper" functionality for Fortran, following the equivalent support for C and C++. This version of the patch has been merged to og13 and contains various fixes for e.g.: * Mappers with deferred-length strings * Array descriptors not being appropriately transferred to the offload target (see "OMP_MAP_POINTER_ONLY" and gimplify.cc:omp_maybe_get_descriptor_from_ptr). 2023-06-30 Julian Brown <julian@codesourcery.com> gcc/fortran/ * dump-parse-tree.cc (show_attr): Show omp_udm_artificial_var flag. (show_omp_namelist): Support OMP_MAP_POINTER_ONLY and OMP_MAP_UNSET. * f95-lang.cc (LANG_HOOKS_OMP_FINISH_MAPPER_CLAUSES, LANG_HOOKS_OMP_EXTRACT_MAPPER_DIRECTIVE, LANG_HOOKS_OMP_MAP_ARRAY_SECTION): Define language hooks. * gfortran.h (gfc_statement): Add ST_OMP_DECLARE_MAPPER. (symbol_attribute): Add omp_udm_artificial_var attribute. (gfc_omp_map_op): Add OMP_MAP_POINTER_ONLY and OMP_MAP_UNSET. (gfc_omp_namelist): Add udm pointer to u2 union. (gfc_omp_udm): New struct. (gfc_omp_namelist_udm): New struct. (gfc_symtree): Add omp_udm pointer. (gfc_namespace): Add omp_udm_root symtree. Add omp_udm_ns flag. (gfc_free_omp_namelist): Update prototype. (gfc_free_omp_udm, gfc_omp_udm_find, gfc_find_omp_udm, gfc_resolve_omp_udms): Add prototypes. * match.cc (gfc_free_omp_namelist): Change FREE_NS and FREE_ALIGN parameters to LIST number, to handle freeing user-defined mapper namelists safely. * match.h (gfc_match_omp_declare_mapper): Add prototype. * module.cc (ab_attribute): Add AB_OMP_DECLARE_MAPPER_VAR. (attr_bits): Add OMP_DECLARE_MAPPER_VAR. (mio_symbol_attribute): Read/write AB_OMP_DECLARE_MAPPER_VAR attribute. Set referenced attr on read. (omp_map_clause_ops, omp_map_cardinality): New arrays. (load_omp_udms, check_omp_declare_mappers): New functions. (read_module): Load and check OMP declare mappers. (write_omp_udm, write_omp_udms): New functions. (write_module): Write OMP declare mappers. * openmp.cc (gfc_free_omp_clauses, gfc_match_omp_variable_list, gfc_match_omp_to_link, gfc_match_omp_depend_sink, gfc_match_omp_clause_reduction): Update calls to gfc_free_omp_namelist. (gfc_free_omp_udm, gfc_find_omp_udm, gfc_omp_udm_find, gfc_match_omp_declare_mapper): New functions. (gfc_match_omp_clauses): Add DEFAULT_MAP_OP parameter. Update calls to gfc_free_omp_namelist. Add declare mapper support. (resolve_omp_clauses): Add declare mapper support. Update calls to gfc_free_omp_namelist. (gfc_resolve_omp_udm, gfc_resolve_omp_udms): New functions. * parse.cc (decode_omp_directive): Add declare mapper support. (case_omp_decl): Add ST_OMP_DECLARE_MAPPER case. (gfc_ascii_statement): Add ST_OMP_DECLARE_MAPPER case. * resolve.cc (resolve_types): Call gfc_resolve_omp_udms. * st.cc (gfc_free_statement): Update call to gfc_free_omp_namelist. * symbol.cc (free_omp_udm_tree): New function. (gfc_free_namespace): Call above. * trans-decl.cc (omp_declare_mapper_ns): New global. (gfc_finish_var_decl, gfc_generate_function_code): Support declare mappers. (gfc_trans_deferred_vars): Ignore artificial declare-mapper vars. * trans-openmp.cc (tree-iterator.h): Include. (toc_directive): New enum. (gfc_trans_omp_array_section): Change OP and OPENMP parameters to toc_directive CD ('clause directive'). (gfc_omp_finish_mapper_clauses, gfc_omp_extract_mapper_directive, gfc_omp_map_array_section): New functions. (omp_clause_directive): New enum. (gfc_trans_omp_clauses): Remove DECLARE_SIMD and OPENACC parameters. Replace with toc_directive CD, defaulting to TOC_OPENMP. Add declare mapper support and OMP_MAP_POINTER_ONLY support. (gfc_trans_omp_construct, gfc_trans_oacc_executable_directive, gfc_trans_oacc_combined_directive): Update calls to gfc_trans_omp_clauses. (gfc_subst_replace, gfc_subst_prepend_ref): New variables. (gfc_subst_in_expr_1, gfc_subst_in_expr, gfc_subst_mapper_var, gfc_trans_omp_instantiate_mapper, gfc_trans_omp_instantiate_mappers, gfc_record_mapper_bindings_code_fn, gfc_record_mapper_bindings_expr_fn, gfc_find_nested_mappers, gfc_record_mapper_bindings): New functions. (gfc_typespec * hash traits): New template. (omp_declare_mapper_ns): Extern declaration. (gfc_trans_omp_target): Call gfc_trans_omp_instantiate_mappers and gfc_record_mapper_bindings. Update calls to gfc_trans_omp_clauses. (gfc_trans_omp_declare_simd, gfc_trans_omp_declare_variant): Update calls to gfc_trans_omp_clauses. (gfc_trans_omp_mapper_name, gfc_trans_omp_declare_mapper, gfc_trans_omp_declare_mappers): New functions. * trans-stmt.h (gfc_trans_omp_declare_mappers): Add prototype. * trans.h (gfc_omp_finish_mapper_clauses, gfc_omp_extract_mapper_directive, gfc_omp_map_array_section): Add prototypes. gcc/ * gimplify.cc (dwarf2out.h): Include. (omp_maybe_get_descriptor_from_ptr): New function. (build_omp_struct_comp_nodes): Use above function to locate array descriptor when necessary. (omp_mapping_group_data, omp_mapping_group_ptr, omp_mapping_group_pset): New functions. (omp_instantiate_mapper): Handle inlining of "declare mapper" function bodies containing setup code (e.g. for Fortran). Handle pointers to derived types. Handle GOMP_MAP_MAPPING_GROUPs. * tree-pretty-print.cc (dump_omp_clause): Handle GOMP_MAP_MAPPING_GROUP. include/ * gomp-constants.h (gomp_map_kind): Add GOMP_MAP_MAPPING_GROUP. gcc/testsuite/ * gfortran.dg/gomp/declare-mapper-1.f90: New test. * gfortran.dg/gomp/declare-mapper-5.f90: New test. * gfortran.dg/gomp/declare-mapper-14.f90: New test. libgomp/ * testsuite/libgomp.fortran/declare-mapper-2.f90: New test. * testsuite/libgomp.fortran/declare-mapper-3.f90: New test. * testsuite/libgomp.fortran/declare-mapper-4.f90: New test. * testsuite/libgomp.fortran/declare-mapper-6.f90: New test. * testsuite/libgomp.fortran/declare-mapper-7.f90: New test. * testsuite/libgomp.fortran/declare-mapper-8.f90: New test. * testsuite/libgomp.fortran/declare-mapper-9.f90: New test. * testsuite/libgomp.fortran/declare-mapper-10.f90: New test. * testsuite/libgomp.fortran/declare-mapper-11.f90: New test. * testsuite/libgomp.fortran/declare-mapper-12.f90: New test. * testsuite/libgomp.fortran/declare-mapper-13.f90: New test. * testsuite/libgomp.fortran/declare-mapper-15.f90: New test. * testsuite/libgomp.fortran/declare-mapper-17.f90: New test. * testsuite/libgomp.fortran/declare-mapper-18.f90: New test. * testsuite/libgomp.fortran/declare-mapper-19.f90: New test. * testsuite/libgomp.fortran/declare-mapper-20.f90: New test. * testsuite/libgomp.fortran/declare-mapper-21.f90: New test. --- gcc/fortran/dump-parse-tree.cc | 4 + gcc/fortran/f95-lang.cc | 7 + gcc/fortran/gfortran.h | 56 +- gcc/fortran/match.cc | 9 +- gcc/fortran/match.h | 1 + gcc/fortran/module.cc | 251 +++++- gcc/fortran/openmp.cc | 299 ++++++- gcc/fortran/parse.cc | 14 +- gcc/fortran/resolve.cc | 2 + gcc/fortran/st.cc | 2 +- gcc/fortran/symbol.cc | 16 + gcc/fortran/trans-decl.cc | 33 +- gcc/fortran/trans-openmp.cc | 785 ++++++++++++++++-- gcc/fortran/trans-stmt.h | 1 + gcc/fortran/trans.h | 3 + gcc/gimplify.cc | 298 ++++++- .../gfortran.dg/gomp/declare-mapper-1.f90 | 71 ++ .../gfortran.dg/gomp/declare-mapper-14.f90 | 26 + .../gfortran.dg/gomp/declare-mapper-5.f90 | 45 + gcc/tree-pretty-print.cc | 3 + include/gomp-constants.h | 5 +- .../libgomp.fortran/declare-mapper-10.f90 | 40 + .../libgomp.fortran/declare-mapper-11.f90 | 38 + .../libgomp.fortran/declare-mapper-12.f90 | 33 + .../libgomp.fortran/declare-mapper-13.f90 | 49 ++ .../libgomp.fortran/declare-mapper-15.f90 | 24 + .../libgomp.fortran/declare-mapper-17.f90 | 92 ++ .../libgomp.fortran/declare-mapper-18.f90 | 46 + .../libgomp.fortran/declare-mapper-19.f90 | 29 + .../libgomp.fortran/declare-mapper-2.f90 | 32 + .../libgomp.fortran/declare-mapper-20.f90 | 29 + .../libgomp.fortran/declare-mapper-21.f90 | 24 + .../libgomp.fortran/declare-mapper-3.f90 | 33 + .../libgomp.fortran/declare-mapper-4.f90 | 36 + .../libgomp.fortran/declare-mapper-6.f90 | 28 + .../libgomp.fortran/declare-mapper-7.f90 | 29 + .../libgomp.fortran/declare-mapper-8.f90 | 115 +++ .../libgomp.fortran/declare-mapper-9.f90 | 27 + 38 files changed, 2540 insertions(+), 95 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-mapper-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-mapper-14.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-mapper-5.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-10.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-11.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-12.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-13.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-15.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-17.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-18.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-19.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-2.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-20.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-21.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-3.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-4.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-6.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-7.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-8.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/declare-mapper-9.f90