https://gcc.gnu.org/g:628859fb41e9f21b9ee048efa5723b1ab4a39a63
commit 628859fb41e9f21b9ee048efa5723b1ab4a39a63
Author: Julian Brown <jul...@codesourcery.com>
Date: Sat Jul 15 09:16:44 2023 +0000
OpenMP: Reprocess expanded clauses after 'declare mapper' instantiation
This patch reprocesses expanded clauses after 'declare mapper'
instantiation -- checking things such as duplicated clauses, illegal
use of strided accesses, and so forth. Two functions are broken out
of the 'resolve_omp_clauses' function and reused in a new function
'resolve_omp_mapper_clauses', called after mapper instantiation.
This improves diagnostic output.
2023-08-10 Julian Brown <jul...@codesourcery.com>
gcc/fortran/
* gfortran.h (gfc_omp_clauses): Add NS field.
* openmp.cc (verify_omp_clauses_symbol_dups,
omp_verify_map_motion_clauses): New functions, broken out of...
(resolve_omp_clauses): Here. Record namespace containing clauses.
Call above functions.
(resolve_omp_mapper_clauses): New function, using helper functions
broken out above.
(gfc_resolve_omp_directive): Add NS parameter to resolve_omp_clauses
calls.
(gfc_omp_instantiate_mappers): Call resolve_omp_mapper_clauses if we
instantiate any mappers.
gcc/testsuite/
* gfortran.dg/gomp/declare-mapper-26.f90: New test.
* gfortran.dg/gomp/declare-mapper-29.f90: New test.
Diff:
---
gcc/fortran/ChangeLog.omp | 14 +
gcc/fortran/gfortran.h | 1 +
gcc/fortran/openmp.cc | 1123 +++++++++++---------
gcc/testsuite/ChangeLog.omp | 5 +
.../gfortran.dg/gomp/declare-mapper-26.f90 | 28 +
.../gfortran.dg/gomp/declare-mapper-29.f90 | 22 +
6 files changed, 672 insertions(+), 521 deletions(-)
diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index 95b3bb90e8f..515a30cd557 100644
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,17 @@
+2023-08-10 Julian Brown <jul...@codesourcery.com>
+
+ * gfortran.h (gfc_omp_clauses): Add NS field.
+ * openmp.cc (verify_omp_clauses_symbol_dups,
+ omp_verify_map_motion_clauses): New functions, broken out of...
+ (resolve_omp_clauses): Here. Record namespace containing clauses.
+ Call above functions.
+ (resolve_omp_mapper_clauses): New function, using helper functions
+ broken out above.
+ (gfc_resolve_omp_directive): Add NS parameter to resolve_omp_clauses
+ calls.
+ (gfc_omp_instantiate_mappers): Call resolve_omp_mapper_clauses if we
+ instantiate any mappers.
+
2023-08-10 Julian Brown <jul...@codesourcery.com>
* gfortran.h (toc_directive): Move here.
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 3d4abfc6cfd..491a1498279 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1590,6 +1590,7 @@ typedef struct gfc_omp_clauses
struct gfc_omp_assumptions *assume;
struct gfc_expr_list *sizes_list;
const char *critical_name;
+ gfc_namespace *ns;
enum gfc_omp_default_sharing default_sharing;
enum gfc_omp_atomic_op atomic_op;
enum gfc_omp_defaultmap defaultmap[OMP_DEFAULTMAP_CAT_NUM];
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index e7bb4dc80b7..574c1b2ba0c 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -7822,246 +7822,18 @@ gfc_resolve_omp_assumptions (gfc_omp_assumptions
*assume)
&el->expr->where);
}
-
-/* OpenMP directive resolving routines. */
+/* Check OMP_CLAUSES for duplicate symbols and various other constraints.
+ Helper function for resolve_omp_clauses and resolve_omp_mapper_clauses. */
static void
-resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
- gfc_namespace *ns, bool openacc = false)
+verify_omp_clauses_symbol_dups (gfc_code *code, gfc_omp_clauses *omp_clauses,
+ gfc_namespace *ns, bool openacc)
{
- gfc_omp_namelist *n, *last;
- gfc_expr_list *el;
+ gfc_omp_namelist *n;
int list;
- int ifc;
- bool if_without_mod = false;
- gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
- static const char *clause_names[]
- = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
- "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
- "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
- "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
- "IN_REDUCTION", "TASK_REDUCTION",
- "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
- "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
- "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
- "USES_ALLOCATORS" };
- STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
-
- if (omp_clauses == NULL)
- return;
-
- if (ns == NULL)
- ns = gfc_current_ns;
-
- if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
- gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
- &code->loc);
- if (omp_clauses->order_concurrent && omp_clauses->ordered)
- gfc_error ("ORDER clause must not be used together ORDERED at %L",
- &code->loc);
- if (omp_clauses->if_expr)
- {
- gfc_expr *expr = omp_clauses->if_expr;
- if (!gfc_resolve_expr (expr)
- || expr->ts.type != BT_LOGICAL || expr->rank != 0)
- gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
- &expr->where);
- if_without_mod = true;
- }
- for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
- if (omp_clauses->if_exprs[ifc])
- {
- gfc_expr *expr = omp_clauses->if_exprs[ifc];
- bool ok = true;
- if (!gfc_resolve_expr (expr)
- || expr->ts.type != BT_LOGICAL || expr->rank != 0)
- gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
- &expr->where);
- else if (if_without_mod)
- {
- gfc_error ("IF clause without modifier at %L used together with "
- "IF clauses with modifiers",
- &omp_clauses->if_expr->where);
- if_without_mod = false;
- }
- else
- switch (code->op)
- {
- case EXEC_OMP_CANCEL:
- ok = ifc == OMP_IF_CANCEL;
- break;
-
- case EXEC_OMP_PARALLEL:
- case EXEC_OMP_PARALLEL_DO:
- case EXEC_OMP_PARALLEL_LOOP:
- case EXEC_OMP_PARALLEL_MASKED:
- case EXEC_OMP_PARALLEL_MASTER:
- case EXEC_OMP_PARALLEL_SECTIONS:
- case EXEC_OMP_PARALLEL_WORKSHARE:
- case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
- case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
- ok = ifc == OMP_IF_PARALLEL;
- break;
-
- case EXEC_OMP_PARALLEL_DO_SIMD:
- case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
- case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
- break;
-
- case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
- case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
- ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
- break;
-
- case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
- case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
- ok = (ifc == OMP_IF_PARALLEL
- || ifc == OMP_IF_TASKLOOP
- || ifc == OMP_IF_SIMD);
- break;
-
- case EXEC_OMP_SIMD:
- case EXEC_OMP_DO_SIMD:
- case EXEC_OMP_DISTRIBUTE_SIMD:
- case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
- ok = ifc == OMP_IF_SIMD;
- break;
-
- case EXEC_OMP_TASK:
- ok = ifc == OMP_IF_TASK;
- break;
-
- case EXEC_OMP_TASKLOOP:
- case EXEC_OMP_MASKED_TASKLOOP:
- case EXEC_OMP_MASTER_TASKLOOP:
- ok = ifc == OMP_IF_TASKLOOP;
- break;
-
- case EXEC_OMP_TASKLOOP_SIMD:
- case EXEC_OMP_MASKED_TASKLOOP_SIMD:
- case EXEC_OMP_MASTER_TASKLOOP_SIMD:
- ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
- break;
-
- case EXEC_OMP_TARGET:
- case EXEC_OMP_TARGET_TEAMS:
- case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
- case EXEC_OMP_TARGET_TEAMS_LOOP:
- ok = ifc == OMP_IF_TARGET;
- break;
-
- case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
- case EXEC_OMP_TARGET_SIMD:
- ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
- break;
-
- case EXEC_OMP_TARGET_DATA:
- ok = ifc == OMP_IF_TARGET_DATA;
- break;
-
- case EXEC_OMP_TARGET_UPDATE:
- ok = ifc == OMP_IF_TARGET_UPDATE;
- break;
-
- case EXEC_OMP_TARGET_ENTER_DATA:
- ok = ifc == OMP_IF_TARGET_ENTER_DATA;
- break;
-
- case EXEC_OMP_TARGET_EXIT_DATA:
- ok = ifc == OMP_IF_TARGET_EXIT_DATA;
- break;
-
- case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
- case EXEC_OMP_TARGET_PARALLEL:
- case EXEC_OMP_TARGET_PARALLEL_DO:
- case EXEC_OMP_TARGET_PARALLEL_LOOP:
- ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
- break;
-
- case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
- case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- ok = (ifc == OMP_IF_TARGET
- || ifc == OMP_IF_PARALLEL
- || ifc == OMP_IF_SIMD);
- break;
-
- default:
- ok = false;
- break;
- }
- if (!ok)
- {
- static const char *ifs[] = {
- "CANCEL",
- "PARALLEL",
- "SIMD",
- "TASK",
- "TASKLOOP",
- "TARGET",
- "TARGET DATA",
- "TARGET UPDATE",
- "TARGET ENTER DATA",
- "TARGET EXIT DATA"
- };
- gfc_error ("IF clause modifier %s at %L not appropriate for "
- "the current OpenMP construct", ifs[ifc], &expr->where);
- }
- }
-
- if (omp_clauses->self_expr)
- {
- gfc_expr *expr = omp_clauses->self_expr;
- if (!gfc_resolve_expr (expr)
- || expr->ts.type != BT_LOGICAL || expr->rank != 0)
- gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
- &expr->where);
- }
-
- if (omp_clauses->final_expr)
- {
- gfc_expr *expr = omp_clauses->final_expr;
- if (!gfc_resolve_expr (expr)
- || expr->ts.type != BT_LOGICAL || expr->rank != 0)
- gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
- &expr->where);
- }
- if (omp_clauses->num_threads)
- resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
- if (omp_clauses->chunk_size)
- {
- gfc_expr *expr = omp_clauses->chunk_size;
- if (!gfc_resolve_expr (expr)
- || expr->ts.type != BT_INTEGER || expr->rank != 0)
- gfc_error ("SCHEDULE clause's chunk_size at %L requires "
- "a scalar INTEGER expression", &expr->where);
- else if (expr->expr_type == EXPR_CONSTANT
- && expr->ts.type == BT_INTEGER
- && mpz_sgn (expr->value.integer) <= 0)
- gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
- "chunk_size at %L must be positive", &expr->where);
- }
- if (omp_clauses->sched_kind != OMP_SCHED_NONE
- && omp_clauses->sched_nonmonotonic)
- {
- if (omp_clauses->sched_monotonic)
- gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
- "specified at %L", &code->loc);
- else if (omp_clauses->ordered)
- gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
- "clause at %L", &code->loc);
- }
- if (omp_clauses->depobj
- && (!gfc_resolve_expr (omp_clauses->depobj)
- || omp_clauses->depobj->ts.type != BT_INTEGER
- || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
- || omp_clauses->depobj->rank != 0))
- gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
- "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
-
- /* Check that no symbol appears on multiple clauses, except that
- a symbol can appear on both firstprivate and lastprivate. */
+ /* Check that no symbol appears on multiple clauses, except that a symbol
+ can appear on both firstprivate and lastprivate. */
for (list = 0; list < OMP_LIST_NUM; list++)
for (n = omp_clauses->lists[list]; n; n = n->next)
{
@@ -8090,22 +7862,23 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
&& n->sym->result == n->sym
&& n->sym->attr.function)
{
- if (ns->proc_name == n->sym
- || (ns->parent && ns->parent->proc_name == n->sym))
+ if (gfc_current_ns->proc_name == n->sym
+ || (gfc_current_ns->parent
+ && gfc_current_ns->parent->proc_name == n->sym))
continue;
- if (ns->proc_name->attr.entry_master)
+ if (gfc_current_ns->proc_name->attr.entry_master)
{
- gfc_entry_list *el = ns->entries;
+ gfc_entry_list *el = gfc_current_ns->entries;
for (; el; el = el->next)
if (el->sym == n->sym)
break;
if (el)
continue;
}
- if (ns->parent
- && ns->parent->proc_name->attr.entry_master)
+ if (gfc_current_ns->parent
+ && gfc_current_ns->parent->proc_name->attr.entry_master)
{
- gfc_entry_list *el = ns->parent->entries;
+ gfc_entry_list *el = gfc_current_ns->parent->entries;
for (; el; el = el->next)
if (el->sym == n->sym)
break;
@@ -8138,8 +7911,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
&& code->op != EXEC_OMP_PARALLEL_DO
&& code->op != EXEC_OMP_PARALLEL_DO_SIMD)
gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
- "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
- loc);
+ "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L", loc);
if (omp_clauses->ordered)
gfc_error ("ORDERED clause specified together with %<inscan%> "
"REDUCTION clause at %L", loc);
@@ -8233,7 +8005,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
/* Detect specifically the case where we have "map(x) private(x)" and raise
an error. If we have "...simd" combined directives though, the "private"
- applies to the simd part, so this is permitted though. */
+ applies to the simd part, so this is permitted. */
for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
if (n->sym->mark
&& n->sym->gen_mark
@@ -8243,31 +8015,48 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
&& code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
&& code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
&& code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
- gfc_error ("Symbol %qs present on multiple clauses at %L",
- n->sym->name, &n->where);
+ gfc_error ("Symbol %qs present on multiple clauses at %L", n->sym->name,
+ &n->where);
gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
- for (n = omp_clauses->lists[list]; n; n = n->next)
- if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
+ {
+ gfc_omp_namelist **pn = &omp_clauses->lists[list];
+ while ((n = *pn) != NULL)
{
- gfc_error ("Symbol %qs present on multiple clauses at %L",
- n->sym->name, &n->where);
- n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
- }
- else if (n->sym->mark
- && code->op != EXEC_OMP_TARGET_TEAMS
- && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
- && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
- && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
- && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
- && code->op != EXEC_OMP_TARGET_PARALLEL
- && code->op != EXEC_OMP_TARGET_PARALLEL_DO
- && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
- && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
- && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
- gfc_error ("Symbol %qs present on both data and map clauses "
- "at %L", n->sym->name, &n->where);
+ bool remove = false;
+
+ if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
+ {
+ gfc_error ("Symbol %qs present on multiple clauses at %L",
+ n->sym->name, &n->where);
+ n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
+ }
+ else if (n->sym->mark
+ && code->op != EXEC_OMP_TARGET_TEAMS
+ && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
+ && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
+ && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
+ && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
+ && code->op != EXEC_OMP_TARGET_PARALLEL
+ && code->op != EXEC_OMP_TARGET_PARALLEL_DO
+ && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
+ && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
+ && (code->op
+ != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD))
+ {
+ gfc_error ("Symbol %qs present on both data and map clauses "
+ "at %L", n->sym->name, &n->where);
+ /* We've already shown an error. Avoid confusing gimplify. */
+ remove = true;
+ }
+
+ if (remove)
+ *pn = n->next;
+ else
+ pn = &n->next;
+ }
+ }
for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
{
@@ -8395,8 +8184,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
if (n->sym->mark == 1)
gfc_error ("%qs specified in %<allocate%> clause at %L but not "
- "in an explicit privatization clause",
- n->sym->name, &n->where);
+ "in an explicit privatization clause", n->sym->name,
+ &n->where);
}
if (code
&& (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
@@ -8518,9 +8307,497 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
"must specify an ALLOCATOR clause", &code->loc);
}
- }
+ }
+ }
+ for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
+ n->sym->mark = 0;
+ for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
+ if (n->expr == NULL)
+ n->sym->mark = 1;
+ for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
+ {
+ if (n->expr == NULL && n->sym->mark)
+ gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
+ n->sym->name, &n->where);
+ else
+ n->sym->mark = 1;
+ }
+}
+
+/* Check that the parameter of a MAP, TO and FROM clause N meets certain
+ constraints. Helper function for resolve_omp_clauses and
+ resolve_omp_mapper_clauses. */
+
+static bool
+omp_verify_map_motion_clauses (gfc_code *code, int list, const char *name,
+ gfc_omp_namelist *n, bool openacc)
+{
+ gfc_ref *lastref = NULL, *lastslice = NULL;
+ bool resolved = false;
+ if (n->expr)
+ {
+ lastref = n->expr->ref;
+ resolved = gfc_resolve_expr (n->expr);
+
+ /* Look through component refs to find last array
+ reference. */
+ if (resolved)
+ {
+ for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT
+ || ref->type == REF_SUBSTRING
+ || ref->type == REF_INQUIRY)
+ lastref = ref;
+ else if (ref->type == REF_ARRAY)
+ {
+ for (int i = 0; i < ref->u.ar.dimen; i++)
+ if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
+ lastslice = ref;
+
+ lastref = ref;
+ }
+
+ /* The "!$acc cache" directive allows rectangular subarrays to be
+ specified, with some restrictions on the form of bounds (not
+ implemented).
+ Only raise an error here if we're really sure the array isn't
+ contiguous. An expression such as arr(-n:n,-n:n) could be
+ contiguous even if it looks like it may not be. Also OpenMP's
+ 'target update' permits strides for the to/from clause. */
+ if (code
+ && code->op != EXEC_OACC_UPDATE
+ && code->op != EXEC_OMP_TARGET_UPDATE
+ && list != OMP_LIST_CACHE
+ && list != OMP_LIST_DEPEND
+ && !gfc_is_simply_contiguous (n->expr, false, true)
+ && gfc_is_not_contiguous (n->expr)
+ && !(lastslice && (lastslice->next
+ || lastslice->type != REF_ARRAY)))
+ gfc_error ("Array is not contiguous at %L",
+ &n->where);
+ }
+ }
+ if (openacc && list == OMP_LIST_MAP
+ && (n->u.map.op == OMP_MAP_ATTACH || n->u.map.op == OMP_MAP_DETACH))
+ {
+ symbol_attribute attr;
+ if (n->expr)
+ attr = gfc_expr_attr (n->expr);
+ else
+ attr = n->sym->attr;
+ if (!attr.pointer && !attr.allocatable)
+ gfc_error ("%qs clause argument must be ALLOCATABLE or a POINTER "
+ "at %L",
+ (n->u.map.op == OMP_MAP_ATTACH) ? "attach" : "detach",
+ &n->where);
+ }
+ if (lastref
+ || (n->expr && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
+ {
+ if (!lastslice && lastref && lastref->type == REF_SUBSTRING)
+ gfc_error ("Unexpected substring reference in %s clause "
+ "at %L", name, &n->where);
+ else if (!lastslice && lastref && lastref->type == REF_INQUIRY)
+ {
+ gcc_assert (lastref->u.i == INQUIRY_RE
+ || lastref->u.i == INQUIRY_IM);
+ gfc_error ("Unexpected complex-parts designator "
+ "reference in %s clause at %L",
+ name, &n->where);
+ }
+ else if (!resolved
+ || n->expr->expr_type != EXPR_VARIABLE
+ || (lastslice
+ && (lastslice->next || lastslice->type != REF_ARRAY)))
+ gfc_error ("%qs in %s clause at %L is not a proper "
+ "array section", n->sym->name, name,
+ &n->where);
+ else if (lastslice)
+ {
+ int i;
+ gfc_array_ref *ar = &lastslice->u.ar;
+ for (i = 0; i < ar->dimen; i++)
+ if (ar->stride[i]
+ && code
+ && code->op != EXEC_OACC_UPDATE
+ && code->op != EXEC_OMP_TARGET_UPDATE)
+ {
+ gfc_error ("Stride should not be specified for "
+ "array section in %s clause at %L",
+ name, &n->where);
+ return false;
+ }
+ else if (ar->dimen_type[i] != DIMEN_ELEMENT
+ && ar->dimen_type[i] != DIMEN_RANGE)
+ {
+ gfc_error ("%qs in %s clause at %L is not a "
+ "proper array section",
+ n->sym->name, name, &n->where);
+ return false;
+ }
+ else if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
+ && ar->start[i]
+ && ar->start[i]->expr_type == EXPR_CONSTANT
+ && ar->end[i]
+ && ar->end[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (ar->start[i]->value.integer,
+ ar->end[i]->value.integer) > 0)
+ {
+ gfc_error ("%qs in %s clause at %L is a zero size array "
+ "section", n->sym->name, list == OMP_LIST_DEPEND
+ ? "DEPEND" : "AFFINITY", &n->where);
+ return false;
+ }
+ }
+ }
+ else if (openacc)
+ {
+ if (list == OMP_LIST_MAP && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
+ resolve_oacc_deviceptr_clause (n->sym, n->where, name);
+ else
+ resolve_oacc_data_clauses (n->sym, n->where, name);
+ }
+ else if (list != OMP_LIST_DEPEND
+ && n->sym->as
+ && 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 (!code || list != OMP_LIST_MAP || openacc)
+ return true;
+
+ switch (code->op)
+ {
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ switch (n->u.map.op)
+ {
+ case OMP_MAP_TO:
+ case OMP_MAP_ALWAYS_TO:
+ case OMP_MAP_PRESENT_TO:
+ case OMP_MAP_ALWAYS_PRESENT_TO:
+ case OMP_MAP_FROM:
+ case OMP_MAP_ALWAYS_FROM:
+ case OMP_MAP_PRESENT_FROM:
+ case OMP_MAP_ALWAYS_PRESENT_FROM:
+ case OMP_MAP_TOFROM:
+ case OMP_MAP_ALWAYS_TOFROM:
+ case OMP_MAP_PRESENT_TOFROM:
+ case OMP_MAP_ALWAYS_PRESENT_TOFROM:
+ case OMP_MAP_ALLOC:
+ case OMP_MAP_PRESENT_ALLOC:
+ break;
+ default:
+ gfc_error ("TARGET%s with map-type other than TO, FROM, TOFROM, or "
+ "ALLOC on MAP clause at %L",
+ code->op == EXEC_OMP_TARGET ? "" : " DATA", &n->where);
+ break;
+ }
+ break;
+ case EXEC_OMP_TARGET_ENTER_DATA:
+ switch (n->u.map.op)
+ {
+ case OMP_MAP_TO:
+ case OMP_MAP_ALWAYS_TO:
+ case OMP_MAP_PRESENT_TO:
+ case OMP_MAP_ALWAYS_PRESENT_TO:
+ case OMP_MAP_ALLOC:
+ case OMP_MAP_PRESENT_ALLOC:
+ break;
+ case OMP_MAP_TOFROM:
+ n->u.map.op = OMP_MAP_TO;
+ break;
+ case OMP_MAP_ALWAYS_TOFROM:
+ n->u.map.op = OMP_MAP_ALWAYS_TO;
+ break;
+ case OMP_MAP_PRESENT_TOFROM:
+ n->u.map.op = OMP_MAP_PRESENT_TO;
+ break;
+ case OMP_MAP_ALWAYS_PRESENT_TOFROM:
+ n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
+ break;
+ default:
+ gfc_error ("TARGET ENTER DATA with map-type other than TO, TOFROM "
+ "or ALLOC on MAP clause at %L", &n->where);
+ break;
+ }
+ break;
+ case EXEC_OMP_TARGET_EXIT_DATA:
+ switch (n->u.map.op)
+ {
+ case OMP_MAP_FROM:
+ case OMP_MAP_ALWAYS_FROM:
+ case OMP_MAP_PRESENT_FROM:
+ case OMP_MAP_ALWAYS_PRESENT_FROM:
+ case OMP_MAP_RELEASE:
+ case OMP_MAP_DELETE:
+ break;
+ case OMP_MAP_TOFROM:
+ n->u.map.op = OMP_MAP_FROM;
+ break;
+ case OMP_MAP_ALWAYS_TOFROM:
+ n->u.map.op = OMP_MAP_ALWAYS_FROM;
+ break;
+ case OMP_MAP_PRESENT_TOFROM:
+ n->u.map.op = OMP_MAP_PRESENT_FROM;
+ break;
+ case OMP_MAP_ALWAYS_PRESENT_TOFROM:
+ n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
+ break;
+ default:
+ gfc_error ("TARGET EXIT DATA with map-type other than FROM, TOFROM, "
+ "RELEASE, or DELETE on MAP clause at %L", &n->where);
+ break;
+ }
+ break;
+ default:
+ ;
+ }
+
+ return true;
+}
+
+/* OpenMP directive resolving routines. */
+
+static void
+resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
+ gfc_namespace *ns, bool openacc = false)
+{
+ gfc_omp_namelist *n, *last;
+ gfc_expr_list *el;
+ int list;
+ int ifc;
+ bool if_without_mod = false;
+ gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
+ static const char *clause_names[]
+ = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
+ "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
+ "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
+ "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
+ "IN_REDUCTION", "TASK_REDUCTION",
+ "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
+ "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
+ "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
+ "USES_ALLOCATORS" };
+ STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
+
+ if (omp_clauses == NULL)
+ return;
+
+ if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
+ gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
+ &code->loc);
+ if (omp_clauses->order_concurrent && omp_clauses->ordered)
+ gfc_error ("ORDER clause must not be used together ORDERED at %L",
+ &code->loc);
+ /* If we're invoking any declared mappers as a result of these clauses, we
may
+ need to know the namespace their directive was originally defined within
in
+ order to resolve clauses again after substitution. Record it here. */
+ if (ns)
+ omp_clauses->ns = ns;
+ if (omp_clauses->if_expr)
+ {
+ gfc_expr *expr = omp_clauses->if_expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+ gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ if_without_mod = true;
+ }
+ for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
+ if (omp_clauses->if_exprs[ifc])
+ {
+ gfc_expr *expr = omp_clauses->if_exprs[ifc];
+ bool ok = true;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+ gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ else if (if_without_mod)
+ {
+ gfc_error ("IF clause without modifier at %L used together with "
+ "IF clauses with modifiers",
+ &omp_clauses->if_expr->where);
+ if_without_mod = false;
+ }
+ else
+ switch (code->op)
+ {
+ case EXEC_OMP_CANCEL:
+ ok = ifc == OMP_IF_CANCEL;
+ break;
+
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_LOOP:
+ case EXEC_OMP_PARALLEL_MASKED:
+ case EXEC_OMP_PARALLEL_MASTER:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ ok = ifc == OMP_IF_PARALLEL;
+ break;
+
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
+ break;
+
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
+ ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
+ break;
+
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
+ ok = (ifc == OMP_IF_PARALLEL
+ || ifc == OMP_IF_TASKLOOP
+ || ifc == OMP_IF_SIMD);
+ break;
+
+ case EXEC_OMP_SIMD:
+ case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+ ok = ifc == OMP_IF_SIMD;
+ break;
+
+ case EXEC_OMP_TASK:
+ ok = ifc == OMP_IF_TASK;
+ break;
+
+ case EXEC_OMP_TASKLOOP:
+ case EXEC_OMP_MASKED_TASKLOOP:
+ case EXEC_OMP_MASTER_TASKLOOP:
+ ok = ifc == OMP_IF_TASKLOOP;
+ break;
+
+ case EXEC_OMP_TASKLOOP_SIMD:
+ case EXEC_OMP_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_MASTER_TASKLOOP_SIMD:
+ ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
+ break;
+
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_TEAMS:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TARGET_TEAMS_LOOP:
+ ok = ifc == OMP_IF_TARGET;
+ break;
+
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TARGET_SIMD:
+ ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
+ break;
+
+ case EXEC_OMP_TARGET_DATA:
+ ok = ifc == OMP_IF_TARGET_DATA;
+ break;
+
+ case EXEC_OMP_TARGET_UPDATE:
+ ok = ifc == OMP_IF_TARGET_UPDATE;
+ break;
+
+ case EXEC_OMP_TARGET_ENTER_DATA:
+ ok = ifc == OMP_IF_TARGET_ENTER_DATA;
+ break;
+
+ case EXEC_OMP_TARGET_EXIT_DATA:
+ ok = ifc == OMP_IF_TARGET_EXIT_DATA;
+ break;
+
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TARGET_PARALLEL:
+ case EXEC_OMP_TARGET_PARALLEL_DO:
+ case EXEC_OMP_TARGET_PARALLEL_LOOP:
+ ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
+ break;
+
+ case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ ok = (ifc == OMP_IF_TARGET
+ || ifc == OMP_IF_PARALLEL
+ || ifc == OMP_IF_SIMD);
+ break;
+
+ default:
+ ok = false;
+ break;
+ }
+ if (!ok)
+ {
+ static const char *ifs[] = {
+ "CANCEL",
+ "PARALLEL",
+ "SIMD",
+ "TASK",
+ "TASKLOOP",
+ "TARGET",
+ "TARGET DATA",
+ "TARGET UPDATE",
+ "TARGET ENTER DATA",
+ "TARGET EXIT DATA"
+ };
+ gfc_error ("IF clause modifier %s at %L not appropriate for "
+ "the current OpenMP construct", ifs[ifc], &expr->where);
+ }
+ }
+
+ if (omp_clauses->self_expr)
+ {
+ gfc_expr *expr = omp_clauses->self_expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+ gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ }
+
+ if (omp_clauses->final_expr)
+ {
+ gfc_expr *expr = omp_clauses->final_expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+ gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ }
+ if (omp_clauses->num_threads)
+ resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
+ if (omp_clauses->chunk_size)
+ {
+ gfc_expr *expr = omp_clauses->chunk_size;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("SCHEDULE clause's chunk_size at %L requires "
+ "a scalar INTEGER expression", &expr->where);
+ else if (expr->expr_type == EXPR_CONSTANT
+ && expr->ts.type == BT_INTEGER
+ && mpz_sgn (expr->value.integer) <= 0)
+ gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size "
+ "at %L must be positive", &expr->where);
+ }
+ if (omp_clauses->sched_kind != OMP_SCHED_NONE
+ && omp_clauses->sched_nonmonotonic)
+ {
+ if (omp_clauses->sched_monotonic)
+ gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
+ "specified at %L", &code->loc);
+ else if (omp_clauses->ordered)
+ gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
+ "clause at %L", &code->loc);
}
+ if (omp_clauses->depobj
+ && (!gfc_resolve_expr (omp_clauses->depobj)
+ || omp_clauses->depobj->ts.type != BT_INTEGER
+ || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
+ || omp_clauses->depobj->rank != 0))
+ gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
+ "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
+
+ verify_omp_clauses_symbol_dups (code, omp_clauses, ns, openacc);
+
/* OpenACC reductions. */
if (openacc)
{
@@ -8542,20 +8819,6 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
}
}
- for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
- n->sym->mark = 0;
- for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
- if (n->expr == NULL)
- n->sym->mark = 1;
- for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
- {
- if (n->expr == NULL && n->sym->mark)
- gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
- n->sym->name, &n->where);
- else
- n->sym->mark = 1;
- }
-
bool has_inscan = false, has_notinscan = false;
for (list = 0; list < OMP_LIST_NUM; list++)
if ((n = omp_clauses->lists[list]) != NULL)
@@ -8724,242 +8987,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
"type shall be a scalar integer of "
"OMP_DEPEND_KIND kind", &n->expr->where);
}
- gfc_ref *lastref = NULL, *lastslice = NULL;
- bool resolved = false;
- if (n->expr)
- {
- lastref = n->expr->ref;
- resolved = gfc_resolve_expr (n->expr);
-
- /* Look through component refs to find last array
- reference. */
- if (resolved)
- {
- for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT
- || ref->type == REF_SUBSTRING
- || ref->type == REF_INQUIRY)
- lastref = ref;
- else if (ref->type == REF_ARRAY)
- {
- for (int i = 0; i < ref->u.ar.dimen; i++)
- if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
- lastslice = ref;
-
- lastref = ref;
- }
-
- /* The "!$acc cache" directive allows rectangular
- subarrays to be specified, with some restrictions
- on the form of bounds (not implemented).
- Only raise an error here if we're really sure the
- array isn't contiguous. An expression such as
- arr(-n:n,-n:n) could be contiguous even if it looks
- like it may not be.
- And OpenMP's 'target update' permits strides for
- the to/from clause. */
- if (code
- && code->op != EXEC_OACC_UPDATE
- && code->op != EXEC_OMP_TARGET_UPDATE
- && list != OMP_LIST_CACHE
- && list != OMP_LIST_DEPEND
- && !gfc_is_simply_contiguous (n->expr, false, true)
- && gfc_is_not_contiguous (n->expr)
- && !(lastslice
- && (lastslice->next
- || lastslice->type != REF_ARRAY)))
- gfc_error ("Array is not contiguous at %L",
- &n->where);
- }
- }
- if (openacc
- && list == OMP_LIST_MAP
- && (n->u.map.op == OMP_MAP_ATTACH
- || n->u.map.op == OMP_MAP_DETACH))
- {
- symbol_attribute attr;
- if (n->expr)
- attr = gfc_expr_attr (n->expr);
- else
- attr = n->sym->attr;
- if (!attr.pointer && !attr.allocatable)
- gfc_error ("%qs clause argument must be ALLOCATABLE or "
- "a POINTER at %L",
- (n->u.map.op == OMP_MAP_ATTACH) ? "attach"
- : "detach", &n->where);
- }
- if (lastref
- || (n->expr
- && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
- {
- if (!lastslice
- && lastref
- && lastref->type == REF_SUBSTRING)
- gfc_error ("Unexpected substring reference in %s clause "
- "at %L", name, &n->where);
- else if (!lastslice
- && lastref
- && lastref->type == REF_INQUIRY)
- {
- gcc_assert (lastref->u.i == INQUIRY_RE
- || lastref->u.i == INQUIRY_IM);
- gfc_error ("Unexpected complex-parts designator "
- "reference in %s clause at %L",
- name, &n->where);
- }
- else if (!resolved
- || n->expr->expr_type != EXPR_VARIABLE
- || (lastslice
- && (lastslice->next
- || lastslice->type != REF_ARRAY)))
- gfc_error ("%qs in %s clause at %L is not a proper "
- "array section", n->sym->name, name,
- &n->where);
- else if (lastslice)
- {
- int i;
- gfc_array_ref *ar = &lastslice->u.ar;
- for (i = 0; i < ar->dimen; i++)
- if (ar->stride[i]
- && code->op != EXEC_OACC_UPDATE
- && code->op != EXEC_OMP_TARGET_UPDATE)
- {
- gfc_error ("Stride should not be specified for "
- "array section in %s clause at %L",
- name, &n->where);
- break;
- }
- else if (ar->dimen_type[i] != DIMEN_ELEMENT
- && ar->dimen_type[i] != DIMEN_RANGE)
- {
- gfc_error ("%qs in %s clause at %L is not a "
- "proper array section",
- n->sym->name, name, &n->where);
- break;
- }
- else if ((list == OMP_LIST_DEPEND
- || list == OMP_LIST_AFFINITY)
- && ar->start[i]
- && ar->start[i]->expr_type == EXPR_CONSTANT
- && ar->end[i]
- && ar->end[i]->expr_type == EXPR_CONSTANT
- && mpz_cmp (ar->start[i]->value.integer,
- ar->end[i]->value.integer) > 0)
- {
- gfc_error ("%qs in %s clause at %L is a "
- "zero size array section",
- n->sym->name,
- list == OMP_LIST_DEPEND
- ? "DEPEND" : "AFFINITY", &n->where);
- break;
- }
- }
- }
- else if (openacc)
- {
- if (list == OMP_LIST_MAP
- && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
- resolve_oacc_deviceptr_clause (n->sym, n->where, name);
- else
- resolve_oacc_data_clauses (n->sym, n->where, name);
- }
- else if (list != OMP_LIST_DEPEND
- && n->sym->as
- && 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 (code && list == OMP_LIST_MAP && !openacc)
- switch (code->op)
- {
- case EXEC_OMP_TARGET:
- case EXEC_OMP_TARGET_DATA:
- switch (n->u.map.op)
- {
- case OMP_MAP_TO:
- case OMP_MAP_ALWAYS_TO:
- case OMP_MAP_PRESENT_TO:
- case OMP_MAP_ALWAYS_PRESENT_TO:
- case OMP_MAP_FROM:
- case OMP_MAP_ALWAYS_FROM:
- case OMP_MAP_PRESENT_FROM:
- case OMP_MAP_ALWAYS_PRESENT_FROM:
- case OMP_MAP_TOFROM:
- case OMP_MAP_ALWAYS_TOFROM:
- case OMP_MAP_PRESENT_TOFROM:
- case OMP_MAP_ALWAYS_PRESENT_TOFROM:
- case OMP_MAP_ALLOC:
- case OMP_MAP_PRESENT_ALLOC:
- break;
- default:
- gfc_error ("TARGET%s with map-type other than TO, "
- "FROM, TOFROM, or ALLOC on MAP clause "
- "at %L",
- code->op == EXEC_OMP_TARGET
- ? "" : " DATA", &n->where);
- break;
- }
- break;
- case EXEC_OMP_TARGET_ENTER_DATA:
- switch (n->u.map.op)
- {
- case OMP_MAP_TO:
- case OMP_MAP_ALWAYS_TO:
- case OMP_MAP_PRESENT_TO:
- case OMP_MAP_ALWAYS_PRESENT_TO:
- case OMP_MAP_ALLOC:
- case OMP_MAP_PRESENT_ALLOC:
- break;
- case OMP_MAP_TOFROM:
- n->u.map.op = OMP_MAP_TO;
- break;
- case OMP_MAP_ALWAYS_TOFROM:
- n->u.map.op = OMP_MAP_ALWAYS_TO;
- break;
- case OMP_MAP_PRESENT_TOFROM:
- n->u.map.op = OMP_MAP_PRESENT_TO;
- break;
- case OMP_MAP_ALWAYS_PRESENT_TOFROM:
- n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
- break;
- default:
- gfc_error ("TARGET ENTER DATA with map-type other "
- "than TO, TOFROM or ALLOC on MAP clause "
- "at %L", &n->where);
- break;
- }
- break;
- case EXEC_OMP_TARGET_EXIT_DATA:
- switch (n->u.map.op)
- {
- case OMP_MAP_FROM:
- case OMP_MAP_ALWAYS_FROM:
- case OMP_MAP_PRESENT_FROM:
- case OMP_MAP_ALWAYS_PRESENT_FROM:
- case OMP_MAP_RELEASE:
- case OMP_MAP_DELETE:
- break;
- case OMP_MAP_TOFROM:
- n->u.map.op = OMP_MAP_FROM;
- break;
- case OMP_MAP_ALWAYS_TOFROM:
- n->u.map.op = OMP_MAP_ALWAYS_FROM;
- break;
- case OMP_MAP_PRESENT_TOFROM:
- n->u.map.op = OMP_MAP_PRESENT_FROM;
- break;
- case OMP_MAP_ALWAYS_PRESENT_TOFROM:
- n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
- break;
- default:
- gfc_error ("TARGET EXIT DATA with map-type other "
- "than FROM, TOFROM, RELEASE, or DELETE on "
- "MAP clause at %L", &n->where);
- break;
- }
- break;
- default:
- break;
- }
+ if (!omp_verify_map_motion_clauses (code, list, name, n,
+ openacc))
+ break;
}
if (list != OMP_LIST_DEPEND)
@@ -9582,6 +9612,46 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
gfc_resolve_omp_assumptions (omp_clauses->assume);
}
+/* This very simplified version of the above function is for use after mapper
+ instantiation. It avoids dealing with anything other than basic
+ verification for map/to/from clauses. */
+
+static void
+resolve_omp_mapper_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
+ gfc_namespace *ns)
+{
+ gfc_omp_namelist *n;
+ int list;
+
+ verify_omp_clauses_symbol_dups (code, omp_clauses, ns, false);
+
+ for (list = OMP_LIST_MAP; list <= OMP_LIST_FROM; list++)
+ if ((n = omp_clauses->lists[list]) != NULL)
+ {
+ const char *name = NULL;
+ switch (list)
+ {
+ case OMP_LIST_MAP:
+ if (name == NULL)
+ name = "MAP";
+ /* Fallthrough. */
+ case OMP_LIST_TO:
+ if (name == NULL)
+ name = "TO";
+ /* Fallthrough. */
+ case OMP_LIST_FROM:
+ if (name == NULL)
+ name = "FROM";
+ for (; n != NULL; n = n->next)
+ if (!omp_verify_map_motion_clauses (code, list, name, n, false))
+ break;
+ break;
+ default:
+ ;
+ }
+ }
+}
+
/* Return true if SYM is ever referenced in EXPR except in the SE node. */
@@ -12084,11 +12154,11 @@ gfc_resolve_omp_directive (gfc_code *code,
gfc_namespace *ns)
case EXEC_OMP_WORKSHARE:
case EXEC_OMP_DEPOBJ:
if (code->ext.omp_clauses)
- resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
+ resolve_omp_clauses (code, code->ext.omp_clauses, ns);
break;
case EXEC_OMP_TARGET_UPDATE:
if (code->ext.omp_clauses)
- resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
+ resolve_omp_clauses (code, code->ext.omp_clauses, ns);
if (code->ext.omp_clauses == NULL
|| (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
&& code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
@@ -12689,6 +12759,7 @@ gfc_omp_instantiate_mappers (gfc_code *code,
gfc_omp_clauses *clauses,
{
gfc_omp_namelist *clause = clauses->lists[list];
gfc_omp_namelist **clausep = &clauses->lists[list];
+ bool invoked_mappers = false;
for (; clause; clause = *clausep)
{
@@ -12715,10 +12786,20 @@ gfc_omp_instantiate_mappers (gfc_code *code,
gfc_omp_clauses *clauses,
clausep = gfc_omp_instantiate_mapper (clausep, clause, outer_map_op,
clause->u2.udm->udm, cd, list);
*clausep = clause->next;
+ invoked_mappers = true;
}
else
clausep = &clause->next;
}
+
+ if (invoked_mappers)
+ {
+ gfc_namespace *old_ns = gfc_current_ns;
+ if (clauses->ns)
+ gfc_current_ns = clauses->ns;
+ resolve_omp_mapper_clauses (code, clauses, gfc_current_ns);
+ gfc_current_ns = old_ns;
+ }
}
/* Resolve !$omp declare mapper constructs. */
diff --git a/gcc/testsuite/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index e4c8afd0293..49ea82ac86b 100644
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,8 @@
+2023-08-10 Julian Brown <jul...@codesourcery.com>
+
+ * gfortran.dg/gomp/declare-mapper-26.f90: New test.
+ * gfortran.dg/gomp/declare-mapper-29.f90: New test.
+
2023-07-14 Julian Brown <jul...@codesourcery.com>
* c-c++-common/gomp/declare-mapper-3.c: Enable for C.
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-mapper-26.f90
b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-26.f90
new file mode 100644
index 00000000000..c408b37f5a9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-26.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+
+type t
+integer, allocatable :: arr(:)
+end type t
+
+!$omp declare mapper(even: T :: tv) map(tv%arr(2::2))
+
+type(t) :: var
+
+allocate(var%arr(100))
+
+var%arr = 0
+
+! You can't do this, the mapper specifies a noncontiguous access.
+!$omp target enter data map(mapper(even), to: var)
+! { dg-error {Stride should not be specified for array section in MAP clause}
"" { target *-*-* } .-1 }
+
+var%arr = 1
+
+! But this is fine. (Re-enabled by later patch.)
+!!$omp target update to(mapper(even): var)
+
+! As 'enter data'.
+!$omp target exit data map(mapper(even), delete: var)
+! { dg-error {Stride should not be specified for array section in MAP clause}
"" { target *-*-* } .-1 }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-mapper-29.f90
b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-29.f90
new file mode 100644
index 00000000000..e2039e80e57
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-mapper-29.f90
@@ -0,0 +1,22 @@
+! { dg-do compile }
+
+! Check duplicate clause detection after mapper expansion.
+
+type t
+integer :: x
+end type t
+
+real(4) :: unrelated
+type(t) :: tvar
+
+!$omp declare mapper (t :: var) map(unrelated) map(var%x)
+
+tvar%x = 0
+unrelated = 5
+
+!$omp target firstprivate(unrelated) map(tofrom: tvar)
+! { dg-error "Symbol .unrelated. present on both data and map clauses" "" {
target *-*-* } .-1 }
+tvar%x = unrelated
+!$omp end target
+
+end
