https://gcc.gnu.org/g:cf6ef1219e488b0fbfa32508237a682bc34d5bff
commit r17-610-gcf6ef1219e488b0fbfa32508237a682bc34d5bff Author: Julian Brown <[email protected]> Date: Tue May 19 21:25:54 2026 +0200 OpenMP: Fortran "!$omp declare mapper" parser support gcc/fortran/ChangeLog: * dump-parse-tree.cc (show_attr): Show omp_udm_artificial_var flag. (show_omp_namelist): Support OMP_MAP_UNSET. * gfortran.h (enum gfc_statement): Add ST_OMP_DECLARE_MAPPER. (symbol_attribute): Add omp_udm_artificial_var attribute. (enum gfc_omp_map_op): Add OMP_MAP_UNSET. (gfc_omp_namelist_udm): New struct. (gfc_omp_namelist): Add udm pointer to u2 union. (gfc_symtree): Add omp_udm pointer. (gfc_namespace): Add omp_udm_root symtree and omp_udm_ns flag. (gfc_free_omp_udm, gfc_omp_udm_find, gfc_find_omp_udm, gfc_resolve_omp_udms): Add prototypes. * match.h (gfc_match_omp_declare_mapper): Add prototype. * match.cc (gfc_free_omp_namelist): Update for declare mapper's udm. * openmp.cc (gfc_omp_directives): Uncomment 'declare mapper'. (gfc_free_omp_udm, gfc_find_omp_udm, gfc_omp_udm_find, gfc_match_omp_declare_mapper, gfc_resolve_omp_udm, gfc_resolve_omp_udms): New. (gfc_match_omp_clauses): Take argument for the default map-type modifier; add support for the 'mapper' modifier. (resolve_omp_clauses): Update for declare-mapper map clauses. * 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. * symbol.cc (free_omp_udm_tree): New function. (gfc_free_namespace): Call it. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/declare-mapper-1.f90: New test. * gfortran.dg/gomp/declare-mapper-2.f90: New test. Co-Authored-By: Tobias Burnus <[email protected]> Diff: --- gcc/fortran/dump-parse-tree.cc | 3 + gcc/fortran/gfortran.h | 55 +++- gcc/fortran/match.cc | 5 +- gcc/fortran/match.h | 1 + gcc/fortran/openmp.cc | 299 ++++++++++++++++++++- gcc/fortran/parse.cc | 7 +- gcc/fortran/resolve.cc | 5 + gcc/fortran/symbol.cc | 16 ++ .../gfortran.dg/gomp/declare-mapper-1.f90 | 55 ++++ .../gfortran.dg/gomp/declare-mapper-2.f90 | 22 ++ 10 files changed, 455 insertions(+), 13 deletions(-) diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 1b3c587179c2..2bf1b75650b2 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -944,6 +944,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) @@ -1628,6 +1630,7 @@ 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_UNSET: fputs ("unset:", dumpfile); break; default: break; } else if (list_type == OMP_LIST_LINEAR && n->u.linear.old_modifier) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 16fc5e52cd9b..7a1f51e51aea 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -284,8 +284,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, @@ -1041,6 +1042,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; @@ -1373,7 +1378,8 @@ enum gfc_omp_map_op OMP_MAP_PRESENT_TOFROM = (1 << 13) | OMP_MAP_TOFROM, OMP_MAP_ALWAYS_PRESENT_TO = OMP_MAP_ALWAYS_TO | OMP_MAP_PRESENT_TO, OMP_MAP_ALWAYS_PRESENT_FROM = OMP_MAP_ALWAYS_FROM | OMP_MAP_PRESENT_FROM, - OMP_MAP_ALWAYS_PRESENT_TOFROM = OMP_MAP_ALWAYS_TOFROM | OMP_MAP_PRESENT_TOFROM + OMP_MAP_ALWAYS_PRESENT_TOFROM = OMP_MAP_ALWAYS_TOFROM | OMP_MAP_PRESENT_TOFROM, + OMP_MAP_UNSET = 1 << 14 }; enum gfc_omp_defaultmap @@ -1408,6 +1414,15 @@ enum gfc_omp_linear_op OMP_LINEAR_UVAL }; +typedef struct gfc_omp_namelist_udm +{ + /* When adding more struct members, change the struct use in gfc_omp_namelist + to a pointer and move the struct definition down, placing it after + '#define gfc_get_omp_udm'. */ + struct gfc_omp_udm *udm; +} +gfc_omp_namelist_udm; + /* For use in OpenMP clauses in case we need extra information (aligned clause alignment, linear clause step, etc.). */ @@ -1453,6 +1468,7 @@ typedef struct gfc_omp_namelist union { struct gfc_omp_namelist_udr *udr; + struct gfc_omp_namelist_udm udm; gfc_namespace *ns; gfc_expr *allocator; struct gfc_symbol *traits_sym; @@ -1848,6 +1864,28 @@ 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; + + /* FIXME: We don't need a whole gfc_omp_clauses here. We only use the + OMP_LIST_MAP clause list; however, the used resolve_omp_clauses + requires the full set. */ + gfc_omp_clauses *clauses; + + tree backend_decl; +} +gfc_omp_udm; +#define gfc_get_omp_udm() XCNEW (gfc_omp_udm) + /* The gfc_st_label structure is a BBT attached to a namespace that records the usage of statement labels within that space. */ @@ -2216,6 +2254,7 @@ typedef struct gfc_symtree gfc_common_head *common; gfc_typebound_proc *tb; gfc_omp_udr *omp_udr; + gfc_omp_udm *omp_udm; } n; unsigned import_only:1; @@ -2271,6 +2310,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; @@ -2398,6 +2439,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; @@ -3936,8 +3980,12 @@ void gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list); void gfc_free_omp_declare_simd (gfc_omp_declare_simd *); void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *); void gfc_free_omp_udr (gfc_omp_udr *); +void gfc_free_omp_udm (gfc_omp_udm *); void gfc_free_omp_variants (gfc_omp_variant *); gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *); +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_allocate (gfc_namespace *, gfc_omp_namelist *); void gfc_resolve_omp_assumptions (gfc_omp_assumptions *); void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *); @@ -3947,6 +3995,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 (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 *); diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 68a8c21e13be..d892a4588b2c 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -6345,6 +6345,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, enum gfc_omp_list_type list) bool free_align_allocator = (list == OMP_LIST_ALLOCATE); bool free_mem_traits_space = (list == OMP_LIST_USES_ALLOCATORS); bool free_init = (list == OMP_LIST_INIT); + bool free_mapper = (list == OMP_LIST_MAP); gfc_omp_namelist *n; gfc_expr *last_allocator = NULL; @@ -6378,7 +6379,9 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, enum gfc_omp_list_type list) free (name->u2.init_interop); } } - else if (name->u2.udr) + else if (free_mapper) + { } /* For now, u2.udm is not a pointer. */ + else if (!free_mapper && name->u2.udr) { if (name->u2.udr->combiner) gfc_free_statement (name->u2.udr->combiner); diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 52cb2f0cd235..0641e5a434c9 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -159,6 +159,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); diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 18a6d6ea5c54..18c67042740d 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -70,7 +70,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { {"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL}, {"critical", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CRITICAL}, /* {"declare induction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_INDUCTION}, */ - /* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */ + {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, {"declare reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION}, {"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD}, {"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET}, @@ -379,6 +379,19 @@ gfc_free_omp_variants (gfc_omp_variant *variant) } } +/* 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) { @@ -2379,13 +2392,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 (); @@ -3682,9 +3734,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 (;;) { @@ -3704,6 +3759,14 @@ 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; if (gfc_match (", ") != MATCH_YES) @@ -3714,7 +3777,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, "OpenMP 5.2"); } - 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; @@ -3745,6 +3808,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) @@ -3765,6 +3829,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], @@ -3773,7 +3843,22 @@ 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.udm = udm; + } + } continue; } gfc_current_locus = old_loc; @@ -5793,6 +5878,169 @@ 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 !$omp declare mapper([ mapper-identifier : ] type :: var) clauses-list */ + +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) + { + gfc_error ("Expected %<(%> at %C"); + 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; + } + old_locus = gfc_current_locus; + + m = gfc_match_type_spec (&ts); + if (m != MATCH_YES) + { + gfc_error ("Expected either a type name at %L or a map-type " + "identifier, a colon, or a type name", &old_locus); + return MATCH_ERROR; + } + + if (ts.type != BT_DERIVED) + { + gfc_error ("!$OMP DECLARE MAPPER with non-derived type at %L", &old_locus); + return MATCH_ERROR; + } + + if (gfc_match (" :: ") != MATCH_YES) + { + gfc_error ("Expected %<::%> at %C"); + return MATCH_ERROR; + } + + if (gfc_match_name (var) != MATCH_YES) + { + gfc_error ("Expected variable name at %C"); + return MATCH_ERROR; + } + + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Expected %<)%> at %C"); + 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) + { + if (mapper_id[0]) + gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs with id %qs", + &where, gfc_typename (&ts), mapper_id); + else + gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs", + &where, gfc_typename (&ts)); + inform (gfc_get_location (&prev_udm->where), + "Previous !$OMP DECLARE MAPPER here"); + return MATCH_ERROR; + } + 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; + } + + return MATCH_YES; + +failure: + if (mapper_ns) + gfc_current_ns = mapper_ns->parent; + gfc_free_omp_udm (omp_udm); + + return MATCH_ERROR; +} + + static bool match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2) { @@ -9145,9 +9393,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; @@ -9879,7 +10131,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, array isn't contiguous. An expression such as arr(-n:n,-n:n) could be contiguous even if it looks like it may not be. */ - if (code->op != EXEC_OACC_UPDATE + if (code + && code->op != EXEC_OACC_UPDATE && list != OMP_LIST_CACHE && list != OMP_LIST_DEPEND && !gfc_is_simply_contiguous (n->expr, false, true) @@ -9991,7 +10244,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: @@ -13739,3 +13992,33 @@ gfc_resolve_omp_udrs (gfc_symtree *st) for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) gfc_resolve_omp_udr (omp_udr); } + +/* 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); + + gfc_omp_namelist *n; + for (n = omp_udm->clauses->lists[OMP_LIST_MAP]; n; n = n->next) + if (n->sym == omp_udm->var_sym) + break; + if (!n) + gfc_error ("At least one %<map%> clause in !$OMP DECLARE MAPPER at %L must " + "map %qs or an element of it", + &omp_udm->where, omp_udm->var_sym->name); +} + +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); +} diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index a41bf090c339..7d59a8b326d1 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -1014,6 +1014,8 @@ decode_omp_directive (void) break; case 'd': + matchdo ("declare mapper", gfc_match_omp_declare_mapper, + ST_OMP_DECLARE_MAPPER); matchds ("declare reduction", gfc_match_omp_declare_reduction, ST_OMP_DECLARE_REDUCTION); matchds ("declare simd", gfc_match_omp_declare_simd, @@ -1993,7 +1995,7 @@ next_statement (void) #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \ case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \ - case ST_OMP_REQUIRES: case ST_OMP_GROUPPRIVATE: \ + case ST_OMP_REQUIRES: case ST_OMP_GROUPPRIVATE: case ST_OMP_DECLARE_MAPPER: \ case ST_OACC_ROUTINE: case ST_OACC_DECLARE /* OpenMP statements that are followed by a structured block. */ @@ -2685,6 +2687,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; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 6d2ebed813f5..12ce8d9b265b 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -20597,6 +20597,11 @@ resolve_types (gfc_namespace *ns) gfc_resolve_omp_udrs (ns->omp_udr_root); + gfc_resolve_omp_udms (ns->omp_udm_root); + if (ns->omp_udm_root) + gfc_error ("Sorry, %<declare mapper%>, used at %L, is not yet implemented", + &ns->omp_udm_root->n.omp_udm->where); + ns->types_resolved = 1; gfc_current_ns = old_ns; diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index e1b49b0ba0da..66e7c8baf492 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -4189,6 +4189,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. */ @@ -4363,6 +4378,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); diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-mapper-1.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-1.f90 new file mode 100644 index 000000000000..ef79f91e3fe7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-1.f90 @@ -0,0 +1,55 @@ +! Check that other variables are fine to be mapped - but only if the var itself is mapped + +subroutine one +implicit none +type t + integer :: x(5) +end type + +integer :: q, z + +!$omp declare mapper(t :: v) map(v%x(1:5)) ! { dg-error "Sorry, 'declare mapper', used at .1., is not yet implemented" } +!$omp declare mapper(my_name : t :: v2) map(q) map(v2) map(z) + +type(t) :: var(4) +type(t) :: var2(4) + + !$omp target enter data map(var) + !$omp target enter data map(mapper(my_name), to : var2) + +!$omp assume contains(declare mapper) ! { dg-error "Invalid 'DECLARE MAPPER' directive at .1. in CONTAINS clause: declarative, informational, and meta directives not permitted" } +block +end block +end + + +subroutine two +implicit none +type t +end type t +integer :: y +!$omp declare mapper( t :: var) map(to: y) ! { dg-error "At least one 'map' clause in !.OMP DECLARE MAPPER at .1. must map 'var' or an element of it" } +! { dg-error "Sorry, 'declare mapper', used at .1., is not yet implemented" "" { target *-*-* } .-1 } +end + + +subroutine three +implicit none +type t +end type t +integer :: y +!$omp declare mapper( t :: var) ! { dg-error "At least one 'map' clause in !.OMP DECLARE MAPPER at .1. must map 'var' or an element of it" } +! { dg-error "Sorry, 'declare mapper', used at .1., is not yet implemented" "" { target *-*-* } .-1 } +end + +subroutine four + type t + end type t + !$omp declare mapper(my_id : t :: v2) map(v2) ! { dg-note "Previous !.OMP DECLARE MAPPER here" } + + !$omp declare mapper(my_id : t :: v3) map(v3) ! { dg-error "Redefinition of !.OMP DECLARE MAPPER at .1. for type 'TYPE\\(t\\)' with id 'my_id'" } + + !$omp declare mapper(t :: v4) map(v4) ! { dg-note "Previous !.OMP DECLARE MAPPER here" } +! { dg-error "Sorry, 'declare mapper', used at .1., is not yet implemented" "" { target *-*-* } .-1 } + !$omp declare mapper(t :: v5) map(v5) ! { dg-error "Redefinition of !.OMP DECLARE MAPPER at .1. for type 'TYPE\\(t\\)'" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-mapper-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-2.f90 new file mode 100644 index 000000000000..b2ae38fd15a6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-2.f90 @@ -0,0 +1,22 @@ +implicit none +type t +end type t +integer :: a,b,c + +!$omp declare mapper ! { dg-error "Expected '\\('" } +!$omp declare mapper( ! { dg-error "Expected either a type name at .1. or a map-type identifier, a colon, or a type name" } +!$omp declare mapper(a : b ! { dg-error "Expected either a type name at .1. or a map-type identifier, a colon, or a type name" } + +!$omp declare mapper(t : a ! { dg-error "Expected either a type name at .1. or a map-type identifier, a colon, or a type name" } +!$omp declare mapper(t :: a ! { dg-error "Expected '\\)'" } + +!$omp declare mapper( name : t :: ! { dg-error "Expected variable name" } + +!$omp declare mapper( name : t :: var ! { dg-error "Expected '\\)'" } + +!$omp declare mapper( name : t :: var) foo ! { dg-error "Failed to match clause" } + + +!$omp declare mapper( name : t2 :: var) ! { dg-error "Expected either a type name at .1. or a map-type identifier, a colon, or a type name" } +!$omp declare mapper( name : integer :: var) ! { dg-error "!.OMP DECLARE MAPPER with non-derived type" } +end
