From eed8a06fca397edd5fb451f08c8b1a6f7d67951a Mon Sep 17 00:00:00 2001 From: Kwok Cheung Yeung Date: Mon, 6 Dec 2021 22:59:36 +0000 Subject: [PATCH 6/7] openmp, fortran: Add Fortran support for parsing metadirectives This adds support for parsing OpenMP metadirectives in the Fortran front end. 2021-12-10 Kwok Cheung Yeung gcc/ * omp-general.c (omp_check_context_selector): Revert string length check. (omp_context_name_list_prop): Likewise. gcc/fortran/ * decl.c (gfc_match_end): Handle COMP_OMP_METADIRECTIVE and COMP_OMP_BEGIN_METADIRECTIVE. * dump-parse-tree.c (show_omp_node): Handle EXEC_OMP_METADIRECTIVE. (show_code_node): Handle EXEC_OMP_METADIRECTIVE. * gfortran.h (enum gfc_statement): Add ST_OMP_METADIRECTIVE, ST_OMP_BEGIN_METADIRECTIVE and ST_OMP_END_METADIRECTIVE. (struct gfc_omp_metadirective_clause): New structure. (gfc_get_omp_metadirective_clause): New macro. (struct gfc_st_label): Add omp_region field. (enum gfc_exec_op): Add EXEC_OMP_METADIRECTIVE. (struct gfc_code): Add omp_metadirective_clauses field. (gfc_free_omp_metadirective_clauses): New prototype. (match_omp_directive): New prototype. * io.c (format_asterisk): Initialize omp_region field. * match.h (gfc_match_omp_begin_metadirective): New prototype. (gfc_match_omp_metadirective): New prototype. * openmp.c (gfc_match_omp_eos): Match ')' in context selectors. (gfc_free_omp_metadirective_clauses): New. (gfc_match_omp_clauses): Remove context_selector argument. Rely on gfc_match_omp_eos to match end of clauses. (match_omp): Remove extra argument to gfc_match_omp_clauses. (gfc_match_omp_context_selector): Remove extra argument to gfc_match_omp_clauses. Set gfc_matching_omp_context_selector before call to gfc_match_omp_clauses and reset after. (gfc_match_omp_context_selector_specification): Modify to take a gfc_omp_set_selector** argument. (gfc_match_omp_declare_variant): Pass set_selectors to gfc_match_omp_context_selector_specification. (match_omp_metadirective): New. (gfc_match_omp_begin_metadirective): New. (gfc_match_omp_metadirective): New. (resolve_omp_metadirective): New. (gfc_resolve_omp_directive): Handle EXEC_OMP_METADIRECTIVE. * parse.c (gfc_matching_omp_context_selector): New variable. (gfc_in_metadirective_body): New variable. (gfc_omp_region_count): New variable. (decode_omp_directive): Match 'begin metadirective', 'end metadirective' and 'metadirective'. (match_omp_directive): New. (case_omp_structured_block): New. (case_omp_do): New. (gfc_ascii_statement): Handle metadirective statements. (gfc_omp_end_stmt): New. (parse_omp_do): Delegate to gfc_omp_end_stmt. (parse_omp_structured_block): Delegate to gfc_omp_end_stmt. Handle ST_OMP_END_METADIRECTIVE. (parse_omp_metadirective_body): New. (parse_executable): Delegate to case_omp_structured_block and case_omp_do. Return after one statement if compiling regular metadirective. Handle metadirective statements. (gfc_parse_file): Reset gfc_omp_region_count, gfc_in_metadirective_body and gfc_matching_omp_context_selector. * parse.h (enum gfc_compile_state): Add COMP_OMP_METADIRECTIVE and COMP_OMP_BEGIN_METADIRECTIVE. (gfc_omp_end_stmt): New prototype. (gfc_matching_omp_context_selector): New declaration. (gfc_in_metadirective_body): New declaration. (gfc_omp_region_count): New declaration. * resolve.c (gfc_resolve_code): Handle EXEC_OMP_METADIRECTIVE. * st.c (gfc_free_statement): Handle EXEC_OMP_METADIRECTIVE. * symbol.c (compare_st_labels): Take omp_region into account. (gfc_get_st_labels): Incorporate omp_region into label. * trans-decl.c (gfc_get_label_decl): Add omp_region into translated label name. * trans-openmp.c (gfc_trans_omp_directive): Handle EXEC_OMP_METADIRECTIVE. (gfc_trans_omp_set_selector): Hoist code from... (gfc_trans_omp_declare_variant): ...here. (gfc_trans_omp_metadirective): New. * trans-stmt.h (gfc_trans_omp_metadirective): New prototype. * trans.c (trans_code): Handle EXEC_OMP_METADIRECTIVE. --- gcc/fortran/decl.c | 8 + gcc/fortran/dump-parse-tree.c | 20 ++ gcc/fortran/gfortran.h | 17 ++ gcc/fortran/io.c | 2 +- gcc/fortran/match.h | 2 + gcc/fortran/openmp.c | 222 ++++++++++++-- gcc/fortran/parse.c | 532 ++++++++++++++++++++-------------- gcc/fortran/parse.h | 8 +- gcc/fortran/resolve.c | 12 + gcc/fortran/st.c | 4 + gcc/fortran/symbol.c | 18 +- gcc/fortran/trans-decl.c | 5 +- gcc/fortran/trans-openmp.c | 190 +++++++----- gcc/fortran/trans-stmt.h | 1 + gcc/fortran/trans.c | 1 + gcc/omp-general.c | 5 +- 16 files changed, 729 insertions(+), 318 deletions(-) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 4971638f9b6..d50c3ea2277 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -8323,6 +8323,8 @@ gfc_match_end (gfc_statement *st) case COMP_CONTAINS: case COMP_DERIVED_CONTAINS: + case COMP_OMP_METADIRECTIVE: + case COMP_OMP_BEGIN_METADIRECTIVE: state = gfc_state_stack->previous->state; block_name = gfc_state_stack->previous->sym == NULL ? NULL : gfc_state_stack->previous->sym->name; @@ -8475,6 +8477,12 @@ gfc_match_end (gfc_statement *st) gfc_free_enum_history (); break; + case COMP_OMP_BEGIN_METADIRECTIVE: + *st = ST_OMP_END_METADIRECTIVE; + target = " metadirective"; + eos_ok = 0; + break; + default: gfc_error ("Unexpected END statement at %C"); goto cleanup; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 2aa44ff864c..4ec64ad5ea3 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -2015,6 +2015,7 @@ show_omp_node (int level, gfc_code *c) case EXEC_OMP_MASTER: name = "MASTER"; break; case EXEC_OMP_MASTER_TASKLOOP: name = "MASTER TASKLOOP"; break; case EXEC_OMP_MASTER_TASKLOOP_SIMD: name = "MASTER TASKLOOP SIMD"; break; + case EXEC_OMP_METADIRECTIVE: name = "METADIRECTIVE"; break; case EXEC_OMP_ORDERED: name = "ORDERED"; break; case EXEC_OMP_DEPOBJ: name = "DEPOBJ"; break; case EXEC_OMP_PARALLEL: name = "PARALLEL"; break; @@ -2209,6 +2210,24 @@ show_omp_node (int level, gfc_code *c) d = d->block; } } + else if (c->op == EXEC_OMP_METADIRECTIVE) + { + gfc_omp_metadirective_clause *clause = c->ext.omp_metadirective_clauses; + + while (clause) + { + code_indent (level + 1, 0); + if (clause->selectors) + fputs ("WHEN ()\n", dumpfile); + else + fputs ("DEFAULT ()\n", dumpfile); + /* TODO: Print selector. */ + show_code (level + 2, clause->code); + if (clause->next) + fputs ("\n", dumpfile); + clause = clause->next; + } + } else show_code (level + 1, c->block->next); if (c->op == EXEC_OMP_ATOMIC) @@ -3335,6 +3354,7 @@ show_code_node (int level, gfc_code *c) case EXEC_OMP_MASTER: case EXEC_OMP_MASTER_TASKLOOP: case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_METADIRECTIVE: case EXEC_OMP_ORDERED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index e5d2dd7971e..5025df1bda2 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -316,6 +316,7 @@ enum gfc_statement ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD, ST_OMP_MASKED_TASKLOOP, ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD, ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE, + ST_OMP_METADIRECTIVE, ST_OMP_BEGIN_METADIRECTIVE, ST_OMP_END_METADIRECTIVE, ST_OMP_ERROR, ST_NONE }; @@ -1658,6 +1659,17 @@ typedef struct gfc_omp_declare_variant gfc_omp_declare_variant; #define gfc_get_omp_declare_variant() XCNEW (gfc_omp_declare_variant) +typedef struct gfc_omp_metadirective_clause +{ + struct gfc_omp_metadirective_clause *next; + locus where; /* Where the metadirective clause occurred. */ + + gfc_omp_set_selector *selectors; + enum gfc_statement stmt; + struct gfc_code *code; + +} gfc_omp_metadirective_clause; +#define gfc_get_omp_metadirective_clause() XCNEW (gfc_omp_metadirective_clause) typedef struct gfc_omp_udr { @@ -1706,6 +1718,7 @@ typedef struct gfc_st_label locus where; gfc_namespace *ns; + int omp_region; } gfc_st_label; @@ -2922,6 +2935,7 @@ enum gfc_exec_op EXEC_OMP_TARGET_TEAMS_LOOP, EXEC_OMP_MASKED, EXEC_OMP_PARALLEL_MASKED, EXEC_OMP_PARALLEL_MASKED_TASKLOOP, EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD, EXEC_OMP_MASKED_TASKLOOP, EXEC_OMP_MASKED_TASKLOOP_SIMD, EXEC_OMP_SCOPE, + EXEC_OMP_METADIRECTIVE, EXEC_OMP_ERROR }; @@ -2978,6 +2992,7 @@ typedef struct gfc_code gfc_omp_clauses *omp_clauses; const char *omp_name; gfc_omp_namelist *omp_namelist; + gfc_omp_metadirective_clause *omp_metadirective_clauses; bool omp_bool; } ext; /* Points to additional structures required by statement */ @@ -3552,6 +3567,7 @@ 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_metadirective_clauses (gfc_omp_metadirective_clause *); gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *); void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *); void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool); @@ -3827,6 +3843,7 @@ void debug (gfc_expr *); bool gfc_parse_file (void); void gfc_global_used (gfc_gsymbol *, locus *); gfc_namespace* gfc_build_block_ns (gfc_namespace *); +gfc_statement match_omp_directive (void); /* dependency.c */ int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool); diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index fc97df79eca..adb811a423c 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -29,7 +29,7 @@ along with GCC; see the file COPYING3. If not see gfc_st_label format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, - 0, {NULL, NULL}, NULL}; + 0, {NULL, NULL}, NULL, 0}; typedef struct { diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index e9368db281d..cf0f711f4ec 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -151,6 +151,7 @@ match gfc_match_oacc_routine (void); match gfc_match_omp_eos_error (void); match gfc_match_omp_atomic (void); match gfc_match_omp_barrier (void); +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); @@ -174,6 +175,7 @@ match gfc_match_omp_masked_taskloop_simd (void); match gfc_match_omp_master (void); match gfc_match_omp_master_taskloop (void); match gfc_match_omp_master_taskloop_simd (void); +match gfc_match_omp_metadirective (void); match gfc_match_omp_nothing (void); match gfc_match_omp_ordered (void); match gfc_match_omp_ordered_depend (void); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 846fd7b5c5a..1a423c8e041 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -31,7 +31,8 @@ along with GCC; see the file COPYING3. If not see #include "target-memory.h" /* For gfc_encode_character. */ /* Match an end of OpenMP directive. End of OpenMP directive is optional - whitespace, followed by '\n' or comment '!'. */ + whitespace, followed by '\n' or comment '!'. In the special case where a + context selector is being matched, match against ')' instead. */ static match gfc_match_omp_eos (void) @@ -42,17 +43,25 @@ gfc_match_omp_eos (void) old_loc = gfc_current_locus; gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - switch (c) + if (gfc_matching_omp_context_selector) { - case '!': - do - c = gfc_next_ascii_char (); - while (c != '\n'); - /* Fall through */ + if (gfc_peek_ascii_char () == ')') + return MATCH_YES; + } + else + { + c = gfc_next_ascii_char (); + switch (c) + { + case '!': + do + c = gfc_next_ascii_char (); + while (c != '\n'); + /* Fall through */ - case '\n': - return MATCH_YES; + case '\n': + return MATCH_YES; + } } gfc_current_locus = old_loc; @@ -248,6 +257,19 @@ gfc_free_omp_udr (gfc_omp_udr *omp_udr) } } +/* Free clauses of an !$omp metadirective construct. */ + +void +gfc_free_omp_metadirective_clauses (gfc_omp_metadirective_clause *clause) +{ + while (clause) + { + gfc_omp_metadirective_clause *next_clause = clause->next; + gfc_free_omp_set_selector_list (clause->selectors); + free (clause); + clause = next_clause; + } +} static gfc_omp_udr * gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts) @@ -1434,8 +1456,7 @@ gfc_match_dupl_atomic (bool not_dupl, const char *name) static match gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, bool first = true, bool needs_space = true, - bool openacc = false, bool context_selector = false, - bool openmp_target = false) + bool openacc = false, bool openmp_target = false) { bool error = false; gfc_omp_clauses *c = gfc_get_omp_clauses (); @@ -2982,9 +3003,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } end: - if (error - || (context_selector && gfc_peek_ascii_char () != ')') - || (!context_selector && gfc_match_omp_eos () != MATCH_YES)) + if (error || gfc_match_omp_eos () != MATCH_YES) { if (!gfc_error_flag_test ()) gfc_error ("Failed to match clause at %C"); @@ -3655,7 +3674,7 @@ static match match_omp (gfc_exec_op op, const omp_mask mask) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, mask, true, true, false, false, + if (gfc_match_omp_clauses (&c, mask, true, true, false, op == EXEC_OMP_TARGET) != MATCH_YES) return MATCH_ERROR; new_st.op = op; @@ -4804,14 +4823,17 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss) break; case CTX_PROPERTY_SIMD: { + gfc_matching_omp_context_selector = true; if (gfc_match_omp_clauses (&otp->clauses, OMP_DECLARE_SIMD_CLAUSES, - true, false, false, true) + true, false, false) != MATCH_YES) { - gfc_error ("expected simd clause at %C"); + gfc_matching_omp_context_selector = false; + gfc_error ("expected simd clause at %C"); return MATCH_ERROR; } + gfc_matching_omp_context_selector = false; break; } default: @@ -4857,7 +4879,7 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss) user */ match -gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv) +gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head) { do { @@ -4897,9 +4919,9 @@ gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv) } gfc_omp_set_selector *oss = gfc_get_omp_set_selector (); - oss->next = odv->set_selectors; + oss->next = *oss_head; oss->trait_set_selector_name = selector_sets[i]; - odv->set_selectors = oss; + *oss_head = oss; if (gfc_match_omp_context_selector (oss) != MATCH_YES) return MATCH_ERROR; @@ -5000,7 +5022,8 @@ gfc_match_omp_declare_variant (void) return MATCH_ERROR; } - if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES) + if (gfc_match_omp_context_selector_specification (&odv->set_selectors) + != MATCH_YES) return MATCH_ERROR; if (gfc_match (" )") != MATCH_YES) @@ -5016,6 +5039,145 @@ gfc_match_omp_declare_variant (void) } +static match +match_omp_metadirective (bool begin_p) +{ + locus old_loc = gfc_current_locus; + gfc_omp_metadirective_clause *clause_head; + gfc_omp_metadirective_clause **next_clause = &clause_head; + bool default_seen = false; + + /* Parse the context selectors. */ + for (;;) + { + bool default_p = false; + gfc_omp_set_selector *selectors = NULL; + + if (gfc_match (" default ( ") == MATCH_YES) + default_p = true; + else if (gfc_match_eos () == MATCH_YES) + break; + else if (gfc_match (" when ( ") != MATCH_YES) + { + gfc_error ("expected 'default' or 'when' at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + if (default_p && default_seen) + { + gfc_error ("there can only be one default clause in a " + "metadirective at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + if (!default_p) + { + if (gfc_match_omp_context_selector_specification (&selectors) + != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match (" : ") != MATCH_YES) + { + gfc_error ("expected ':' at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + gfc_commit_symbols (); + } + + gfc_matching_omp_context_selector = true; + gfc_statement directive = match_omp_directive (); + gfc_matching_omp_context_selector = false; + + if (gfc_error_flag_test ()) + { + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("Expected ')' at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + gfc_commit_symbols (); + + if (begin_p && directive != ST_NONE + && gfc_omp_end_stmt (directive) == ST_NONE) + { + gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE " + "at %C must have a corresponding end directive"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + if (default_p) + default_seen = true; + + gfc_omp_metadirective_clause *omc = gfc_get_omp_metadirective_clause (); + omc->selectors = selectors; + omc->stmt = directive; + if (directive == ST_NONE) + { + /* The directive was a 'nothing' directive. */ + omc->code = gfc_get_code (EXEC_CONTINUE); + omc->code->ext.omp_clauses = NULL; + } + else + { + omc->code = gfc_get_code (new_st.op); + omc->code->ext.omp_clauses = new_st.ext.omp_clauses; + /* Prevent the OpenMP clauses from being freed via NEW_ST. */ + new_st.ext.omp_clauses = NULL; + } + + *next_clause = omc; + next_clause = &omc->next; + } + + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + /* Add a 'default (nothing)' clause if no default is explicitly given. */ + if (!default_seen) + { + gfc_omp_metadirective_clause *omc = gfc_get_omp_metadirective_clause (); + omc->stmt = ST_NONE; + omc->code = gfc_get_code (EXEC_CONTINUE); + omc->code->ext.omp_clauses = NULL; + omc->selectors = NULL; + + *next_clause = omc; + next_clause = &omc->next; + } + + new_st.op = EXEC_OMP_METADIRECTIVE; + new_st.ext.omp_metadirective_clauses = clause_head; + + return MATCH_YES; +} + +match +gfc_match_omp_begin_metadirective (void) +{ + return match_omp_metadirective (true); +} + +match +gfc_match_omp_metadirective (void) +{ + return match_omp_metadirective (false); +} + match gfc_match_omp_threadprivate (void) { @@ -8486,6 +8648,19 @@ resolve_omp_do (gfc_code *code) } } +static void +resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns) +{ + gfc_omp_metadirective_clause *clause = code->ext.omp_metadirective_clauses; + + while (clause) + { + gfc_code *clause_code = clause->code; + gfc_resolve_code (clause_code, ns); + clause = clause->next; + } +} + static gfc_statement omp_code_to_statement (gfc_code *code) @@ -9113,6 +9288,9 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) code->ext.omp_clauses->if_present = false; resolve_omp_clauses (code, code->ext.omp_clauses, ns); break; + case EXEC_OMP_METADIRECTIVE: + resolve_omp_metadirective (code, ns); + break; default: break; } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 1f111091b0a..a96c892c608 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -40,6 +40,10 @@ static jmp_buf eof_buf; gfc_state_data *gfc_state_stack; static bool last_was_use_stmt = false; +bool gfc_matching_omp_context_selector; +bool gfc_in_metadirective_body; +int gfc_omp_region_count; + /* TODO: Re-order functions to kill these forward decls. */ static void check_statement_label (gfc_statement); static void undo_new_statement (void); @@ -889,6 +893,8 @@ decode_omp_directive (void) break; case 'b': matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER); + matcho ("begin metadirective", gfc_match_omp_begin_metadirective, + ST_OMP_BEGIN_METADIRECTIVE); break; case 'c': matcho ("cancellation% point", gfc_match_omp_cancellation_point, @@ -936,6 +942,8 @@ decode_omp_directive (void) matcho ("end master taskloop", gfc_match_omp_eos_error, ST_OMP_END_MASTER_TASKLOOP); matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER); + matcho ("end metadirective", gfc_match_omp_eos_error, + ST_OMP_END_METADIRECTIVE); matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED); matchs ("end parallel do simd", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO_SIMD); @@ -1018,6 +1026,8 @@ decode_omp_directive (void) matcho ("master taskloop", gfc_match_omp_master_taskloop, ST_OMP_MASTER_TASKLOOP); matcho ("master", gfc_match_omp_master, ST_OMP_MASTER); + matcho ("metadirective", gfc_match_omp_metadirective, + ST_OMP_METADIRECTIVE); break; case 'n': matcho ("nothing", gfc_match_omp_nothing, ST_NONE); @@ -1146,6 +1156,10 @@ decode_omp_directive (void) gfc_error_now ("Unclassifiable OpenMP directive at %C"); } + /* If parsing a metadirective, let the caller deal with the cleanup. */ + if (gfc_matching_omp_context_selector) + return ST_NONE; + reject_statement (); gfc_error_recovery (); @@ -1213,6 +1227,12 @@ decode_omp_directive (void) return ST_GET_FCN_CHARACTERISTICS; } +gfc_statement +match_omp_directive (void) +{ + return decode_omp_directive (); +} + static gfc_statement decode_gcc_attribute (void) { @@ -1734,6 +1754,43 @@ next_statement (void) case ST_OMP_DECLARE_VARIANT: \ case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE +/* OpenMP statements that are followed by a structured block. */ + +#define case_omp_structured_block case ST_OMP_PARALLEL: \ + case ST_OMP_PARALLEL_MASKED: case ST_OMP_PARALLEL_MASTER: \ + case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_ORDERED: \ + case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASTER: \ + case ST_OMP_SCOPE: case ST_OMP_SECTIONS: case ST_OMP_SINGLE: \ + case ST_OMP_TARGET: case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_PARALLEL: \ + case ST_OMP_TARGET_TEAMS: case ST_OMP_TEAMS: case ST_OMP_TASK: \ + case ST_OMP_TASKGROUP: \ + case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE + +/* OpenMP statements that are followed by a do loop. */ + +#define case_omp_do case ST_OMP_DISTRIBUTE: \ + case ST_OMP_DISTRIBUTE_PARALLEL_DO: \ + case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE_SIMD: \ + case ST_OMP_DO: case ST_OMP_DO_SIMD: case ST_OMP_LOOP: \ + case ST_OMP_PARALLEL_DO: case ST_OMP_PARALLEL_DO_SIMD: \ + case ST_OMP_PARALLEL_LOOP: case ST_OMP_PARALLEL_MASKED_TASKLOOP: \ + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: \ + case ST_OMP_PARALLEL_MASTER_TASKLOOP: \ + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \ + case ST_OMP_MASKED_TASKLOOP: case ST_OMP_MASKED_TASKLOOP_SIMD: \ + case ST_OMP_MASTER_TASKLOOP: case ST_OMP_MASTER_TASKLOOP_SIMD: \ + case ST_OMP_SIMD: \ + case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \ + case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_SIMD: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: case ST_OMP_TARGET_TEAMS_LOOP: \ + case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \ + case ST_OMP_TEAMS_DISTRIBUTE: case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \ + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \ + case ST_OMP_TEAMS_DISTRIBUTE_SIMD: case ST_OMP_TEAMS_LOOP + /* Block end statements. Errors associated with interchanging these are detected in gfc_match_end(). */ @@ -2357,6 +2414,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_BARRIER: p = "!$OMP BARRIER"; break; + case ST_OMP_BEGIN_METADIRECTIVE: + p = "!$OMP BEGIN METADIRECTIVE"; + break; case ST_OMP_CANCEL: p = "!$OMP CANCEL"; break; @@ -2450,6 +2510,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_END_MASTER_TASKLOOP_SIMD: p = "!$OMP END MASTER TASKLOOP SIMD"; break; + case ST_OMP_END_METADIRECTIVE: + p = "!OMP END METADIRECTIVE"; + break; case ST_OMP_END_ORDERED: p = "!$OMP END ORDERED"; break; @@ -2594,6 +2657,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_MASTER_TASKLOOP_SIMD: p = "!$OMP MASTER TASKLOOP SIMD"; break; + case ST_OMP_METADIRECTIVE: + p = "!$OMP METADIRECTIVE"; + break; case ST_OMP_ORDERED: case ST_OMP_ORDERED_DEPEND: p = "!$OMP ORDERED"; @@ -2848,6 +2914,8 @@ accept_statement (gfc_statement st) break; case ST_ENTRY: + case ST_OMP_METADIRECTIVE: + case ST_OMP_BEGIN_METADIRECTIVE: case_executable: case_exec_markers: add_statement (); @@ -5124,6 +5192,138 @@ loop: accept_statement (st); } +/* Get the corresponding ending statement type for the OpenMP directive + OMP_ST. If it does not have one, return ST_NONE. */ + +gfc_statement +gfc_omp_end_stmt (gfc_statement omp_st, + bool omp_do_p, bool omp_structured_p) +{ + if (omp_do_p) + { + switch (omp_st) + { + case ST_OMP_DISTRIBUTE: return ST_OMP_END_DISTRIBUTE; + case ST_OMP_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_END_DISTRIBUTE_PARALLEL_DO; + case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD; + case ST_OMP_DISTRIBUTE_SIMD: + return ST_OMP_END_DISTRIBUTE_SIMD; + case ST_OMP_DO: return ST_OMP_END_DO; + case ST_OMP_DO_SIMD: return ST_OMP_END_DO_SIMD; + case ST_OMP_LOOP: return ST_OMP_END_LOOP; + case ST_OMP_PARALLEL_DO: return ST_OMP_END_PARALLEL_DO; + case ST_OMP_PARALLEL_DO_SIMD: + return ST_OMP_END_PARALLEL_DO_SIMD; + case ST_OMP_PARALLEL_LOOP: + return ST_OMP_END_PARALLEL_LOOP; + case ST_OMP_SIMD: return ST_OMP_END_SIMD; + case ST_OMP_TARGET_PARALLEL_DO: + return ST_OMP_END_TARGET_PARALLEL_DO; + case ST_OMP_TARGET_PARALLEL_DO_SIMD: + return ST_OMP_END_TARGET_PARALLEL_DO_SIMD; + case ST_OMP_TARGET_PARALLEL_LOOP: + return ST_OMP_END_TARGET_PARALLEL_LOOP; + case ST_OMP_TARGET_SIMD: return ST_OMP_END_TARGET_SIMD; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE: + return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD; + case ST_OMP_TARGET_TEAMS_LOOP: + return ST_OMP_END_TARGET_TEAMS_LOOP; + case ST_OMP_TASKLOOP: return ST_OMP_END_TASKLOOP; + case ST_OMP_TASKLOOP_SIMD: return ST_OMP_END_TASKLOOP_SIMD; + case ST_OMP_MASKED_TASKLOOP: return ST_OMP_END_MASKED_TASKLOOP; + case ST_OMP_MASKED_TASKLOOP_SIMD: + return ST_OMP_END_MASKED_TASKLOOP_SIMD; + case ST_OMP_MASTER_TASKLOOP: return ST_OMP_END_MASTER_TASKLOOP; + case ST_OMP_MASTER_TASKLOOP_SIMD: + return ST_OMP_END_MASTER_TASKLOOP_SIMD; + case ST_OMP_PARALLEL_MASKED_TASKLOOP: + return ST_OMP_END_PARALLEL_MASKED_TASKLOOP; + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + return ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD; + case ST_OMP_PARALLEL_MASTER_TASKLOOP: + return ST_OMP_END_PARALLEL_MASTER_TASKLOOP; + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + return ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD; + case ST_OMP_TEAMS_DISTRIBUTE: + return ST_OMP_END_TEAMS_DISTRIBUTE; + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO; + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; + case ST_OMP_TEAMS_DISTRIBUTE_SIMD: + return ST_OMP_END_TEAMS_DISTRIBUTE_SIMD; + case ST_OMP_TEAMS_LOOP: + return ST_OMP_END_TEAMS_LOOP; + default: + break; + } + } + + if (omp_structured_p) + { + switch (omp_st) + { + case ST_OMP_PARALLEL: + return ST_OMP_END_PARALLEL; + case ST_OMP_PARALLEL_MASKED: + return ST_OMP_END_PARALLEL_MASKED; + case ST_OMP_PARALLEL_MASTER: + return ST_OMP_END_PARALLEL_MASTER; + case ST_OMP_PARALLEL_SECTIONS: + return ST_OMP_END_PARALLEL_SECTIONS; + case ST_OMP_SCOPE: + return ST_OMP_END_SCOPE; + case ST_OMP_SECTIONS: + return ST_OMP_END_SECTIONS; + case ST_OMP_ORDERED: + return ST_OMP_END_ORDERED; + case ST_OMP_CRITICAL: + return ST_OMP_END_CRITICAL; + case ST_OMP_MASKED: + return ST_OMP_END_MASKED; + case ST_OMP_MASTER: + return ST_OMP_END_MASTER; + case ST_OMP_SINGLE: + return ST_OMP_END_SINGLE; + case ST_OMP_TARGET: + return ST_OMP_END_TARGET; + case ST_OMP_TARGET_DATA: + return ST_OMP_END_TARGET_DATA; + case ST_OMP_TARGET_PARALLEL: + return ST_OMP_END_TARGET_PARALLEL; + case ST_OMP_TARGET_TEAMS: + return ST_OMP_END_TARGET_TEAMS; + case ST_OMP_TASK: + return ST_OMP_END_TASK; + case ST_OMP_TASKGROUP: + return ST_OMP_END_TASKGROUP; + case ST_OMP_TEAMS: + return ST_OMP_END_TEAMS; + case ST_OMP_TEAMS_DISTRIBUTE: + return ST_OMP_END_TEAMS_DISTRIBUTE; + case ST_OMP_DISTRIBUTE: + return ST_OMP_END_DISTRIBUTE; + case ST_OMP_WORKSHARE: + return ST_OMP_END_WORKSHARE; + case ST_OMP_PARALLEL_WORKSHARE: + return ST_OMP_END_PARALLEL_WORKSHARE; + case ST_OMP_BEGIN_METADIRECTIVE: + return ST_OMP_END_METADIRECTIVE; + default: + break; + } + } + + return ST_NONE; +} /* Parse the statements of OpenMP do/parallel do. */ @@ -5174,94 +5374,16 @@ parse_omp_do (gfc_statement omp_st) pop_state (); st = next_statement (); - gfc_statement omp_end_st = ST_OMP_END_DO; - switch (omp_st) - { - case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break; - case ST_OMP_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD; - break; - case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break; - case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break; - case ST_OMP_LOOP: omp_end_st = ST_OMP_END_LOOP; break; - case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break; - case ST_OMP_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD; - break; - case ST_OMP_PARALLEL_LOOP: - omp_end_st = ST_OMP_END_PARALLEL_LOOP; - break; - case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break; - case ST_OMP_TARGET_PARALLEL_DO: - omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO; - break; - case ST_OMP_TARGET_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD; - break; - case ST_OMP_TARGET_PARALLEL_LOOP: - omp_end_st = ST_OMP_END_TARGET_PARALLEL_LOOP; - break; - case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD; - break; - case ST_OMP_TARGET_TEAMS_LOOP: - omp_end_st = ST_OMP_END_TARGET_TEAMS_LOOP; - break; - case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break; - case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break; - case ST_OMP_MASKED_TASKLOOP: omp_end_st = ST_OMP_END_MASKED_TASKLOOP; break; - case ST_OMP_MASKED_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_MASKED_TASKLOOP_SIMD; - break; - case ST_OMP_MASTER_TASKLOOP: omp_end_st = ST_OMP_END_MASTER_TASKLOOP; break; - case ST_OMP_MASTER_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_MASTER_TASKLOOP_SIMD; - break; - case ST_OMP_PARALLEL_MASKED_TASKLOOP: - omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP; - break; - case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD; - break; - case ST_OMP_PARALLEL_MASTER_TASKLOOP: - omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP; - break; - case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD; - break; - case ST_OMP_TEAMS_DISTRIBUTE: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; - break; - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_TEAMS_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD; - break; - case ST_OMP_TEAMS_LOOP: - omp_end_st = ST_OMP_END_TEAMS_LOOP; - break; - default: gcc_unreachable (); - } + gfc_statement omp_end_st = gfc_omp_end_stmt (omp_st, true, false); + if (omp_st == ST_NONE) + gcc_unreachable (); + + /* If handling a metadirective variant, treat 'omp end metadirective' + as the expected end statement for the current construct. */ + if (st == ST_OMP_END_METADIRECTIVE + && gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE) + st = omp_end_st; + if (st == omp_end_st) { if (new_st.op == EXEC_OMP_END_NOWAIT) @@ -5496,77 +5618,9 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) np->op = cp->op; np->block = NULL; - switch (omp_st) - { - case ST_OMP_PARALLEL: - omp_end_st = ST_OMP_END_PARALLEL; - break; - case ST_OMP_PARALLEL_MASKED: - omp_end_st = ST_OMP_END_PARALLEL_MASKED; - break; - case ST_OMP_PARALLEL_MASTER: - omp_end_st = ST_OMP_END_PARALLEL_MASTER; - break; - case ST_OMP_PARALLEL_SECTIONS: - omp_end_st = ST_OMP_END_PARALLEL_SECTIONS; - break; - case ST_OMP_SCOPE: - omp_end_st = ST_OMP_END_SCOPE; - break; - case ST_OMP_SECTIONS: - omp_end_st = ST_OMP_END_SECTIONS; - break; - case ST_OMP_ORDERED: - omp_end_st = ST_OMP_END_ORDERED; - break; - case ST_OMP_CRITICAL: - omp_end_st = ST_OMP_END_CRITICAL; - break; - case ST_OMP_MASKED: - omp_end_st = ST_OMP_END_MASKED; - break; - case ST_OMP_MASTER: - omp_end_st = ST_OMP_END_MASTER; - break; - case ST_OMP_SINGLE: - omp_end_st = ST_OMP_END_SINGLE; - break; - case ST_OMP_TARGET: - omp_end_st = ST_OMP_END_TARGET; - break; - case ST_OMP_TARGET_DATA: - omp_end_st = ST_OMP_END_TARGET_DATA; - break; - case ST_OMP_TARGET_PARALLEL: - omp_end_st = ST_OMP_END_TARGET_PARALLEL; - break; - case ST_OMP_TARGET_TEAMS: - omp_end_st = ST_OMP_END_TARGET_TEAMS; - break; - case ST_OMP_TASK: - omp_end_st = ST_OMP_END_TASK; - break; - case ST_OMP_TASKGROUP: - omp_end_st = ST_OMP_END_TASKGROUP; - break; - case ST_OMP_TEAMS: - omp_end_st = ST_OMP_END_TEAMS; - break; - case ST_OMP_TEAMS_DISTRIBUTE: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; - break; - case ST_OMP_DISTRIBUTE: - omp_end_st = ST_OMP_END_DISTRIBUTE; - break; - case ST_OMP_WORKSHARE: - omp_end_st = ST_OMP_END_WORKSHARE; - break; - case ST_OMP_PARALLEL_WORKSHARE: - omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE; - break; - default: - gcc_unreachable (); - } + omp_end_st = gfc_omp_end_stmt (omp_st, false, true); + if (omp_st == ST_NONE) + gcc_unreachable (); bool block_construct = false; gfc_namespace *my_ns = NULL; @@ -5665,6 +5719,14 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) } else st = parse_executable (st); + + /* If handling a metadirective variant, treat 'omp end metadirective' + as the expected end statement for the current construct. */ + if (st == ST_OMP_END_METADIRECTIVE + && gfc_state_stack->previous != NULL + && gfc_state_stack->previous->state == COMP_OMP_BEGIN_METADIRECTIVE) + st = omp_end_st; + if (st == ST_NONE) unexpected_eof (); else if (st == ST_OMP_SECTION @@ -5734,6 +5796,70 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) return st; } +static gfc_statement +parse_omp_metadirective_body (gfc_statement omp_st) +{ + gfc_omp_metadirective_clause *clause = new_st.ext.omp_metadirective_clauses; + locus body_locus = gfc_current_locus; + + accept_statement (omp_st); + + gfc_statement next_st = ST_NONE; + + while (clause) + { + gfc_current_locus = body_locus; + gfc_state_data s; + bool workshare_p = clause->stmt == ST_OMP_WORKSHARE + || clause->stmt == ST_OMP_PARALLEL_WORKSHARE; + enum gfc_compile_state new_state = + (omp_st == ST_OMP_METADIRECTIVE) + ? COMP_OMP_METADIRECTIVE : COMP_OMP_BEGIN_METADIRECTIVE; + + new_st = *clause->code; + push_state (&s, new_state, NULL); + + gfc_statement st; + bool old_in_metadirective_body = gfc_in_metadirective_body; + gfc_in_metadirective_body = true; + + gfc_omp_region_count++; + switch (clause->stmt) + { + case_omp_structured_block: + st = parse_omp_structured_block (clause->stmt, workshare_p); + break; + case_omp_do: + st = parse_omp_do (clause->stmt); + /* TODO: Does st == ST_IMPLIED_ENDDO need special handling? */ + break; + default: + accept_statement (clause->stmt); + st = parse_executable (next_statement ()); + break; + } + + gfc_in_metadirective_body = old_in_metadirective_body; + + *clause->code = *gfc_state_stack->head; + pop_state (); + + gfc_commit_symbols (); + gfc_warning_check (); + if (clause->next) + gfc_clear_new_st (); + + /* Sanity-check that each clause finishes parsing at the same place. */ + if (next_st == ST_NONE) + next_st = st; + else + gcc_assert (st == next_st); + + clause = clause->next; + } + + return next_st; +} /* Accept a series of executable statements. We return the first statement that doesn't fit to the caller. Any block statements are @@ -5744,12 +5870,19 @@ static gfc_statement parse_executable (gfc_statement st) { int close_flag; + bool one_stmt_p = false; if (st == ST_NONE) st = next_statement (); for (;;) { + /* Only parse one statement for the form of metadirective without + an explicit begin..end. */ + if (gfc_state_stack->state == COMP_OMP_METADIRECTIVE && one_stmt_p) + return st; + one_stmt_p = true; + close_flag = check_do_closure (); if (close_flag) switch (st) @@ -5854,67 +5987,13 @@ parse_executable (gfc_statement st) parse_oacc_structured_block (st); break; - case ST_OMP_PARALLEL: - case ST_OMP_PARALLEL_MASKED: - case ST_OMP_PARALLEL_MASTER: - case ST_OMP_PARALLEL_SECTIONS: - case ST_OMP_ORDERED: - case ST_OMP_CRITICAL: - case ST_OMP_MASKED: - case ST_OMP_MASTER: - case ST_OMP_SCOPE: - case ST_OMP_SECTIONS: - case ST_OMP_SINGLE: - case ST_OMP_TARGET: - case ST_OMP_TARGET_DATA: - case ST_OMP_TARGET_PARALLEL: - case ST_OMP_TARGET_TEAMS: - case ST_OMP_TEAMS: - case ST_OMP_TASK: - case ST_OMP_TASKGROUP: - st = parse_omp_structured_block (st, false); - continue; - - case ST_OMP_WORKSHARE: - case ST_OMP_PARALLEL_WORKSHARE: - st = parse_omp_structured_block (st, true); + case_omp_structured_block: + st = parse_omp_structured_block (st, + st == ST_OMP_WORKSHARE + || st == ST_OMP_PARALLEL_WORKSHARE); continue; - case ST_OMP_DISTRIBUTE: - case ST_OMP_DISTRIBUTE_PARALLEL_DO: - case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case ST_OMP_DISTRIBUTE_SIMD: - case ST_OMP_DO: - case ST_OMP_DO_SIMD: - case ST_OMP_LOOP: - case ST_OMP_PARALLEL_DO: - case ST_OMP_PARALLEL_DO_SIMD: - case ST_OMP_PARALLEL_LOOP: - case ST_OMP_PARALLEL_MASKED_TASKLOOP: - case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case ST_OMP_PARALLEL_MASTER_TASKLOOP: - case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case ST_OMP_MASKED_TASKLOOP: - case ST_OMP_MASKED_TASKLOOP_SIMD: - case ST_OMP_MASTER_TASKLOOP: - case ST_OMP_MASTER_TASKLOOP_SIMD: - case ST_OMP_SIMD: - case ST_OMP_TARGET_PARALLEL_DO: - case ST_OMP_TARGET_PARALLEL_DO_SIMD: - case ST_OMP_TARGET_PARALLEL_LOOP: - case ST_OMP_TARGET_SIMD: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case ST_OMP_TARGET_TEAMS_LOOP: - case ST_OMP_TASKLOOP: - case ST_OMP_TASKLOOP_SIMD: - case ST_OMP_TEAMS_DISTRIBUTE: - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case ST_OMP_TEAMS_DISTRIBUTE_SIMD: - case ST_OMP_TEAMS_LOOP: + case_omp_do: st = parse_omp_do (st); if (st == ST_IMPLIED_ENDDO) return st; @@ -5928,6 +6007,19 @@ parse_executable (gfc_statement st) st = parse_omp_oacc_atomic (true); continue; + case ST_OMP_METADIRECTIVE: + case ST_OMP_BEGIN_METADIRECTIVE: + st = parse_omp_metadirective_body (st); + continue; + + case ST_OMP_END_METADIRECTIVE: + if (gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE) + { + st = next_statement (); + return st; + } + /* FALLTHRU */ + default: return st; } @@ -6700,6 +6792,10 @@ gfc_parse_file (void) gfc_statement_label = NULL; + gfc_omp_region_count = 0; + gfc_in_metadirective_body = false; + gfc_matching_omp_context_selector = false; + if (setjmp (eof_buf)) return false; /* Come here on unexpected EOF */ diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 66b275de89b..43bdd91aa14 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -31,7 +31,8 @@ enum gfc_compile_state COMP_STRUCTURE, COMP_UNION, COMP_MAP, COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, COMP_SELECT_TYPE, COMP_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, - COMP_DO_CONCURRENT, COMP_OMP_STRICTLY_STRUCTURED_BLOCK + COMP_DO_CONCURRENT, COMP_OMP_STRICTLY_STRUCTURED_BLOCK, + COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE }; /* Stack element for the current compilation state. These structures @@ -67,10 +68,15 @@ int gfc_check_do_variable (gfc_symtree *); bool gfc_find_state (gfc_compile_state); gfc_state_data *gfc_enclosing_unit (gfc_compile_state *); const char *gfc_ascii_statement (gfc_statement); +gfc_statement gfc_omp_end_stmt (gfc_statement, bool = true, bool = true); match gfc_match_enum (void); match gfc_match_enumerator_def (void); void gfc_free_enum_history (void); extern bool gfc_matching_function; +extern bool gfc_matching_omp_context_selector; +extern bool gfc_in_metadirective_body; +extern int gfc_omp_region_count; + match gfc_match_prefix (gfc_typespec *); bool is_oacc (gfc_state_data *); #endif /* GFC_PARSE_H */ diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0ed31970f8b..1a07aef6771 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11834,6 +11834,17 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) gfc_resolve_forall (code, ns, forall_save); forall_flag = 2; } + else if (code->op == EXEC_OMP_METADIRECTIVE) + { + gfc_omp_metadirective_clause *clause + = code->ext.omp_metadirective_clauses; + + while (clause) + { + gfc_resolve_code (clause->code, ns); + clause = clause->next; + } + } else if (code->block) { omp_workshare_save = -1; @@ -12322,6 +12333,7 @@ start: case EXEC_OMP_MASKED: case EXEC_OMP_MASKED_TASKLOOP: case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_METADIRECTIVE: case EXEC_OMP_ORDERED: case EXEC_OMP_SCAN: case EXEC_OMP_SCOPE: diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 6bf730c9062..b15a0885e2e 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -296,6 +296,10 @@ gfc_free_statement (gfc_code *p) case EXEC_OMP_TASKYIELD: break; + case EXEC_OMP_METADIRECTIVE: + gfc_free_omp_metadirective_clauses (p->ext.omp_metadirective_clauses); + break; + default: gfc_internal_error ("gfc_free_statement(): Bad statement"); } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index ebd99846610..8a56ee31b33 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2624,10 +2624,13 @@ free_components (gfc_component *p) static int compare_st_labels (void *a1, void *b1) { - int a = ((gfc_st_label *) a1)->value; - int b = ((gfc_st_label *) b1)->value; + gfc_st_label *a = (gfc_st_label *) a1; + gfc_st_label *b = (gfc_st_label *) b1; - return (b - a); + int a_value = a->value + 10000 * a->omp_region; + int b_value = b->value + 10000 * b->omp_region; + + return (b_value - a_value); } @@ -2677,6 +2680,7 @@ gfc_get_st_label (int labelno) { gfc_st_label *lp; gfc_namespace *ns; + int omp_region = gfc_in_metadirective_body ? gfc_omp_region_count : 0; if (gfc_current_state () == COMP_DERIVED) ns = gfc_current_block ()->f2k_derived; @@ -2693,10 +2697,13 @@ gfc_get_st_label (int labelno) lp = ns->st_labels; while (lp) { - if (lp->value == labelno) + int a = lp->value + 10000 * lp->omp_region; + int b = labelno + 10000 * omp_region; + + if (a == b) return lp; - if (lp->value < labelno) + if (a < b) lp = lp->left; else lp = lp->right; @@ -2708,6 +2715,7 @@ gfc_get_st_label (int labelno) lp->defined = ST_LABEL_UNKNOWN; lp->referenced = ST_LABEL_UNKNOWN; lp->ns = ns; + lp->omp_region = omp_region; gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index cb7f684d52c..69ea7f02871 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -326,7 +326,10 @@ gfc_get_label_decl (gfc_st_label * lp) gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE); /* Build a mangled name for the label. */ - sprintf (label_name, "__label_%.6d", lp->value); + if (lp->omp_region) + sprintf (label_name, "__label_%d_%.6d", lp->omp_region, lp->value); + else + sprintf (label_name, "__label_%.6d", lp->value); /* Build the LABEL_DECL node. */ label_decl = gfc_build_label_decl (get_identifier (label_name)); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index d8229a5ac30..3be453a513a 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -7207,6 +7207,8 @@ gfc_trans_omp_directive (gfc_code *code) case EXEC_OMP_MASTER_TASKLOOP: case EXEC_OMP_MASTER_TASKLOOP_SIMD: return gfc_trans_omp_master_masked_taskloop (code, code->op); + case EXEC_OMP_METADIRECTIVE: + return gfc_trans_omp_metadirective (code); case EXEC_OMP_ORDERED: return gfc_trans_omp_ordered (code); case EXEC_OMP_PARALLEL: @@ -7298,6 +7300,87 @@ gfc_trans_omp_declare_simd (gfc_namespace *ns) } } +static tree +gfc_trans_omp_set_selector (gfc_omp_set_selector *gfc_selectors, locus where) +{ + tree set_selectors = NULL_TREE; + gfc_omp_set_selector *oss; + + for (oss = gfc_selectors; oss; oss = oss->next) + { + tree selectors = NULL_TREE; + gfc_omp_selector *os; + for (os = oss->trait_selectors; os; os = os->next) + { + tree properties = NULL_TREE; + gfc_omp_trait_property *otp; + + for (otp = os->properties; otp; otp = otp->next) + { + switch (otp->property_kind) + { + case CTX_PROPERTY_USER: + case CTX_PROPERTY_EXPR: + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, otp->expr); + properties = tree_cons (NULL_TREE, se.expr, + properties); + } + break; + case CTX_PROPERTY_ID: + properties = tree_cons (get_identifier (otp->name), + NULL_TREE, properties); + break; + case CTX_PROPERTY_NAME_LIST: + { + tree prop = NULL_TREE, value = NULL_TREE; + if (otp->is_name) + prop = get_identifier (otp->name); + else + { + value = gfc_conv_constant_to_tree (otp->expr); + + /* The string length is expected to include the null + terminator in context selectors. This is safe as + build_string always null-terminates strings. */ + ++TREE_STRING_LENGTH (value); + } + + properties = tree_cons (prop, value, properties); + } + break; + case CTX_PROPERTY_SIMD: + properties = gfc_trans_omp_clauses (NULL, otp->clauses, + where, true); + break; + default: + gcc_unreachable (); + } + } + + if (os->score) + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, os->score); + properties = tree_cons (get_identifier (" score"), + se.expr, properties); + } + + selectors = tree_cons (get_identifier (os->trait_selector_name), + properties, selectors); + } + + set_selectors + = tree_cons (get_identifier (oss->trait_set_selector_name), + selectors, set_selectors); + } + + return set_selectors; +} + void gfc_trans_omp_declare_variant (gfc_namespace *ns) { @@ -7373,73 +7456,8 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) && strcmp (odv->base_proc_symtree->name, ns->proc_name->name))) continue; - tree set_selectors = NULL_TREE; - gfc_omp_set_selector *oss; - - for (oss = odv->set_selectors; oss; oss = oss->next) - { - tree selectors = NULL_TREE; - gfc_omp_selector *os; - for (os = oss->trait_selectors; os; os = os->next) - { - tree properties = NULL_TREE; - gfc_omp_trait_property *otp; - - for (otp = os->properties; otp; otp = otp->next) - { - switch (otp->property_kind) - { - case CTX_PROPERTY_USER: - case CTX_PROPERTY_EXPR: - { - gfc_se se; - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, otp->expr); - properties = tree_cons (NULL_TREE, se.expr, - properties); - } - break; - case CTX_PROPERTY_ID: - properties = tree_cons (get_identifier (otp->name), - NULL_TREE, properties); - break; - case CTX_PROPERTY_NAME_LIST: - { - tree prop = NULL_TREE, value = NULL_TREE; - if (otp->is_name) - prop = get_identifier (otp->name); - else - value = gfc_conv_constant_to_tree (otp->expr); - - properties = tree_cons (prop, value, properties); - } - break; - case CTX_PROPERTY_SIMD: - properties = gfc_trans_omp_clauses (NULL, otp->clauses, - odv->where, true); - break; - default: - gcc_unreachable (); - } - } - - if (os->score) - { - gfc_se se; - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, os->score); - properties = tree_cons (get_identifier (" score"), - se.expr, properties); - } - - selectors = tree_cons (get_identifier (os->trait_selector_name), - properties, selectors); - } - - set_selectors - = tree_cons (get_identifier (oss->trait_set_selector_name), - selectors, set_selectors); - } + tree set_selectors = gfc_trans_omp_set_selector (odv->set_selectors, + odv->where); const char *variant_proc_name = odv->variant_proc_symtree->name; gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym; @@ -7501,3 +7519,41 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) } } } + +tree +gfc_trans_omp_metadirective (gfc_code *code) +{ + gfc_omp_metadirective_clause *clause = code->ext.omp_metadirective_clauses; + + tree metadirective_tree = make_node (OMP_METADIRECTIVE); + SET_EXPR_LOCATION (metadirective_tree, gfc_get_location (&code->loc)); + TREE_TYPE (metadirective_tree) = void_type_node; + OMP_METADIRECTIVE_CLAUSES (metadirective_tree) = NULL_TREE; + + tree tree_body = NULL_TREE; + + while (clause) + { + tree selectors = gfc_trans_omp_set_selector (clause->selectors, + clause->where); + gfc_code *next_code = clause->code->next; + if (next_code && tree_body == NULL_TREE) + tree_body = gfc_trans_code (next_code); + + if (next_code) + clause->code->next = NULL; + tree directive = gfc_trans_code (clause->code); + if (next_code) + clause->code->next = next_code; + + tree body = next_code ? tree_body : NULL_TREE; + tree variant = build_tree_list (selectors, build_tree_list (directive, body)); + OMP_METADIRECTIVE_CLAUSES (metadirective_tree) + = chainon (OMP_METADIRECTIVE_CLAUSES (metadirective_tree), variant); + clause = clause->next; + } + + /* TODO: Resolve the metadirective here if possible. */ + + return metadirective_tree; +} diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index e824caf4d08..08355e582c8 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -71,6 +71,7 @@ tree gfc_trans_deallocate (gfc_code *); tree gfc_trans_omp_directive (gfc_code *); void gfc_trans_omp_declare_simd (gfc_namespace *); void gfc_trans_omp_declare_variant (gfc_namespace *); +tree gfc_trans_omp_metadirective (gfc_code *code); tree gfc_trans_oacc_directive (gfc_code *); tree gfc_trans_oacc_declare (gfc_namespace *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index a377d0eeb24..007ee65a169 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -2161,6 +2161,7 @@ trans_code (gfc_code * code, tree cond) case EXEC_OMP_MASTER: case EXEC_OMP_MASTER_TASKLOOP: case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_METADIRECTIVE: case EXEC_OMP_ORDERED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: diff --git a/gcc/omp-general.c b/gcc/omp-general.c index 6340d1600a6..5a8a34573c8 100644 --- a/gcc/omp-general.c +++ b/gcc/omp-general.c @@ -1198,7 +1198,7 @@ omp_check_context_selector (location_t loc, tree ctx) const char *str = TREE_STRING_POINTER (TREE_VALUE (t2)); if (!strcmp (str, props[i].props[j]) && ((size_t) TREE_STRING_LENGTH (TREE_VALUE (t2)) - == strlen (str) + (lang_GNU_Fortran () ? 0 : 1))) + == strlen (str) + 1)) break; } else if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)), @@ -1247,8 +1247,7 @@ omp_context_name_list_prop (tree prop) else { const char *ret = TREE_STRING_POINTER (TREE_VALUE (prop)); - if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop)) - == strlen (ret) + (lang_GNU_Fortran () ? 0 : 1)) + if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop)) == strlen (ret) + 1) return ret; return NULL; } -- 2.25.1