From: Paul-Antoine Arras Date: Thu, 16 Oct 2025 16:22:08 +0000 (+0100) Subject: OpenMP: Handle non-executable directives in intervening code [PR120180,PR122306] X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=80af807e52e4f4c480454e5a54aaeb7ce44556fd;p=thirdparty%2Fgcc.git OpenMP: Handle non-executable directives in intervening code [PR120180,PR122306] OpenMP 6 permits non-executable directives in intervening code; this commit adds support for a sensible subset, namely metadirectives, nothing, assume, and 'error at(compilation)'. Also handle the special case where a metadirective can be resolved at parse time to 'omp nothing'. This fixes a build issue that affects 10 out 12 SPECaccel benchmarks. Co-authored by: Tobias Burnus PR c/120180 PR fortran/122306 gcc/c/ChangeLog: * c-parser.cc (c_parser_pragma): Accept a subset of non-executable OpenMP directives in intervening code. (c_parser_omp_error): Reject 'error at(execution)' in intervening code. (c_parser_omp_metadirective): Return early if only one selector matches and it resolves to 'omp nothing'. gcc/cp/ChangeLog: * parser.cc (cp_parser_omp_metadirective): Return early if only one selector matches and it resolves to 'omp nothing'. (cp_parser_omp_error): Reject 'error at(execution)' in intervening code. (cp_parser_pragma): Accept a subset of non-executable OpenMP directives as intervening code. gcc/fortran/ChangeLog: * gfortran.h (enum gfc_exec_op): Add EXEC_OMP_FIRST_OPENMP_EXEC and EXEC_OMP_LAST_OPENMP_EXEC. * openmp.cc (gfc_match_omp_context_selector): Remove static. Remove checks on score. Add cleanup. Remove checks on trait properties. (gfc_match_omp_context_selector_specification): Remove static. Adjust calls to gfc_match_omp_context_selector. (gfc_match_omp_declare_variant): Adjust call to gfc_match_omp_context_selector_specification. (match_omp_metadirective): Likewise. (icode_code_error_callback): Reject all statements except 'assume' and 'metadirective'. (gfc_resolve_omp_context_selector): New function. (resolve_omp_metadirective): Skip metadirectives which context selectors can be statically resolved to false. Replace metadirective by its body if only 'nothing' remains. (gfc_resolve_omp_declare): Call gfc_resolve_omp_context_selector for each variant. gcc/testsuite/ChangeLog: * c-c++-common/gomp/imperfect1.c: Adjust dg-error. * c-c++-common/gomp/imperfect4.c: Likewise. * c-c++-common/gomp/pr120180.c: Move to... * c-c++-common/gomp/pr120180-1.c: ...here. Remove dg-error. * g++.dg/gomp/attrs-imperfect1.C: Adjust dg-error. * g++.dg/gomp/attrs-imperfect4.C: Likewise. * gfortran.dg/gomp/declare-variant-2.f90: Adjust dg-error. * gfortran.dg/gomp/declare-variant-20.f90: Likewise. * c-c++-common/gomp/pr120180-2.c: New test. * g++.dg/gomp/pr120180-1.C: New test. * gfortran.dg/gomp/pr120180-1.f90: New test. * gfortran.dg/gomp/pr120180-2.f90: New test. * gfortran.dg/gomp/pr122306-1.f90: New file. * gfortran.dg/gomp/pr122306-2.f90: New file. --- diff --git a/gcc/c/c-parser.cc b/gcc/c/c-parser.cc index dfee421165a..1d212b51fcd 100644 --- a/gcc/c/c-parser.cc +++ b/gcc/c/c-parser.cc @@ -15787,11 +15787,15 @@ c_parser_pragma (c_parser *parser, enum pragma_context context, bool *if_p, gcc_assert (id != PRAGMA_NONE); if (parser->omp_for_parse_state && parser->omp_for_parse_state->in_intervening_code - && id >= PRAGMA_OMP__START_ - && id <= PRAGMA_OMP__LAST_) - { - error_at (input_location, - "intervening code must not contain OpenMP directives"); + && id >= PRAGMA_OMP__START_ && id <= PRAGMA_OMP__LAST_ + /* Allow a safe subset of non-executable directives. See classification in + array c_omp_directives. */ + && id != PRAGMA_OMP_METADIRECTIVE && id != PRAGMA_OMP_NOTHING + && id != PRAGMA_OMP_ASSUME && id != PRAGMA_OMP_ERROR) + { + error_at ( + input_location, + "intervening code must not contain executable OpenMP directives"); parser->omp_for_parse_state->fail = true; c_parser_skip_until_found (parser, CPP_PRAGMA_EOL, NULL); return false; @@ -29334,6 +29338,14 @@ c_parser_omp_error (c_parser *parser, enum pragma_context context) "may only be used in compound statements"); return true; } + if (parser->omp_for_parse_state + && parser->omp_for_parse_state->in_intervening_code) + { + error_at (loc, "%<#pragma omp error%> with % clause " + "may not be used in intervening code"); + parser->omp_for_parse_state->fail = true; + return true; + } tree fndecl = builtin_decl_explicit (severity_fatal ? BUILT_IN_GOMP_ERROR : BUILT_IN_GOMP_WARNING); @@ -29864,6 +29876,17 @@ c_parser_omp_metadirective (c_parser *parser, bool *if_p) } c_parser_skip_to_pragma_eol (parser); + /* If only one selector matches and it evaluates to 'omp nothing', no need to + proceed. */ + if (ctxs.length () == 1) + { + tree ctx = ctxs[0]; + if (ctx == NULL_TREE + || (omp_context_selector_matches (ctx, NULL_TREE, false) == 1 + && directive_tokens[0].pragma_kind == PRAGMA_OMP_NOTHING)) + return; + } + if (!default_seen) { /* Add a default clause that evaluates to 'omp nothing'. */ @@ -29944,7 +29967,7 @@ c_parser_omp_metadirective (c_parser *parser, bool *if_p) if (standalone_body == NULL_TREE) { standalone_body = push_stmt_list (); - c_parser_statement (parser, if_p); + c_parser_statement (parser, if_p); // TODO skip this standalone_body = pop_stmt_list (standalone_body); } else diff --git a/gcc/cp/parser.cc b/gcc/cp/parser.cc index e5d5d92cb8e..0917a16a908 100644 --- a/gcc/cp/parser.cc +++ b/gcc/cp/parser.cc @@ -52740,6 +52740,18 @@ cp_parser_omp_metadirective (cp_parser *parser, cp_token *pragma_tok, } cp_parser_skip_to_pragma_eol (parser, pragma_tok); + /* If only one selector matches and it evaluates to 'omp nothing', no need to + proceed. */ + if (ctxs.length () == 1) + { + tree ctx = ctxs[0]; + if (ctx == NULL_TREE + || (omp_context_selector_matches (ctx, NULL_TREE, false) == 1 + && cp_parser_pragma_kind (&directive_tokens[0]) + == PRAGMA_OMP_NOTHING)) + return; + } + if (!default_seen) { /* Add a default clause that evaluates to 'omp nothing'. */ @@ -53852,6 +53864,14 @@ cp_parser_omp_error (cp_parser *parser, cp_token *pragma_tok, "may only be used in compound statements"); return true; } + if (parser->omp_for_parse_state + && parser->omp_for_parse_state->in_intervening_code) + { + error_at (loc, "%<#pragma omp error%> with % clause " + "may not be used in intervening code"); + parser->omp_for_parse_state->fail = true; + return true; + } tree fndecl = builtin_decl_explicit (severity_fatal ? BUILT_IN_GOMP_ERROR : BUILT_IN_GOMP_WARNING); @@ -54769,11 +54789,15 @@ cp_parser_pragma (cp_parser *parser, enum pragma_context context, bool *if_p) id = cp_parser_pragma_kind (pragma_tok); if (parser->omp_for_parse_state && parser->omp_for_parse_state->in_intervening_code - && id >= PRAGMA_OMP__START_ - && id <= PRAGMA_OMP__LAST_) - { - error_at (pragma_tok->location, - "intervening code must not contain OpenMP directives"); + && id >= PRAGMA_OMP__START_ && id <= PRAGMA_OMP__LAST_ + /* Allow a safe subset of non-executable directives. See classification in + array c_omp_directives. */ + && id != PRAGMA_OMP_METADIRECTIVE && id != PRAGMA_OMP_NOTHING + && id != PRAGMA_OMP_ASSUME && id != PRAGMA_OMP_ERROR) + { + error_at ( + pragma_tok->location, + "intervening code must not contain executable OpenMP directives"); parser->omp_for_parse_state->fail = true; cp_parser_skip_to_pragma_eol (parser, pragma_tok); return false; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a14202fda8f..19473dfa791 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3161,7 +3161,8 @@ enum gfc_exec_op EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA, EXEC_OACC_ATOMIC, EXEC_OACC_DECLARE, - EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, + EXEC_OMP_CRITICAL, EXEC_OMP_FIRST_OPENMP_EXEC = EXEC_OMP_CRITICAL, + EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO, EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE, EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE, @@ -3192,7 +3193,8 @@ enum gfc_exec_op 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_UNROLL, EXEC_OMP_TILE, EXEC_OMP_INTEROP, EXEC_OMP_METADIRECTIVE, - EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS, EXEC_OMP_DISPATCH + EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS, EXEC_OMP_DISPATCH, + EXEC_OMP_LAST_OPENMP_EXEC = EXEC_OMP_DISPATCH }; /* Enum Definition for locality types. */ diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 6c6ffdaf343..8cea7242de2 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -6316,9 +6316,8 @@ gfc_match_omp_interop (void) trait-score: score(score-expression) */ -match -gfc_match_omp_context_selector (gfc_omp_set_selector *oss, - bool metadirective_p) +static match +gfc_match_omp_context_selector (gfc_omp_set_selector *oss) { do { @@ -6382,22 +6381,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss, gfc_error ("expected %<(%> at %C"); return MATCH_ERROR; } - if (gfc_match_expr (&os->score) != MATCH_YES - || !gfc_resolve_expr (os->score) - || os->score->ts.type != BT_INTEGER - || os->score->rank != 0) - { - gfc_error ("% argument must be constant integer " - "expression at %C"); - return MATCH_ERROR; - } - - if (os->score->expr_type == EXPR_CONSTANT - && mpz_sgn (os->score->value.integer) < 0) - { - gfc_error ("% argument must be non-negative at %C"); - return MATCH_ERROR; - } + if (gfc_match_expr (&os->score) != MATCH_YES) + return MATCH_ERROR; if (gfc_match (" )") != MATCH_YES) { @@ -6430,6 +6415,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss, else { gfc_error ("expected identifier at %C"); + free (otp); + os->properties = nullptr; return MATCH_ERROR; } } @@ -6450,6 +6437,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss, { gfc_error ("expected identifier or string literal " "at %C"); + free (otp); + os->properties = nullptr; return MATCH_ERROR; } @@ -6470,51 +6459,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss, if (gfc_match_expr (&otp->expr) != MATCH_YES) { gfc_error ("expected expression at %C"); - return MATCH_ERROR; - } - if (!gfc_resolve_expr (otp->expr) - || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR - && otp->expr->ts.type != BT_LOGICAL) - || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR - && otp->expr->ts.type != BT_INTEGER) - || otp->expr->rank != 0 - || (!metadirective_p - && otp->expr->expr_type != EXPR_CONSTANT)) - { - if (metadirective_p) - { - if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) - gfc_error ("property must be a " - "logical expression at %L", - &otp->expr->where); - else - gfc_error ("property must be an " - "integer expression at %L", - &otp->expr->where); - } - else - { - if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) - gfc_error ("property must be a constant " - "logical expression at %L", - &otp->expr->where); - else - gfc_error ("property must be a constant " - "integer expression at %L", - &otp->expr->where); - } - return MATCH_ERROR; - } - /* Device number must be conforming, which includes - omp_initial_device (-1) and omp_invalid_device (-4). */ - if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR - && otp->expr->expr_type == EXPR_CONSTANT - && mpz_sgn (otp->expr->value.integer) < 0 - && mpz_cmp_si (otp->expr->value.integer, -1) != 0 - && mpz_cmp_si (otp->expr->value.integer, -4) != 0) - { - gfc_error ("property must be a conforming device number " - "at %C"); + free (otp); + os->properties = nullptr; return MATCH_ERROR; } break; @@ -6590,9 +6536,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss, implementation user */ -match -gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head, - bool metadirective_p) +static match +gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head) { do { @@ -6629,7 +6574,7 @@ gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head, oss->code = set; *oss_head = oss; - if (gfc_match_omp_context_selector (oss, metadirective_p) != MATCH_YES) + if (gfc_match_omp_context_selector (oss) != MATCH_YES) return MATCH_ERROR; m = gfc_match (" }"); @@ -6760,8 +6705,7 @@ gfc_match_omp_declare_variant (void) return MATCH_ERROR; } has_match = true; - if (gfc_match_omp_context_selector_specification (&odv->set_selectors, - false) + if (gfc_match_omp_context_selector_specification (&odv->set_selectors) != MATCH_YES) return MATCH_ERROR; if (gfc_match (" )") != MATCH_YES) @@ -7052,7 +6996,7 @@ match_omp_metadirective (bool begin_p) if (!default_p) { - if (gfc_match_omp_context_selector_specification (&selectors, true) + if (gfc_match_omp_context_selector_specification (&selectors) != MATCH_YES) return MATCH_ERROR; @@ -11428,82 +11372,10 @@ icode_code_error_callback (gfc_code **codep, /* Errors have already been diagnosed in match_exit_cycle. */ state->errorp = true; break; - case EXEC_OMP_CRITICAL: - case EXEC_OMP_DO: - case EXEC_OMP_FLUSH: - case EXEC_OMP_MASTER: - case EXEC_OMP_ORDERED: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SINGLE: - case EXEC_OMP_WORKSHARE: - case EXEC_OMP_ATOMIC: - case EXEC_OMP_BARRIER: - case EXEC_OMP_END_NOWAIT: - case EXEC_OMP_END_SINGLE: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TASKYIELD: - case EXEC_OMP_CANCEL: - case EXEC_OMP_CANCELLATION_POINT: - case EXEC_OMP_TASKGROUP: - case EXEC_OMP_SIMD: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TEAMS: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_END_CRITICAL: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_SCAN: - case EXEC_OMP_DEPOBJ: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_LOOP: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_MASKED: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_SCOPE: - case EXEC_OMP_ERROR: - case EXEC_OMP_DISPATCH: - gfc_error ("%s cannot contain OpenMP directive in intervening code " - "at %L", - state->name, &code->loc); - state->errorp = true; + case EXEC_OMP_ASSUME: + case EXEC_OMP_METADIRECTIVE: + /* Per OpenMP 6.0, some non-executable directives are allowed in + intervening code. */ break; case EXEC_CALL: /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to @@ -11519,7 +11391,14 @@ icode_code_error_callback (gfc_code **codep, } break; default: - break; + if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC + && code->op <= EXEC_OMP_LAST_OPENMP_EXEC) + { + gfc_error ("%s cannot contain OpenMP directive in intervening code " + "at %L", + state->name, &code->loc); + state->errorp = true; + } } return 0; } @@ -12322,6 +12201,118 @@ resolve_omp_do (gfc_code *code) non_generated_count); } +/* Resolve the context selector. In particular, SKIP_P is set to true, + the context can never be matched. */ + +static void +gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss, + bool is_metadirective, bool *skip_p) +{ + if (skip_p) + *skip_p = false; + for (gfc_omp_set_selector *set_selector = oss; set_selector; + set_selector = set_selector->next) + for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next) + { + if (os->score) + { + if (!gfc_resolve_expr (os->score) + || os->score->ts.type != BT_INTEGER + || os->score->rank != 0) + { + gfc_error ("% argument must be constant integer " + "expression at %L", &os->score->where); + gfc_free_expr (os->score); + os->score = nullptr; + } + else if (os->score->expr_type == EXPR_CONSTANT + && mpz_sgn (os->score->value.integer) < 0) + { + gfc_error ("% argument must be non-negative at %L", + &os->score->where); + gfc_free_expr (os->score); + os->score = nullptr; + } + } + + enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type; + gfc_omp_trait_property *otp = os->properties; + + if (!otp) + continue; + switch (property_kind) + { + case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR: + case OMP_TRAIT_PROPERTY_BOOL_EXPR: + if (!gfc_resolve_expr (otp->expr) + || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR + && otp->expr->ts.type != BT_LOGICAL) + || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR + && otp->expr->ts.type != BT_INTEGER) + || otp->expr->rank != 0 + || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT)) + { + if (is_metadirective) + { + if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) + gfc_error ("property must be a " + "logical expression at %L", + &otp->expr->where); + else + gfc_error ("property must be an " + "integer expression at %L", + &otp->expr->where); + } + else + { + if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) + gfc_error ("property must be a constant " + "logical expression at %L", + &otp->expr->where); + else + gfc_error ("property must be a constant " + "integer expression at %L", + &otp->expr->where); + } + /* Prevent later ICEs. */ + gfc_expr *e; + if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) + e = gfc_get_logical_expr (gfc_default_logical_kind, + &otp->expr->where, true); + else + e = gfc_get_int_expr (gfc_default_integer_kind, + &otp->expr->where, 0); + gfc_free_expr (otp->expr); + otp->expr = e; + continue; + } + /* Device number must be conforming, which includes + omp_initial_device (-1) and omp_invalid_device (-4). */ + if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR + && otp->expr->expr_type == EXPR_CONSTANT + && mpz_sgn (otp->expr->value.integer) < 0 + && mpz_cmp_si (otp->expr->value.integer, -1) != 0 + && mpz_cmp_si (otp->expr->value.integer, -4) != 0) + gfc_error ("property must be a conforming device number at %L", + &otp->expr->where); + break; + default: + break; + } + /* This only handles one specific case: User condition. + FIXME: Handle more cases by calling omp_context_selector_matches; + unfortunately, we cannot generate the tree here as, e.g., PARM_DECL + backend decl are not available at this stage - but might be used in, + e.g. user conditions. See PR122361. */ + if (skip_p && otp + && os->code == OMP_TRAIT_USER_CONDITION + && otp->expr->expr_type == EXPR_CONSTANT + && otp->expr->value.logical == false) + *skip_p = true; + } +} + + static void resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns) { @@ -12329,9 +12320,38 @@ resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns) while (variant) { + bool skip; + gfc_resolve_omp_context_selector (variant->selectors, true, &skip); gfc_code *variant_code = variant->code; gfc_resolve_code (variant_code, ns); - variant = variant->next; + if (skip) + { + /* The following should only be true if an error occurred + as the 'otherwise' clause should always match. */ + if (variant == code->ext.omp_variants && !variant->next) + break; + if (variant == code->ext.omp_variants) + code->ext.omp_variants = variant->next; + gfc_omp_variant *tmp = variant; + variant = variant->next; + gfc_free_omp_set_selector_list (tmp->selectors); + free (tmp); + } + else + variant = variant->next; + } + /* Replace metadirective by its body if only 'nothing' remains. */ + if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE) + { + gfc_code *next = code->next; + gfc_code *inner = code->ext.omp_variants->code; + gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors); + free (code->ext.omp_variants); + *code = *inner; + free (inner); + while (code->next) + code = code->next; + code->next = next; } } @@ -13108,6 +13128,9 @@ gfc_resolve_omp_declare (gfc_namespace *ns) gfc_omp_declare_variant *odv; gfc_omp_namelist *range_begin = NULL; + + for (odv = ns->omp_declare_variant; odv; odv = odv->next) + gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr); for (odv = ns->omp_declare_variant; odv; odv = odv->next) for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next) { diff --git a/gcc/testsuite/c-c++-common/gomp/imperfect1.c b/gcc/testsuite/c-c++-common/gomp/imperfect1.c index 705626ad169..bef783bb907 100644 --- a/gcc/testsuite/c-c++-common/gomp/imperfect1.c +++ b/gcc/testsuite/c-c++-common/gomp/imperfect1.c @@ -15,7 +15,7 @@ void s1 (int a1, int a2, int a3) f1 (0, i); for (j = 0; j < a2; j++) { -#pragma omp barrier /* { dg-error "intervening code must not contain OpenMP directives" } */ +#pragma omp barrier /* { dg-error "intervening code must not contain executable OpenMP directives" } */ f1 (1, j); if (i == 2) continue; /* { dg-error "invalid exit" } */ diff --git a/gcc/testsuite/c-c++-common/gomp/imperfect4.c b/gcc/testsuite/c-c++-common/gomp/imperfect4.c index 1a0c07cd48e..30d1cc66235 100644 --- a/gcc/testsuite/c-c++-common/gomp/imperfect4.c +++ b/gcc/testsuite/c-c++-common/gomp/imperfect4.c @@ -21,7 +21,7 @@ void s1 (int a1, int a2, int a3) /* According to the grammar, this is intervening code; we don't know that we are also missing a nested for loop until we have parsed this whole compound expression. */ -#pragma omp barrier /* { dg-error "intervening code must not contain OpenMP directives" } */ +#pragma omp barrier /* { dg-error "intervening code must not contain executable OpenMP directives" } */ f1 (2, k); f2 (2, k); } diff --git a/gcc/testsuite/c-c++-common/gomp/pr120180.c b/gcc/testsuite/c-c++-common/gomp/pr120180-1.c similarity index 79% rename from gcc/testsuite/c-c++-common/gomp/pr120180.c rename to gcc/testsuite/c-c++-common/gomp/pr120180-1.c index cb5a0d5a819..52b5082b4e7 100644 --- a/gcc/testsuite/c-c++-common/gomp/pr120180.c +++ b/gcc/testsuite/c-c++-common/gomp/pr120180-1.c @@ -1,7 +1,7 @@ /* { dg-do compile } */ -/* This test used to ICE after erroring on the metadirective in the - loop nest. */ +/* This test case checks that the inner metadirective is accepted as intervening + code since it resolves to 'omp nothing'. */ int main() { @@ -14,7 +14,7 @@ int main() when(user={condition(1)}: target teams loop collapse(2) map(qq[:0]) private(i)) for(k=0; k 1) + z = __builtin_fabs (x - i); + for (k = 0; k < m; k++) + qq[k * m + i] = z; + } + return 0; +} + +int +test3 () +{ + int i, k, m, n; + double *qq, z; +#pragma omp for collapse(2) + for (i = 1; i < n; i++) + { +#pragma omp error at(compilation) /* { dg-error "'pragma omp error' encountered" } */ + for (k = 0; k < m; k++) + qq[k * m + i] = z; + } + return 0; +} + +int +test4 () +{ + int i, k, m, n; + double *qq, z; +#pragma omp for collapse(2) + for (i = 1; i < n; i++) + { +#pragma omp error at(execution) /* { dg-error "pragma omp error' with 'at\\(execution\\)' clause may not be used in intervening code" } */ + for (k = 0; k < m; k++) + qq[k * m + i] = z; + } + return 0; +} diff --git a/gcc/testsuite/g++.dg/gomp/attrs-imperfect1.C b/gcc/testsuite/g++.dg/gomp/attrs-imperfect1.C index cf293b5081c..b43139c8968 100644 --- a/gcc/testsuite/g++.dg/gomp/attrs-imperfect1.C +++ b/gcc/testsuite/g++.dg/gomp/attrs-imperfect1.C @@ -15,7 +15,7 @@ void s1 (int a1, int a2, int a3) f1 (0, i); for (j = 0; j < a2; j++) { - [[ omp :: directive (barrier) ]] ; /* { dg-error "intervening code must not contain OpenMP directives" } */ + [[ omp :: directive (barrier) ]] ; /* { dg-error "intervening code must not contain executable OpenMP directives" } */ f1 (1, j); if (i == 2) continue; /* { dg-error "invalid exit" } */ diff --git a/gcc/testsuite/g++.dg/gomp/attrs-imperfect4.C b/gcc/testsuite/g++.dg/gomp/attrs-imperfect4.C index 16636ab3eb6..94b4db856a9 100644 --- a/gcc/testsuite/g++.dg/gomp/attrs-imperfect4.C +++ b/gcc/testsuite/g++.dg/gomp/attrs-imperfect4.C @@ -21,7 +21,7 @@ void s1 (int a1, int a2, int a3) /* According to the grammar, this is intervening code; we don't know that we are also missing a nested for loop until we have parsed this whole compound expression. */ - [[ omp :: directive (barrier) ]] ; /* { dg-error "intervening code must not contain OpenMP directives" } */ + [[ omp :: directive (barrier) ]] ; /* { dg-error "intervening code must not contain executable OpenMP directives" } */ f1 (2, k); f2 (2, k); } diff --git a/gcc/testsuite/g++.dg/gomp/pr120180-1.C b/gcc/testsuite/g++.dg/gomp/pr120180-1.C new file mode 100644 index 00000000000..819b3ee9045 --- /dev/null +++ b/gcc/testsuite/g++.dg/gomp/pr120180-1.C @@ -0,0 +1,26 @@ +// { dg-do compile } +// { dg-additional-options "-std=c++11" } + +// This test case checks that the inner metadirective is accepted as intervening +// code since it resolves to 'omp nothing'. + +int main() +{ + constexpr int use_teams = 1; + constexpr int use_simd = 0; + + int blksize = 15000; + double *qq; + int i, k, nq; + + #pragma omp metadirective when(user={condition(use_teams)}: teams distribute parallel for collapse(2)) \ + otherwise(parallel for collapse(1)) + for(k=0; k PR middle-end/113904 !$omp declare variant(variant5) match(target_device={device_num(my_device)}) ! { dg-error "property must be a constant integer expression" } + ! { dg-error "Symbol 'my_device' at .1. has no IMPLICIT type" "" { target *-*-* } .-1 } !$omp declare variant(variant5) match(target_device={device_num(-2)}) ! { dg-error "property must be a conforming device number" } res = 99 diff --git a/gcc/testsuite/gfortran.dg/gomp/pr120180-1.f90 b/gcc/testsuite/gfortran.dg/gomp/pr120180-1.f90 new file mode 100644 index 00000000000..f16a256f6c6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr120180-1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } + +! This test case checks that the inner metadirective is accepted as intervening +! code since it resolves to 'omp nothing'. + +SUBROUTINE test1(x_min, x_max, y_min, y_max, xarea, vol_flux_x) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: x_min, x_max, y_min, y_max + + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: xarea + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: vol_flux_x + + INTEGER :: j,k + + !$omp metadirective & + !$omp when(user={condition(.false.)}: & + !$omp target teams distribute parallel do simd collapse(2)) & + !$omp when(user={condition(.false.)}: & + !$omp target teams distribute parallel do) & + !$omp default( & + !$omp target teams loop collapse(2)) + DO k=y_min,y_max + !$omp metadirective when(user={condition(.false.)}: simd) + DO j=x_min,x_max + vol_flux_x(j,k)=0.25_8*xarea(j,k) + ENDDO + ENDDO + +END SUBROUTINE test1 diff --git a/gcc/testsuite/gfortran.dg/gomp/pr120180-2.f90 b/gcc/testsuite/gfortran.dg/gomp/pr120180-2.f90 new file mode 100644 index 00000000000..ea90ad68e99 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr120180-2.f90 @@ -0,0 +1,90 @@ +! { dg-do compile } + +! This test case checks that a non-executable OpenMP directive is accepted +! as intervening code. + +SUBROUTINE test1(x_min, x_max, y_min, y_max, xarea, vol_flux_x) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: x_min, x_max, y_min, y_max + + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: xarea + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: vol_flux_x + + INTEGER :: j,k + + !$omp do collapse(2) + DO k=y_min,y_max + !$omp nothing + DO j=x_min,x_max + vol_flux_x(j,k)=0.25_8*xarea(j,k) + ENDDO + ENDDO + +END SUBROUTINE test1 + +SUBROUTINE test2(x_min, x_max, y_min, y_max, x, z, vol_flux_x) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: x_min, x_max, y_min, y_max + + REAL(KIND=8) :: x, z + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: vol_flux_x + + INTEGER :: j,k + + !$omp do collapse(2) + DO k=y_min,y_max + !$omp assume holds(x>1) + z = abs(x-1) + !$omp end assume + DO j=x_min,x_max + vol_flux_x(j,k)=0.25_8*z + ENDDO + ENDDO + +END SUBROUTINE test2 + +SUBROUTINE test3(x_min, x_max, y_min, y_max, z, vol_flux_x) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: x_min, x_max, y_min, y_max + + REAL(KIND=8) :: z + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: vol_flux_x + + INTEGER :: j,k + + !$omp do collapse(2) + DO k=y_min,y_max + !$omp error at(compilation) ! { dg-error "OMP ERROR encountered at" } + DO j=x_min,x_max + vol_flux_x(j,k)=0.25_8*z + ENDDO + ENDDO + +END SUBROUTINE test3 + +SUBROUTINE test4(x_min, x_max, y_min, y_max, z, vol_flux_x) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: x_min, x_max, y_min, y_max + + REAL(KIND=8) :: z + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: vol_flux_x + + INTEGER :: j,k + + !$omp do collapse(2) + DO k=y_min,y_max + !$omp error at(execution) ! { dg-error "OMP DO cannot contain OpenMP directive in intervening code" } + DO j=x_min,x_max + vol_flux_x(j,k)=0.25_8*z + ENDDO + ENDDO + +END SUBROUTINE test4 diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122306-1.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122306-1.f90 new file mode 100644 index 00000000000..b7eb44f6ba6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122306-1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } + +! This test case checks that a function call in a context selector is accepted. + +module m + implicit none (type, external) +contains + integer function f(n) + integer :: i, n + f = 0 + !$omp metadirective & + !$omp& when(user={condition(use_target())}: target parallel do map(f) reduction(+:f)) & + !$omp& otherwise(parallel do reduction(+:f)) + do i = 1, n + f = f + 1 + end do + end + logical function use_target() + use_target = .false. + end +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122306-2.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122306-2.f90 new file mode 100644 index 00000000000..799c92be6cb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122306-2.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } + +! This test case checks that various user-condition context selectors correctly +! parsed and resolved. + +SUBROUTINE test1(x_min, x_max, vol_flux_x) + IMPLICIT NONE + INTEGER, INTENT(IN) :: x_min, x_max + REAL(KIND=8), DIMENSION(x_min:x_max) :: vol_flux_x + integer, parameter :: one = 1 + INTEGER :: j + + !$omp begin metadirective when(user={condition(one < 0)}: parallel) + DO j=x_min,x_max + vol_flux_x(j)=0.25_8 + ENDDO + !$omp end metadirective +END SUBROUTINE test1 + +SUBROUTINE test2(x_min, x_max, vol_flux_x, flag) + IMPLICIT NONE + INTEGER, INTENT(IN) :: x_min, x_max + REAL(KIND=8), DIMENSION(x_min:x_max) :: vol_flux_x + LOGICAL :: flag + INTEGER :: j + + !$omp begin metadirective when(user={condition(flag)}: parallel) + DO j=x_min,x_max + vol_flux_x(j)=0.25_8 + ENDDO + !$omp end metadirective +END SUBROUTINE test2 +