This patch upstreams parts of Julian's "OpenMP: Fortran "!$omp declare mapper" support" OG14 commit 015cb4002d6c022b33234e6098303edf159fb19e https://gcc.gnu.org/g:015cb4002d6c022b33234e6098303edf159fb19e
One part already landed as r17-279-g357207648f16ee Fortran/OpenMP: cleanup gfc_free_omp_namelist The attached patch implements only the parser support, i.e. has several parts removed related to late resolving and module storage. On the other hand, it contains several fixes regarding to the diagnostic and one missing restriction check. When using this feature, it fails with 'sorry'. (To be fixed by the next patch or two.) Comments before I push this commit?* Tobias (*speaking with my hat as OpenMP maintainer on.)
Author: Julian Brown <[email protected]> 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): (resolve_omp_clauses): Take argument for the default map-type modifier; add support for the 'mapper' modifier. * 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]> 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 1b3c587179c..2bf1b75650b 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 16fc5e52cd9..7a1f51e51ae 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 68a8c21e13b..d892a4588b2 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 52cb2f0cd23..0641e5a434c 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 18a6d6ea5c5..18c67042740 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 a41bf090c33..7d59a8b326d 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 6d2ebed813f..12ce8d9b265 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 e1b49b0ba0d..66e7c8baf49 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 00000000000..ef79f91e3fe --- /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 00000000000..b2ae38fd15a --- /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
