https://gcc.gnu.org/g:26d41e245dbba3e2267c0bd432f31c6d1fb81361
commit r16-5633-g26d41e245dbba3e2267c0bd432f31c6d1fb81361 Author: Tobias Burnus <[email protected]> Date: Wed Nov 26 21:47:18 2025 +0100 OpenMP/Fortran: 'declare target' fix + parse 'local' clause; parse groupprivate Declare target's 'link' clause disallows 'nohost'; check for it. Additionally, some other cleanups have been done. The 'local' clause to 'declare target' is now supported in the FE, but a 'sorry, unimplemented' is printed at TREE generation time. This commit also adds the 'groupprivate' directive, which implies 'declare target' with the 'local' clause. And for completeness also the 'dyn_groupprivate' clause to 'target'. However, all those new features will eventually print 'sorry, unimplemented' for now. gcc/fortran/ChangeLog: * dump-parse-tree.cc (show_attr): Handle OpenMP's 'local' clause and the 'groupprivate' directive. (show_omp_clauses): Handle dyn_groupprivate. * frontend-passes.cc (gfc_code_walker): Walk dyn_groupprivate. * gfortran.h (enum gfc_statement): Add ST_OMP_GROUPPRIVATE. (enum gfc_omp_fallback, gfc_add_omp_groupprivate, gfc_add_omp_declare_target_local): New. * match.h (gfc_match_omp_groupprivate): New. * module.cc (enum ab_attribute, mio_symbol_attribute, load_commons, write_common_0): Handle 'groupprivate' + declare target's 'local'. * openmp.cc (gfc_omp_directives): Add 'groupprivate'. (gfc_free_omp_clauses): Free dyn_groupprivate. (enum omp_mask2): Add OMP_CLAUSE_LOCAL and OMP_CLAUSE_DYN_GROUPPRIVATE. (gfc_match_omp_clauses): Match them. (OMP_TARGET_CLAUSES): Add OMP_CLAUSE_DYN_GROUPPRIVATE. (OMP_DECLARE_TARGET_CLAUSES): Add OMP_CLAUSE_LOCAL. (gfc_match_omp_declare_target): Handle groupprivate + fixes. (gfc_match_omp_threadprivate): Code move to and calling now ... (gfc_match_omp_thread_group_private): ... this new function. Also handle groupprivate. (gfc_match_omp_groupprivate): New. (resolve_omp_clauses): Resolve dyn_groupprivate. * parse.cc (decode_omp_directive): Match groupprivate. (case_omp_decl, parse_spec, gfc_ascii_statement): Handle it. * resolve.cc (resolve_symbol): Handle groupprivate. * symbol.cc (gfc_check_conflict, gfc_copy_attr): Handle 'local' and 'groupprivate'. (gfc_add_omp_groupprivate, gfc_add_omp_declare_target_local): New. * trans-common.cc (build_common_decl, accumulate_equivalence_attributes): Print 'sorry' for groupprivate and declare target's local. * trans-decl.cc (add_attributes_to_decl): Likewise.. * trans-openmp.cc (gfc_trans_omp_clauses): Print 'sorry' for dyn_groupprivate. (fallback): Process declare target with link/local as done for 'enter'. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/crayptr2.f90: Move dg-error line. * gfortran.dg/gomp/declare-target-2.f90: Extend. * gfortran.dg/gomp/declare-target-4.f90: Update comment, enable one test. * gfortran.dg/gomp/declare-target-5.f90: Update dg- wording, add new test. * gfortran.dg/gomp/declare-target-indirect-2.f90: Expect 'device_type(any)' in scan-tree-dump. * gfortran.dg/gomp/declare-target-6.f90: New test. * gfortran.dg/gomp/dyn_groupprivate-1.f90: New test. * gfortran.dg/gomp/dyn_groupprivate-2.f90: New test. * gfortran.dg/gomp/groupprivate-1.f90: New test. * gfortran.dg/gomp/groupprivate-2.f90: New test. * gfortran.dg/gomp/groupprivate-3.f90: New test. * gfortran.dg/gomp/groupprivate-4.f90: New test. * gfortran.dg/gomp/groupprivate-5.f90: New test. * gfortran.dg/gomp/groupprivate-6.f90: New test. Diff: --- gcc/fortran/dump-parse-tree.cc | 18 ++ gcc/fortran/frontend-passes.cc | 1 + gcc/fortran/gfortran.h | 19 ++ gcc/fortran/match.h | 1 + gcc/fortran/module.cc | 20 +- gcc/fortran/openmp.cc | 359 ++++++++++++++++----- gcc/fortran/parse.cc | 10 +- gcc/fortran/resolve.cc | 19 +- gcc/fortran/symbol.cc | 64 +++- gcc/fortran/trans-common.cc | 31 +- gcc/fortran/trans-decl.cc | 26 +- gcc/fortran/trans-openmp.cc | 23 +- gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 | 4 +- .../gfortran.dg/gomp/declare-target-2.f90 | 4 + .../gfortran.dg/gomp/declare-target-4.f90 | 9 +- .../gfortran.dg/gomp/declare-target-5.f90 | 37 +-- .../gfortran.dg/gomp/declare-target-6.f90 | 15 + .../gfortran.dg/gomp/declare-target-indirect-2.f90 | 4 +- .../gfortran.dg/gomp/dyn_groupprivate-1.f90 | 20 ++ .../gfortran.dg/gomp/dyn_groupprivate-2.f90 | 23 ++ gcc/testsuite/gfortran.dg/gomp/groupprivate-1.f90 | 23 ++ gcc/testsuite/gfortran.dg/gomp/groupprivate-2.f90 | 37 +++ gcc/testsuite/gfortran.dg/gomp/groupprivate-3.f90 | 16 + gcc/testsuite/gfortran.dg/gomp/groupprivate-4.f90 | 25 ++ gcc/testsuite/gfortran.dg/gomp/groupprivate-5.f90 | 58 ++++ gcc/testsuite/gfortran.dg/gomp/groupprivate-6.f90 | 34 ++ 26 files changed, 778 insertions(+), 122 deletions(-) diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index eda0659d6e23..2a4ebb0fa0f9 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -843,6 +843,8 @@ show_attr (symbol_attribute *attr, const char * module) fputs (" VALUE", dumpfile); if (attr->volatile_) fputs (" VOLATILE", dumpfile); + if (attr->omp_groupprivate) + fputs (" GROUPPRIVATE", dumpfile); if (attr->threadprivate) fputs (" THREADPRIVATE", dumpfile); if (attr->temporary) @@ -938,6 +940,8 @@ show_attr (symbol_attribute *attr, const char * module) fputs (" OMP-DECLARE-TARGET", dumpfile); if (attr->omp_declare_target_link) fputs (" OMP-DECLARE-TARGET-LINK", dumpfile); + if (attr->omp_declare_target_local) + fputs (" OMP-DECLARE-TARGET-LOCAL", dumpfile); if (attr->omp_declare_target_indirect) fputs (" OMP-DECLARE-TARGET-INDIRECT", dumpfile); if (attr->omp_device_type == OMP_DEVICE_TYPE_HOST) @@ -2211,6 +2215,20 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) fputs (" DEPEND(source)", dumpfile); if (omp_clauses->doacross_source) fputs (" DOACROSS(source:)", dumpfile); + if (omp_clauses->dyn_groupprivate) + { + fputs (" DYN_GROUPPRIVATE(", dumpfile); + if (omp_clauses->fallback != OMP_FALLBACK_NONE) + fputs ("FALLBACK(", dumpfile); + if (omp_clauses->fallback == OMP_FALLBACK_ABORT) + fputs ("ABORT):", dumpfile); + else if (omp_clauses->fallback == OMP_FALLBACK_DEFAULT_MEM) + fputs ("DEFAULT_MEM):", dumpfile); + else if (omp_clauses->fallback == OMP_FALLBACK_NULL) + fputs ("NULL):", dumpfile); + show_expr (omp_clauses->dyn_groupprivate); + fputc (')', dumpfile); + } if (omp_clauses->capture) fputs (" CAPTURE", dumpfile); if (omp_clauses->depobj_update != OMP_DEPEND_UNSET) diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index 595c5095eaf9..b699231e971e 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -5645,6 +5645,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, WALK_SUBEXPR (co->ext.omp_clauses->num_tasks); WALK_SUBEXPR (co->ext.omp_clauses->priority); WALK_SUBEXPR (co->ext.omp_clauses->detach); + WALK_SUBEXPR (co->ext.omp_clauses->dyn_groupprivate); WALK_SUBEXPR (co->ext.omp_clauses->novariants); WALK_SUBEXPR (co->ext.omp_clauses->nocontext); for (idx = 0; idx < ARRAY_SIZE (list_types); idx++) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 2997c0326ca1..72aecfb83794 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -311,6 +311,7 @@ enum gfc_statement ST_OMP_TASKLOOP, ST_OMP_END_TASKLOOP, ST_OMP_SCAN, ST_OMP_DEPOBJ, ST_OMP_TASKLOOP_SIMD, ST_OMP_END_TASKLOOP_SIMD, ST_OMP_ORDERED_DEPEND, ST_OMP_REQUIRES, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, + ST_OMP_GROUPPRIVATE, ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST, ST_EVENT_WAIT, ST_FAIL_IMAGE, ST_FORM_TEAM, ST_CHANGE_TEAM, ST_END_TEAM, ST_SYNC_TEAM, ST_OMP_PARALLEL_MASTER, @@ -1042,8 +1043,10 @@ typedef struct /* Mentioned in OMP DECLARE TARGET. */ unsigned omp_declare_target:1; unsigned omp_declare_target_link:1; + unsigned omp_declare_target_local:1; unsigned omp_declare_target_indirect:1; ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2; + unsigned omp_groupprivate:1; unsigned omp_allocate:1; /* Mentioned in OACC DECLARE. */ @@ -1488,6 +1491,7 @@ enum OMP_LIST_TASK_REDUCTION, OMP_LIST_DEVICE_RESIDENT, OMP_LIST_LINK, + OMP_LIST_LOCAL, OMP_LIST_USE_DEVICE, OMP_LIST_CACHE, OMP_LIST_IS_DEVICE_PTR, @@ -1614,6 +1618,14 @@ enum gfc_omp_bind_type OMP_BIND_THREAD }; +enum gfc_omp_fallback +{ + OMP_FALLBACK_NONE, + OMP_FALLBACK_ABORT, + OMP_FALLBACK_DEFAULT_MEM, + OMP_FALLBACK_NULL +}; + typedef struct gfc_omp_assumptions { int n_absent, n_contains; @@ -1649,6 +1661,7 @@ typedef struct gfc_omp_clauses struct gfc_expr *detach; struct gfc_expr *depobj; struct gfc_expr *dist_chunk_size; + struct gfc_expr *dyn_groupprivate; struct gfc_expr *message; struct gfc_expr *novariants; struct gfc_expr *nocontext; @@ -1681,6 +1694,7 @@ typedef struct gfc_omp_clauses ENUM_BITFIELD (gfc_omp_at_type) at:2; ENUM_BITFIELD (gfc_omp_severity_type) severity:2; ENUM_BITFIELD (gfc_omp_sched_kind) dist_sched_kind:3; + ENUM_BITFIELD (gfc_omp_fallback) fallback:2; /* OpenACC. */ struct gfc_expr *async_expr; @@ -2118,6 +2132,8 @@ typedef struct gfc_common_head char use_assoc, saved, threadprivate; unsigned char omp_declare_target : 1; unsigned char omp_declare_target_link : 1; + unsigned char omp_declare_target_local : 1; + unsigned char omp_groupprivate : 1; ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2; /* Provide sufficient space to hold "symbol.symbol.eq.1234567890". */ char name[2*GFC_MAX_SYMBOL_LEN + 1 + 14 + 1]; @@ -3717,6 +3733,9 @@ bool gfc_add_threadprivate (symbol_attribute *, const char *, locus *); bool gfc_add_omp_declare_target (symbol_attribute *, const char *, locus *); bool gfc_add_omp_declare_target_link (symbol_attribute *, const char *, locus *); +bool gfc_add_omp_declare_target_local (symbol_attribute *, const char *, + locus *); +bool gfc_add_omp_groupprivate (symbol_attribute *, const char *, locus *); bool gfc_add_target (symbol_attribute *, locus *); bool gfc_add_dummy (symbol_attribute *, const char *, locus *); bool gfc_add_generic (symbol_attribute *, const char *, locus *); diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 410361c4bd1c..314be6baa92e 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -174,6 +174,7 @@ match gfc_match_omp_do_simd (void); match gfc_match_omp_loop (void); match gfc_match_omp_error (void); match gfc_match_omp_flush (void); +match gfc_match_omp_groupprivate (void); match gfc_match_omp_interop (void); match gfc_match_omp_masked (void); match gfc_match_omp_masked_taskloop (void); diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index c489decec8dc..262f72b8e7c3 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -2092,7 +2092,8 @@ enum ab_attribute AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE, AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, - AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, + AB_OMP_DECLARE_TARGET_LINK, AB_OMP_DECLARE_TARGET_LOCAL, + AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, AB_PDT_COMP, AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ, @@ -2102,7 +2103,7 @@ enum ab_attribute AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL, AB_OMP_REQ_MEM_ORDER_ACQUIRE, AB_OMP_REQ_MEM_ORDER_RELEASE, AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST, - AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY + AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY, AB_OMP_GROUPPRIVATE }; static const mstring attr_bits[] = @@ -2166,6 +2167,8 @@ static const mstring attr_bits[] = minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT), minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK), minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK), + minit ("OMP_DECLARE_TARGET_LOCAL", AB_OMP_DECLARE_TARGET_LOCAL), + minit ("OMP_GROUPPRIVATE", AB_OMP_GROUPPRIVATE), minit ("PDT_KIND", AB_PDT_KIND), minit ("PDT_LEN", AB_PDT_LEN), minit ("PDT_TYPE", AB_PDT_TYPE), @@ -2399,6 +2402,10 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits); if (attr->omp_declare_target_link) MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits); + if (attr->omp_declare_target_local) + MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LOCAL, attr_bits); + if (attr->omp_groupprivate) + MIO_NAME (ab_attribute) (AB_OMP_GROUPPRIVATE, attr_bits); if (attr->pdt_kind) MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits); if (attr->pdt_len) @@ -2654,6 +2661,12 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_OMP_DECLARE_TARGET_LINK: attr->omp_declare_target_link = 1; break; + case AB_OMP_DECLARE_TARGET_LOCAL: + attr->omp_declare_target_local = 1; + break; + case AB_OMP_GROUPPRIVATE: + attr->omp_groupprivate = 1; + break; case AB_ARRAY_OUTER_DEPENDENCY: attr->array_outer_dependency =1; break; @@ -5268,6 +5281,8 @@ load_commons (void) if (flags & 2) p->threadprivate = 1; p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3); + if ((flags >> 4) & 1) + p->omp_groupprivate = 1; p->use_assoc = 1; /* Get whether this was a bind(c) common or not. */ @@ -6191,6 +6206,7 @@ write_common_0 (gfc_symtree *st, bool this_module) if (p->threadprivate) flags |= 2; flags |= p->omp_device_type << 2; + flags |= p->omp_groupprivate << 4; mio_integer (&flags); /* Write out whether the common block is bind(c) or not. */ diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 81d624b7b54a..f047028187f6 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -84,6 +84,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { /* {"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}, @@ -195,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); @@ -1172,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 }; @@ -3096,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)) @@ -3567,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) @@ -5064,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) @@ -5092,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 \ @@ -6113,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) @@ -6122,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) @@ -6130,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", @@ -7108,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; @@ -7150,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: @@ -7165,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; @@ -7182,6 +7358,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) { @@ -8554,7 +8744,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" }; @@ -8761,6 +8951,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_positive_int_expr (omp_clauses->dyn_groupprivate, + "DYN_GROUPPRIVATE"); if (omp_clauses->chunk_size) { gfc_expr *expr = omp_clauses->chunk_size; diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index e4d65200f3ab..3fd45b9518ec 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -1195,6 +1195,9 @@ decode_omp_directive (void) case 'f': matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); break; + case 'g': + matchdo ("groupprivate", gfc_match_omp_groupprivate, ST_OMP_GROUPPRIVATE); + break; case 'i': matcho ("interop", gfc_match_omp_interop, ST_OMP_INTEROP); break; @@ -1990,7 +1993,8 @@ next_statement (void) #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \ case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \ - case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE + case ST_OMP_REQUIRES: case ST_OMP_GROUPPRIVATE: \ + case ST_OACC_ROUTINE: case ST_OACC_DECLARE /* OpenMP statements that are followed by a structured block. */ @@ -2909,6 +2913,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel) case ST_OMP_FLUSH: p = "!$OMP FLUSH"; break; + case ST_OMP_GROUPPRIVATE: + p = "!$OMP GROUPPRIVATE"; + break; case ST_OMP_INTEROP: p = "!$OMP INTEROP"; break; @@ -4437,6 +4444,7 @@ loop: case ST_EQUIVALENCE: case ST_IMPLICIT: case ST_IMPLICIT_NONE: + case ST_OMP_GROUPPRIVATE: case ST_OMP_THREADPRIVATE: case ST_PARAMETER: case ST_STRUCTURE_DECL: diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index e4e7751dbf04..9f3ce1d2ad61 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -18714,17 +18714,30 @@ skip_interfaces: } /* Check threadprivate restrictions. */ - if (sym->attr.threadprivate + if ((sym->attr.threadprivate || sym->attr.omp_groupprivate) && !(sym->attr.save || sym->attr.data || sym->attr.in_common) && !(sym->ns->save_all && !sym->attr.automatic) && sym->module == NULL && (sym->ns->proc_name == NULL || (sym->ns->proc_name->attr.flavor != FL_MODULE && !sym->ns->proc_name->attr.is_main_program))) - gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + { + if (sym->attr.threadprivate) + gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + else + gfc_error ("OpenMP groupprivate variable %qs at %L must have the SAVE " + "attribute", sym->name, &sym->declared_at); + } + + if (sym->attr.omp_groupprivate && sym->value) + gfc_error ("!$OMP GROUPPRIVATE variable %qs at %L must not have an " + "initializer", sym->name, &sym->declared_at); /* Check omp declare target restrictions. */ - if (sym->attr.omp_declare_target + if ((sym->attr.omp_declare_target + || sym->attr.omp_declare_target_link + || sym->attr.omp_declare_target_local) + && !sym->attr.omp_groupprivate /* already warned. */ && sym->attr.flavor == FL_VARIABLE && !sym->attr.save && !(sym->ns->save_all && !sym->attr.automatic) diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index becaaf394509..62925c028e6c 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -458,8 +458,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC", *pdt_len = "LEN", *pdt_kind = "KIND"; static const char *threadprivate = "THREADPRIVATE"; + static const char *omp_groupprivate = "OpenMP GROUPPRIVATE"; static const char *omp_declare_target = "OMP DECLARE TARGET"; static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK"; + static const char *omp_declare_target_local = "OMP DECLARE TARGET LOCAL"; static const char *oacc_declare_copyin = "OACC DECLARE COPYIN"; static const char *oacc_declare_create = "OACC DECLARE CREATE"; static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR"; @@ -553,8 +555,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (dummy, entry); conf (dummy, intrinsic); conf (dummy, threadprivate); + conf (dummy, omp_groupprivate); conf (dummy, omp_declare_target); conf (dummy, omp_declare_target_link); + conf (dummy, omp_declare_target_local); conf (pointer, target); conf (pointer, intrinsic); conf (pointer, elemental); @@ -604,8 +608,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (in_equivalence, entry); conf (in_equivalence, allocatable); conf (in_equivalence, threadprivate); + conf (in_equivalence, omp_groupprivate); conf (in_equivalence, omp_declare_target); conf (in_equivalence, omp_declare_target_link); + conf (in_equivalence, omp_declare_target_local); conf (in_equivalence, oacc_declare_create); conf (in_equivalence, oacc_declare_copyin); conf (in_equivalence, oacc_declare_deviceptr); @@ -616,6 +622,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (entry, result); conf (generic, result); conf (generic, omp_declare_target); + conf (generic, omp_declare_target_local); conf (generic, omp_declare_target_link); conf (function, subroutine); @@ -661,8 +668,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointee, in_common); conf (cray_pointee, in_equivalence); conf (cray_pointee, threadprivate); + conf (cray_pointee, omp_groupprivate); conf (cray_pointee, omp_declare_target); conf (cray_pointee, omp_declare_target_link); + conf (cray_pointee, omp_declare_target_local); conf (cray_pointee, oacc_declare_create); conf (cray_pointee, oacc_declare_copyin); conf (cray_pointee, oacc_declare_deviceptr); @@ -720,9 +729,11 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (proc_pointer, abstract) conf (proc_pointer, omp_declare_target) + conf (proc_pointer, omp_declare_target_local) conf (proc_pointer, omp_declare_target_link) conf (entry, omp_declare_target) + conf (entry, omp_declare_target_local) conf (entry, omp_declare_target_link) conf (entry, oacc_declare_create) conf (entry, oacc_declare_copyin) @@ -782,8 +793,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (omp_declare_target); conf2 (omp_declare_target_link); + conf2 (omp_declare_target_local); conf2 (oacc_declare_create); conf2 (oacc_declare_copyin); conf2 (oacc_declare_deviceptr); @@ -828,7 +841,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (dimension); conf2 (function); if (!attr->proc_pointer) - conf2 (threadprivate); + { + conf2 (threadprivate); + conf2 (omp_groupprivate); + } } /* Procedure pointers in COMMON blocks are allowed in F03, @@ -836,6 +852,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008)) conf2 (in_common); + conf2 (omp_declare_target_local); conf2 (omp_declare_target_link); switch (attr->proc) @@ -852,6 +869,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) case PROC_DUMMY: conf2 (result); conf2 (threadprivate); + conf2 (omp_groupprivate); break; default: @@ -872,8 +890,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (result); conf2 (omp_declare_target); + conf2 (omp_declare_target_local); conf2 (omp_declare_target_link); conf2 (oacc_declare_create); conf2 (oacc_declare_copyin); @@ -905,6 +925,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (volatile_); conf2 (asynchronous); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (value); conf2 (codimension); conf2 (result); @@ -1406,6 +1427,25 @@ gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) } +bool +gfc_add_omp_groupprivate (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_groupprivate) + { + duplicate_attr ("OpenMP GROUPPRIVATE", where); + return false; + } + + attr->omp_groupprivate = true; + return gfc_check_conflict (attr, name, where); +} + + bool gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) { @@ -1456,6 +1496,22 @@ gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name, } +bool +gfc_add_omp_declare_target_local (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_declare_target_local) + return true; + + attr->omp_declare_target_local = 1; + return gfc_check_conflict (attr, name, where); +} + + bool gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name, locus *where) @@ -2110,6 +2166,9 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) goto fail; if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where)) goto fail; + if (src->omp_groupprivate + && !gfc_add_omp_groupprivate (dest, NULL, where)) + goto fail; if (src->threadprivate && !gfc_add_threadprivate (dest, NULL, where)) goto fail; @@ -2119,6 +2178,9 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) if (src->omp_declare_target_link && !gfc_add_omp_declare_target_link (dest, NULL, where)) goto fail; + if (src->omp_declare_target_local + && !gfc_add_omp_declare_target_local (dest, NULL, where)) + goto fail; if (src->oacc_declare_create && !gfc_add_oacc_declare_create (dest, NULL, where)) goto fail; diff --git a/gcc/fortran/trans-common.cc b/gcc/fortran/trans-common.cc index 135d3047a154..6439a1530c63 100644 --- a/gcc/fortran/trans-common.cc +++ b/gcc/fortran/trans-common.cc @@ -488,6 +488,27 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) } omp_clauses = c; } + /* Also check trans-decl.cc when updating/removing the following; + also update f95.c's gfc_gnu_attributes. + For the warning, see also OpenMP spec issue 4663. */ + if (com->omp_groupprivate && com->threadprivate) + { + /* Unset this flag; implicit 'declare target local(...)' remains. */ + com->omp_groupprivate = 0; + gfc_warning (OPT_Wopenmp, + "Ignoring the %<groupprivate%> attribute for " + "%<threadprivate%> common block %</%s/%> declared at %L", + com->name, &com->where); + } + if (com->omp_groupprivate) + gfc_error ("Sorry, OMP GROUPPRIVATE not implemented, used by common " + "block %</%s/%> declared at %L", com->name, &com->where); + else if (com->omp_declare_target_local) + /* Use 'else if' as groupprivate implies 'local'. */ + gfc_error ("Sorry, OMP DECLARE TARGET with LOCAL clause not implemented" + ", used by common block %</%s/%> declared at %L", + com->name, &com->where); + if (com->omp_declare_target_link) DECL_ATTRIBUTES (decl) = tree_cons (get_identifier ("omp declare target link"), @@ -497,10 +518,12 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) = tree_cons (get_identifier ("omp declare target"), omp_clauses, DECL_ATTRIBUTES (decl)); - if (com->omp_declare_target_link || com->omp_declare_target) + if (com->omp_declare_target_link || com->omp_declare_target + /* FIXME: || com->omp_declare_target_local */) { - /* Add to offload_vars; get_create does so for omp_declare_target, - omp_declare_target_link requires manual work. */ + /* Add to offload_vars; get_create does so for omp_declare_target + and omp_declare_target_local, omp_declare_target_link requires + manual work. */ gcc_assert (symtab_node::get (decl) == 0); symtab_node *node = symtab_node::get_create (decl); if (node != NULL && com->omp_declare_target_link) @@ -1045,8 +1068,10 @@ accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e) dummy_symbol->generic |= attr.generic; dummy_symbol->automatic |= attr.automatic; dummy_symbol->threadprivate |= attr.threadprivate; + dummy_symbol->omp_groupprivate |= attr.omp_groupprivate; dummy_symbol->omp_declare_target |= attr.omp_declare_target; dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link; + dummy_symbol->omp_declare_target_local |= attr.omp_declare_target_local; dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin; dummy_symbol->oacc_declare_create |= attr.oacc_declare_create; dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr; diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 419de2c63cf2..2164b37e4cb2 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -1560,7 +1560,11 @@ add_attributes_to_decl (tree *decl_p, const gfc_symbol *sym) clauses = c; } - if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET) + /* FIXME: 'declare_target_link' permits both any and host, but + will fail if one sets OMP_CLAUSE_DEVICE_TYPE_KIND. */ + if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && !sym_attr.omp_declare_target_link + && !sym_attr.omp_declare_target_indirect /* implies 'any' */) { tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); switch (sym_attr.omp_device_type) @@ -1581,6 +1585,26 @@ add_attributes_to_decl (tree *decl_p, const gfc_symbol *sym) clauses = c; } + /* Also check trans-common.cc when updating/removing the following; + also update f95.c's gfc_gnu_attributes. + For the warning, see also OpenMP spec issue 4663. */ + if (sym_attr.omp_groupprivate && sym_attr.threadprivate) + { + /* Unset this flag; implicit 'declare target local(...)' remains. */ + sym_attr.omp_groupprivate = 0; + gfc_warning (OPT_Wopenmp, + "Ignoring the %<groupprivate%> attribute for " + "%<threadprivate%> variable %qs declared at %L", + sym->name, &sym->declared_at); + } + if (sym_attr.omp_groupprivate) + gfc_error ("Sorry, OMP GROUPPRIVATE not implemented, " + "used by %qs declared at %L", sym->name, &sym->declared_at); + else if (sym_attr.omp_declare_target_local) + /* Use 'else if' as groupprivate implies 'local'. */ + gfc_error ("Sorry, OMP DECLARE TARGET with LOCAL clause not implemented, " + "used by %qs declared at %L", sym->name, &sym->declared_at); + bool has_declare = true; if (sym_attr.omp_declare_target_link || sym_attr.oacc_declare_link) diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 69a70d7138cf..c0a8ed927d9d 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -4180,7 +4180,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree type = TREE_TYPE (decl); if (n->sym->ts.type == BT_CHARACTER && n->sym->ts.deferred - && n->sym->attr.omp_declare_target + && (n->sym->attr.omp_declare_target + || n->sym->attr.omp_declare_target_link + || n->sym->attr.omp_declare_target_local) && (always_modifier || n->sym->attr.pointer) && op != EXEC_OMP_TARGET_EXIT_DATA && n->u.map.op != OMP_MAP_DELETE @@ -5263,6 +5265,25 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } + if (clauses->dyn_groupprivate) + { + sorry_at (gfc_get_location (&where), "%<dyn_groupprivate%> clause"); +#if 0 /* FIXME: Handle it, including 'fallback(abort/default_mem/null)' */ + tree dyn_groupprivate; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->dyn_groupprivate); + gfc_add_block_to_block (block, &se.pre); + dyn_groupprivate = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), + OMP_CLAUSE_DYN_GROUPPRIVATE); + OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); +#endif + } + chunk_size = NULL_TREE; if (clauses->chunk_size) { diff --git a/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 b/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 index 476d7b9e771c..06ac60424e9a 100644 --- a/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 @@ -3,7 +3,7 @@ ! { dg-require-effective-target tls } module crayptr2 - integer :: e ! { dg-error "CRAY POINTEE attribute conflicts with THREADPRIVATE" } + integer :: e pointer (ip5, e) ! The standard is not very clear about this. @@ -12,6 +12,6 @@ module crayptr2 ! be if they are module variables. But threadprivate pointees don't ! make any sense anyway. -!$omp threadprivate (e) +!$omp threadprivate (e) ! { dg-error "CRAY POINTEE attribute conflicts with THREADPRIVATE" } end module crayptr2 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-target-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-target-2.f90 index 93075fb147ea..b4f1e52f7251 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-target-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-2.f90 @@ -24,7 +24,11 @@ module declare_target_2 end interface end subroutine bar + !$omp declare target enter (q) ! { dg-error "isn.t SAVEd" } + !$omp declare target link (r) ! { dg-error "isn.t SAVEd" } + !$omp declare target local (s) ! { dg-error "isn.t SAVEd" } !$omp declare target link (baz) ! { dg-error "isn.t SAVEd" } + integer :: q, r, s call baz ! { dg-error "attribute conflicts" } end subroutine subroutine foo ! { dg-error "attribute conflicts" } diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-target-4.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-target-4.f90 index 55534d8fe998..296c0dbd869d 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-target-4.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-4.f90 @@ -42,15 +42,14 @@ module mymod !$omp declare target to(a) device_type(nohost) !$omp declare target to(b) device_type(host) !$omp declare target to(c) device_type(any) - ! Fails in ME with "Error: wrong number of arguments specified for 'omp declare target link' attribute" - ! !$omp declare target link(e) device_type(nohost) - ! !$omp declare target link(f) device_type(host) - ! !$omp declare target link(g) device_type(any) + ! !$omp declare target link(e) device_type(nohost) ! -> invalid: only 'any' is permitted + ! !$omp declare target link(f) device_type(host) ! -> invalid: only 'any' is permitted + !$omp declare target link(g) device_type(any) !$omp declare target to(/block1/) device_type(nohost) !$omp declare target to(/block2/) device_type(host) !$omp declare target to(/block3/) device_type(any) - !$omp declare target link(/block4/) device_type(nohost) + ! !$omp declare target link(/block4/) device_type(nohost) ! -> invalid, link requires host or any !$omp declare target link(/block5/) device_type(host) !$omp declare target link(/block6/) device_type(any) contains diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-target-5.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-target-5.f90 index 76687d476d5b..0dacb8952295 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-target-5.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-5.f90 @@ -4,9 +4,15 @@ end subroutine bar() !$omp declare target to(bar) device_type(nohost) - !$omp declare target to(bar) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target to(bar) device_type(host) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'nohost'" } end +module invalid + implicit none + integer :: d + !$omp declare target link(d) device_type(nohost) ! { dg-error "set with NOHOST specified may not appear in a LINK clause" } +end module + module mymod_one implicit none integer :: a, b, c, d, e ,f @@ -17,24 +23,21 @@ module mymod_one !$omp declare target to(a) device_type(nohost) !$omp declare target to(b) device_type(any) !$omp declare target to(c) device_type(host) - !$omp declare target link(d) device_type(nohost) !$omp declare target link(e) device_type(any) !$omp declare target link(f) device_type(host) !$omp declare target to(c) device_type(host) - !$omp declare target link(d) device_type(nohost) end module module mtest use mymod_one ! { dg-error "Cannot change attributes of USE-associated symbol" } implicit none - !$omp declare target to(a) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target to(b) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target to(c) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(d) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(e) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(f) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target to(a) device_type(any) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'nohost'" } + !$omp declare target to(b) device_type(host) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'any'" } + !$omp declare target to(c) device_type(nohost) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp declare target link(e) device_type(host) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'any'" } + !$omp declare target link(f) device_type(any) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } end module module mymod @@ -47,17 +50,15 @@ module mymod !$omp declare target to(a) device_type(nohost) !$omp declare target to(b) device_type(any) !$omp declare target to(c) device_type(host) - !$omp declare target link(d) device_type(nohost) + !$omp declare target link(d) device_type(nohost) ! { dg-error "set with NOHOST specified may not appear in a LINK clause" } !$omp declare target link(e) device_type(any) !$omp declare target link(f) device_type(host) !$omp declare target to(c) device_type(host) - !$omp declare target link(d) device_type(nohost) - - !$omp declare target to(a) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target to(b) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target to(c) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(d) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(e) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(f) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + + !$omp declare target to(a) device_type(any) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'nohost'" } + !$omp declare target to(b) device_type(host) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'any'" } + !$omp declare target to(c) device_type(nohost) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp declare target link(e) device_type(host) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'any'" } + !$omp declare target link(f) device_type(any) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } end diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-target-6.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-target-6.f90 new file mode 100644 index 000000000000..21970e6fbb43 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-6.f90 @@ -0,0 +1,15 @@ +subroutine sub ! { dg-error "SUBROUTINE attribute conflicts with OMP DECLARE TARGET LINK attribute in 'sub'" } + !$omp declare target link(sub) +end subroutine sub + +subroutine sub2 ! { dg-error "SUBROUTINE attribute conflicts with OMP DECLARE TARGET LOCAL attribute in 'sub2'" } + !$omp declare target local(sub2) +end subroutine sub2 + +integer function func() ! { dg-error "PROCEDURE attribute conflicts with OMP DECLARE TARGET LINK attribute in 'func'" } + !$omp declare target link(func) +end + +integer function func2() ! { dg-error "PROCEDURE attribute conflicts with OMP DECLARE TARGET LOCAL attribute in 'func2'" } + !$omp declare target local(func2) +end diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-target-indirect-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-target-indirect-2.f90 index f6b3ae178564..4345c69b74bb 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-target-indirect-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-indirect-2.f90 @@ -11,7 +11,7 @@ contains subroutine sub2 !$omp declare target indirect (.false.) to (sub2) end subroutine - ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target\\\)\\\)\\\n.*\\\nvoid sub2" "gimple" } } + ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target \\(device_type\\(any\\)\\)\\\)\\\)\\\n.*\\\nvoid sub2" "gimple" } } subroutine sub3 !$omp declare target indirect (.true.) to (sub3) @@ -21,5 +21,5 @@ contains subroutine sub4 !$omp declare target indirect (.false.) enter (sub4) end subroutine - ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target\\\)\\\)\\\n.*\\\nvoid sub4" "gimple" } } + ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target \\(device_type\\(any\\)\\)\\\)\\\)\\\n.*\\\nvoid sub4" "gimple" } } end module diff --git a/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-1.f90 b/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-1.f90 new file mode 100644 index 000000000000..2e09febe18c2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-1.f90 @@ -0,0 +1,20 @@ +implicit none + +integer :: N +N = 1024 + +!$omp target dyn_groupprivate(1024) ! { dg-message "sorry, unimplemented: 'dyn_groupprivate' clause" } +!$omp end target + +!$omp target dyn_groupprivate (1024 * N) ! { dg-message "sorry, unimplemented: 'dyn_groupprivate' clause" } +!$omp end target + +!$omp target dyn_groupprivate ( fallback ( abort ) : N) ! { dg-message "sorry, unimplemented: 'dyn_groupprivate' clause" } +!$omp end target + +!$omp target dyn_groupprivate ( fallback ( null ) : N) ! { dg-message "sorry, unimplemented: 'dyn_groupprivate' clause" } +!$omp end target + +!$omp target dyn_groupprivate ( fallback ( default_mem ) : N) ! { dg-message "sorry, unimplemented: 'dyn_groupprivate' clause" } +!$omp end target +end diff --git a/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-2.f90 b/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-2.f90 new file mode 100644 index 000000000000..0a5a644b9f40 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-2.f90 @@ -0,0 +1,23 @@ +implicit none + +integer, parameter :: M = 1024 +integer :: N, A(1) + +N = 1024 + +!$omp target dyn_groupprivate(-123) ! { dg-warning "INTEGER expression of DYN_GROUPPRIVATE clause at .1. must be positive \\\[-Wopenmp\\\]" } +block; end block + +!$omp target dyn_groupprivate (0 * M) ! { dg-warning "INTEGER expression of DYN_GROUPPRIVATE clause at .1. must be positive \\\[-Wopenmp\\\]" } +block; end block + +!$omp target dyn_groupprivate ( fallback ( other ) : N) ! { dg-error "Failed to match clause" } +block; end block + +!$omp target dyn_groupprivate ( A ) ! { dg-error "DYN_GROUPPRIVATE clause at .1. requires a scalar INTEGER expression" } +block; end block + +!$omp target dyn_groupprivate ( 1024. ) ! { dg-error "DYN_GROUPPRIVATE clause at .1. requires a scalar INTEGER expression" } +block; end block + +end diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-1.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-1.f90 new file mode 100644 index 000000000000..f776c0875dd0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-1.f90 @@ -0,0 +1,23 @@ +module m + implicit none + integer :: ii + integer :: x, y(20), z, v, u, k ! { dg-warning "Ignoring the 'groupprivate' attribute for 'threadprivate' variable 'k' declared at .1. \\\[-Wopenmp\\\]" } +! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by 'x' declared at .1." "" { target *-*-* } .-1 } +! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by 'y' declared at .1." "" { target *-*-* } .-2 } +! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by 'z' declared at .1." "" { target *-*-* } .-3 } +! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by 'v' declared at .1." "" { target *-*-* } .-4 } +! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by 'u' declared at .1." "" { target *-*-* } .-5 } +! +! Note:Error different as 'groupprivate' flag is overwritten by 'threadprivate', cf. warning above. +! { dg-error "Sorry, OMP DECLARE TARGET with LOCAL clause not implemented, used by 'k' declared at .1." "" { target *-*-* } .-8 } + !$omp groupprivate(x, z) device_Type( any ) + !$omp declare target local(x) device_type ( any ) + !$omp declare target enter( ii) ,local(y), device_type ( host ) + !$omp groupprivate(y) device_type( host) + !$omp groupprivate(v) device_type (nohost ) + !$omp groupprivate(u) + + ! See also (currently unresolved) OpenMP Specification Issue 4663. + !$omp groupprivate(k) + !$omp threadprivate(k) +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-2.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-2.f90 new file mode 100644 index 000000000000..922d229bf89f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-2.f90 @@ -0,0 +1,37 @@ +module m + implicit none + integer :: ii + integer :: x, y(20), z, v, q, r,o, b2,c + + !$omp groupprivate(x, z, o) device_Type( any ) + !$omp declare target enter(x) device_type ( any ) ! { dg-error "List item 'x' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target to(z) device_type ( any ) ! { dg-error "List item 'z' at .1. not appear in the 'to' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target link(o) device_type ( any ) ! { dg-error "List item 'o' at .1. not appear in the 'link' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target enter( ii) ,local(y,c), link(r), to(q) device_type ( host ) + !$omp groupprivate(r,q) device_type(host) +! { dg-error "List item 'q' at .1. implies OMP DECLARE TARGET with the LOCAL clause, but it has been specified with a different clause before" "" { target *-*-* } .-1 } +! { dg-error "List item 'r' at .1. implies OMP DECLARE TARGET with the LOCAL clause, but it has been specified with a different clause before" "" { target *-*-* } .-2 } + !$omp groupprivate(c) ! { dg-error "List item 'c' at .1. set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp groupprivate(y) device_type( any) ! { dg-error "List item 'y' at .1. set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp groupprivate(v) device_type (nohost ) + !$omp groupprivate(v) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified" } + + !$omp declare target link(b2) device_type(nohost) ! { dg-error "List item 'b2' at .1. set with NOHOST specified may not appear in a LINK clause" } +end module + +subroutine sub() + implicit none + integer, save :: x0,x1,x2,x3,x4 + !$omp groupprivate(x0) + !$omp groupprivate(x1) + !$omp groupprivate(x2) device_type ( any) + !$omp groupprivate(x3) device_type (host ) + !$omp groupprivate(x4) device_type( nohost) + + !$omp declare target(x0) ! { dg-error "List item 'x0' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(any) to(x1) ! { dg-error "List item 'x1' at .1. not appear in the 'to' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(any) enter(x2) ! { dg-error "List item 'x2' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(host) link(x3) ! { dg-error "List item 'x3' at .1. not appear in the 'link' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(host) local(x4) ! { dg-error "List item 'x4' at .1. set in previous OMP GROUPPRIVATE directive to the different DEVICE_TYPE 'nohost'" } + +end diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-3.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-3.f90 new file mode 100644 index 000000000000..d7ccbe292d5e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-3.f90 @@ -0,0 +1,16 @@ +module m +implicit none +integer :: y = 5 ! { dg-error "!.OMP GROUPPRIVATE variable 'y' at .1. must not have an initializer" } +!$omp groupprivate(y) +end + +subroutine sub + integer :: k ! { dg-error "OpenMP groupprivate variable 'k' at .1. must have the SAVE attribute" } + !$omp groupprivate(k) +end + +subroutine sub2 + !$omp groupprivate(q) + integer, save :: q + !$omp groupprivate(q) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified at .1." } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-4.f90 new file mode 100644 index 000000000000..2a3a054483e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-4.f90 @@ -0,0 +1,25 @@ +module m + implicit none + integer :: ii + integer :: x, y(20), z, v, u, k + + common /b_ii/ ii + common /b_x/ x ! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by common block '/b_x/' declared at .1." } + common /b_y/ y ! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by common block '/b_y/' declared at .1." } + common /b_z/ z ! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by common block '/b_z/' declared at .1." } + common /b_v/ v ! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by common block '/b_v/' declared at .1." } + common /b_u/ u ! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by common block '/b_u/' declared at .1." } + common /b_k/ k ! { dg-warning "Ignoring the 'groupprivate' attribute for 'threadprivate' common block '/b_k/' declared at .1. \\\[-Wopenmp\\\]" } +! { dg-error "Sorry, OMP DECLARE TARGET with LOCAL clause not implemented, used by common block '/b_k/' declared at .1." "" { target *-*-* } .-1 } + + !$omp groupprivate(/b_x/, /b_z/) device_Type( any ) + !$omp declare target local(/b_x/) device_type ( any ) + !$omp declare target enter( /b_ii/) ,local(/b_y/), device_type ( host ) + !$omp groupprivate(/b_y/) device_type( host) + !$omp groupprivate(/b_v/) device_type (nohost ) + !$omp groupprivate(/b_u/) + + ! See also (currently unresolved) OpenMP Specification Issue 4663. + !$omp groupprivate(/b_k/) + !$omp threadprivate(/b_k/) +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-5.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-5.f90 new file mode 100644 index 000000000000..c9f89feb4aa5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-5.f90 @@ -0,0 +1,58 @@ +module m + implicit none + integer :: ii + integer :: x, y(20), z, v, q, r,o, b2,c + + common /b_ii/ ii + common /b_x/ x + common /b_y/ y + common /b_z/ z + common /b_v/ v + common /b_q/ q + common /b_r/ r + common /b_o/ o + common /b_b2/ b2 + common /b_c/ c + + !$omp groupprivate(/b_x/, /b_z/, /b_o/) device_Type( any ) + !$omp declare target enter(/b_x/) device_type ( any ) ! { dg-error "Common block '/b_x/' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target to(/b_z/) device_type ( any ) ! { dg-error "Common block '/b_z/' at .1. not appear in the 'to' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target link(/b_o/) device_type ( any ) ! { dg-error "Common block '/b_o/' at .1. not appear in the 'link' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target enter( / b_ii / ) ,local(/b_y/ , /b_c/), link(/b_r/), to(/b_q/) device_type ( host ) + !$omp groupprivate( /b_r/ ,/b_q/) device_type(host) +! { dg-error "List item '/b_r/' at .1. implies OMP DECLARE TARGET with the LOCAL clause, but it has been specified with a different clause before" "" { target *-*-* } .-1 } +! { dg-error "List item '/b_q/' at .1. implies OMP DECLARE TARGET with the LOCAL clause, but it has been specified with a different clause before" "" { target *-*-* } .-2 } + !$omp groupprivate(/b_c/) ! { dg-error "List item 'b_c' at .1. set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp groupprivate(/b_y/) device_type( any) ! { dg-error "List item 'b_y' at .1. set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp groupprivate(/b_v/) device_type (nohost ) + !$omp groupprivate(/b_v/) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified at .1." } + + !$omp declare target link(/b_b2/) device_type(nohost) ! { dg-error "Common block '/b_b2/' at .1. set with NOHOST specified may not appear in a LINK clause" } +end module + +subroutine sub() + implicit none + integer, save :: xx + integer :: x0,x1,x2,x3,x4 + + common /b_xx/ xx ! { dg-error "COMMON attribute conflicts with SAVE attribute in 'xx' at .1." } + common /b_x0/ x0 + common /b_x1/ x1 + common /b_x2/ x2 + common /b_x3/ x3 + common /b_x4/ x4 + + !$omp groupprivate(/b_xx/) ! { dg-error "COMMON attribute conflicts with SAVE attribute in 'xx' at .1." } + !$omp groupprivate(/b_x0/) + !$omp groupprivate(/b_x1/) + !$omp groupprivate(/b_x2/) device_type ( any) + !$omp groupprivate(/b_x3/) device_type (host ) + !$omp groupprivate(/b_x4/) device_type( nohost) + + !$omp declare target(/b_x0/) ! { dg-error "Common block '/b_x0/' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(any) to(/b_x1/) ! { dg-error "Common block '/b_x1/' at .1. not appear in the 'to' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(any) enter(/b_x2/) ! { dg-error "Common block '/b_x2/' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(host) link(/b_x3/) ! { dg-error "Common block '/b_x3/' at .1. not appear in the 'link' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(host) local(/b_x4/) ! { dg-error "Common block '/b_x4/' at .1. set in previous OMP GROUPPRIVATE directive to the different DEVICE_TYPE 'nohost'" } + +end diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-6.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-6.f90 new file mode 100644 index 000000000000..6ae5b3dc59b1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-6.f90 @@ -0,0 +1,34 @@ +module m +implicit none +integer :: y = 5 ! { dg-error "!.OMP GROUPPRIVATE variable 'y' at .1. must not have an initializer" } +common /b_y/ y +!$omp groupprivate(/b_y/) +end + +subroutine sub + integer, save :: k + common /b_k/ k ! { dg-error "COMMON attribute conflicts with SAVE attribute in 'k' at .1." } + !$omp groupprivate(/b_k/) ! { dg-error "COMMON attribute conflicts with SAVE attribute in 'k' at .1." } +end + +subroutine sub2 + common /b_q/ q + !$omp groupprivate(/b_q/) + integer :: q + !$omp groupprivate(/b_q/) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified at .1." } +end + +subroutine dupl + integer :: a,b,c,d + integer :: u,v,w,x + common /b_a/ a + common /b_b/ b + common /b_c/ c + common /b_d/ d + + !$omp groupprivate(/b_a/,u,/b_a/) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified" } + !$omp groupprivate(v,/b_b/,v) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified" } + + !$omp threadprivate(/b_a/,u,/b_a/) ! { dg-error "Duplicate THREADPRIVATE attribute specified" } + !$omp threadprivate(v,/b_b/,v) ! { dg-error "Duplicate THREADPRIVATE attribute specified" } +end
