On Thu, Jan 13, 2022 at 02:53:16PM +0000, Hafiz Abid Qadeer wrote:
> Currently we only make use of this directive when it is associated
> with an allocate statement.
Sorry for the delay.
I'll start with a comment that allocate directive in 5.0/5.1
for Fortran is a complete mess that has been fixed only in 5.2
by splitting the directive into the allocators construct and
allocate directive.
The problem with 5.0/5.1 is that it is just ambiguous whether
!$omp allocate (list) optional-clauses
is associated with an allocate statement or not.
When it is not associated with allocate statement, it is a declarative
directive that should appear only in the specification part, when it is
associated with a allocate stmt, it should appear only in the executable
part. And a mess starts when it is on the boundary between the two.
Now, how exactly to differentiate between the 2 I'm afraid depends
on the exact OpenMP version.
1) if we are p->state == ORDER_EXEC already, it must be associated
with allocate-stmt (and we should error whenever it violates restrictions
for those)
2) if (list) is missing, it must be associated with allocate-stmt
3) for 5.0 only, if allocator clause isn't specified, it must be
not associated with allocate-stmt, but in 5.1 the clauses are optional
also for one associated with it; if align clause is specified, it must be
5.1
4) all the allocate directives after one that must be associated with
allocate-stmt must be also associated with allocate-stmt
5) if variables in list are allocatable, it must be associated with
allocate-stmt, if they aren't allocatable, it must not be associated
with allocate-stmt
In your patch, you put ST_OMP_ALLOCATE into case_executable define,
I'm afraid due to the above we need to handle ST_OMP_ALLOCATE manually
whenever case_executable/case_omp_decl appear in parse.cc and be prepared
that it could be either declarative directive or executable construct
and resolve based on the 1-5 above into which category it belongs
(either during parsing or during resolving). And certainly have
testsuite coverage for cases like:
integer :: i, j
integer, allocatable :: k(:), l(:)
!$omp allocate (i) allocator (alloc1)
!$omp allocate (j) allocator (alloc2)
!$omp allocate (k) allocator (alloc3)
!$omp allocate (l) allocator (alloc4)
allocate (k(14), l(23))
where I think the first 2 are declarative directives and the last
2 bind to allocate-stmt (etc., cover all the cases mentioned above).
On the other side, 5.1 has:
"An allocate directive that is associated with an allocate-stmt and specifies a list must be
preceded by an executable statement or OpenMP construct."
restriction, so if we implement that, the ambiguity decreases.
We wouldn't need to worry about 3) and 5), would decide on 1) and 2) and 4)
only.
> gcc/fortran/ChangeLog:
>
> * dump-parse-tree.c (show_omp_node): Handle EXEC_OMP_ALLOCATE.
> (show_code_node): Likewise.
> * gfortran.h (enum gfc_statement): Add ST_OMP_ALLOCATE.
> (OMP_LIST_ALLOCATOR): New enum value.
> (enum gfc_exec_op): Add EXEC_OMP_ALLOCATE.
> * match.h (gfc_match_omp_allocate): New function.
> * openmp.c (enum omp_mask1): Add OMP_CLAUSE_ALLOCATOR.
> (OMP_ALLOCATE_CLAUSES): New define.
> (gfc_match_omp_allocate): New function.
> (resolve_omp_clauses): Add ALLOCATOR in clause_names.
> (omp_code_to_statement): Handle EXEC_OMP_ALLOCATE.
> (EMPTY_VAR_LIST): New define.
> (check_allocate_directive_restrictions): New function.
> (gfc_resolve_omp_allocate): Likewise.
> (gfc_resolve_omp_directive): Handle EXEC_OMP_ALLOCATE.
> * parse.c (decode_omp_directive): Handle ST_OMP_ALLOCATE.
> (next_statement): Likewise.
You didn't change next_statement, but case_executable macro.
But see above.
> (gfc_ascii_statement): Likewise.
> * resolve.c (gfc_resolve_code): Handle EXEC_OMP_ALLOCATE.
> * st.c (gfc_free_statement): Likewise.
> * trans.c (trans_code): Likewise
>
> gcc/testsuite/ChangeLog:
>
> * gfortran.dg/gomp/allocate-4.f90: New test.
> * gfortran.dg/gomp/allocate-5.f90: New test.
> ---
> --- a/gcc/fortran/openmp.c
> +++ b/gcc/fortran/openmp.c
> @@ -921,6 +921,7 @@ enum omp_mask1
> OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
> OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
> OMP_CLAUSE_NOWAIT,
> + OMP_CLAUSE_ALLOCATOR,
I don't see how can you add OMP_CLAUSE_ALLOCATOR to enum omp_mask1.
OMP_MASK1_LAST is already 64, so I think the
gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
assertion would fail.
OMP_MASK2_LAST is on the other side just 30, and allocate directive
takes just allocator or in 5.1 align clauses, so both should
go to the enum omp_mask2 block. And for newly added clauses,
we add the /* OpenMP 5.0. */ etc. comments when the clause
appeared first (5.0 for allocator, 5.1 for align).
> /* This must come last. */
> OMP_MASK1_LAST
> };
> @@ -3568,6 +3569,7 @@ cleanup:
> }
>
>
> +#define OMP_ALLOCATE_CLAUSES (omp_mask (OMP_CLAUSE_ALLOCATOR))
You define the above.
> #define OMP_PARALLEL_CLAUSES \
> (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
> | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
> @@ -5762,6 +5764,64 @@ gfc_match_omp_ordered_depend (void)
> return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND));
> }
>
> +/* omp allocate (list) [clause-list]
> + - clause-list: allocator
> +*/
> +
> +match
> +gfc_match_omp_allocate (void)
> +{
> + gfc_omp_clauses *c = gfc_get_omp_clauses ();
> + gfc_expr *allocator = NULL;
> + match m;
> +
> + m = gfc_match (" (");
> + if (m == MATCH_YES)
> + {
> + m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATOR],
> + true, NULL);
> +
> + if (m != MATCH_YES)
> + {
> + /* If the list was empty, we must find closing ')'. */
Empty list should be invalid if ( is seen, no?
> + m = gfc_match (")");
> + if (m != MATCH_YES)
> + return m;
> + }
> + }
> +
> + if (gfc_match (" allocator ( ") == MATCH_YES)
> + {
> + m = gfc_match_expr (&allocator);
> + if (m != MATCH_YES)
> + {
> + gfc_error ("Expected allocator at %C");
> + return MATCH_ERROR;
> + }
> + if (gfc_match (" ) ") != MATCH_YES)
> + {
> + gfc_error ("Expected ')' at %C");
> + gfc_free_expr (allocator);
> + return MATCH_ERROR;
> + }
> + }
But then parse the allocator clause by hand, so
OMP_ALLOCATE_CLAUSES is never used. I think it would be better
to go through the normal clause parsing because we'll need to handle
align clause too soon and while there can be at most one allocator
clause and at most one align clause, they can appear in either order,
and there can or doesn't have to be a comma in between them.
> + if (!omp_al || gfc_extract_int (omp_al, &tmp))
> + gfc_error ("%qs should use predefined allocator at %L", sym->name,
> + &loc);
> + }
> + if (ns != sym->ns)
> + gfc_error ("%qs is not in the same scope as %<allocate%>"
> + " directive at %L", sym->name, &loc);
> +}
> +
> +#define EMPTY_VAR_LIST(node) \
> + (node->ext.omp_clauses->lists[OMP_LIST_ALLOCATOR] == NULL)
> +
> +static void
> +gfc_resolve_omp_allocate (gfc_code *code, gfc_namespace *ns)
> +{
> + gfc_alloc *al;
> + gfc_omp_namelist *n = NULL;
> + gfc_omp_namelist *cn = NULL;
> + gfc_omp_namelist *p, *tail;
> + gfc_code *cur;
> + hash_set<gfc_symbol*> vars;
> +
> + gfc_omp_clauses *clauses = code->ext.omp_clauses;
> + gcc_assert (clauses);
> + cn = clauses->lists[OMP_LIST_ALLOCATOR];
> + gfc_expr *omp_al = cn ? cn->expr : NULL;
> +
> + if (omp_al && (omp_al->ts.type != BT_INTEGER
> + || omp_al->ts.kind != gfc_c_intptr_kind))
The formatting is weird, || should be below omp_al->
> + gfc_error ("Expected integer expression of the "
> + "%<omp_allocator_handle_kind%> kind at %L", &omp_al->where);
Jakub
@@ -1993,6 +1993,7 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
+ case EXEC_OMP_ALLOCATE: name = "ALLOCATE"; break;
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
case EXEC_OMP_CANCEL: name = "CANCEL"; break;
@@ -2194,6 +2195,7 @@ show_omp_node (int level, gfc_code *c)
|| c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA
|| c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN
|| c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR
+ || c->op == EXEC_OMP_ALLOCATE
|| (c->op == EXEC_OMP_ORDERED && c->block == NULL))
return;
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
@@ -3314,6 +3316,7 @@ show_code_node (int level, gfc_code *c)
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
+ case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
@@ -259,7 +259,7 @@ enum gfc_statement
ST_OACC_CACHE, ST_OACC_KERNELS_LOOP, ST_OACC_END_KERNELS_LOOP,
ST_OACC_SERIAL_LOOP, ST_OACC_END_SERIAL_LOOP, ST_OACC_SERIAL,
ST_OACC_END_SERIAL, ST_OACC_ENTER_DATA, ST_OACC_EXIT_DATA, ST_OACC_ROUTINE,
- ST_OACC_ATOMIC, ST_OACC_END_ATOMIC,
+ ST_OACC_ATOMIC, ST_OACC_END_ATOMIC, ST_OMP_ALLOCATE,
ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_ATOMIC,
ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED,
ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS,
@@ -1392,6 +1392,7 @@ enum
OMP_LIST_USE_DEVICE_PTR,
OMP_LIST_USE_DEVICE_ADDR,
OMP_LIST_NONTEMPORAL,
+ OMP_LIST_ALLOCATOR,
OMP_LIST_NUM
};
@@ -2893,6 +2894,7 @@ enum gfc_exec_op
EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE,
EXEC_OACC_WAIT, EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA,
EXEC_OACC_ATOMIC, EXEC_OACC_DECLARE,
+ EXEC_OMP_ALLOCATE,
EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
@@ -149,6 +149,7 @@ match gfc_match_oacc_routine (void);
/* OpenMP directive matchers. */
match gfc_match_omp_eos_error (void);
+match gfc_match_omp_allocate (void);
match gfc_match_omp_atomic (void);
match gfc_match_omp_barrier (void);
match gfc_match_omp_cancel (void);
@@ -921,6 +921,7 @@ enum omp_mask1
OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
OMP_CLAUSE_NOWAIT,
+ OMP_CLAUSE_ALLOCATOR,
/* This must come last. */
OMP_MASK1_LAST
};
@@ -3568,6 +3569,7 @@ cleanup:
}
+#define OMP_ALLOCATE_CLAUSES (omp_mask (OMP_CLAUSE_ALLOCATOR))
#define OMP_PARALLEL_CLAUSES \
(omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
@@ -5762,6 +5764,64 @@ gfc_match_omp_ordered_depend (void)
return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND));
}
+/* omp allocate (list) [clause-list]
+ - clause-list: allocator
+*/
+
+match
+gfc_match_omp_allocate (void)
+{
+ gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ gfc_expr *allocator = NULL;
+ match m;
+
+ m = gfc_match (" (");
+ if (m == MATCH_YES)
+ {
+ m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATOR],
+ true, NULL);
+
+ if (m != MATCH_YES)
+ {
+ /* If the list was empty, we must find closing ')'. */
+ m = gfc_match (")");
+ if (m != MATCH_YES)
+ return m;
+ }
+ }
+
+ if (gfc_match (" allocator ( ") == MATCH_YES)
+ {
+ m = gfc_match_expr (&allocator);
+ if (m != MATCH_YES)
+ {
+ gfc_error ("Expected allocator at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_match (" ) ") != MATCH_YES)
+ {
+ gfc_error ("Expected ')' at %C");
+ gfc_free_expr (allocator);
+ return MATCH_ERROR;
+ }
+ }
+
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_free_expr (allocator);
+ gfc_error ("Unexpected junk after $OMP allocate at %C");
+ return MATCH_ERROR;
+ }
+ gfc_omp_namelist *n;
+ for (n = c->lists[OMP_LIST_ALLOCATOR]; n; n = n->next)
+ n->expr = gfc_copy_expr (allocator);
+
+ new_st.op = EXEC_OMP_ALLOCATE;
+ new_st.ext.omp_clauses = c;
+ gfc_free_expr (allocator);
+ return MATCH_YES;
+}
+
/* omp atomic [clause-list]
- atomic-clause: read | write | update
@@ -6243,7 +6303,7 @@ 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" };
+ "NONTEMPORAL", "ALLOCATOR" };
STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
if (omp_clauses == NULL)
@@ -8507,6 +8567,8 @@ omp_code_to_statement (gfc_code *code)
{
switch (code->op)
{
+ case EXEC_OMP_ALLOCATE:
+ return ST_OMP_ALLOCATE;
case EXEC_OMP_PARALLEL:
return ST_OMP_PARALLEL;
case EXEC_OMP_PARALLEL_MASKED:
@@ -8987,6 +9049,138 @@ gfc_resolve_oacc_routines (gfc_namespace *ns)
}
}
+static void
+check_allocate_directive_restrictions (gfc_symbol *sym, gfc_expr *omp_al,
+ gfc_namespace *ns, locus loc)
+{
+ if (sym->attr.save != SAVE_NONE || sym->attr.in_common == 1
+ || sym->module != NULL)
+ {
+ int tmp;
+ /* Assumption here is that we can extract an integer then
+ it is a predefined thing. */
+ if (!omp_al || gfc_extract_int (omp_al, &tmp))
+ gfc_error ("%qs should use predefined allocator at %L", sym->name,
+ &loc);
+ }
+ if (ns != sym->ns)
+ gfc_error ("%qs is not in the same scope as %<allocate%>"
+ " directive at %L", sym->name, &loc);
+}
+
+#define EMPTY_VAR_LIST(node) \
+ (node->ext.omp_clauses->lists[OMP_LIST_ALLOCATOR] == NULL)
+
+static void
+gfc_resolve_omp_allocate (gfc_code *code, gfc_namespace *ns)
+{
+ gfc_alloc *al;
+ gfc_omp_namelist *n = NULL;
+ gfc_omp_namelist *cn = NULL;
+ gfc_omp_namelist *p, *tail;
+ gfc_code *cur;
+ hash_set<gfc_symbol*> vars;
+
+ gfc_omp_clauses *clauses = code->ext.omp_clauses;
+ gcc_assert (clauses);
+ cn = clauses->lists[OMP_LIST_ALLOCATOR];
+ gfc_expr *omp_al = cn ? cn->expr : NULL;
+
+ if (omp_al && (omp_al->ts.type != BT_INTEGER
+ || omp_al->ts.kind != gfc_c_intptr_kind))
+ gfc_error ("Expected integer expression of the "
+ "%<omp_allocator_handle_kind%> kind at %L", &omp_al->where);
+
+ /* Check that variables in this allocate directive are not duplicated
+ in this directive or others coming directly after it. */
+ for (cur = code; cur != NULL && cur->op == EXEC_OMP_ALLOCATE;
+ cur = cur->next)
+ {
+ gfc_omp_clauses *c = cur->ext.omp_clauses;
+ gcc_assert (c);
+ for (n = c->lists[OMP_LIST_ALLOCATOR]; n; n = n->next)
+ {
+ if (vars.contains (n->sym))
+ gfc_error ("%qs is used in multiple %<allocate%> "
+ "directives at %L", n->sym->name, &cur->loc);
+ /* This helps us avoid duplicate error messages. */
+ if (cur == code)
+ vars.add (n->sym);
+ }
+ }
+
+ if (cur == NULL || cur->op != EXEC_ALLOCATE)
+ {
+ /* There is no allocate statement right after allocate directive.
+ We don't support this case at the moment. */
+ for (n = cn; n != NULL; n = n->next)
+ {
+ gfc_symbol *sym = n->sym;
+ if (sym->attr.allocatable == 1)
+ gfc_error ("%qs with ALLOCATABLE attribute is not allowed in "
+ "%<allocate%> directive at %L as this directive is not"
+ " associated with an %<allocate%> statement.",
+ sym->name, &code->loc);
+ }
+ sorry_at (code->loc.lb->location, "%<allocate%> directive that is "
+ "not associated with an %<allocate%> statement is not "
+ "supported.");
+ return;
+ }
+
+ /* If there is another allocate directive right after this one, check
+ that none of them is empty. Doing it this way, we can check this
+ thing even when multiple directives are together and generate
+ error at right location. */
+ if (code->next && code->next->op == EXEC_OMP_ALLOCATE
+ && (EMPTY_VAR_LIST (code) || EMPTY_VAR_LIST (code->next)))
+ gfc_error ("Empty variable list is not allowed at %L when multiple "
+ "%<allocate%> directives are associated with an "
+ "%<allocate%> statement.",
+ EMPTY_VAR_LIST (code) ? &code->loc : &code->next->loc);
+
+ if (EMPTY_VAR_LIST (code))
+ {
+ /* Empty namelist means allocate directive applies to all
+ variables in allocate statement. 'cur' points to associated
+ allocate statement. */
+ for (al = cur->ext.alloc.list; al != NULL; al = al->next)
+ if (al->expr && al->expr->symtree && al->expr->symtree->n.sym)
+ {
+ check_allocate_directive_restrictions (al->expr->symtree->n.sym,
+ omp_al, ns, code->loc);
+ p = gfc_get_omp_namelist ();
+ p->sym = al->expr->symtree->n.sym;
+ p->expr = omp_al;
+ p->where = code->loc;
+ if (cn == NULL)
+ cn = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ }
+ clauses->lists[OMP_LIST_ALLOCATOR]= cn;
+ }
+ else
+ {
+ for (n = cn; n != NULL; n = n->next)
+ {
+ for (al = cur->ext.alloc.list; al != NULL; al = al->next)
+ if (al->expr && al->expr->symtree && al->expr->symtree->n.sym
+ && al->expr->symtree->n.sym == n->sym)
+ break;
+ if (al == NULL)
+ gfc_error ("%qs in %<allocate%> directive at %L is not present "
+ "in associated %<allocate%> statement.",
+ n->sym->name, &code->loc);
+ check_allocate_directive_restrictions (n->sym, omp_al, ns,
+ code->loc);
+ }
+ }
+}
+
void
gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
@@ -9128,6 +9322,9 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
code->ext.omp_clauses->if_present = false;
resolve_omp_clauses (code, code->ext.omp_clauses, ns);
break;
+ case EXEC_OMP_ALLOCATE:
+ gfc_resolve_omp_allocate (code, ns);
+ break;
default:
break;
}
@@ -886,6 +886,7 @@ decode_omp_directive (void)
{
case 'a':
matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
+ matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE);
break;
case 'b':
matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
@@ -1672,9 +1673,9 @@ next_statement (void)
case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
- case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
- case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
- case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
+ case ST_OMP_ALLOCATE: case ST_ERROR_STOP: case ST_OMP_SCAN: \
+ case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: \
+ case ST_UNLOCK: case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
case ST_END_TEAM: case ST_SYNC_TEAM: \
case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
@@ -2351,6 +2352,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_OACC_END_ATOMIC:
p = "!$ACC END ATOMIC";
break;
+ case ST_OMP_ALLOCATE:
+ p = "!$OMP ALLOCATE";
+ break;
case ST_OMP_ATOMIC:
p = "!$OMP ATOMIC";
break;
@@ -12306,6 +12306,7 @@ start:
gfc_resolve_oacc_directive (code, ns);
break;
+ case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CANCEL:
@@ -214,6 +214,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
case EXEC_OACC_ROUTINE:
+ case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
@@ -2140,6 +2140,7 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_dt_end (code);
break;
+ case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CANCEL:
new file mode 100644
@@ -0,0 +1,112 @@
+! { dg-do compile }
+
+module test
+ integer, allocatable :: mvar1
+ integer, allocatable :: mvar2
+ integer, allocatable :: mvar3
+end module
+
+subroutine foo(x, y)
+ use omp_lib
+ implicit none
+ integer :: x
+ integer :: y
+
+ integer, allocatable :: var1(:)
+ integer, allocatable :: var2(:)
+ integer, allocatable :: var3(:)
+ integer, allocatable :: var4(:)
+ integer, allocatable :: var5(:)
+ integer, allocatable :: var6(:)
+ integer, allocatable :: var7(:)
+ integer, allocatable :: var8(:)
+ integer, allocatable :: var9(:)
+
+ !$omp allocate (var1) allocator(10) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." }
+ allocate (var1(x))
+
+ !$omp allocate (var2) ! { dg-error "'var2' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
+ allocate (var3(x))
+
+ !$omp allocate (x) ! { dg-message "sorry, unimplemented: 'allocate' directive that is not associated with an 'allocate' statement is not supported." }
+ x = 2
+
+ !$omp allocate (var4) ! { dg-error "'var4' with ALLOCATABLE attribute is not allowed in 'allocate' directive at .1. as this directive is not associated with an 'allocate' statement." }
+ ! { dg-message "sorry, unimplemented: 'allocate' directive that is not associated with an 'allocate' statement is not supported." "" { target *-*-* } .-1 }
+ y = 2
+
+ !$omp allocate (var5)
+ !$omp allocate ! { dg-error "Empty variable list is not allowed at .1. when multiple 'allocate' directives are associated with an 'allocate' statement." }
+ allocate (var5(x))
+
+ !$omp allocate (var6)
+ !$omp allocate (var7) ! { dg-error "'var7' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
+ !$omp allocate (var8) ! { dg-error "'var8' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
+ allocate (var6(x))
+
+ !$omp allocate (var9)
+ !$omp allocate (var9) ! { dg-error "'var9' is used in multiple 'allocate' directives at .1." }
+ allocate (var9(x))
+
+end subroutine
+
+function outer(a)
+ IMPLICIT NONE
+
+ integer :: outer, a
+ integer, allocatable :: var1
+
+ outer = inner(a) + 5
+ return
+
+ contains
+
+ integer function inner(x)
+ integer :: x
+ integer, allocatable :: var2
+
+ !$omp allocate (var1, var2) ! { dg-error "'var1' is not in the same scope as 'allocate' directive at .1." }
+ allocate (var1, var2)
+
+ inner = x + 10
+ return
+ end function inner
+
+end function outer
+
+subroutine bar(s)
+ use omp_lib
+ use test
+ integer :: s
+ integer, save, allocatable :: svar1
+ integer, save, allocatable :: svar2
+ integer, save, allocatable :: svar3
+
+ type (omp_alloctrait) :: traits(3)
+ integer (omp_allocator_handle_kind) :: a
+
+ traits = [omp_alloctrait (omp_atk_alignment, 64), &
+ omp_alloctrait (omp_atk_fallback, omp_atv_null_fb), &
+ omp_alloctrait (omp_atk_pool_size, 8192)]
+ a = omp_init_allocator (omp_default_mem_space, 3, traits)
+ if (a == omp_null_allocator) stop 1
+
+ !$omp allocate (mvar1) allocator(a) ! { dg-error "'mvar1' should use predefined allocator at .1." }
+ allocate (mvar1)
+
+ !$omp allocate (mvar2) ! { dg-error "'mvar2' should use predefined allocator at .1." }
+ allocate (mvar2)
+
+ !$omp allocate (mvar3) allocator(omp_low_lat_mem_alloc)
+ allocate (mvar3)
+
+ !$omp allocate (svar1) allocator(a) ! { dg-error "'svar1' should use predefined allocator at .1." }
+ allocate (svar1)
+
+ !$omp allocate (svar2) ! { dg-error "'svar2' should use predefined allocator at .1." }
+ allocate (svar2)
+
+ !$omp allocate (svar3) allocator(omp_low_lat_mem_alloc)
+ allocate (svar3)
+end subroutine
+
new file mode 100644
@@ -0,0 +1,73 @@
+! { dg-do compile }
+
+module omp_lib_kinds
+ use iso_c_binding, only: c_int, c_intptr_t
+ implicit none
+ private :: c_int, c_intptr_t
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+end module
+
+subroutine foo(x, y)
+ use omp_lib_kinds
+ implicit none
+ integer :: x
+ integer :: y
+
+ integer, allocatable :: var1(:)
+ integer, allocatable :: var2(:)
+ integer, allocatable :: var3(:)
+ integer, allocatable :: var4(:,:)
+ integer, allocatable :: var5(:)
+ integer, allocatable :: var6(:)
+ integer, allocatable :: var7(:)
+ integer, allocatable :: var8(:)
+ integer, allocatable :: var9(:)
+ integer, allocatable :: var10(:)
+ integer, allocatable :: var11(:)
+ integer, allocatable :: var12(:)
+
+ !$omp allocate (var1) allocator(omp_default_mem_alloc)
+ allocate (var1(x))
+
+ !$omp allocate (var2)
+ allocate (var2(x))
+
+ !$omp allocate (var3, var4) allocator(omp_large_cap_mem_alloc)
+ allocate (var3(x),var4(x,y))
+
+ !$omp allocate()
+ allocate (var5(x))
+
+ !$omp allocate
+ allocate (var6(x))
+
+ !$omp allocate () allocator(omp_default_mem_alloc)
+ allocate (var7(x))
+
+ !$omp allocate allocator(omp_default_mem_alloc)
+ allocate (var8(x))
+
+ !$omp allocate (var9) allocator(omp_default_mem_alloc)
+ !$omp allocate (var10) allocator(omp_large_cap_mem_alloc)
+ allocate (var9(x), var10(x))
+
+end subroutine