commit 89d0f082b3c95f68d116d4480126e3ab7fb7f36b
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Mon Jul 17 15:13:44 2023 +0200
OpenMP/Fortran: Parsing support for 'uses_allocators'
The 'uses_allocators' clause to the 'target' construct accepts predefined
allocators and can also be used to define a new allocator for a target region.
As predefined allocators in GCC do not require special handling, those can and
are ignored after parsing, such that this feature now works. On the other hand,
defining a new allocator will fail for now with a 'sorry, unimplemented'.
Note that both the OpenMP 5.0/5.1 and 5.2 syntax for uses_allocators
is supported by this commit.
2023-07-17 Tobias Burnus <tobias@codesoucery.com>
Chung-Lin Tang <cltang@codesourcery.com>
gcc/fortran/ChangeLog:
* dump-parse-tree.cc (show_omp_namelist, show_omp_clauses): Dump
uses_allocators clause.
* gfortran.h (gfc_free_omp_namelist): Add memspace_sym to u union
and traits_sym to u2 union.
(OMP_LIST_USES_ALLOCATORS): New enum value.
(gfc_free_omp_namelist): Add 'bool free_mem_traits_space' arg.
* match.cc (gfc_free_omp_namelist): Likewise.
* openmp.cc (gfc_free_omp_clauses, gfc_match_omp_variable_list,
gfc_match_omp_to_link, gfc_match_omp_doacross_sink,
gfc_match_omp_clause_reduction, gfc_match_omp_allocate,
gfc_match_omp_flush): Update call.
(gfc_match_omp_clauses): Likewise. Parse uses_allocators clause.
(gfc_match_omp_clause_uses_allocators): New.
(enum omp_mask2): Add new OMP_CLAUSE_USES_ALLOCATORS.
(OMP_TARGET_CLAUSES): Accept it.
(resolve_omp_clauses): Resolve uses_allocators clause
* st.cc (gfc_free_statement): Update gfc_free_omp_namelist call.
* trans-openmp.cc (gfc_trans_omp_clauses): Handle
OMP_LIST_USES_ALLOCATORS; fail with sorry unless predefined allocator.
(gfc_split_omp_clauses): Handle uses_allocators.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/uses_allocators_1.f90: New test.
* testsuite/libgomp.fortran/uses_allocators_2.f90: New test.
Co-authored-by: Chung-Lin Tang <cltang@codesourcery.com>
---
gcc/fortran/dump-parse-tree.cc | 24 +++
gcc/fortran/gfortran.h | 5 +-
gcc/fortran/match.cc | 7 +-
gcc/fortran/openmp.cc | 194 +++++++++++++++++++--
gcc/fortran/st.cc | 2 +-
gcc/fortran/trans-openmp.cc | 11 ++
.../libgomp.fortran/uses_allocators_1.f90 | 168 ++++++++++++++++++
.../libgomp.fortran/uses_allocators_2.f90 | 99 +++++++++++
8 files changed, 491 insertions(+), 19 deletions(-)
@@ -1497,6 +1497,29 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
case OMP_LINEAR_UVAL: fputs ("uval(", dumpfile); break;
default: break;
}
+ else if (list_type == OMP_LIST_USES_ALLOCATORS)
+ {
+ if (n->u.memspace_sym)
+ {
+ fputs ("memspace(", dumpfile);
+ fputs (n->sym->name, dumpfile);
+ fputc (')', dumpfile);
+ }
+ if (n->u.memspace_sym && n->u2.traits_sym)
+ fputc (',', dumpfile);
+ if (n->u2.traits_sym)
+ {
+ fputs ("traits(", dumpfile);
+ fputs (n->u2.traits_sym->name, dumpfile);
+ fputc (')', dumpfile);
+ }
+ if (n->u.memspace_sym || n->u2.traits_sym)
+ fputc (':', dumpfile);
+ fputs (n->sym->name, dumpfile);
+ if (n->next)
+ fputs (", ", dumpfile);
+ continue;
+ }
fprintf (dumpfile, "%s", n->sym ? n->sym->name : "omp_all_memory");
if (list_type == OMP_LIST_LINEAR && n->u.linear.op != OMP_LINEAR_DEFAULT)
fputc (')', dumpfile);
@@ -1799,6 +1822,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
case OMP_LIST_ALLOCATE: type = "ALLOCATE"; break;
case OMP_LIST_SCAN_IN: type = "INCLUSIVE"; break;
case OMP_LIST_SCAN_EX: type = "EXCLUSIVE"; break;
+ case OMP_LIST_USES_ALLOCATORS: type = "USES_ALLOCATORS"; break;
default:
gcc_unreachable ();
}
@@ -1368,6 +1368,7 @@ typedef struct gfc_omp_namelist
bool old_modifier;
} linear;
struct gfc_common_head *common;
+ struct gfc_symbol *memspace_sym;
bool lastprivate_conditional;
bool present_modifier;
} u;
@@ -1376,6 +1377,7 @@ typedef struct gfc_omp_namelist
struct gfc_omp_namelist_udr *udr;
gfc_namespace *ns;
gfc_expr *allocator;
+ struct gfc_symbol *traits_sym;
} u2;
struct gfc_omp_namelist *next;
locus where;
@@ -1419,6 +1421,7 @@ enum
OMP_LIST_ALLOCATE,
OMP_LIST_HAS_DEVICE_ADDR,
OMP_LIST_ENTER,
+ OMP_LIST_USES_ALLOCATORS,
OMP_LIST_NUM /* Must be the last. */
};
@@ -3600,7 +3603,7 @@ void gfc_free_iterator (gfc_iterator *, int);
void gfc_free_forall_iterator (gfc_forall_iterator *);
void gfc_free_alloc_list (gfc_alloc *);
void gfc_free_namelist (gfc_namelist *);
-void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool);
+void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool, bool);
void gfc_free_equiv (gfc_equiv *);
void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *);
void gfc_free_data (gfc_data *);
@@ -5537,7 +5537,8 @@ gfc_free_namelist (gfc_namelist *name)
void
gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
- bool free_align_allocator)
+ bool free_align_allocator,
+ bool free_mem_traits_space)
{
gfc_omp_namelist *n;
@@ -5546,10 +5547,14 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
gfc_free_expr (name->expr);
if (free_align_allocator)
gfc_free_expr (name->u.align);
+ else if (free_mem_traits_space)
+ { } /* name->u.memspace_sym: shall not call gfc_free_symbol here. */
if (free_ns)
gfc_free_namespace (name->u2.ns);
else if (free_align_allocator)
gfc_free_expr (name->u2.allocator);
+ else if (free_mem_traits_space)
+ { } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */
else if (name->u2.udr)
{
if (name->u2.udr->combiner)
@@ -188,7 +188,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
for (i = 0; i < OMP_LIST_NUM; i++)
gfc_free_omp_namelist (c->lists[i],
i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND,
- i == OMP_LIST_ALLOCATE);
+ i == OMP_LIST_ALLOCATE,
+ i == OMP_LIST_USES_ALLOCATORS);
gfc_free_expr_list (c->wait_list);
gfc_free_expr_list (c->tile_list);
free (CONST_CAST (char *, c->critical_name));
@@ -553,7 +554,7 @@ syntax:
gfc_error ("Syntax error in OpenMP variable list at %C");
cleanup:
- gfc_free_omp_namelist (head, false, false);
+ gfc_free_omp_namelist (head, false, false, false);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
@@ -643,7 +644,7 @@ syntax:
gfc_error ("Syntax error in OpenMP variable list at %C");
cleanup:
- gfc_free_omp_namelist (head, false, false);
+ gfc_free_omp_namelist (head, false, false, false);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
@@ -752,7 +753,7 @@ syntax:
gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
cleanup:
- gfc_free_omp_namelist (head, false, false);
+ gfc_free_omp_namelist (head, false, false, false);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
@@ -1091,6 +1092,7 @@ enum omp_mask2
OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
+ OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
/* This must come last. */
OMP_MASK2_LAST
};
@@ -1502,7 +1504,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
*head = NULL;
gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
buffer, &old_loc);
- gfc_free_omp_namelist (n, false, false);
+ gfc_free_omp_namelist (n, false, false, false);
}
else
for (n = *head; n; n = n->next)
@@ -1697,6 +1699,106 @@ omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
return MATCH_YES;
}
+/* OpenMP 5.0
+ uses_allocators ( allocator-list )
+
+ allocator:
+ predefined-allocator
+ variable ( traits-array )
+
+ OpenMP 5.2:
+ uses_allocators ( [modifier-list :] allocator-list )
+
+ allocator:
+ variable or predefined-allocator
+ modifier:
+ traits ( traits-array )
+ memspace ( mem-space-handle ) */
+
+static match
+gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
+{
+ gfc_symbol *memspace_sym = NULL;
+ gfc_symbol *traits_sym = NULL;
+ gfc_omp_namelist *head = NULL;
+ gfc_omp_namelist *p, *tail, **list;
+ int ntraits, nmemspace;
+ bool has_modifiers;
+ locus old_loc, cur_loc;
+
+ gfc_gobble_whitespace ();
+ old_loc = gfc_current_locus;
+ ntraits = nmemspace = 0;
+ do
+ {
+ cur_loc = gfc_current_locus;
+ if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
+ ntraits++;
+ else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
+ nmemspace++;
+ if (ntraits > 1 || nmemspace > 1)
+ {
+ gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
+ ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
+ return MATCH_ERROR;
+ }
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (": ") != MATCH_YES)
+ {
+ /* Assume no modifier. */
+ memspace_sym = traits_sym = NULL;
+ gfc_current_locus = old_loc;
+ break;
+ }
+ break;
+ } while (true);
+
+ has_modifiers = traits_sym != NULL || memspace_sym != NULL;
+ do
+ {
+ p = gfc_get_omp_namelist ();
+ p->where = gfc_current_locus;
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ if (gfc_match ("%S ", &p->sym) != MATCH_YES)
+ goto error;
+ if (!has_modifiers)
+ gfc_match ("( %S ) ", &p->u2.traits_sym);
+ else if (gfc_peek_ascii_char () == '(')
+ {
+ gfc_error ("Unexpected %<(%> at %C");
+ goto error;
+ }
+ else
+ {
+ p->u.memspace_sym = memspace_sym;
+ p->u2.traits_sym = traits_sym;
+ }
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (") ") == MATCH_YES)
+ break;
+ goto error;
+ } while (true);
+
+ list = &c->lists[OMP_LIST_USES_ALLOCATORS];
+ while (*list)
+ list = &(*list)->next;
+ *list = head;
+
+ return MATCH_YES;
+
+error:
+ gfc_free_omp_namelist (head, false, false, true);
+ return MATCH_ERROR;
+}
+
/* Match with duplicate check. Matches 'name'. If expr != NULL, it
then matches '(expr)', otherwise, if open_parens is true,
@@ -1820,7 +1922,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
{
- gfc_free_omp_namelist (*head, false, false);
+ gfc_free_omp_namelist (*head, false, false, false);
gfc_current_locus = old_loc;
*head = NULL;
break;
@@ -2763,7 +2865,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
end_colon = true;
else if (gfc_match (" )") != MATCH_YES)
{
- gfc_free_omp_namelist (*head, false, false);
+ gfc_free_omp_namelist (*head, false, false, false);
gfc_current_locus = old_loc;
*head = NULL;
break;
@@ -2774,7 +2876,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
{
if (gfc_match (" %e )", &step) != MATCH_YES)
{
- gfc_free_omp_namelist (*head, false, false);
+ gfc_free_omp_namelist (*head, false, false, false);
gfc_current_locus = old_loc;
*head = NULL;
goto error;
@@ -2871,7 +2973,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
if (has_error)
{
- gfc_free_omp_namelist (*head, false, false);
+ gfc_free_omp_namelist (*head, false, false, false);
*head = NULL;
goto error;
}
@@ -3561,6 +3663,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
false, NULL, NULL, true) == MATCH_YES)
continue;
+ if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
+ && (gfc_match ("uses_allocators ( ") == MATCH_YES))
+ {
+ if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
+ goto error;
+ continue;
+ }
break;
case 'v':
/* VECTOR_LENGTH must be matched before VECTOR, because the latter
@@ -4290,7 +4399,7 @@ 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_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS)
#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)
@@ -4410,7 +4519,7 @@ gfc_match_omp_allocate (void)
gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
"directive", &n->expr->where);
- gfc_free_omp_namelist (vars, false, true);
+ gfc_free_omp_namelist (vars, false, true, false);
goto error;
}
@@ -4814,14 +4923,14 @@ gfc_match_omp_flush (void)
{
gfc_error ("List specified together with memory order clause in FLUSH "
"directive at %C");
- gfc_free_omp_namelist (list, false, false);
+ gfc_free_omp_namelist (list, false, false, false);
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
- gfc_free_omp_namelist (list, false, false);
+ gfc_free_omp_namelist (list, false, false, false);
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
@@ -7229,7 +7338,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
"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" };
+ "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
+ "USES_ALLOCATORS" };
STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
if (omp_clauses == NULL)
@@ -7495,7 +7605,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
" cannot be and need not be mapped", n->sym->name,
&n->where);
}
- else
+ else if (list != OMP_LIST_USES_ALLOCATORS)
gfc_error ("Object %qs is not a variable at %L", n->sym->name,
&n->where);
}
@@ -7721,7 +7831,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
{
prev->next = n->next;
n->next = NULL;
- gfc_free_omp_namelist (n, false, true);
+ gfc_free_omp_namelist (n, false, true, false);
n = prev->next;
}
continue;
@@ -8291,6 +8401,58 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
n = n->next;
}
break;
+ case OMP_LIST_USES_ALLOCATORS:
+ {
+ if (n != NULL
+ && n->u.memspace_sym
+ && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
+ || n->u.memspace_sym->ts.type != BT_INTEGER
+ || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
+ || n->u.memspace_sym->attr.dimension
+ || (!startswith (n->u.memspace_sym->name, "omp_")
+ && !startswith (n->u.memspace_sym->name, "ompx_"))
+ || !endswith (n->u.memspace_sym->name, "_mem_space")))
+ gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
+ "a predefined memory space",
+ n->u.memspace_sym->name, &n->where);
+ for (; n != NULL; n = n->next)
+ {
+ if (n->sym->ts.type != BT_INTEGER
+ || n->sym->ts.kind != gfc_c_intptr_kind
+ || n->sym->attr.dimension)
+ gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
+ "be a scalar integer of kind "
+ "%<omp_allocator_handle_kind%>", n->sym->name,
+ &n->where);
+ else if (n->sym->attr.flavor != FL_VARIABLE
+ && ((!startswith (n->sym->name, "omp_")
+ && !startswith (n->sym->name, "ompx_"))
+ || !endswith (n->sym->name, "_mem_alloc")))
+ gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
+ "either a variable or a predefined allocator",
+ n->sym->name, &n->where);
+ else if ((n->u.memspace_sym || n->u2.traits_sym)
+ && n->sym->attr.flavor != FL_VARIABLE)
+ gfc_error ("A memory space or traits array may not be "
+ "specified for predefined allocator %qs at %L",
+ n->sym->name, &n->where);
+ if (n->u2.traits_sym
+ && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
+ || !n->u2.traits_sym->attr.dimension
+ || n->u2.traits_sym->as->rank != 1
+ || n->u2.traits_sym->ts.type != BT_DERIVED
+ || strcmp (n->u2.traits_sym->ts.u.derived->name,
+ "omp_alloctrait") != 0))
+ {
+ gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
+ "be a one-dimensional named constant array of "
+ "type %<omp_alloctrait%>",
+ n->u2.traits_sym->name, &n->where);
+ break;
+ }
+ }
+ break;
+ }
default:
for (; n != NULL; n = n->next)
{
@@ -288,7 +288,7 @@ gfc_free_statement (gfc_code *p)
break;
case EXEC_OMP_FLUSH:
- gfc_free_omp_namelist (p->ext.omp_namelist, false, false);
+ gfc_free_omp_namelist (p->ext.omp_namelist, false, false, false);
break;
case EXEC_OMP_BARRIER:
@@ -3923,6 +3923,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
omp_clauses = gfc_trans_add_clause (node, omp_clauses);
}
break;
+ case OMP_LIST_USES_ALLOCATORS:
+ /* Ignore pre-defined allocators as no special treatment is needed. */
+ for (; n != NULL; n = n->next)
+ if (n->sym->attr.flavor == FL_VARIABLE)
+ break;
+ if (n != NULL)
+ sorry_at (input_location, "%<uses_allocators%> clause with traits "
+ "and memory spaces");
+ break;
default:
break;
}
@@ -6581,6 +6590,8 @@ gfc_split_omp_clauses (gfc_code *code,
= code->ext.omp_clauses->device;
clausesa[GFC_OMP_SPLIT_TARGET].thread_limit
= code->ext.omp_clauses->thread_limit;
+ clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_USES_ALLOCATORS]
+ = code->ext.omp_clauses->lists[OMP_LIST_USES_ALLOCATORS];
for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i]
= code->ext.omp_clauses->defaultmap[i];
new file mode 100644
@@ -0,0 +1,168 @@
+! { dg-do compile }
+
+subroutine test
+ use omp_lib
+ implicit none
+
+ !$omp target uses_allocators ( omp_default_mem_alloc , omp_large_cap_mem_alloc, &
+ !$omp& omp_const_mem_alloc,omp_high_bw_mem_alloc, &
+ !$omp& omp_low_lat_mem_alloc ,omp_cgroup_mem_alloc , &
+ !$omp& omp_pteam_mem_alloc, omp_thread_mem_alloc )
+ block; end block
+
+ !$omp target uses_allocators(omp_default_mem_alloc, omp_high_bw_mem_alloc) &
+ !$omp& uses_allocators(omp_high_bw_mem_alloc, omp_low_lat_mem_alloc) ! { dg-error "Symbol 'omp_high_bw_mem_alloc' present on multiple clauses" }
+ block; end block
+
+ !$omp target firstprivate ( omp_default_mem_alloc ) , uses_allocators &
+ !$omp& (omp_default_mem_alloc , omp_high_bw_mem_alloc ) &
+ !$omp& map(to: omp_high_bw_mem_alloc)
+ block; end block
+! { dg-error "Object 'omp_default_mem_alloc' is not a variable" "" { target *-*-* } .-4 }
+! { dg-error "Symbol 'omp_default_mem_alloc' present on both data and map clauses" "" { target *-*-* } .-5 }
+! { dg-error "Symbol 'omp_high_bw_mem_alloc' present on multiple clauses" "" { target *-*-* } .-5 }
+! { dg-error "Object 'omp_high_bw_mem_alloc' is not a variable at .1.; parameters cannot be and need not be mapped" "" { target *-*-* } .-5 }
+end
+
+subroutine non_predef
+ use omp_lib
+ implicit none
+
+ type(omp_alloctrait), parameter :: trait(0) = [omp_alloctrait :: ]
+ type(omp_alloctrait), parameter :: trait2(*) &
+ = [omp_alloctrait (omp_atk_alignment, 16), &
+ omp_alloctrait (omp_atk_sync_hint, omp_atv_default), &
+ omp_alloctrait (omp_atk_access, omp_atv_default)]
+
+ integer(kind=omp_allocator_handle_kind) :: a1, a2, a3
+
+ !$omp target uses_allocators(omp_default_mem_alloc, a1(trait), a2(trait2))
+ block; end block
+
+ !$omp target uses_allocators(omp_default_mem_alloc, a1(trait), omp_cgroup_mem_alloc, a1(trait2)) ! { dg-error "Symbol 'a1' present on multiple clauses" }
+ block; end block
+
+ !$omp target uses_allocators(traits(trait):a1) &
+ !$omp& uses_allocators ( memspace ( omp_low_lat_mem_space ) , traits ( trait2 ) : a2 , a3)
+ block; end block
+
+ !$omp target uses_allocators ( traits(trait2) , memspace ( omp_low_lat_mem_space ) : a2 , a3)
+ block; end block
+
+ !$omp target firstprivate ( a2 ) , & ! { dg-error "Symbol 'a2' present on both data and map clauses" }
+ !$omp& uses_allocators (a2, a3) & ! { dg-error "Symbol 'a3' present on multiple clauses" }
+ !$omp& map(to: a3)
+ block; end block
+end subroutine
+
+subroutine duplicate
+ use omp_lib
+ implicit none
+ type(omp_alloctrait), parameter :: trait1(0) = [omp_alloctrait :: ]
+ type(omp_alloctrait), parameter :: trait2(0) = [omp_alloctrait :: ]
+
+ !$omp target uses_allocators(traits(trait1), memspace ( omp_low_lat_mem_space ) , traits ( trait2 ) : bar) ! { dg-error "Duplicate TRAITS modifier" }
+ block; end block
+
+ !$omp target uses_allocators(traits(trait1), memspace ( omp_low_lat_mem_space ) , memspace (omp_large_cap_mem_space) : bar) ! { dg-error "Duplicate MEMSPACE modifier" }
+ block; end block
+end
+
+subroutine trait_present
+ use omp_lib
+ implicit none
+
+ type(omp_alloctrait), parameter :: trait1(0) = [omp_alloctrait :: ]
+ integer(kind=omp_allocator_handle_kind) :: a1
+
+ !$omp target uses_allocators(omp_cgroup_mem_alloc(trait1)) ! { dg-error "A memory space or traits array may not be specified for predefined allocator 'omp_cgroup_mem_alloc'" }
+ block; end block
+
+ !$omp target uses_allocators(traits(trait1) : omp_pteam_mem_alloc) ! { dg-error "A memory space or traits array may not be specified for predefined allocator 'omp_pteam_mem_alloc'" }
+ block; end block
+
+ !$omp target uses_allocators(memspace(omp_low_lat_mem_space) : omp_thread_mem_alloc) ! { dg-error "A memory space or traits array may not be specified for predefined allocator 'omp_thread_mem_alloc'" }
+ block; end block
+
+ ! Invalid in OpenMP 5.0 / 5.1, but valid since 5.2 the same as omp_default_mem_space + emptry traits array
+ !$omp target uses_allocators ( a1 )
+ block; end block
+end
+
+subroutine odd_names
+ use omp_lib
+ implicit none
+
+ type(omp_alloctrait), parameter :: trait1(0) = [omp_alloctrait :: ]
+
+ ! oddly named allocators:
+ integer(kind=omp_allocator_handle_kind) :: traits
+ integer(kind=omp_allocator_handle_kind) :: memspace
+
+ !$omp target uses_allocators ( traits(trait1), memspace(trait1) )
+ block; end block
+
+ !$omp target uses_allocators ( traits(trait1), memspace(omp_low_lat_mem_space) : traits)
+ block; end block
+
+ !$omp target uses_allocators ( memspace(omp_low_lat_mem_space), traits(trait1) : memspace)
+ block; end block
+end
+
+subroutine more_checks
+ use omp_lib
+ implicit none
+
+ integer(kind=kind(omp_low_lat_mem_space)) :: my_memspace
+ integer(kind=omp_allocator_handle_kind) :: a1, a2(4)
+ integer(kind=1) :: a3
+
+ !$omp target uses_allocators ( memspace(my_memspace) : a1) ! { dg-error "Memspace 'my_memspace' at .1. in USES_ALLOCATORS must be a predefined memory space" }
+ block; end block
+
+ !$omp target uses_allocators ( omp_low_lat_mem_space) ! { dg-error "Allocator 'omp_low_lat_mem_space' at .1. in USES_ALLOCATORS must either a variable or a predefined allocator" }
+ block; end block
+
+ !$omp target uses_allocators ( memspace (omp_low_lat_mem_alloc) : a1) ! { dg-error "Memspace 'omp_low_lat_mem_alloc' at .1. in USES_ALLOCATORS must be a predefined memory space" }
+ block; end block
+
+ !$omp target uses_allocators(memspace (omp_low_lat_mem_space) : a1 )
+ block; end block
+
+ !$omp target uses_allocators(memspace (omp_low_lat_mem_space) : a2 ) ! { dg-error "Allocator 'a2' at .1. in USES_ALLOCATORS must be a scalar integer of kind 'omp_allocator_handle_kind'" }
+ block; end block
+
+ !$omp target uses_allocators(memspace (omp_low_lat_mem_space) : a3 ) ! { dg-error "Allocator 'a3' at .1. in USES_ALLOCATORS must be a scalar integer of kind 'omp_allocator_handle_kind'" }
+ block; end block
+end
+
+subroutine traits_checks
+ use omp_lib
+ implicit none
+
+ type(omp_alloctrait), parameter :: trait1 = omp_alloctrait (omp_atk_alignment, 16)
+ type(omp_alloctrait) :: trait2
+ integer(kind=omp_atk_alignment), parameter :: trait3(1) = omp_atk_alignment
+ integer(kind=omp_allocator_handle_kind) :: a1
+
+ ! Sensible - but not (yet?) valid - an array constructor:
+ !$omp target uses_allocators(traits ([omp_alloctrait :: ]) : a1 ) ! { dg-error "Invalid character in name" }
+ block; end block
+ !$omp target uses_allocators(a1 ([omp_alloctrait :: ])) ! { dg-error "Invalid character in name" }
+ block; end block
+
+ !$omp target uses_allocators(traits (trait1) : a1 ) ! { dg-error "Traits array 'trait1' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" }
+ block; end block
+ !$omp target uses_allocators(a1 (trait1)) ! { dg-error "Traits array 'trait1' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" }
+ block; end block
+
+ !$omp target uses_allocators(traits (trait2) : a1 ) ! { dg-error "Traits array 'trait2' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" }
+ block; end block
+ !$omp target uses_allocators(a1 (trait2)) ! { dg-error "Traits array 'trait2' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" }
+ block; end block
+
+ !$omp target uses_allocators(traits (trait3) : a1 ) ! { dg-error "Traits array 'trait3' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" }
+ block; end block
+ !$omp target uses_allocators(a1 (trait3)) ! { dg-error "Traits array 'trait3' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" }
+ block; end block
+end
new file mode 100644
@@ -0,0 +1,99 @@
+! { dg-do compile }
+
+! Minimal test for valid code:
+! - predefined allocators do not need any special treatment in uses_allocators
+! (as 'requires dynamic_allocators' is the default).
+!
+! - Non-predefined allocators are currently rejected ('sorry)'
+
+subroutine test
+ use omp_lib
+ implicit none
+
+ !$omp target uses_allocators ( omp_default_mem_alloc , omp_large_cap_mem_alloc, &
+ !$omp& omp_const_mem_alloc,omp_high_bw_mem_alloc, &
+ !$omp& omp_low_lat_mem_alloc ,omp_cgroup_mem_alloc , &
+ !$omp& omp_pteam_mem_alloc, omp_thread_mem_alloc )
+ block; end block
+
+ !$omp target parallel uses_allocators ( omp_default_mem_alloc , omp_large_cap_mem_alloc, &
+ !$omp& omp_const_mem_alloc,omp_high_bw_mem_alloc, &
+ !$omp& omp_low_lat_mem_alloc ,omp_cgroup_mem_alloc , &
+ !$omp& omp_pteam_mem_alloc, omp_thread_mem_alloc )
+ block; end block
+end
+
+subroutine non_predef
+ use omp_lib
+ implicit none
+
+ type(omp_alloctrait), parameter :: trait(0) = [omp_alloctrait :: ]
+ type(omp_alloctrait), parameter :: trait2(*) &
+ = [omp_alloctrait (omp_atk_alignment, 16), &
+ omp_alloctrait (omp_atk_sync_hint, omp_atv_default), &
+ omp_alloctrait (omp_atk_access, omp_atv_default)]
+
+ integer(kind=omp_allocator_handle_kind) :: a1, a2, a3
+
+ !$omp target uses_allocators(omp_default_mem_alloc, a1(trait), a2(trait2)) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" }
+ block; end block
+
+ !$omp target parallel uses_allocators(omp_default_mem_alloc, a1(trait), a2(trait2)) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" }
+ block; end block
+
+
+ !$omp target uses_allocators(traits(trait):a1) &
+ !$omp& uses_allocators ( memspace ( omp_low_lat_mem_space ) , traits ( trait2 ) : a2 , a3) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" }
+ block; end block
+
+ !$omp target parallel uses_allocators(traits(trait):a1) &
+ !$omp& uses_allocators ( memspace ( omp_low_lat_mem_space ) , traits ( trait2 ) : a2 , a3) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" }
+ block; end block
+
+ !$omp target uses_allocators ( traits(trait2) , memspace ( omp_low_lat_mem_space ) : a2 , a3) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" }
+ block; end block
+end subroutine
+
+subroutine trait_present
+ use omp_lib
+ implicit none
+
+ type(omp_alloctrait), parameter :: trait1(0) = [omp_alloctrait :: ]
+ integer(kind=omp_allocator_handle_kind) :: a1
+
+ ! Invalid in OpenMP 5.0 / 5.1, but valid since 5.2 the same as omp_default_mem_space + emptry traits array
+ !$omp target uses_allocators ( a1 ) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" }
+ block; end block
+end
+
+subroutine odd_names
+ use omp_lib
+ implicit none
+
+ type(omp_alloctrait), parameter :: trait1(0) = [omp_alloctrait :: ]
+
+ ! oddly named allocators:
+ integer(kind=omp_allocator_handle_kind) :: traits
+ integer(kind=omp_allocator_handle_kind) :: memspace
+
+ !$omp target uses_allocators ( traits(trait1), memspace(trait1) ) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" }
+ block; end block
+
+ !$omp target uses_allocators ( traits(trait1), memspace(omp_low_lat_mem_space) : traits) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" }
+ block; end block
+
+ !$omp target uses_allocators ( memspace(omp_low_lat_mem_space), traits(trait1) : memspace) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" }
+ block; end block
+end
+
+subroutine more_checks
+ use omp_lib
+ implicit none
+
+ integer(kind=kind(omp_low_lat_mem_space)) :: my_memspace
+ integer(kind=omp_allocator_handle_kind) :: a1, a2(4)
+ integer(kind=1) :: a3
+
+ !$omp target uses_allocators(memspace (omp_low_lat_mem_space) : a1 ) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" }
+ block; end block
+end