procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran/OpenMP: Add parsing support for allocators/allocate directives

Browse source 
gcc/fortran/ChangeLog:

	* dump-parse-tree.cc (show_omp_namelist): Update allocator, fix
	align dump.
	(show_omp_node, show_code_node): Handle EXEC_OMP_ALLOCATE.
	* gfortran.h (enum gfc_statement): Add ST_OMP_ALLOCATE and ..._EXEC.
	(enum gfc_exec_op): Add EXEC_OMP_ALLOCATE.
	(struct gfc_omp_namelist): Add 'allocator' to 'u2' union.
	(struct gfc_namespace): Add omp_allocate.
	(gfc_resolve_omp_allocate): New.
	* match.cc (gfc_free_omp_namelist): Free 'u2.allocator'.
	* match.h (gfc_match_omp_allocate, gfc_match_omp_allocators): New.
	* openmp.cc (gfc_omp_directives): Uncomment allocate/allocators.
	(gfc_match_omp_variable_list): Add bool arg for
	rejecting listening common-block vars separately.
	(gfc_match_omp_clauses): Update for u2.allocators.
	(OMP_ALLOCATORS_CLAUSES, gfc_match_omp_allocate,
	gfc_match_omp_allocators, is_predefined_allocator,
	gfc_resolve_omp_allocate): New.
	(resolve_omp_clauses): Update 'allocate' clause checks.
	(omp_code_to_statement, gfc_resolve_omp_directive): Handle
	OMP ALLOCATE/ALLOCATORS.
	* parse.cc (in_exec_part): New global var.
	(check_omp_allocate_stmt, parse_openmp_allocate_block): New.
	(decode_omp_directive, case_exec_markers, case_omp_decl,
	gfc_ascii_statement, parse_omp_structured_block): Handle
	OMP allocate/allocators.
	(verify_st_order, parse_executable): Set in_exec_part.
	* resolve.cc (gfc_resolve_blocks, resolve_codes): Handle
	allocate/allocators.
	* st.cc (gfc_free_statement): Likewise.
	* trans.cc (trans_code): Likewise.
	* trans-openmp.cc (gfc_trans_omp_directive): Likewise.
	(gfc_trans_omp_clauses, gfc_split_omp_clauses): Update for
	u2.allocator, fix for u.align.

libgomp/ChangeLog:

	* testsuite/libgomp.fortran/allocate-4.f90: Update dg-error.

gcc/testsuite/ChangeLog:

	* gfortran.dg/gomp/allocate-2.f90: Update dg-error.
	* gfortran.dg/gomp/allocate-4.f90: New test.
	* gfortran.dg/gomp/allocate-5.f90: New test.
	* gfortran.dg/gomp/allocate-6.f90: New test.
	* gfortran.dg/gomp/allocate-7.f90: New test.
	* gfortran.dg/gomp/allocators-1.f90: New test.
	* gfortran.dg/gomp/allocators-2.f90: New test.
This commit is contained in:
Tobias Burnus 2023-05-26 20:39:33 +02:00
parent 252b8319ad
commit d64e8e1224
18 changed files with 1068 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
gcc/fortran/dump-parse-tree.cc
View file

@ -1377,14 +1377,14 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
if (n->expr)
{
fputs ("allocator(", dumpfile);
show_expr (n->expr);
show_expr (n->u2.allocator);
fputc (')', dumpfile);
}
if (n->expr && n->u.align)
fputc (',', dumpfile);
if (n->u.align)
{
fputs ("allocator(", dumpfile);
fputs ("align(", dumpfile);
show_expr (n->u.align);
fputc (')', dumpfile);
}
@ -2096,6 +2096,8 @@ 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_ALLOCATORS: name = "ALLOCATORS"; break;
case EXEC_OMP_ASSUME: name = "ASSUME"; break;
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
@ -3424,6 +3426,8 @@ 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_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:

9
gcc/fortran/gfortran.h
View file

@ -318,6 +318,8 @@ enum gfc_statement
ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD,
ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
ST_OMP_ERROR, ST_OMP_ASSUME, ST_OMP_END_ASSUME, ST_OMP_ASSUMES,
ST_OMP_ALLOCATE, ST_OMP_ALLOCATE_EXEC,
ST_OMP_ALLOCATORS, ST_OMP_END_ALLOCATORS,
/* Note: gfc_match_omp_nothing returns ST_NONE. */
ST_OMP_NOTHING, ST_NONE
};
@ -1365,6 +1367,7 @@ typedef struct gfc_omp_namelist
{
struct gfc_omp_namelist_udr *udr;
gfc_namespace *ns;
gfc_expr *allocator;
} u2;
struct gfc_omp_namelist *next;
locus where;
@ -2177,8 +2180,9 @@ typedef struct gfc_namespace
/* Linked list of !$omp declare variant constructs. */
struct gfc_omp_declare_variant *omp_declare_variant;
/* OpenMP assumptions. */
/* OpenMP assumptions and allocate for static/stack vars. */
struct gfc_omp_assumptions *omp_assumes;
struct gfc_omp_namelist *omp_allocate;
/* A hash set for the gfc expressions that have already
been finalized in this namespace. */
@ -2974,7 +2978,7 @@ enum gfc_exec_op
EXEC_OMP_TARGET_TEAMS_LOOP, EXEC_OMP_MASKED, EXEC_OMP_PARALLEL_MASKED,
EXEC_OMP_PARALLEL_MASKED_TASKLOOP, EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
EXEC_OMP_MASKED_TASKLOOP, EXEC_OMP_MASKED_TASKLOOP_SIMD, EXEC_OMP_SCOPE,
EXEC_OMP_ERROR
EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS
};
typedef struct gfc_code
@ -3613,6 +3617,7 @@ void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
void gfc_resolve_omp_allocate (gfc_namespace *, gfc_omp_namelist *);
void gfc_resolve_omp_assumptions (gfc_omp_assumptions *);
void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool);

