diff options
Diffstat (limited to 'gcc/fortran/openmp.cc')
| -rw-r--r-- | gcc/fortran/openmp.cc | 894 |
1 files changed, 579 insertions, 315 deletions
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 905980a..abc27d5 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -59,6 +59,7 @@ struct gfc_omp_directive { and "nothing". */ static const struct gfc_omp_directive gfc_omp_directives[] = { + /* allocate as alias for allocators is also executive. */ {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE}, {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS}, {"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES}, @@ -68,6 +69,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { {"cancellation point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT}, {"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 reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION}, {"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD}, @@ -79,7 +81,11 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { {"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO}, /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */ {"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR}, + /* {"flatten", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLATTEN}, */ {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH}, + /* {"fuse", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSE}, */ + {"groupprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_GROUPPRIVATE}, + /* {"interchange", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTERCHANGE}, */ {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP}, {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED}, @@ -98,11 +104,15 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { {"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION}, {"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD}, {"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE}, + /* {"split", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SPLIT}, */ + /* {"strip", GFC_OMP_DIR_EXECUTABLE, ST_OMP_STRIP}, */ {"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA}, {"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA}, {"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA}, {"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE}, {"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET}, + /* {"taskgraph", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKGRAPH}, */ + /* {"task iteration", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK_ITERATION}, */ {"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP}, {"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT}, {"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD}, @@ -111,6 +121,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { {"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE}, {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE}, {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL}, + /* {"workdistribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKDISTRIBUTE}, */ {"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE}, }; @@ -185,6 +196,7 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) gfc_free_expr (c->num_teams_lower); gfc_free_expr (c->num_teams_upper); gfc_free_expr (c->device); + gfc_free_expr (c->dyn_groupprivate); gfc_free_expr (c->thread_limit); gfc_free_expr (c->dist_chunk_size); gfc_free_expr (c->grainsize); @@ -1162,6 +1174,8 @@ enum omp_mask2 OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */ OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */ OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */ + OMP_CLAUSE_LOCAL, /* OpenMP 6.0 */ + OMP_CLAUSE_DYN_GROUPPRIVATE, /* OpenMP 6.1 */ /* This must come last. */ OMP_MASK2_LAST }; @@ -1588,7 +1602,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, { gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl; p->sym = n->sym; - p->where = p->where; + p->where = n->where; p->u.map.op = OMP_MAP_ALWAYS_TOFROM; tl = &c->lists[OMP_LIST_MAP]; @@ -2138,10 +2152,8 @@ gfc_match_omp_prefer_type (char **type_str, int *type_str_len) the 'interop' directive and the 'append_args' directive of 'declare variant'. [prefer_type(...)][,][<target|targetsync>, ...]) - If is_init_clause, there might be no modifiers but variables like 'target'; - additionally, the modifier parsing ends with a ':'. - If not is_init_clause (i.e. append_args), there must be modifiers and the - parsing ends with ')'. */ + If is_init_clause, the modifier parsing ends with a ':'. + If not is_init_clause (i.e. append_args), the parsing ends with ')'. */ static match gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync, @@ -2153,9 +2165,10 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync, *type_str = NULL; type_str_len = 0; match m; - locus old_loc = gfc_current_locus; - do { - if (gfc_match ("prefer_type ( ") == MATCH_YES) + + do + { + if (gfc_match ("prefer_type ( ") == MATCH_YES) { if (*type_str) { @@ -2181,12 +2194,17 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync, } return MATCH_ERROR; } - if (gfc_match ("targetsync ") == MATCH_YES) + + if (gfc_match ("prefer_type ") == MATCH_YES) + { + gfc_error ("Expected %<(%> after %<prefer_type%> at %C"); + return MATCH_ERROR; + } + + if (gfc_match ("targetsync ") == MATCH_YES) { if (targetsync) { - /* Avoid the word 'modifier' as it could be also be no clauses and - twice a variable named 'targetsync', which is also invalid. */ gfc_error ("Duplicate %<targetsync%> at %C"); return MATCH_ERROR; } @@ -2202,13 +2220,6 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync, } if (gfc_match (": ") == MATCH_YES) break; - gfc_char_t c = gfc_peek_char (); - if (!*type_str && (c == ')' || (gfc_current_form != FORM_FREE - && (c == '_' || ISALPHA (c))))) - { - gfc_current_locus = old_loc; - break; - } gfc_error ("Expected %<,%> or %<:%> at %C"); return MATCH_ERROR; } @@ -2231,25 +2242,21 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync, } if (gfc_match (": ") == MATCH_YES) break; - gfc_char_t c = gfc_peek_char (); - if (!*type_str && (c == ')' || (gfc_current_form != FORM_FREE - && (c == '_' || ISALPHA (c))))) - { - gfc_current_locus = old_loc; - break; - } gfc_error ("Expected %<,%> or %<:%> at %C"); return MATCH_ERROR; } - if (*type_str) - { - gfc_error ("Expected %<target%> or %<targetsync%> at %C"); - return MATCH_ERROR; - } - gfc_current_locus = old_loc; - break; + gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> " + "at %C"); + return MATCH_ERROR; } while (true); + + if (!target && !targetsync) + { + gfc_error ("Missing required %<target%> and/or %<targetsync%> " + "modifier at %C"); + return MATCH_ERROR; + } return MATCH_YES; } @@ -2266,17 +2273,17 @@ gfc_match_omp_init (gfc_omp_namelist **list) type_str_len, true) == MATCH_ERROR) return MATCH_ERROR; - gfc_omp_namelist **head = NULL; - if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES) - return MATCH_ERROR; - for (gfc_omp_namelist *n = *head; n; n = n->next) - { - n->u.init.target = target; - n->u.init.targetsync = targetsync; - n->u.init.len = type_str_len; - n->u2.init_interop = type_str; - } - return MATCH_YES; + gfc_omp_namelist **head = NULL; + if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES) + return MATCH_ERROR; + for (gfc_omp_namelist *n = *head; n; n = n->next) + { + n->u.init.target = target; + n->u.init.targetsync = targetsync; + n->u.init.len = type_str_len; + n->u2.init_interop = type_str; + } + return MATCH_YES; } @@ -3093,6 +3100,22 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, else continue; } + if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE) + && gfc_match_dupl_check (!c->dyn_groupprivate, + "dyn_groupprivate", true) == MATCH_YES) + { + if (gfc_match ("fallback ( abort ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_ABORT; + else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_DEFAULT_MEM; + else if (gfc_match ("fallback ( null ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_NULL; + if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES) + return MATCH_ERROR; + if (gfc_match (" )") != MATCH_YES) + goto error; + continue; + } break; case 'e': if ((mask & OMP_CLAUSE_ENTER)) @@ -3564,6 +3587,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, &c->lists[OMP_LIST_LINK]) == MATCH_YES)) continue; + if ((mask & OMP_CLAUSE_LOCAL) + && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL]) + == MATCH_YES)) + continue; break; case 'm': if ((mask & OMP_CLAUSE_MAP) @@ -4481,7 +4508,7 @@ error: | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \ | OMP_CLAUSE_DETACH) #define OACC_WAIT_CLAUSES \ - omp_mask (OMP_CLAUSE_ASYNC) + omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF #define OACC_ROUTINE_CLAUSES \ (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ | OMP_CLAUSE_SEQ \ @@ -5061,7 +5088,8 @@ cleanup: | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \ | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \ - | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS) + | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \ + | OMP_CLAUSE_DYN_GROUPPRIVATE) #define OMP_TARGET_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) @@ -5089,7 +5117,7 @@ cleanup: (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD) #define OMP_DECLARE_TARGET_CLAUSES \ (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \ - | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT) + | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL) #define OMP_ATOMIC_CLAUSES \ (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \ | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \ @@ -6110,7 +6138,7 @@ gfc_match_omp_declare_target (void) gfc_buffer_error (false); static const int to_enter_link_lists[] - = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK }; + = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL }; for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) && (list = to_enter_link_lists[listn], true); ++listn) for (n = c->lists[list]; n; n = n->next) @@ -6119,6 +6147,8 @@ gfc_match_omp_declare_target (void) else if (n->u.common->head) n->u.common->head->mark = 0; + if (c->device_type == OMP_DEVICE_TYPE_UNSET) + c->device_type = OMP_DEVICE_TYPE_ANY; for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) && (list = to_enter_link_lists[listn], true); ++listn) for (n = c->lists[list]; n; n = n->next) @@ -6127,105 +6157,161 @@ gfc_match_omp_declare_target (void) if (n->sym->attr.in_common) gfc_error_now ("OMP DECLARE TARGET variable at %L is an " "element of a COMMON block", &n->where); + else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL) + gfc_error_now ("List item %qs at %L not appear in the %qs clause " + "as it was previously specified in a GROUPPRIVATE " + "directive", n->sym->name, &n->where, + list == OMP_LIST_LINK + ? "link" : list == OMP_LIST_TO ? "to" : "enter"); else if (n->sym->mark) gfc_error_now ("Variable at %L mentioned multiple times in " "clauses of the same OMP DECLARE TARGET directive", &n->where); - else if (n->sym->attr.omp_declare_target - && n->sym->attr.omp_declare_target_link - && list != OMP_LIST_LINK) + else if ((n->sym->attr.omp_declare_target_link + || n->sym->attr.omp_declare_target_local) + && list != OMP_LIST_LINK + && list != OMP_LIST_LOCAL) gfc_error_now ("OMP DECLARE TARGET variable at %L previously " - "mentioned in LINK clause and later in %s clause", - &n->where, list == OMP_LIST_TO ? "TO" : "ENTER"); + "mentioned in %s clause and later in %s clause", + &n->where, + n->sym->attr.omp_declare_target_link ? "LINK" + : "LOCAL", + list == OMP_LIST_TO ? "TO" : "ENTER"); else if (n->sym->attr.omp_declare_target - && !n->sym->attr.omp_declare_target_link - && list == OMP_LIST_LINK) + && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL)) gfc_error_now ("OMP DECLARE TARGET variable at %L previously " "mentioned in TO or ENTER clause and later in " - "LINK clause", &n->where); - else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, - &n->sym->declared_at)) + "%s clause", &n->where, + list == OMP_LIST_LINK ? "LINK" : "LOCAL"); + else { + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, + &n->sym->declared_at); if (list == OMP_LIST_LINK) gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name, &n->sym->declared_at); + if (list == OMP_LIST_LOCAL) + gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name, + &n->sym->declared_at); + } + if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && n->sym->attr.omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + if (n->sym->attr.omp_groupprivate) + gfc_error_now ("List item %qs at %L set in previous OMP " + "GROUPPRIVATE directive to the different " + "DEVICE_TYPE %qs", n->sym->name, &n->where, dt); + else + gfc_error_now ("List item %qs at %L set in previous OMP " + "DECLARE TARGET directive to the different " + "DEVICE_TYPE %qs", n->sym->name, &n->where, dt); } - if (c->device_type != OMP_DEVICE_TYPE_UNSET) - { - if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && n->sym->attr.omp_device_type != c->device_type) - gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " - "TARGET directive to a different DEVICE_TYPE", - n->sym->name, &n->where); - n->sym->attr.omp_device_type = c->device_type; - } - if (c->indirect) + n->sym->attr.omp_device_type = c->device_type; + if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY) { - if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_ANY) - gfc_error_now ("DEVICE_TYPE must be ANY when used with " - "INDIRECT at %L", &n->where); - n->sym->attr.omp_declare_target_indirect = c->indirect; + gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT " + "at %L", &n->where); + c->indirect = 0; } - + n->sym->attr.omp_declare_target_indirect = c->indirect; + if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST) + gfc_error_now ("List item %qs at %L set with NOHOST specified may " + "not appear in a LINK clause", n->sym->name, + &n->where); n->sym->mark = 1; } - else if (n->u.common->omp_declare_target - && n->u.common->omp_declare_target_link - && list != OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in LINK clause and later in %s clause", - &n->where, list == OMP_LIST_TO ? "TO" : "ENTER"); - else if (n->u.common->omp_declare_target - && !n->u.common->omp_declare_target_link - && list == OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in TO or ENTER clause and later in " - "LINK clause", &n->where); - else if (n->u.common->head && n->u.common->head->mark) - gfc_error_now ("COMMON at %L mentioned multiple times in " - "clauses of the same OMP DECLARE TARGET directive", - &n->where); - else - { - n->u.common->omp_declare_target = 1; - n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK); + else /* common block */ + { + if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL) + gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs " + "clause as it was previously specified in a " + "GROUPPRIVATE directive", + n->u.common->name, &n->where, + list == OMP_LIST_LINK + ? "link" : list == OMP_LIST_TO ? "to" : "enter"); + else if (n->u.common->head && n->u.common->head->mark) + gfc_error_now ("Common block %</%s/%> at %L mentioned multiple " + "times in clauses of the same OMP DECLARE TARGET " + "directive", n->u.common->name, &n->where); + else if ((n->u.common->omp_declare_target_link + || n->u.common->omp_declare_target_local) + && list != OMP_LIST_LINK + && list != OMP_LIST_LOCAL) + gfc_error_now ("Common block %</%s/%> at %L previously mentioned " + "in %s clause and later in %s clause", + n->u.common->name, &n->where, + n->u.common->omp_declare_target_link ? "LINK" + : "LOCAL", + list == OMP_LIST_TO ? "TO" : "ENTER"); + else if (n->u.common->omp_declare_target + && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL)) + gfc_error_now ("Common block %</%s/%> at %L previously mentioned " + "in TO or ENTER clause and later in %s clause", + n->u.common->name, &n->where, + list == OMP_LIST_LINK ? "LINK" : "LOCAL"); if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET && n->u.common->omp_device_type != c->device_type) - gfc_error_now ("COMMON at %L set in previous OMP DECLARE " - "TARGET directive to a different DEVICE_TYPE", - &n->where); + { + const char *dt = "any"; + if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + if (n->u.common->omp_groupprivate) + gfc_error_now ("Common block %</%s/%> at %L set in previous OMP " + "GROUPPRIVATE directive to the different " + "DEVICE_TYPE %qs", n->u.common->name, &n->where, + dt); + else + gfc_error_now ("Common block %</%s/%> at %L set in previous OMP " + "DECLARE TARGET directive to the different " + "DEVICE_TYPE %qs", n->u.common->name, &n->where, + dt); + } n->u.common->omp_device_type = c->device_type; + if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY) + { + gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT " + "at %L", &n->where); + c->indirect = 0; + } + if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST) + gfc_error_now ("Common block %</%s/%> at %L set with NOHOST " + "specified may not appear in a LINK clause", + n->u.common->name, &n->where); + + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + n->u.common->omp_declare_target = 1; + if (list == OMP_LIST_LINK) + n->u.common->omp_declare_target_link = 1; + if (list == OMP_LIST_LOCAL) + n->u.common->omp_declare_target_local = 1; + for (s = n->u.common->head; s; s = s->common_next) { s->mark = 1; - if (gfc_add_omp_declare_target (&s->attr, s->name, - &s->declared_at)) - { - if (list == OMP_LIST_LINK) - gfc_add_omp_declare_target_link (&s->attr, s->name, - &s->declared_at); - } - if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && s->attr.omp_device_type != c->device_type) - gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" - " TARGET directive to a different DEVICE_TYPE", - s->name, &n->where); + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + gfc_add_omp_declare_target (&s->attr, s->name, &n->where); + if (list == OMP_LIST_LINK) + gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where); + if (list == OMP_LIST_LOCAL) + gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where); s->attr.omp_device_type = c->device_type; - - if (c->indirect - && s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && s->attr.omp_device_type != OMP_DEVICE_TYPE_ANY) - gfc_error_now ("DEVICE_TYPE must be ANY when used with " - "INDIRECT at %L", &n->where); s->attr.omp_declare_target_indirect = c->indirect; } } if ((c->device_type || c->indirect) && !c->lists[OMP_LIST_ENTER] && !c->lists[OMP_LIST_TO] - && !c->lists[OMP_LIST_LINK]) + && !c->lists[OMP_LIST_LINK] + && !c->lists[OMP_LIST_LOCAL]) gfc_warning_now (OPT_Wopenmp, "OMP DECLARE TARGET directive at %L with only " "DEVICE_TYPE or INDIRECT clauses is ignored", @@ -6313,9 +6399,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 { @@ -6379,22 +6464,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 ("%<score%> 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 ("%<score%> 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) { @@ -6427,6 +6498,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; } } @@ -6447,6 +6520,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; } @@ -6467,51 +6542,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; @@ -6587,9 +6619,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 { @@ -6626,7 +6657,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 (" }"); @@ -6757,8 +6788,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) @@ -6989,13 +7019,9 @@ gfc_match_omp_declare_variant (void) return MATCH_ERROR; } - if ((has_adjust_args || has_append_args) && !has_match) + if (!has_match) { - gfc_error ("the %qs clause at %L can only be specified if the " - "%<dispatch%> selector of the construct selector set appears " - "in the %<match%> clause", - has_adjust_args ? "adjust_args" : "append_args", - has_adjust_args ? &adjust_args_loc : &append_args_loc); + gfc_error ("expected %<match%> clause at %C"); return MATCH_ERROR; } @@ -7053,7 +7079,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; @@ -7165,32 +7191,44 @@ gfc_match_omp_metadirective (void) return match_omp_metadirective (false); } -match -gfc_match_omp_threadprivate (void) +/* Match 'omp threadprivate' or 'omp groupprivate'. */ +static match +gfc_match_omp_thread_group_private (bool is_groupprivate) { locus old_loc; char n[GFC_MAX_SYMBOL_LEN+1]; gfc_symbol *sym; match m; gfc_symtree *st; + struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; }; + auto_vec<sym_loc_t> syms; old_loc = gfc_current_locus; - m = gfc_match (" ("); + m = gfc_match (" ( "); if (m != MATCH_YES) return m; for (;;) { + locus sym_loc = gfc_current_locus; m = gfc_match_symbol (&sym, 0); switch (m) { case MATCH_YES: if (sym->attr.in_common) - gfc_error_now ("Threadprivate variable at %C is an element of " - "a COMMON block"); - else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) + gfc_error_now ("%qs variable at %L is an element of a COMMON block", + is_groupprivate ? "groupprivate" : "threadprivate", + &sym_loc); + else if (!is_groupprivate + && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc)) goto cleanup; + else if (is_groupprivate) + { + if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc)) + goto cleanup; + syms.safe_push ({sym, nullptr, sym_loc}); + } goto next_item; case MATCH_NO: break; @@ -7207,12 +7245,20 @@ gfc_match_omp_threadprivate (void) st = gfc_find_symtree (gfc_current_ns->common_root, n); if (st == NULL) { - gfc_error ("COMMON block /%s/ not found at %C", n); + gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc); goto cleanup; } - st->n.common->threadprivate = 1; + syms.safe_push ({nullptr, st->n.common, sym_loc}); + if (is_groupprivate) + st->n.common->omp_groupprivate = 1; + else + st->n.common->threadprivate = 1; for (sym = st->n.common->head; sym; sym = sym->common_next) - if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) + if (!is_groupprivate + && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc)) + goto cleanup; + else if (is_groupprivate + && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc)) goto cleanup; next_item: @@ -7222,16 +7268,89 @@ gfc_match_omp_threadprivate (void) goto syntax; } + if (is_groupprivate) + { + gfc_omp_clauses *c; + m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE)); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (c->device_type == OMP_DEVICE_TYPE_UNSET) + c->device_type = OMP_DEVICE_TYPE_ANY; + + for (size_t i = 0; i < syms.length (); i++) + if (syms[i].sym) + { + sym_loc_t &n = syms[i]; + if (n.sym->attr.in_common) + gfc_error_now ("Variable %qs at %L is an element of a COMMON " + "block", n.sym->name, &n.loc); + else if (n.sym->attr.omp_declare_target + || n.sym->attr.omp_declare_target_link) + gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET " + "with the LOCAL clause, but it has been specified" + " with a different clause before", + n.sym->name, &n.loc); + if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && n.sym->attr.omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " + "TARGET directive to the different DEVICE_TYPE %qs", + n.sym->name, &n.loc, dt); + } + gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name, + &n.loc); + n.sym->attr.omp_device_type = c->device_type; + } + else /* Common block. */ + { + sym_loc_t &n = syms[i]; + if (n.com->omp_declare_target + || n.com->omp_declare_target_link) + gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE " + "TARGET with the LOCAL clause, but it has been " + "specified with a different clause before", + n.com->name, &n.loc); + if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET + && n.com->omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" + " TARGET directive to the different DEVICE_TYPE " + "%qs", n.com->name, &n.loc, dt); + } + n.com->omp_declare_target_local = 1; + n.com->omp_device_type = c->device_type; + for (gfc_symbol *s = n.com->head; s; s = s->common_next) + { + gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc); + s->attr.omp_device_type = c->device_type; + } + } + free (c); + } + if (gfc_match_omp_eos () != MATCH_YES) { - gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C"); + gfc_error ("Unexpected junk after OMP %s at %C", + is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE"); goto cleanup; } return MATCH_YES; syntax: - gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C"); + gfc_error ("Syntax error in !$OMP %s list at %C", + is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE"); cleanup: gfc_current_locus = old_loc; @@ -7240,6 +7359,20 @@ cleanup: match +gfc_match_omp_groupprivate (void) +{ + return gfc_match_omp_thread_group_private (true); +} + + +match +gfc_match_omp_threadprivate (void) +{ + return gfc_match_omp_thread_group_private (false); +} + + +match gfc_match_omp_parallel (void) { return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES); @@ -8416,9 +8549,9 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, } /* Assume that a constant expression in the range 1 (omp_default_mem_alloc) - to 8 (omp_thread_mem_alloc) range, or 200 (ompx_gnu_pinned_mem_alloc) is - fine. The original symbol name is already lost during matching via - gfc_match_expr. */ + to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to + GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already + lost during matching via gfc_match_expr. */ static bool is_predefined_allocator (gfc_expr *expr) { @@ -8549,7 +8682,8 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all || (n->sym->ns->proc_name && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM - || n->sym->ns->proc_name->attr.flavor == FL_MODULE))) + || n->sym->ns->proc_name->attr.flavor == FL_MODULE + || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA))) { bool com = n->sym->attr.in_common; if (!n->u2.allocator) @@ -8563,6 +8697,30 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) &n->u2.allocator->where, com ? "/" : "", com ? n->sym->common_head->name : n->sym->name, com ? "/" : "", &n->where); + /* Only local static variables might use omp_cgroup_mem_alloc (6), + omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */ + else if ((!ns->proc_name + || ns->proc_name->attr.flavor == FL_PROGRAM + || ns->proc_name->attr.flavor == FL_BLOCK_DATA + || ns->proc_name->attr.flavor == FL_MODULE + || com) + && mpz_cmp_si (n->u2.allocator->value.integer, + 6 /* cgroup */) >= 0 + && mpz_cmp_si (n->u2.allocator->value.integer, + 8 /* thread */) <= 0) + { + const char *alloc_name[] = {"omp_cgroup_mem_alloc", + "omp_pteam_mem_alloc", + "omp_thread_mem_alloc" }; + gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, " + "used for list item %<%s%s%s%> at %L, may only be used" + " for local static variables", + alloc_name[mpz_get_ui (n->u2.allocator->value.integer) + - 6 /* cgroup */], &n->u2.allocator->where, + com ? "/" : "", + com ? n->sym->common_head->name : n->sym->name, + com ? "/" : "", &n->where); + } while (n->sym->attr.in_common && n->next && n->next->sym && n->sym->common_head == n->next->sym->common_head) n = n->next; @@ -8611,7 +8769,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "TO", "FROM", "INCLUSIVE", "EXCLUSIVE", "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/, "IN_REDUCTION", "TASK_REDUCTION", - "DEVICE_RESIDENT", "LINK", "USE_DEVICE", + "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE", "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER", "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" }; @@ -8818,6 +8976,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, } if (omp_clauses->num_threads) resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS"); + if (omp_clauses->dyn_groupprivate) + resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate, + "DYN_GROUPPRIVATE"); if (omp_clauses->chunk_size) { gfc_expr *expr = omp_clauses->chunk_size; @@ -8902,15 +9063,21 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, if (list == OMP_LIST_MAP && n->sym->attr.flavor == FL_PARAMETER) { + /* OpenACC since 3.4 permits for Fortran named constants, but + permits removing then as optimization is not needed and such + ignore them. Likewise below for FIRSTPRIVATE. */ if (openacc) - gfc_error ("Object %qs is not a variable at %L; parameters" - " cannot be and need not be copied", n->sym->name, - &n->where); + gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is " + "ignored as parameters need not be copied", + n->sym->name, &n->where); else gfc_error ("Object %qs is not a variable at %L; parameters" " cannot be and need not be mapped", n->sym->name, &n->where); } + else if (openacc && n->sym->attr.flavor == FL_PARAMETER) + gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored" + " as it is a parameter", n->sym->name, &n->where); else if (list != OMP_LIST_USES_ALLOCATORS) gfc_error ("Object %qs is not a variable at %L", n->sym->name, &n->where); @@ -9688,22 +9855,6 @@ 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 (!openacc - && list == OMP_LIST_MAP - && n->sym->ts.type == BT_DERIVED - && n->sym->ts.u.derived->attr.alloc_comp) - gfc_error ("List item %qs with allocatable components is not " - "permitted in map clause at %L", n->sym->name, - &n->where); - if (!openacc - && (list == OMP_LIST_MAP - || list == OMP_LIST_FROM - || list == OMP_LIST_TO) - && ((n->expr && n->expr->ts.type == BT_CLASS) - || (!n->expr && n->sym->ts.type == BT_CLASS))) - gfc_warning (OPT_Wopenmp, - "Mapping polymorphic list item at %L is " - "unspecified behavior", &n->where); if (list == OMP_LIST_MAP && !openacc) switch (code->op) { @@ -10015,9 +10166,11 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n->sym->name, name, &n->where); if (!openacc - && list == OMP_LIST_FIRSTPRIVATE - && ((n->expr && n->expr->ts.type == BT_CLASS) - || (!n->expr && n->sym->ts.type == BT_CLASS))) + && (list == OMP_LIST_PRIVATE + || list == OMP_LIST_FIRSTPRIVATE) + && ((n->sym->ts.type == BT_DERIVED + && n->sym->ts.u.derived->attr.alloc_comp) + || n->sym->ts.type == BT_CLASS)) switch (code->op) { case EXEC_OMP_TARGET: @@ -10032,9 +10185,19 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: case EXEC_OMP_TARGET_TEAMS_LOOP: - gfc_warning (OPT_Wopenmp, - "FIRSTPRIVATE with polymorphic list item at " - "%L is unspecified behavior", &n->where); + if (n->sym->ts.type == BT_DERIVED + && n->sym->ts.u.derived->attr.alloc_comp) + gfc_error ("Sorry, list item %qs at %L with allocatable" + " components is not yet supported in %s " + "clause", n->sym->name, &n->where, + list == OMP_LIST_PRIVATE ? "PRIVATE" + : "FIRSTPRIVATE"); + else + gfc_error ("Polymorphic list item %qs at %L in %s " + "clause has unspecified behavior and " + "unsupported", n->sym->name, &n->where, + list == OMP_LIST_PRIVATE ? "PRIVATE" + : "FIRSTPRIVATE"); break; default: break; @@ -11427,82 +11590,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 @@ -11518,7 +11609,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; } @@ -12270,7 +12368,8 @@ resolve_omp_do (gfc_code *code) name, i, &code->loc); goto fail; } - else if (next != do_code->block->next || next->next) + else if (next != do_code->block->next + || (next->next && next->next->op != EXEC_CONTINUE)) /* Imperfectly nested loop found. */ { /* Only diagnose violation of imperfect nesting constraints once. */ @@ -12321,16 +12420,166 @@ 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 ("%<score%> 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 ("%<score%> argument must be non-negative at %L", + &os->score->where); + gfc_free_expr (os->score); + os->score = nullptr; + } + } + + if (os->code == OMP_TRAIT_INVALID) + break; + 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), omp_invalid_device (-4), + and omp_default_device (-5). */ + 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 + && mpz_cmp_si (otp->expr->value.integer, -5) != 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) { gfc_omp_variant *variant = code->ext.omp_variants; + gfc_omp_variant *prev_variant = variant; 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; + gfc_omp_variant *tmp = variant; + if (variant == code->ext.omp_variants) + variant = prev_variant = code->ext.omp_variants = variant->next; + else + variant = prev_variant->next = variant->next; + gfc_free_omp_set_selector_list (tmp->selectors); + free (tmp); + } + else + { + prev_variant = variant; + 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; } } @@ -12767,9 +13016,21 @@ gfc_resolve_oacc_declare (gfc_namespace *ns) && (n->sym->attr.flavor != FL_PROCEDURE || n->sym->result != n->sym)) { - gfc_error ("Object %qs is not a variable at %L", - n->sym->name, &oc->loc); - continue; + if (n->sym->attr.flavor != FL_PARAMETER) + { + gfc_error ("Object %qs is not a variable at %L", + n->sym->name, &oc->loc); + continue; + } + /* Note that OpenACC 3.4 permits name constants, but the + implementation is permitted to ignore the clause; + as semantically, device_resident kind of makes sense + (and the wording with it is a bit odd), the warning + is suppressed. */ + if (list != OMP_LIST_DEVICE_RESIDENT) + gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as" + " parameters need not be copied", n->sym->name, + &oc->loc); } if (n->expr && n->expr->ref->type == REF_ARRAY) @@ -13095,6 +13356,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) { |