7
gcc/fortran/match.cc
View file

@ -5534,17 +5534,20 @@ gfc_free_namelist (gfc_namelist *name)
/* Free an OpenMP namelist structure. */
void
gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align)
gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
bool free_align_allocator)
{
gfc_omp_namelist *n;
for (; name; name = n)
{
gfc_free_expr (name->expr);
if (free_align)
if (free_align_allocator)
gfc_free_expr (name->u.align);
if (free_ns)
gfc_free_namespace (name->u2.ns);
else if (free_align_allocator)
gfc_free_expr (name->u2.allocator);
else if (name->u2.udr)
{
if (name->u2.udr->combiner)

2
gcc/fortran/match.h
View file

@ -149,6 +149,8 @@ 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_allocators (void);
match gfc_match_omp_assume (void);
match gfc_match_omp_assumes (void);
match gfc_match_omp_atomic (void);

333
gcc/fortran/openmp.cc
View file

@ -54,8 +54,8 @@ struct gfc_omp_directive {
and "nothing". */
static const struct gfc_omp_directive gfc_omp_directives[] = {
/* {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE}, */
/* {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS}, */
{"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE},
{"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS},
{"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES},
{"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME},
{"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC},
@ -394,7 +394,8 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
gfc_omp_namelist ***headp = NULL,
bool allow_sections = false,
bool allow_derived = false,
bool *has_all_memory = NULL)
bool *has_all_memory = NULL,
bool reject_common_vars = false)
{
gfc_omp_namelist *head, *tail, *p;
locus old_loc, cur_loc;
@ -482,6 +483,15 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
tail->sym = sym;
tail->expr = expr;
tail->where = cur_loc;
if (reject_common_vars && sym->attr.in_common)
{
gcc_assert (allow_common);
gfc_error ("%qs at %L is part of the common block %</%s/%> and "
"may only be specificed implicitly via the named "
"common block", sym->name, &cur_loc,
sym->common_head->name);
goto cleanup;
}
goto next_item;
case MATCH_NO:
break;
@ -1895,7 +1905,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
for (gfc_omp_namelist *n = *head; n; n = n->next)
{
n->expr = (allocator) ? gfc_copy_expr (allocator) : NULL;
n->u2.allocator = ((allocator)
? gfc_copy_expr (allocator) : NULL);
n->u.align = (align) ? gfc_copy_expr (align) : NULL;
}
gfc_free_expr (allocator);
@ -4270,6 +4281,8 @@ cleanup:
(omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
#define OMP_WORKSHARE_CLAUSES \
omp_mask (OMP_CLAUSE_NOWAIT)
#define OMP_ALLOCATORS_CLAUSES \
omp_mask (OMP_CLAUSE_ALLOCATE)
static match
@ -4284,6 +4297,113 @@ match_omp (gfc_exec_op op, const omp_mask mask)
return MATCH_YES;
}
/* Handles both declarative and (deprecated) executable ALLOCATE directive;
accepts optional list (for executable) and common blocks.
If no variables have been provided, the single omp namelist has sym == NULL.
Note that the executable ALLOCATE directive permits structure elements only
in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
'omp allocators' directive below. The accidental change was reverted for
OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
Hence, structure elements are rejected for now, also to make resolving
OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
Fortran allocate stmt). TODO: Permit structure elements. */
match
gfc_match_omp_allocate (void)
{
match m;
bool first = true;
gfc_omp_namelist *vars = NULL;
gfc_expr *align = NULL;
gfc_expr *allocator = NULL;
locus loc = gfc_current_locus;
m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
NULL, true);
if (m == MATCH_ERROR)
return m;
while (true)
{
gfc_gobble_whitespace ();
if (gfc_match_omp_eos () == MATCH_YES)
break;
if (!first)
gfc_match (", ");
first = false;
if ((m = gfc_match_dupl_check (!align, "align", true, &align))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
if ((m = gfc_match_dupl_check (!allocator, "allocator",
true, &allocator)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
continue;
}
gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
return MATCH_ERROR;
}
for (gfc_omp_namelist *n = vars; n; n = n->next)
if (n->expr)
{
if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
|| (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
"directive is not yet supported", &n->expr->where);
else
gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
"directive", &n->expr->where);
gfc_free_omp_namelist (vars, false, true);
goto error;
}
new_st.op = EXEC_OMP_ALLOCATE;
new_st.ext.omp_clauses = gfc_get_omp_clauses ();
if (vars == NULL)
{
vars = gfc_get_omp_namelist ();
vars->where = loc;
vars->u.align = align;
vars->u2.allocator = allocator;
new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
}
else
{
new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
for (; vars; vars = vars->next)
{
vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
vars->u2.allocator = ((allocator) ? gfc_copy_expr (allocator) : NULL);
}
gfc_free_expr (allocator);
gfc_free_expr (align);
}
return MATCH_YES;
error:
gfc_free_expr (align);
gfc_free_expr (allocator);
return MATCH_ERROR;
}
/* In line with OpenMP 5.2 derived-type components are rejected.
See also comment before gfc_match_omp_allocate. */
match
gfc_match_omp_allocators (void)
{
return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
}
match
gfc_match_omp_assume (void)
@ -6903,6 +7023,128 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
return copy;
}
/* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is
already lost during matching via gfc_match_expr. */
bool
is_predefined_allocator (gfc_expr *expr)
{
return (gfc_resolve_expr (expr)
&& expr->rank == 0
&& expr->ts.type == BT_INTEGER
&& expr->ts.kind == gfc_c_intptr_kind
&& expr->expr_type == EXPR_CONSTANT
&& mpz_sgn (expr->value.integer) > 0
&& mpz_cmp_si (expr->value.integer, 8) <= 0);
}
/* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
as /block/ not individual, which is ensured during parsing. */
void
gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
{
for (gfc_omp_namelist *n = list; n; n = n->next)
n->sym->mark = 0;
for (gfc_omp_namelist *n = list; n; n = n->next)
{
if (n->sym->attr.flavor != FL_VARIABLE)
{
gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
"directive must be a variable", n->sym->name,
&n->where);
continue;
}
if (ns != n->sym->ns || n->sym->attr.use_assoc
|| n->sym->attr.host_assoc || n->sym->attr.imported)
{
gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
" in the same scope as the variable declaration",
n->sym->name, &n->where);
continue;
}
if (n->sym->attr.dummy)
{
gfc_error ("Unexpected dummy argument %qs as argument at %L to "
"declarative !$OMP ALLOCATE", n->sym->name, &n->where);
continue;
}
if (n->sym->mark)
{
if (n->sym->attr.in_common)
{
gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
"at %L", n->sym->common_head->name, &n->where);
while (n->next && n->next->sym
&& n->sym->common_head == n->next->sym->common_head)
n = n->next;
}
else
gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
n->sym->name, &n->where);
continue;
}
n->sym->mark = 1;
if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
&& CLASS_DATA (n->sym)->attr.allocatable)
|| (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
"!$OMP ALLOCATE directive", n->sym->name, &n->where);
else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
&& CLASS_DATA (n->sym)->attr.class_pointer)
|| (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
gfc_error ("Unexpected pointer variable %qs at %L in declarative "
"!$OMP ALLOCATE directive", n->sym->name, &n->where);
HOST_WIDE_INT alignment = 0;
if (n->u.align
&& (!gfc_resolve_expr (n->u.align)
|| n->u.align->ts.type != BT_INTEGER
|| n->u.align->rank != 0
|| n->u.align->expr_type != EXPR_CONSTANT
|| gfc_extract_hwi (n->u.align, &alignment)
|| !pow2p_hwi (alignment)))
{
gfc_error ("ALIGN requires a scalar positive constant integer "
"alignment expression at %L that is a power of two",
&n->u.align->where);
while (n->sym->attr.in_common && n->next && n->next->sym
&& n->sym->common_head == n->next->sym->common_head)
n = n->next;
continue;
}
if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
|| (n->sym->ns->proc_name
&& (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
|| n->sym->ns->proc_name->attr.flavor == FL_MODULE)))
{
bool com = n->sym->attr.in_common;
if (!n->u2.allocator)
gfc_error ("An ALLOCATOR clause is required as the list item "
"%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
com ? n->sym->common_head->name : n->sym->name,
com ? "/" : "", &n->where);
else if (!is_predefined_allocator (n->u2.allocator))
gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
" as the list item %<%s%s%s%> at %L has the SAVE attribute",
&n->u2.allocator->where, com ? "/" : "",
com ? n->sym->common_head->name : n->sym->name,
com ? "/" : "", &n->where);
while (n->sym->attr.in_common && n->next && n->next->sym
&& n->sym->common_head == n->next->sym->common_head)
n = n->next;
}
else if (n->u2.allocator
&& (!gfc_resolve_expr (n->u2.allocator)
|| n->u2.allocator->ts.type != BT_INTEGER
|| n->u2.allocator->rank != 0
|| n->u2.allocator->ts.kind != gfc_c_intptr_kind))
gfc_error ("Expected integer expression of the "
"%<omp_allocator_handle_kind%> kind at %L",
&n->u2.allocator->where);
}
gfc_error ("Sorry, declarative !$OMP ALLOCATE at %L not yet supported",
&list->where);
}
/* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
is handled during parse time in omp_verify_merge_absent_contains. */
@ -7376,28 +7618,31 @@ 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->expr && (!gfc_resolve_expr (n->expr)
|| n->expr->ts.type != BT_INTEGER
|| n->expr->ts.kind != gfc_c_intptr_kind))
if (n->u2.allocator
&& (!gfc_resolve_expr (n->u2.allocator)
|| n->u2.allocator->ts.type != BT_INTEGER
|| n->u2.allocator->rank != 0
|| n->u2.allocator->ts.kind != gfc_c_intptr_kind))
{
gfc_error ("Expected integer expression of the "
"%<omp_allocator_handle_kind%> kind at %L",
&n->expr->where);
&n->u2.allocator->where);
break;
}
if (!n->u.align)
continue;
int alignment = 0;
HOST_WIDE_INT alignment = 0;
if (!gfc_resolve_expr (n->u.align)
|| n->u.align->ts.type != BT_INTEGER
|| n->u.align->rank != 0
|| gfc_extract_int (n->u.align, &alignment)
|| n->u.align->expr_type != EXPR_CONSTANT
|| gfc_extract_hwi (n->u.align, &alignment)
|| alignment <= 0
|| !pow2p_hwi (alignment))
{
gfc_error ("ALIGN modifier requires at %L a scalar positive "
"constant integer alignment expression that is a "
"power of two", &n->u.align->where);
gfc_error ("ALIGN requires a scalar positive constant integer "
"alignment expression at %L that is a power of two",
&n->u.align->where);
break;
}
}
@ -7407,15 +7652,21 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
2. Variable in allocate clause are also present in some
privatization clase (non-composite case). */
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
n->sym->mark = 0;
if (n->sym)
n->sym->mark = 0;
gfc_omp_namelist *prev = NULL;
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n;)
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
{
if (n->sym == NULL)
{
n = n->next;
continue;
}
if (n->sym->mark == 1)
{
gfc_warning (0, "%qs appears more than once in %<allocate%> "
"clauses at %L" , n->sym->name, &n->where);
"at %L" , n->sym->name, &n->where);
/* We have already seen this variable so it is a duplicate.
Remove it. */
if (prev != NULL && prev->next == n)
@ -7460,6 +7711,28 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
"in an explicit privatization clause",
n->sym->name, &n->where);
}
if (code
&& (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
&& code->block
&& code->block->next
&& code->block->next->op == EXEC_ALLOCATE)
{
gfc_alloc *a;
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
{
if (n->sym == NULL)
continue;
for (a = code->block->next->ext.alloc.list; a; a = a->next)
if (a->expr->expr_type == EXPR_VARIABLE
&& a->expr->symtree->n.sym == n->sym)
break;
if (a == NULL)
gfc_error ("%qs specified in %<allocate%> at %L but not "
"in the associated ALLOCATE statement",
n->sym->name, &n->where);
}
}
}
/* OpenACC reductions. */
@ -7563,15 +7836,13 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
n->sym->name, &n->where);
else if (n->expr)
{
gfc_expr *expr = n->expr;
int alignment = 0;
if (!gfc_resolve_expr (expr)
|| expr->ts.type != BT_INTEGER
|| expr->rank != 0
|| gfc_extract_int (expr, &alignment)
|| alignment <= 0)
gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
"positive constant integer alignment "
if (!gfc_resolve_expr (n->expr)
|| n->expr->ts.type != BT_INTEGER
|| n->expr->rank != 0
|| n->expr->expr_type != EXPR_CONSTANT
|| mpz_sgn (n->expr->value.integer) <= 0)
gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
" positive constant integer alignment "
"expression", n->sym->name, &n->where);
}
}
@ -7951,6 +8222,12 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
default:
for (; n != NULL; n = n->next)
{
if (n->sym == NULL)
{
gcc_assert (code->op == EXEC_OMP_ALLOCATORS
|| code->op == EXEC_OMP_ALLOCATE);
continue;
}
bool bad = false;
bool is_reduction = (list == OMP_LIST_REDUCTION
|| list == OMP_LIST_REDUCTION_INSCAN
@ -9667,6 +9944,10 @@ omp_code_to_statement (gfc_code *code)
return ST_OMP_DO;
case EXEC_OMP_LOOP:
return ST_OMP_LOOP;
case EXEC_OMP_ALLOCATE:
return ST_OMP_ALLOCATE_EXEC;
case EXEC_OMP_ALLOCATORS:
return ST_OMP_ALLOCATORS;
case EXEC_OMP_ASSUME:
return ST_OMP_ASSUME;
case EXEC_OMP_ATOMIC:
@ -10188,6 +10469,8 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_TEAMS_LOOP:
resolve_omp_do (code);
break;
case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_ERROR:

184
gcc/fortran/parse.cc
View file

@ -39,6 +39,7 @@ static jmp_buf eof_buf;
gfc_state_data *gfc_state_stack;
static bool last_was_use_stmt = false;
bool in_exec_part;
/* TODO: Re-order functions to kill these forward decls. */
static void check_statement_label (gfc_statement);
@ -745,6 +746,82 @@ decode_oacc_directive (void)
return ST_GET_FCN_CHARACTERISTICS;
}
/* Checks for the ST_OMP_ALLOCATE. First, check whether all list items
are allocatables/pointers - and if so, assume it is associated with a Fortran
ALLOCATE stmt. If not, do some initial parsing-related checks and append
namelist to namespace.
The check follows OpenMP 5.1 by requiring an executable stmt or OpenMP
construct before a directive associated with an allocate statement
(-> ST_OMP_ALLOCATE_EXEC); instead of showing an error, conversion of
ST_OMP_ALLOCATE -> ST_OMP_ALLOCATE_EXEC would be an alternative. */
bool
check_omp_allocate_stmt (locus *loc)
{
gfc_omp_namelist *n;
if (new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
{
gfc_error ("%qs directive at %L must either have a variable argument or, "
"if associated with an ALLOCATE stmt, must be preceded by an "
"executable statement or OpenMP construct",
gfc_ascii_statement (ST_OMP_ALLOCATE), loc);
return false;
}
bool has_allocatable = false;
bool has_non_allocatable = false;
for (n = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
{
if (n->expr)
{
gfc_error ("Structure-component expression at %L in %qs directive not"
" permitted in declarative directive; as directive "
"associated with an ALLOCATE stmt it must be preceded by "
"an executable statement or OpenMP construct",
&n->expr->where, gfc_ascii_statement (ST_OMP_ALLOCATE));
return false;
}
bool alloc_ptr;
if (n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok)
alloc_ptr = (CLASS_DATA (n->sym)->attr.allocatable
|| CLASS_DATA (n->sym)->attr.class_pointer);
else
alloc_ptr = (n->sym->attr.allocatable || n->sym->attr.pointer
|| n->sym->attr.proc_pointer);
if (alloc_ptr
|| (n->sym->ns && n->sym->ns->proc_name
&& (n->sym->ns->proc_name->attr.allocatable
|| n->sym->ns->proc_name->attr.pointer
|| n->sym->ns->proc_name->attr.proc_pointer)))
has_allocatable = true;
else
has_non_allocatable = true;
}
/* All allocatables - assume it is allocated with an ALLOCATE stmt. */
if (has_allocatable && !has_non_allocatable)
{
gfc_error ("%qs directive at %L associated with an ALLOCATE stmt must be "
"preceded by an executable statement or OpenMP construct; "
"note the variables in the list all have the allocatable or "
"pointer attribute", gfc_ascii_statement (ST_OMP_ALLOCATE),
loc);
return false;
}
if (!gfc_current_ns->omp_allocate)
gfc_current_ns->omp_allocate
= new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
else
{
for (n = gfc_current_ns->omp_allocate; n->next; n = n->next)
;
n->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
}
new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
gfc_free_omp_clauses (new_st.ext.omp_clauses);
return true;
}
/* Like match, but set a flag simd_matched if keyword matched
and if spec_only, goto do_spec_only without actually matching. */
#define matchs(keyword, subr, st) \
@ -885,6 +962,11 @@ decode_omp_directive (void)
switch (c)
{
case 'a':
if (in_exec_part)
matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE_EXEC);
else
matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE);
matcho ("allocators", gfc_match_omp_allocators, ST_OMP_ALLOCATORS);
/* For -fopenmp-simd, ignore 'assumes'; note no clause starts with 's'. */
if (!flag_openmp && gfc_match ("assumes") == MATCH_YES)
break;
@ -918,6 +1000,7 @@ decode_omp_directive (void)
break;
case 'e':
matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS);
matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
@ -1174,6 +1257,9 @@ decode_omp_directive (void)
return ST_NONE;
}
}
if (ret == ST_OMP_ALLOCATE && !check_omp_allocate_stmt (&old_locus))
goto error_handling;
switch (ret)
{
/* Set omp_target_seen; exclude ST_OMP_DECLARE_TARGET.
@ -1723,7 +1809,7 @@ next_statement (void)
case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
case ST_OMP_ASSUME: \
case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \
case ST_CRITICAL: \
case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
@ -1741,7 +1827,7 @@ next_statement (void)
#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
case ST_OMP_DECLARE_VARIANT: case ST_OMP_ASSUMES: \
case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \
case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* Block end statements. Errors associated with interchanging these
@ -2362,6 +2448,13 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
case ST_OACC_END_ATOMIC:
p = "!$ACC END ATOMIC";
break;
case ST_OMP_ALLOCATE:
case ST_OMP_ALLOCATE_EXEC:
p = "!$OMP ALLOCATE";
break;
case ST_OMP_ALLOCATORS:
p = "!$OMP ALLOCATORS";
break;
case ST_OMP_ASSUME:
p = "!$OMP ASSUME";
break;
@ -2416,6 +2509,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
case ST_OMP_DO_SIMD:
p = "!$OMP DO SIMD";
break;
case ST_OMP_END_ALLOCATORS:
p = "!$OMP END ALLOCATORS";
break;
case ST_OMP_END_ASSUME:
p = "!$OMP END ASSUME";
break;
@ -2983,6 +3079,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
{
case ST_NONE:
p->state = ORDER_START;
in_exec_part = false;
break;
case ST_USE:
@ -3056,6 +3153,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
case_exec_markers:
if (p->state < ORDER_EXEC)
p->state = ORDER_EXEC;
in_exec_part = true;
break;
default:
@ -5532,6 +5630,77 @@ parse_oacc_loop (gfc_statement acc_st)
}
/* Parse an OpenMP allocate block, including optional ALLOCATORS
end directive. */
static gfc_statement
parse_openmp_allocate_block (gfc_statement omp_st)
{
gfc_statement st;
gfc_code *cp, *np;
gfc_state_data s;
bool empty_list = false;
locus empty_list_loc;
gfc_omp_namelist *n_first = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
if (omp_st == ST_OMP_ALLOCATE_EXEC
&& new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
{
empty_list = true;
empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
}
accept_statement (omp_st);
cp = gfc_state_stack->tail;
push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
np = new_level (cp);
np->op = cp->op;
np->block = NULL;
st = next_statement ();
while (omp_st == ST_OMP_ALLOCATE_EXEC && st == ST_OMP_ALLOCATE_EXEC)
{
if (empty_list && !new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
{
locus *loc = &new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
gfc_error_now ("%s statements at %L and %L have both no list item but"
" only one may", gfc_ascii_statement (st),
&empty_list_loc, loc);
empty_list = false;
}
if (!new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
{
empty_list = true;
empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
}
for ( ; n_first->next; n_first = n_first->next)
;
n_first->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
gfc_free_omp_clauses (new_st.ext.omp_clauses);
accept_statement (ST_NONE);
st = next_statement ();
}
if (st != ST_ALLOCATE && omp_st == ST_OMP_ALLOCATE_EXEC)
gfc_error_now ("Unexpected %s at %C; expected ALLOCATE or %s statement",
gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
else if (st != ST_ALLOCATE)
gfc_error_now ("Unexpected %s at %C; expected ALLOCATE statement after %s",
gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
accept_statement (st);
pop_state ();
st = next_statement ();
if (omp_st == ST_OMP_ALLOCATORS && st == ST_OMP_END_ALLOCATORS)
{
accept_statement (st);
st = next_statement ();
}
return st;
}
/* Parse the statements of an OpenMP structured block. */
static gfc_statement
@ -5687,6 +5856,11 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
parse_forall_block ();
break;
case ST_OMP_ALLOCATE_EXEC:
case ST_OMP_ALLOCATORS:
st = parse_openmp_allocate_block (st);
continue;
case ST_OMP_ASSUME:
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_MASKED:
@ -5819,6 +5993,7 @@ static gfc_statement
parse_executable (gfc_statement st)
{
int close_flag;
in_exec_part = true;
if (st == ST_NONE)
st = next_statement ();
@ -5929,6 +6104,11 @@ parse_executable (gfc_statement st)
parse_oacc_structured_block (st);
break;
case ST_OMP_ALLOCATE_EXEC:
case ST_OMP_ALLOCATORS:
st = parse_openmp_allocate_block (st);
continue;
case ST_OMP_ASSUME:
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_MASKED:

6
gcc/fortran/resolve.cc
View file

@ -11044,6 +11044,8 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
case EXEC_OACC_ROUTINE:
case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DISTRIBUTE:
@ -12712,6 +12714,8 @@ start:
gfc_resolve_oacc_directive (code, ns);
break;
case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
@ -18007,6 +18011,8 @@ resolve_codes (gfc_namespace *ns)
gfc_resolve_oacc_declare (ns);
gfc_resolve_oacc_routines (ns);
gfc_resolve_omp_local_vars (ns);
if (ns->omp_allocate)
gfc_resolve_omp_allocate (ns, ns->omp_allocate);
gfc_resolve_code (ns->code, ns);
bitmap_obstack_release (&labels_obstack);

2
gcc/fortran/st.cc
View file

@ -214,6 +214,8 @@ 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_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:

11
gcc/fortran/trans-openmp.cc
View file

@ -2748,11 +2748,11 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
tree node = build_omp_clause (input_location,
OMP_CLAUSE_ALLOCATE);
OMP_CLAUSE_DECL (node) = t;
if (n->expr)
if (n->u2.allocator)
{
tree allocator_;
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, n->expr);
gfc_conv_expr (&se, n->u2.allocator);
allocator_ = gfc_evaluate_now (se.expr, block);
OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
}
@ -6861,6 +6861,8 @@ gfc_split_omp_clauses (gfc_code *code,
p = gfc_get_omp_namelist ();
p->sym = alloc_nl->sym;
p->expr = alloc_nl->expr;
p->u.align = alloc_nl->u.align;
p->u2.allocator = alloc_nl->u2.allocator;
p->where = alloc_nl->where;
if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL)
{
@ -7912,6 +7914,11 @@ gfc_trans_omp_directive (gfc_code *code)
{
switch (code->op)
{
case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ALLOCATORS:
sorry ("%<!$OMP %s%> not yet supported",
code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS");
return NULL_TREE;
case EXEC_OMP_ASSUME:
return gfc_trans_omp_assume (code);
case EXEC_OMP_ATOMIC:

2
gcc/fortran/trans.cc
View file

@ -2453,6 +2453,8 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_dt_end (code);
break;
case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:

4
gcc/testsuite/gfortran.dg/gomp/allocate-2.f90
View file

@ -25,11 +25,11 @@ subroutine foo(x)
x=3
!$omp end parallel
!$omp parallel private (x) allocate (x) allocate (x) ! { dg-warning "'x' appears more than once in 'allocate' clauses at .1." }
!$omp parallel private (x) allocate (x) allocate (x) ! { dg-warning "'x' appears more than once in 'allocate' at .1." }
x=4
!$omp end parallel
!$omp parallel private (x) allocate (x, x) ! { dg-warning "'x' appears more than once in 'allocate' clauses at .1." }
!$omp parallel private (x) allocate (x, x) ! { dg-warning "'x' appears more than once in 'allocate' at .1." }
x=5
!$omp end parallel

54
gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 Normal file
View file

@ -0,0 +1,54 @@
module my_omp_lib
use iso_c_binding, only: c_intptr_t
!use omp_lib
implicit none
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 my_omp_lib
subroutine one(n, my_alloc)
use my_omp_lib
implicit none
integer :: n
integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
!stack variables:
integer :: a,b,c(n),d(5),e(2)
!$omp allocate(a) ! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" }
!$omp allocate ( b , c ) align ( 32) allocator (my_alloc)
!$omp allocate (d) align( 128 )
!$omp allocate( e ) allocator( omp_high_bw_mem_alloc )
!saved vars
integer, save :: k,l,m(5),r(2)
!$omp allocate(k) align(16) , allocator (omp_large_cap_mem_alloc)
!$omp allocate ( l ) allocator (omp_large_cap_mem_alloc) , align ( 32)
!$omp allocate (m) align( 128 ),allocator( omp_high_bw_mem_alloc )
!$omp allocate( r ) allocator( omp_high_bw_mem_alloc )
!common /block/
integer :: q,x,y(2),z(5)
common /com1/ q,x
common /com2/ y,z
!$omp allocate ( / com1/) align( 128 ) allocator( omp_high_bw_mem_alloc )
!$omp allocate(/com2 / ) allocator( omp_high_bw_mem_alloc )
end

93
gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 Normal file
View file

@ -0,0 +1,93 @@
module my_omp_lib
use iso_c_binding, only: c_intptr_t
!use omp_lib
implicit none
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
type t
integer :: a
end type t
end module my_omp_lib
subroutine zero()
!$omp assumes absent (allocators)
!$omp assume absent (allocators)
!$omp end assume
end
subroutine two(c,x2,y2)
use my_omp_lib
implicit none
integer, allocatable :: a, b(:), c(:,:)
type(t), allocatable :: x1
type(t), pointer :: x2(:)
class(t), allocatable :: y1
class(t), pointer :: y2(:)
!$omp flush ! some executable statement
!$omp allocate(a) ! { dg-message "not yet supported" }
allocate(a,b(4),c(3,4))
deallocate(a,b,c)
!$omp allocate(x1,y1,x2,y2) ! { dg-message "not yet supported" }
allocate(x1,y1,x2(5),y2(5))
deallocate(x1,y1,x2,y2)
!$omp allocate(b,a) align ( 128 ) ! { dg-message "not yet supported" }
!$omp allocate align ( 64 )
allocate(a,b(4),c(3,4))
deallocate(a,b,c)
end
subroutine three(c)
use my_omp_lib
implicit none
integer :: q
integer, allocatable :: a, b(:), c(:,:)
call foo() ! executable stmt
!$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64) ! { dg-message "not yet supported" }
!$omp allocate(b) allocator( omp_high_bw_mem_alloc )
!$omp allocate(c) allocator( omp_high_bw_mem_alloc )
allocate(a,b(4),c(3,4))
deallocate(a,b,c)
block
q = 5 ! executable stmt
!$omp allocate(a) align(64) ! { dg-message "not yet supported" }
!$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
!$omp allocate(c) allocator( omp_thread_mem_alloc )
allocate(a,b(4),c(3,4))
deallocate(a,b,c)
end block
call inner
contains
subroutine inner
call foo() ! executable stmt
!$omp allocate(a) align(64) ! { dg-message "not yet supported" }
!$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
!$omp allocate(c) allocator( omp_thread_mem_alloc )
allocate(a,b(4),c(3,4))
deallocate(a,b,c)
end subroutine inner
end

103
gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 Normal file
View file

@ -0,0 +1,103 @@
module my_omp_lib
use iso_c_binding, only: c_intptr_t
!use omp_lib
implicit none
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
type t
integer,allocatable :: a
integer,pointer :: b(:,:)
end type t
end module my_omp_lib
subroutine zero()
!$omp assumes absent (allocate) ! { dg-error "Invalid 'ALLOCATE' directive at .1. in ABSENT clause: declarative, informational and meta directives not permitted" }
!$omp assume absent (allocate) ! { dg-error "Invalid 'ALLOCATE' directive at .1. in ABSENT clause: declarative, informational and meta directives not permitted" }
!!$omp end assume
end
subroutine alloc(c,x2,y2)
use my_omp_lib
implicit none
integer, allocatable :: a, b(:), c(:,:)
type(t) :: x1,x2
class(t) :: y1,y2
allocatable :: x1, y1
!$omp flush ! some executable statement
!$omp allocate(x2%a,x2%b,y2%a,y2%b) allocator(omp_pteam_mem_alloc) align(64) ! { dg-error "Sorry, structure-element list item at .1. in ALLOCATE directive is not yet supported" }
allocate(x2%a,x2%b(3,4),y2%a,y2%b(3,4))
!$omp allocate(b(3)) align ( 64 ) ! { dg-error "Unexpected expression as list item at .1. in ALLOCATE directive" }
allocate(b(3))
end
subroutine one(n, my_alloc)
use my_omp_lib
implicit none
integer :: n
integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
integer :: a,b,c(n),d(5),e(2)
integer, save :: k,l,m(5),r(2)
integer :: q,x,y(2),z(5)
common /com1/ q,x
common /com2/ y,z
integer, allocatable :: alloc
integer, pointer :: ptr
!$omp allocate(q) ! { dg-error "'q' at .1. is part of the common block '/com1/' and may only be specificed implicitly via the named common block" }
!$omp allocate(d(:)) ! { dg-error "Unexpected expression as list item at .1. in ALLOCATE directive" }
!$omp allocate(a) align(4), align(4) ! { dg-error "Duplicated 'align' clause" }
!$omp allocate( e ) allocator( omp_high_bw_mem_alloc ), align(32),allocator( omp_high_bw_mem_alloc ) ! { dg-error "Duplicated 'allocator' clause" }
!$omp allocate align(32) ! { dg-error "'!.OMP ALLOCATE' directive at .1. must either have a variable argument or, if associated with an ALLOCATE stmt, must be preceded by an executable statement or OpenMP construct" }
!$omp allocate(alloc) align(128) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" }
!$omp allocate(ptr) align(128) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" }
!$omp allocate(e) allocate(omp_thread_mem_alloc) ! { dg-error "Expected ALIGN or ALLOCATOR clause" }
end
subroutine two()
integer, allocatable :: a,b,c
call foo()
!$omp allocate(a)
a = 5 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
!$omp allocate ! { dg-error "!.OMP ALLOCATE statements at .1. and .2. have both no list item but only one may" }
!$omp allocate(b)
!$omp allocate ! { dg-error "!.OMP ALLOCATE statements at .1. and .2. have both no list item but only one may" }
allocate(a,b,c)
!$omp allocate
allocate(a,b,c) ! allocate is no block construct, hence:
!$omp end allocate ! { dg-error "Unclassifiable OpenMP directive" }
!$omp allocators allocate(align(64) : a, b)
!$omp allocators allocate(align(128) : c) ! { dg-error "Unexpected !.OMP ALLOCATORS at .1.; expected ALLOCATE statement after !.OMP ALLOCATORS" }
allocate(a,b,c)
end

231
gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 Normal file
View file

@ -0,0 +1,231 @@
! { dg-additional-options "-fmax-errors=1000" }
module my_omp_lib
use iso_c_binding, only: c_intptr_t
!use omp_lib
implicit none
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
type t
integer,allocatable :: a
integer,pointer :: b(:,:)
end type t
integer :: used
end module my_omp_lib
subroutine one(n, my_alloc)
use my_omp_lib
implicit none
integer :: n
integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
integer :: a,b,c(n),d(5),e(2)
integer, save :: k,l,m(5),r(2)
integer :: q,x,y(2),z(5)
common /com1/ q,x
common /com2/ y,z
integer, allocatable :: alloc
integer, pointer :: ptr
integer, parameter :: prm=5
!$omp allocate(prm) align(64) ! { dg-error "Argument 'prm' at .1. to declarative !.OMP ALLOCATE directive must be a variable" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate(used) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'used' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
!$omp allocate(n) allocator(omp_pteam_mem_alloc) ! { dg-error "Unexpected dummy argument 'n' as argument at .1. to declarative !.OMP ALLOCATE" }
!$omp allocate (x) align(128) ! { dg-error "'x' at .1. is part of the common block '/com1/' and may only be specificed implicitly via the named common block" }
!$omp allocate (a, b, a) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'a' in !.OMP ALLOCATE" }
contains
subroutine inner
!$omp allocate(a) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'a' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
end
end
subroutine three(n)
use my_omp_lib
implicit none
integer,value :: n
integer :: a,b,c(n),d(5),e(2)
integer, save :: k,l,m(5)
integer :: q,x,y(2),z(5),r
common /com4/ y,z
allocatable :: q
pointer :: b
!$omp allocate (c, d) allocator (omp_pteam_mem_alloc)
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc)
!$omp allocate (c) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE" }
!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated common block '/com4/' in !.OMP ALLOCATE" }
!$omp allocate(q,x) ! { dg-error "Unexpected allocatable variable 'q' at .1. in declarative !.OMP ALLOCATE directive" }
!$omp allocate(b,e) ! { dg-error "Unexpected pointer variable 'b' at .1. in declarative !.OMP ALLOCATE directive" }
end
subroutine four(n)
integer :: qq, rr, ss, tt, uu, vv,n
!$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
!$omp allocate (uu) align(31) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
end
subroutine five(n,my_alloc)
use my_omp_lib
implicit none
integer :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
!$omp allocate (tt) allocator(my_alloc) ! OK
end
subroutine five_SaveAll(n,my_alloc)
use my_omp_lib
implicit none
save
integer :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
end
subroutine five_Save(n,my_alloc)
use my_omp_lib
implicit none
integer :: n
integer, save :: qq, rr, ss, tt, uu, vv
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
end
module five_Module
use my_omp_lib
implicit none
integer, save :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
end module
program five_program
use my_omp_lib
implicit none
integer, save :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
end program
subroutine six(n,my_alloc)
use my_omp_lib
implicit none
integer :: qq, rr, ss, tt, uu, vv,n
common /com6qq/ qq
common /com6rr/ rr
common /com6ss/ ss
common /com6tt/ tt
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (/com6qq/) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6qq/' at .2. has the SAVE attribute" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (/com6rr/) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6rr/' at .2. has the SAVE attribute" }
!$omp allocate (/com6ss/) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6ss/' at .2. has the SAVE attribute" }
!$omp allocate (/com6tt/) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6tt/' at .2. has the SAVE attribute" }
end
subroutine two()
use my_omp_lib
implicit none
integer,allocatable :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
call foo()
!$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
allocate(qq)
!$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
allocate(rr)
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
allocate(ss)
!$omp allocate (tt) allocator(my_alloc) ! OK
allocate(tt)
end
subroutine two_ptr()
use my_omp_lib
implicit none
integer,pointer :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
call foo()
!$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
allocate(qq)
!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
allocate(rr)
!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
allocate(ss)
!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
allocate(tt)
!$omp allocate (uu) align(31) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
allocate(uu)
end
subroutine next()
use my_omp_lib
implicit none
integer,allocatable :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate(qq) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" }
allocate(qq,rr)
!$omp allocate(uu,tt)
!$omp allocate(tt) ! { dg-warning "'tt' appears more than once in 'allocate" }
allocate(uu,tt)
!$omp allocate(uu,vv) ! { dg-error "'uu' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
allocate(vv)
end

28
gcc/testsuite/gfortran.dg/gomp/allocators-1.f90 Normal file
View file

@ -0,0 +1,28 @@
implicit none
integer, allocatable :: a, b
integer :: q
integer :: arr(2)
!$omp allocators allocate(align(64): a)
block ! { dg-error "expected ALLOCATE statement after !.OMP ALLOCATORS" }
end block ! { dg-error "Expecting END PROGRAM statement" }
!$omp allocators allocate(align(64): a)
allocate(a, b) ! OK
!$omp end allocators
!$omp allocators allocate(align(128): b)
allocate(a, b) ! OK (assuming not allocated)
!$omp allocators allocate(align(64): a)
allocate(a, b, stat=arr) ! { dg-error "Stat-variable at .1. must be a scalar INTEGER variable" }
!$omp end allocators
!$omp allocators allocate(align(64): a)
allocate(q) ! { dg-error "is neither a data pointer nor an allocatable variable" }
!$omp end allocators ! { dg-error "Unexpected !.OMP END ALLOCATORS" }
end

22
gcc/testsuite/gfortran.dg/gomp/allocators-2.f90 Normal file
View file

@ -0,0 +1,22 @@
implicit none
integer, allocatable :: a, b
integer :: q
integer :: arr(2)
!$omp allocators allocate(align(64): a)
allocate(a, b) ! OK
!$omp end allocators
!$omp allocators allocate(align(128): b)
allocate(a, b) ! OK (assuming not allocated)
!$omp allocators allocate(align(62.0): a) ! { dg-error "a scalar positive constant integer alignment expression" }
allocate(a)
!$omp allocators allocate(align(64): a, b) ! { dg-error "'b' specified in 'allocate' at \\(1\\) but not in the associated ALLOCATE statement" }
allocate(a)
!$omp end allocators
end

12
libgomp/testsuite/libgomp.fortran/allocate-4.f90
View file

@ -16,27 +16,27 @@ integer, parameter :: cnst(2) = [64, 101]
!$omp parallel allocate( allocator (omp_high_bw_mem_alloc) : x) firstprivate(x) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
!$omp end parallel
!$omp parallel allocate( align (q) : x) firstprivate(x) ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
!$omp parallel allocate( align (q) : x) firstprivate(x) ! { dg-error "32:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
!$omp parallel allocate( align (32) : x) firstprivate(x) ! OK
!$omp end parallel
!$omp parallel allocate( align(q) : x) firstprivate(x) ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
!$omp parallel allocate( align(q) : x) firstprivate(x) ! { dg-error "31:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
!$omp parallel allocate( align(cnst(1)) : x ) firstprivate(x) ! OK
!$omp end parallel
!$omp parallel allocate( align(cnst(2)) : x) firstprivate(x) ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
!$omp parallel allocate( align(cnst(2)) : x) firstprivate(x) ! { dg-error "31:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
!$omp parallel allocate( align( 31) :x) firstprivate(x) ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
!$omp parallel allocate( align( 31) :x) firstprivate(x) ! { dg-error "32:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
!$omp parallel allocate( align (32.0): x) firstprivate(x) ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
!$omp parallel allocate( align (32.0): x) firstprivate(x) ! { dg-error "32:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
!$omp parallel allocate( align(cnst ) : x ) firstprivate(x) ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
!$omp parallel allocate( align(cnst ) : x ) firstprivate(x) ! { dg-error "31:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
end