git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

OpenMP/Fortran: Merge upstream 'omp allocators' with OG13 'omp allocate' 

This merges mainline's
  r14-1301-gd64e8e1224708e
  Fortran/OpenMP: Add parsing support for allocators/allocate directives
into OG13.

In theory, that just replaces (reverts) the OG13-only commit
  6ce5ee77f7 Add parsing support for allocate directive (OpenMP 5.0)
  by Hafiz Abid Qadeer  <abidh@codesourcery.com>

However, the replacement is not full - thus, this commit does much more:
  While mainline support 'omp allocators' besides 'omp allocate' and
  the latter also for stack and pointer variables,
  the OG13 branch supports actual allocation with the directive version.
* Thus, this commit wires the mainline's executive allocate + new allocators
  with the OG13 GOMP_alloc/GOMP_free handling.
* It also handles now the 'align' clause/modifier.
* By defaulting to 'omp allocators', it re-uses the ALLOCATE clause in the
  ME instead of using the new ALLOCATOR clause, which has now been removed
  from the ME code.

On the FE side, it also includes a modified version of:
  https://gcc.gnu.org/pipermail/gcc-patches/2023-October/634096.html
  [Patch] OpenMP/Fortran: Handle unlisted items in 'omp allocators' + exec. 'omp allocate'

The whole patch cannot be easily disentangled and parts of
6ce5ee77f7 remain in a revised form. For those bits, the
credits belong to Abid.

gcc/fortran/ChangeLog:

	* dump-parse-tree.cc (show_omp_namelist, show_omp_node,
	show_code_node): Dump EXEC_OMP_ALLOCATORS update for struct changes.
	* gfortran.h (enum gfc_statement): Add ST_OMP_(END_)ALLOCATORS.
	(gfc_omp_namelist): Add allocator to union u2.
	(enum): Remove OMP_LIST_ALLOCATOR.
	(gfc_namespace): Add omp_allocate.
	(enum gfc_exec_op): Add EXEC_OMP_ALLOCATORS.
	(gfc_resolve_omp_allocate): New prototype.
	* match.cc (gfc_free_omp_namelist): Free u2.allocator.
	* match.h (gfc_match_omp_allocators): New prototype.
	* openmp.cc (gfc_omp_directives): Enable allocate/allocator.
	(gfc_match_omp_variable_list): Add reject_common_vars Boolean arg.
	(enum omp_mask2): Remove OMP_CLAUSE_ALLOCATOR.
	(gfc_match_omp_clauses): Update for struct change.
	(OMP_ALLOCATE_CLAUSES): Remove.
	(OMP_ALLOCATORS_CLAUSES): Add.
	(gfc_match_omp_allocate): Replace by upstream version.
	(gfc_match_omp_allocators, is_predefined_allocator,
	gfc_resolve_omp_allocate): New.
	(verify_omp_clauses_symbol_dups): Update for allocate/allocator.
	(resolve_omp_clauses): Update from mainline.
	(omp_code_to_statement): Add EXEC_OMP_ALLOCATORS.
	prepare_omp_allocated_var_list_for_cleanup,
	check_allocate_directive_restrictions, EMPTY_VAR_LIST,
	gfc_resolve_omp_allocate): Remove.
	(gfc_resolve_omp_directive): Add EXEC_OMP_ALLOCATORS.
	* parse.cc (check_omp_allocate_stmt, decode_omp_directive
	next_statement, case_omp_decl, gfc_ascii_statement,
	verify_st_order, parse_openmp_allocate_block,
	parse_omp_structured_block, parse_executable): Update from mainline.
	* resolve.cc (gfc_resolve_blocks, resolve_codes): Handle allocate
	and allocator.
	* st.cc (gfc_free_statement): And EXEC_OMP_ALLOCATORS.
	* trans-decl.cc (gfc_trans_deferred_vars): Use OMP_LIST_ALLOCATE
	instead of OMP_LIST_ALLOCATOR.
	* trans-openmp.cc (gfc_trans_omp_clauses): Remove OMP_LIST_ALLOCATOR,
	update allocate handling.
	(gfc_trans_omp_allocate): Renamed to ...
	(gfc_trans_omp_allocators): ... this.
	(gfc_split_omp_clauses, gfc_trans_omp_directive): Update.
	* trans.cc (trans_code): Handle EXEC_OMP_ALLOCATORS.

gcc/ChangeLog:

	* omp-low.cc (scan_sharing_clauses): Update message for directive use.
	(lower_omp_allocate, lower_omp_1): Update for clause changes; handle
	alignment.
	* tree-core.h (enum omp_clause_code): Remove OMP_CLAUSE_ALLOCATOR.
	* tree-pretty-print.cc (dump_omp_clause): Likewise.
	* tree.cc (omp_clause_num_ops): Likewise.
	* tree.h (OMP_ALLOCATE_DECL, OMP_ALLOCATE_ALLOCATOR): Remove.

libgomp/ChangeLog:

	* testsuite/libgomp.fortran/allocate-2a.f90: Add exec stmt.
	* testsuite/libgomp.fortran/allocate-4.f90: Update dg-error
	* testsuite/libgomp.fortran/allocate-5.f90: Likewise; add exec stmt.

gcc/testsuite/ChangeLog:

	* gfortran.dg/gomp/allocate-2.f90: Update dg-warning.
	* gfortran.dg/gomp/allocate-4.f90: New upstream test.
	* gfortran.dg/gomp/allocate-5.f90: New upstream test.
	* gfortran.dg/gomp/allocate-6.f90: New upstream test.
	* gfortran.dg/gomp/allocate-7.f90: New upstream test.
	* gfortran.dg/gomp/allocate-4a.f90: Renamed from allocate-4.f90
	* gfortran.dg/gomp/allocate-6a.f90: Renamed from allocate-6.f90
	* gfortran.dg/gomp/allocate-7a.f90: Renamed from allocate-7.f90
	* gfortran.dg/gomp/allocate-9a.f90: New test.
	* gfortran.dg/gomp/allocators-1.f90: New upstream test.
	* gfortran.dg/gomp/allocators-2.f90: New upstream test.
This commit is contained in:
Tobias Burnus 2023-10-26 11:17:40 +02:00
parent d56305c421
commit a8b1fb51ae
35 changed files with 1489 additions and 525 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/ChangeLog.omp
View File

@ -1,3 +1,14 @@
2023-10-26 Tobias Burnus <tobias@codesourcery.com>
Chung-Lin Tang <cltang@codesourcery.com>
* omp-low.cc (scan_sharing_clauses): Update message for directive use.
(lower_omp_allocate, lower_omp_1): Update for clause changes; handle
alignment.
* tree-core.h (enum omp_clause_code): Remove OMP_CLAUSE_ALLOCATOR.
* tree-pretty-print.cc (dump_omp_clause): Likewise.
* tree.cc (omp_clause_num_ops): Likewise.
* tree.h (OMP_ALLOCATE_DECL, OMP_ALLOCATE_ALLOCATOR): Remove.
2023-09-20 Tobias Burnus <tobias@codesourcery.com>
Backported from master:

45
gcc/fortran/ChangeLog.omp
View File

@ -1,3 +1,48 @@
2023-10-26 Tobias Burnus <tobias@codesourcery.com>
Chung-Lin Tang <cltang@codesourcery.com>
* dump-parse-tree.cc (show_omp_namelist, show_omp_node,
show_code_node): Dump EXEC_OMP_ALLOCATORS update for struct changes.
* gfortran.h (enum gfc_statement): Add ST_OMP_(END_)ALLOCATORS.
(gfc_omp_namelist): Add allocator to union u2.
(enum): Remove OMP_LIST_ALLOCATOR.
(gfc_namespace): Add omp_allocate.
(enum gfc_exec_op): Add EXEC_OMP_ALLOCATORS.
(gfc_resolve_omp_allocate): New prototype.
* match.cc (gfc_free_omp_namelist): Free u2.allocator.
* match.h (gfc_match_omp_allocators): New prototype.
* openmp.cc (gfc_omp_directives): Enable allocate/allocator.
(gfc_match_omp_variable_list): Add reject_common_vars Boolean arg.
(enum omp_mask2): Remove OMP_CLAUSE_ALLOCATOR.
(gfc_match_omp_clauses): Update for struct change.
(OMP_ALLOCATE_CLAUSES): Remove.
(OMP_ALLOCATORS_CLAUSES): Add.
(gfc_match_omp_allocate): Replace by upstream version.
(gfc_match_omp_allocators, is_predefined_allocator,
gfc_resolve_omp_allocate): New.
(verify_omp_clauses_symbol_dups): Update for allocate/allocator.
(resolve_omp_clauses): Update from mainline.
(omp_code_to_statement): Add EXEC_OMP_ALLOCATORS.
prepare_omp_allocated_var_list_for_cleanup,
check_allocate_directive_restrictions, EMPTY_VAR_LIST,
gfc_resolve_omp_allocate): Remove.
(gfc_resolve_omp_directive): Add EXEC_OMP_ALLOCATORS.
* parse.cc (check_omp_allocate_stmt, decode_omp_directive
next_statement, case_omp_decl, gfc_ascii_statement,
verify_st_order, parse_openmp_allocate_block,
parse_omp_structured_block, parse_executable): Update from mainline.
* resolve.cc (gfc_resolve_blocks, resolve_codes): Handle allocate
and allocator.
* st.cc (gfc_free_statement): And EXEC_OMP_ALLOCATORS.
* trans-decl.cc (gfc_trans_deferred_vars): Use OMP_LIST_ALLOCATE
instead of OMP_LIST_ALLOCATOR.
* trans-openmp.cc (gfc_trans_omp_clauses): Remove OMP_LIST_ALLOCATOR,
update allocate handling.
(gfc_trans_omp_allocate): Renamed to ...
(gfc_trans_omp_allocators): ... this.
(gfc_split_omp_clauses, gfc_trans_omp_directive): Update.
* trans.cc (trans_code): Handle EXEC_OMP_ALLOCATORS.
2023-10-16 Tobias Burnus <tobias@codesourcery.com>
Backported from master:

9
gcc/fortran/dump-parse-tree.cc
View File

@ -1364,14 +1364,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);
}
@ -2137,6 +2137,7 @@ show_omp_node (int level, gfc_code *c)
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;
@ -2242,6 +2243,8 @@ show_omp_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_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
@ -2345,7 +2348,6 @@ 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)
@ -3492,6 +3494,7 @@ show_code_node (int level, gfc_code *c)
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:

14
gcc/fortran/gfortran.h
View File

@ -260,7 +260,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_OMP_ALLOCATE,
ST_OACC_ATOMIC, ST_OACC_END_ATOMIC,
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,
@ -320,6 +320,8 @@ enum gfc_statement
ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
ST_OMP_METADIRECTIVE, ST_OMP_BEGIN_METADIRECTIVE, ST_OMP_END_METADIRECTIVE,
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,
ST_OMP_UNROLL, ST_OMP_END_UNROLL,
@ -1387,6 +1389,7 @@ typedef struct gfc_omp_namelist
struct gfc_omp_namelist_udr *udr;
struct gfc_omp_namelist_udm *udm;
gfc_namespace *ns;
gfc_expr *allocator;
struct gfc_omp_namelist *duplicate_of;
} u2;
struct gfc_symbol *memspace_sym;
@ -1431,7 +1434,6 @@ enum
OMP_LIST_USE_DEVICE_ADDR,
OMP_LIST_NONTEMPORAL,
OMP_LIST_ALLOCATE,
OMP_LIST_ALLOCATOR,
OMP_LIST_HAS_DEVICE_ADDR,
OMP_LIST_ENTER,
OMP_LIST_USES_ALLOCATORS,
@ -2257,8 +2259,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. */
@ -3027,7 +3030,6 @@ 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,
@ -3058,7 +3060,8 @@ 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_METADIRECTIVE, EXEC_OMP_UNROLL, EXEC_OMP_TILE, EXEC_OMP_ERROR
EXEC_OMP_METADIRECTIVE, EXEC_OMP_UNROLL, EXEC_OMP_TILE, EXEC_OMP_ERROR,
EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS
};
typedef struct gfc_code
@ -3712,6 +3715,7 @@ void gfc_free_omp_udr (gfc_omp_udr *);
void gfc_free_omp_metadirective_clauses (gfc_omp_metadirective_clause *);
void gfc_free_omp_udm (gfc_omp_udm *);
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 *);
gfc_omp_udm *gfc_omp_udm_find (gfc_symtree *, gfc_typespec *);
gfc_omp_udm *gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id,

2
gcc/fortran/match.cc
View File

@ -5554,6 +5554,8 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, int list)
gfc_free_namespace (name->u2.ns);
else if (free_mapper && name->u2.udm)
free (name->u2.udm);
else if (free_align)
gfc_free_expr (name->u2.allocator);
else if (!free_mapper && name->u2.udr)
{
if (name->u2.udr->combiner)

1
gcc/fortran/match.h
View File

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

704
gcc/fortran/openmp.cc
View File

@ -56,8 +56,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},
@ -430,7 +430,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;
@ -518,6 +519,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;
@ -1187,7 +1197,6 @@ enum omp_mask2
OMP_CLAUSE_FINALIZE,
OMP_CLAUSE_ATTACH,
OMP_CLAUSE_NOHOST,
OMP_CLAUSE_ALLOCATOR,
OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
@ -2643,7 +2652,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);
@ -5031,7 +5041,6 @@ 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 \
@ -5123,6 +5132,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)
#define OMP_UNROLL_CLAUSES \
(omp_mask (OMP_CLAUSE_UNROLL_FULL) | OMP_CLAUSE_UNROLL_PARTIAL)
#define OMP_TILE_CLAUSES \
@ -5140,6 +5151,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, OMP_LIST_ALLOCATE);
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)
@ -7656,66 +7774,6 @@ gfc_match_omp_ordered_depend (void)
return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
}
/* 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;
new_st.resolved_sym = NULL;
gfc_free_expr (allocator);
return MATCH_YES;
}
/* omp atomic [clause-list]
- atomic-clause: read | write | update
- capture
@ -8170,6 +8228,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. */
@ -8457,28 +8637,31 @@ verify_omp_clauses_symbol_dups (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;
}
}
@ -8488,15 +8671,21 @@ verify_omp_clauses_symbol_dups (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)
@ -8541,6 +8730,168 @@ verify_omp_clauses_symbol_dups (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;
gfc_omp_namelist *n_null = NULL;
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
{
if (n->sym == NULL)
{
n_null = n;
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);
}
/* If there is an ALLOCATE directive without list argument, a
namelist with its allocator/align clauses and n->sym = NULL is
created during parsing; here, we add all not otherwise specified
items from the Fortran allocate to that list.
For an ALLOCATORS directive, not listed items use the normal
Fortran way.
The behavior of an ALLOCATE directive that does not list all
arguments but there is no directive without list argument is not
well specified. Thus, we reject such code below. In OpenMP 5.2
the executable ALLOCATE directive is deprecated and in 6.0
deleted such that no spec clarification is to be expected. */
gfc_alloc *a_prev = NULL;
gfc_alloc *extra_alloc = NULL, *extra_alloc_last = NULL;
for (a = code->block->next->ext.alloc.list; a; )
{
if (a->expr->expr_type == EXPR_VARIABLE)
{
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
if (a->expr->symtree->n.sym == n->sym)
break;
if (n == NULL && n_null == NULL)
{
if (!extra_alloc)
extra_alloc = extra_alloc_last = a;
else
{
extra_alloc_last->next = a;
extra_alloc_last = a;
}
a = a->next;
if (code->block->next->ext.alloc.list == extra_alloc_last)
code->block->next->ext.alloc.list = a;
else
a_prev->next = a;
extra_alloc_last->next = NULL;
continue;
}
if (n == NULL)
{
if (a->expr->symtree->n.sym->attr.codimension)
gfc_error ("Unexpected coarray %qs in %<allocate%> at "
"%L, implicitly listed in %<!$OMP ALLOCATE%>"
" at %L", a->expr->symtree->n.sym->name,
&a->expr->where, &n_null->where);
if (n_null->sym == NULL)
n_null->sym = a->expr->symtree->n.sym;
else
{
n = n_null->next;
n_null->next = gfc_get_omp_namelist ();
n_null->next->next = n;
n_null->next->sym = a->expr->symtree->n.sym;
n_null->next->u2.allocator = n_null->u2.allocator;
n_null->next->u.align
= gfc_copy_expr (n_null->u.align);
n_null->next->where = n_null->where;
n_null = n_null->next;
}
}
}
a_prev = a;
a = a->next;
}
if (n_null && n_null->sym == NULL)
{
if (n_null == omp_clauses->lists[OMP_LIST_ALLOCATE])
omp_clauses->lists[OMP_LIST_ALLOCATE] = n_null->next;
else
{
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n;
n = n->next)
if (n->next == n_null)
break;
n->next = n_null->next;
n_null->next = NULL;
gfc_free_omp_namelist (n_null, OMP_LIST_ALLOCATE);
}
}
if (extra_alloc)
{
/* Unspecified whether that should use the default allocator
of OpenMP or the Fortran allocator. Thus, just reject it. */
if (code->op == EXEC_OMP_ALLOCATE)
gfc_error ("%qs listed in %<allocate%> statement at %L but "
"it is neither explicitly in listed in the "
"%<!$OMP ALLOCATE%> directive nor exists a directive"
" without argument list",
extra_alloc->expr->symtree->n.sym->name,
&extra_alloc->expr->where);
gfc_code *c = code->block->next;
gcc_assert (c->op == EXEC_ALLOCATE && c->next == NULL);
gfc_code *cn = code->next;
code->next = gfc_get_code (c->op);
code->next->next = cn;
cn = code->next;
cn->loc = c->loc;
cn->expr1 = gfc_copy_expr (cn->expr1);
cn->expr2 = gfc_copy_expr (cn->expr2);
cn->expr3 = gfc_copy_expr (cn->expr3);
cn->ext.alloc.ts = cn->ext.alloc.ts;
cn->ext.alloc.list = extra_alloc;
cn->ext.alloc.arr_spec_from_expr3
= c->ext.alloc.arr_spec_from_expr3;
cn->ext.alloc.expr3_not_explicit
= c->ext.alloc.expr3_not_explicit;
}
/* The current implementation requires that an EXEC_OMP_ALLOCATE is
added with OMP_ALLOCATE_KIND_FREE set at the end of the scope;
cf. trans-decl.cc's gfc_trans_deferred_vars and
gfc_trans_omp_allocate. */
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
if (n->sym
&& n->sym->attr.allocatable
&& !n->sym->attr.save
&& !n->sym->attr.result
&& !n->sym->ns->proc_name->attr.is_main_program)
{
if (ns != n->sym->ns)
gfc_error ("Sorry, allocation of allocatable %qs with "
"%<!$omp allocators%> or %<!$omp allocate%> at %L "
"is only suppored in the scope where it has been "
"declared, unless it has the SAVE attribute",
n->sym->name, &code->loc);
gfc_symbol *proc = n->sym->ns->proc_name;
gfc_omp_namelist *p = gfc_get_omp_namelist ();
p->sym = n->sym;
p->expr = gfc_copy_expr (n->expr);
p->where = code->loc;
p->next = NULL;
if (proc->omp_allocated == NULL)
proc->omp_allocated_end = proc->omp_allocated = p;
else
{
proc->omp_allocated_end->next = p;
proc->omp_allocated_end = p;
}
}
}
}
for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
n->sym->mark = 0;
@ -8811,7 +9162,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", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER", "ALLOCATOR",
"NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
"USES_ALLOCATORS" };
STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
@ -9110,15 +9461,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);
}
}
@ -9318,6 +9667,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
@ -11706,8 +12061,6 @@ 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:
@ -11754,6 +12107,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:
@ -12207,168 +12564,6 @@ gfc_resolve_oacc_routines (gfc_namespace *ns)
}
}
static void
prepare_omp_allocated_var_list_for_cleanup (gfc_omp_namelist *cn, locus loc)
{
gfc_symbol *proc = cn->sym->ns->proc_name;
gfc_omp_namelist *p, *n;
for (n = cn; n; n = n->next)
{
if (n->sym->attr.allocatable && !n->sym->attr.save
&& !n->sym->attr.result && !proc->attr.is_main_program)
{
p = gfc_get_omp_namelist ();
p->sym = n->sym;
p->expr = gfc_copy_expr (n->expr);
p->where = loc;
p->next = NULL;
if (proc->omp_allocated == NULL)
proc->omp_allocated_end = proc->omp_allocated = p;
else
{
proc->omp_allocated_end->next = p;
proc->omp_allocated_end = p;
}
}
}
}
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 = NULL;
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);
}
}
prepare_omp_allocated_var_list_for_cleanup (cn, code->loc);
}
void
gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
{
@ -12518,6 +12713,8 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_TARGET:
resolve_omp_target (code);
gcc_fallthrough ();
case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_ERROR:
@ -12578,9 +12775,6 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_METADIRECTIVE:
resolve_omp_metadirective (code, ns);
break;
case EXEC_OMP_ALLOCATE:
gfc_resolve_omp_allocate (code, ns);
break;
default:
break;
}

196
gcc/fortran/parse.cc
View File

@ -42,6 +42,7 @@ static jmp_buf eof_buf;
gfc_state_data *gfc_state_stack;
static bool last_was_use_stmt = false;
bool in_exec_part;
bool gfc_matching_omp_context_selector;
bool gfc_in_metadirective_body;
@ -752,6 +753,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) \
@ -865,6 +942,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;
@ -887,6 +969,7 @@ decode_omp_directive (void)
break;
case 'e':
matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS);
matcho ("end metadirective", gfc_match_omp_eos_error,
ST_OMP_END_METADIRECTIVE);
matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD);
@ -927,7 +1010,6 @@ 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);
@ -1228,6 +1310,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.
@ -1769,9 +1854,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_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_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: \
@ -1811,7 +1896,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_OMP_UNROLL: \
case ST_OMP_TILE: \
case ST_CRITICAL: \
@ -1832,8 +1917,8 @@ next_statement (void)
#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_MAPPER: \
case ST_OMP_DECLARE_REDUCTION: case ST_OMP_DECLARE_VARIANT: \
case ST_OMP_ASSUMES: case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: \
case ST_OACC_DECLARE
case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: case ST_OMP_REQUIRES: \
case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* OpenMP statements that are followed by a structured block. */
@ -2494,15 +2579,19 @@ 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;
case ST_OMP_ASSUMES:
p = "!$OMP ASSUMES";
break;
case ST_OMP_ALLOCATE:
p = "!$OMP ALLOCATE";
break;
case ST_OMP_ATOMIC:
p = "!$OMP ATOMIC";
break;
@ -2557,6 +2646,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;
@ -3138,6 +3230,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:
@ -3211,6 +3304,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:
@ -5777,6 +5871,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
@ -5898,6 +6063,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:
@ -6114,6 +6284,7 @@ parse_executable (gfc_statement st)
{
int close_flag;
bool one_stmt_p = false;
in_exec_part = true;
if (st == ST_NONE)
st = next_statement ();
@ -6230,6 +6401,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_omp_structured_block:
st = parse_omp_structured_block (st,
st == ST_OMP_WORKSHARE

5
gcc/fortran/resolve.cc
View File

@ -11040,6 +11040,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:
@ -12713,6 +12715,7 @@ start:
break;
case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
@ -18031,6 +18034,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);

1
gcc/fortran/st.cc
View File

@ -215,6 +215,7 @@ gfc_free_statement (gfc_code *p)
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:

2
gcc/fortran/trans-decl.cc
View File

@ -4654,7 +4654,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_clear_new_st ();
new_st.op = EXEC_OMP_ALLOCATE;
gfc_omp_clauses *c = gfc_get_omp_clauses ();
c->lists[OMP_LIST_ALLOCATOR] = proc_sym->omp_allocated;
c->lists[OMP_LIST_ALLOCATE] = proc_sym->omp_allocated;
new_st.ext.omp_clauses = c;
/* This is just a hacky way to convey to handler that we are
dealing with cleanup here. Saves us from using another field

54
gcc/fortran/trans-openmp.cc
View File

@ -4719,17 +4719,24 @@ 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_;
if (n->expr->expr_type == EXPR_VARIABLE)
allocator_
= gfc_trans_omp_variable (n->expr->symtree->n.sym,
false);
if (n->u2.allocator->expr_type == EXPR_VARIABLE)
{
allocator_
= gfc_trans_omp_variable (n->u2.allocator->symtree->n.sym,
false);
if (POINTER_TYPE_P (TREE_TYPE (allocator_)))
{
allocator_ = build_fold_indirect_ref (allocator_);
allocator_ = gfc_evaluate_now (allocator_, block);
}
}
else
{
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_;
@ -4746,28 +4753,6 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
}
}
break;
case OMP_LIST_ALLOCATOR:
for (; n != NULL; n = n->next)
if (n->sym->attr.referenced)
{
tree t = gfc_trans_omp_variable (n->sym, false);
if (t != error_mark_node)
{
tree node = build_omp_clause (input_location,
OMP_CLAUSE_ALLOCATOR);
OMP_ALLOCATE_DECL (node) = t;
if (n->expr)
{
tree allocator_;
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, n->expr);
allocator_ = gfc_evaluate_now (se.expr, block);
OMP_ALLOCATE_ALLOCATOR (node) = allocator_;
}
omp_clauses = gfc_trans_add_clause (node, omp_clauses);
}
}
break;
case OMP_LIST_LINEAR:
{
gfc_expr *last_step_expr = NULL;
@ -7818,7 +7803,7 @@ gfc_trans_omp_atomic (gfc_code *code)
}
static tree
gfc_trans_omp_allocate (gfc_code *code)
gfc_trans_omp_allocators (gfc_code *code)
{
stmtblock_t block;
tree stmt;
@ -7836,7 +7821,11 @@ gfc_trans_omp_allocate (gfc_code *code)
&& code->resolved_sym != NULL)
OMP_ALLOCATE_KIND_FREE (stmt) = 1;
else
OMP_ALLOCATE_KIND_ALLOCATE (stmt) = 1;
{
OMP_ALLOCATE_KIND_ALLOCATE (stmt) = 1;
gfc_add_expr_to_block (&block, stmt);
stmt = gfc_trans_allocate (code->block->next);
}
gfc_add_expr_to_block (&block, stmt);
gfc_merge_block_scope (&block);
@ -9590,6 +9579,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)
{
@ -10849,7 +10840,8 @@ gfc_trans_omp_directive (gfc_code *code)
switch (code->op)
{
case EXEC_OMP_ALLOCATE:
return gfc_trans_omp_allocate (code);
case EXEC_OMP_ALLOCATORS:
return gfc_trans_omp_allocators (code);
case EXEC_OMP_ASSUME:
return gfc_trans_omp_assume (code);
case EXEC_OMP_ATOMIC:

3
gcc/fortran/trans.cc
View File

@ -2454,7 +2454,8 @@ trans_code (gfc_code * code, tree cond)
break;
case EXEC_OMP_ALLOCATE:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CANCEL:

45
gcc/omp-low.cc
View File

@ -60,6 +60,7 @@ along with GCC; see the file COPYING3. If not see
#include "stringpool.h"
#include "attribs.h"
#include "omp-offload.h"
#include "intl.h"
/* Lowering of OMP parallel and workshare constructs proceeds in two
phases. The first phase scans the function looking for OMP statements
@ -1468,8 +1469,11 @@ scan_sharing_clauses (tree clauses, omp_context *ctx,
if (OMP_CLAUSE_ALLOCATE_ALLOCATOR (c) == NULL_TREE
&& ((omp_requires_mask & OMP_REQUIRES_DYNAMIC_ALLOCATORS) == 0)
&& omp_maybe_offloaded_ctx (ctx))
error_at (OMP_CLAUSE_LOCATION (c), "%<allocate%> clause must"
" specify an allocator here");
error_at (OMP_CLAUSE_LOCATION (c),
gimple_code (ctx->stmt) == GIMPLE_OMP_ALLOCATE
? G_("%<allocate%> directive must specify an allocator "
"here")
: G_("%<allocate%> clause must specify an allocator here"));
if (ctx->allocate_map == NULL)
ctx->allocate_map = new hash_map<tree, tree>;
tree val = integer_zero_node;
@ -2168,7 +2172,6 @@ scan_sharing_clauses (tree clauses, omp_context *ctx,
case OMP_CLAUSE_FINALIZE:
case OMP_CLAUSE_TASK_REDUCTION:
case OMP_CLAUSE_ALLOCATE:
case OMP_CLAUSE_ALLOCATOR:
case OMP_CLAUSE__OMPACC_:
break;
@ -2398,7 +2401,6 @@ scan_sharing_clauses (tree clauses, omp_context *ctx,
case OMP_CLAUSE_FINALIZE:
case OMP_CLAUSE_FILTER:
case OMP_CLAUSE__CONDTEMP_:
case OMP_CLAUSE_ALLOCATOR:
case OMP_CLAUSE__OMPACC_:
break;
@ -9457,31 +9459,20 @@ lower_omp_single_simple (gomp_single *single_stmt, gimple_seq *pre_p)
}
static void
lower_omp_allocate (gimple_stmt_iterator *gsi_p, omp_context *ctx)
lower_omp_allocate (gimple_stmt_iterator *gsi_p)
{
gomp_allocate *st = as_a <gomp_allocate *> (gsi_stmt (*gsi_p));
tree clauses = gimple_omp_allocate_clauses (st);
int kind = gimple_omp_allocate_kind (st);
gcc_assert (kind == GF_OMP_ALLOCATE_KIND_ALLOCATE
|| kind == GF_OMP_ALLOCATE_KIND_FREE);
for (tree c = clauses; c; c = OMP_CLAUSE_CHAIN (c))
{
if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_ALLOCATOR)
if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_ALLOCATE)
continue;
bool allocate = (kind == GF_OMP_ALLOCATE_KIND_ALLOCATE);
/* The allocate directives that appear in a target region must specify
an allocator clause unless a requires directive with the
dynamic_allocators clause is present in the same compilation unit. */
if (OMP_ALLOCATE_ALLOCATOR (c) == NULL_TREE
&& ((omp_requires_mask & OMP_REQUIRES_DYNAMIC_ALLOCATORS) == 0)
&& omp_maybe_offloaded_ctx (ctx))
error_at (OMP_CLAUSE_LOCATION (c), "%<allocate%> directive must"
" specify an allocator here");
tree var = OMP_ALLOCATE_DECL (c);
tree var = OMP_CLAUSE_DECL (c);
gimple_stmt_iterator gsi = *gsi_p;
for (gsi_next (&gsi); !gsi_end_p (gsi); gsi_next (&gsi))
{
@ -9493,10 +9484,11 @@ lower_omp_allocate (gimple_stmt_iterator *gsi_p, omp_context *ctx)
|| (!allocate && gimple_call_fndecl (stmt)
!= builtin_decl_explicit (BUILT_IN_FREE)))
continue;
const gcall *gs = as_a <const gcall *> (stmt);
tree allocator = OMP_ALLOCATE_ALLOCATOR (c)
? OMP_ALLOCATE_ALLOCATOR (c)
: integer_zero_node;
tree allocator = OMP_CLAUSE_ALLOCATE_ALLOCATOR (c)
? OMP_CLAUSE_ALLOCATE_ALLOCATOR (c)
: build_zero_cst (ptr_type_node);
if (allocate)
{
tree lhs = gimple_call_lhs (gs);
@ -9518,12 +9510,17 @@ lower_omp_allocate (gimple_stmt_iterator *gsi_p, omp_context *ctx)
if (lhs == var)
{
unsigned HOST_WIDE_INT ialign = 0;
tree align;
tree align = OMP_CLAUSE_ALLOCATE_ALIGN (c);
if (TYPE_P (var))
ialign = TYPE_ALIGN_UNIT (var);
else
ialign = DECL_ALIGN_UNIT (var);
align = build_int_cst (size_type_node, ialign);
if (align == NULL_TREE)
align = build_int_cst (size_type_node, ialign);
else
align = build_int_cst (size_type_node,
MAX (tree_to_uhwi (align),
ialign));
tree repl = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
tree size = gimple_call_arg (gs, 0);
gimple *g = gimple_build_call (repl, 3, align, size,
@ -16135,7 +16132,7 @@ lower_omp_1 (gimple_stmt_iterator *gsi_p, omp_context *ctx)
case GIMPLE_OMP_ALLOCATE:
ctx = maybe_lookup_ctx (stmt);
gcc_assert (ctx);
lower_omp_allocate (gsi_p, ctx);
lower_omp_allocate (gsi_p);
break;
case GIMPLE_OMP_SINGLE:
ctx = maybe_lookup_ctx (stmt);

15
gcc/testsuite/ChangeLog.omp
View File

@ -1,3 +1,18 @@
2023-10-26 Tobias Burnus <tobias@codesourcery.com>
Chung-Lin Tang <cltang@codesourcery.com>
* gfortran.dg/gomp/allocate-2.f90: Update dg-warning.
* gfortran.dg/gomp/allocate-4.f90: New upstream test.
* gfortran.dg/gomp/allocate-5.f90: New upstream test.
* gfortran.dg/gomp/allocate-6.f90: New upstream test.
* gfortran.dg/gomp/allocate-7.f90: New upstream test.
* gfortran.dg/gomp/allocate-4a.f90: Renamed from allocate-4.f90
* gfortran.dg/gomp/allocate-6a.f90: Renamed from allocate-6.f90
* gfortran.dg/gomp/allocate-7a.f90: Renamed from allocate-7.f90
* gfortran.dg/gomp/allocate-9a.f90: New test.
* gfortran.dg/gomp/allocators-1.f90: New upstream test.
* gfortran.dg/gomp/allocators-2.f90: New upstream test.
2023-09-20 Tobias Burnus <tobias@codesourcery.com>
Backported from master:

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

54
gcc/testsuite/gfortran.dg/gomp/allocate-4a.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

152
gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
View File

@ -1,73 +1,99 @@
! { dg-do compile }
module omp_lib_kinds
use iso_c_binding, only: c_int, c_intptr_t
module my_omp_lib
use iso_c_binding, only: c_intptr_t
!use omp_lib
implicit none
private :: c_int, c_intptr_t
integer, parameter :: omp_allocator_handle_kind = 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
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_null_allocator = 0
subroutine foo(x, y)
use omp_lib_kinds
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 :: x
integer :: y
integer, allocatable :: a, b(:), c(:,:)
type(t), allocatable :: x1
type(t), pointer :: x2(:)
class(t), allocatable :: y1
class(t), pointer :: y2(:)
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 flush ! some executable statement
!$omp allocate(a)
allocate(a)
deallocate(a)
!$omp allocate (var1) allocator(omp_default_mem_alloc)
allocate (var1(x))
!$omp allocate (var2)
allocate (var2(x))
!$omp allocate(x1,y1,x2,y2)
allocate(x1,y1,x2(5),y2(5))
deallocate(x1,y1,x2,y2)
!$omp allocate (var3, var4) allocator(omp_large_cap_mem_alloc)
allocate (var3(x),var4(x,y))
!$omp allocate(b,a) align ( 128 )
!$omp allocate align ( 64 )
allocate(a,b(4),c(3,4))
deallocate(a,b,c)
end
!$omp allocate()
allocate (var5(x))
subroutine three(c)
use my_omp_lib
implicit none
integer :: q
integer, allocatable :: a, b(:), c(:,:)
!$omp allocate
allocate (var6(x))
call foo() ! executable stmt
!$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64)
!$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)
!$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
block
q = 5 ! executable stmt
!$omp allocate(a) align(64)
!$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
!$omp allocate(c) allocator( omp_thread_mem_alloc )
! { dg-error "Sorry, allocation of allocatable 'a' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-3 }
! { dg-error "Sorry, allocation of allocatable 'b' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-4 }
! { dg-error "Sorry, allocation of allocatable 'c' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-5 }
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)
!$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
!$omp allocate(c) allocator( omp_thread_mem_alloc )
! { dg-error "Sorry, allocation of allocatable 'a' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-3 }
! { dg-error "Sorry, allocation of allocatable 'b' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-4 }
! { dg-error "Sorry, allocation of allocatable 'c' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-5 }
allocate(a,b(4),c(3,4))
deallocate(a,b,c)
end subroutine inner
end

159
gcc/testsuite/gfortran.dg/gomp/allocate-6.f90
View File

@ -1,84 +1,103 @@
! { dg-do compile }
! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" }
! { dg-additional-options "-fdump-tree-omplower" }
module omp_lib_kinds
use iso_c_binding, only: c_int, c_intptr_t
module my_omp_lib
use iso_c_binding, only: c_intptr_t
!use omp_lib
implicit none
private :: c_int, c_intptr_t
integer, parameter :: omp_allocator_handle_kind = 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
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 foo(x, y, al)
use omp_lib_kinds
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
type :: my_type
integer :: i
integer :: j
real :: x
end type
integer, allocatable :: a, b(:), c(:,:)
type(t) :: x1,x2
class(t) :: y1,y2
allocatable :: x1, y1
integer :: x
integer :: y
integer (kind=omp_allocator_handle_kind) :: al
!$omp flush ! some executable statement
integer, allocatable :: var1
integer, allocatable :: var2
real, allocatable :: var3(:,:)
type (my_type), allocatable :: var4
integer, pointer :: pii, parr(:)
integer, allocatable :: var
!$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))
character, allocatable :: str1a, str1aarr(:)
character(len=5), allocatable :: str5a, str5aarr(:)
!$omp allocate
allocate(str1a, str1aarr(10), str5a, str5aarr(10))
!$omp allocate(b(3)) align ( 64 ) ! { dg-error "Unexpected expression as list item at .1. in ALLOCATE directive" }
allocate(b(3))
end
!$omp allocate (var1) allocator(omp_default_mem_alloc)
!$omp allocate (var2) allocator(omp_large_cap_mem_alloc)
allocate (var1, var2)
subroutine one(n, my_alloc)
use my_omp_lib
implicit none
integer :: n
integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
!$omp allocate (var4) allocator(omp_low_lat_mem_alloc)
allocate (var4)
var4%i = 5
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 (var3) allocator(omp_low_lat_mem_alloc)
allocate (var3(x,y))
!$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(pii, parr(5))
allocate(a,b,c) ! allocate is no block construct, hence:
!$omp end allocate ! { dg-error "Unclassifiable OpenMP directive" }
! allocate statement not associated with an allocate directive
allocate(var)
end subroutine
! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 6 "original" } }
! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "original" } }
! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 6 "gimple" } }
! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "gimple" } }
! { dg-final { scan-tree-dump-times "builtin_malloc" 11 "original" } }
! { dg-final { scan-tree-dump-times "builtin_free" 9 "original" } }
! { dg-final { scan-tree-dump-times "GOMP_alloc" 10 "omplower" } }
! { dg-final { scan-tree-dump-times "GOMP_free" 8 "omplower" } }
!$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

85
gcc/testsuite/gfortran.dg/gomp/allocate-6a.f90 Normal file
View File

@ -0,0 +1,85 @@
! { dg-do compile }
! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" }
! { dg-additional-options "-fdump-tree-omplower" }
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, al)
use omp_lib_kinds
implicit none
type :: my_type
integer :: i
integer :: j
real :: x
end type
integer :: x
integer :: y
integer (kind=omp_allocator_handle_kind) :: al
integer, allocatable :: var1
integer, allocatable :: var2
real, allocatable :: var3(:,:)
type (my_type), allocatable :: var4
integer, pointer :: pii, parr(:)
integer, allocatable :: var
character, allocatable :: str1a, str1aarr(:)
character(len=5), allocatable :: str5a, str5aarr(:)
x = 5 ! Some executable stmt
!$omp allocate
allocate(str1a, str1aarr(10), str5a, str5aarr(10))
!$omp allocate (var1) allocator(omp_default_mem_alloc)
!$omp allocate (var2) allocator(omp_large_cap_mem_alloc)
allocate (var1, var2)
!$omp allocate (var4) allocator(omp_low_lat_mem_alloc)
allocate (var4)
var4%i = 5
!$omp allocate (var3) allocator(omp_low_lat_mem_alloc)
allocate (var3(x,y))
!$omp allocate
allocate(pii, parr(5))
! allocate statement not associated with an allocate directive
allocate(var)
end subroutine
! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 5 "original" } }
! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "original" } }
! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 5 "gimple" } }
! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "gimple" } }
! { dg-final { scan-tree-dump-times "builtin_malloc" 11 "original" } }
! { dg-final { scan-tree-dump-times "builtin_free" 9 "original" } }
! { dg-final { scan-tree-dump-times "GOMP_alloc" 10 "omplower" } }
! { dg-final { scan-tree-dump-times "GOMP_free" 8 "omplower" } }

238
gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
View File

@ -1,13 +1,231 @@
! { dg-do compile }
subroutine bar(a)
! { dg-additional-options "-fmax-errors=1000" }
module my_omp_lib
use iso_c_binding, only: c_intptr_t
!use omp_lib
implicit none
integer :: a
integer, allocatable :: var
!$omp target
!$omp allocate (var) ! { dg-error "'allocate' directive must specify an allocator here" }
allocate (var)
!$omp end target
integer, parameter :: omp_allocator_handle_kind = c_intptr_t
end subroutine
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

13
gcc/testsuite/gfortran.dg/gomp/allocate-7a.f90 Normal file
View File

@ -0,0 +1,13 @@
! { dg-do compile }
subroutine bar(a)
implicit none
integer :: a
integer, allocatable :: var
!$omp target
!$omp allocate (var) ! { dg-error "'allocate' directive must specify an allocator here" }
allocate (var)
!$omp end target
end subroutine

0
gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 → gcc/testsuite/gfortran.dg/gomp/allocate-8a.f90
View File

15
gcc/testsuite/gfortran.dg/gomp/allocate-9a.f90 Normal file
View File

@ -0,0 +1,15 @@
! { dg-additional-options "-fdump-tree-omplower" }
subroutine f()
integer, allocatable :: A, B
!$omp allocators allocate(align(128): A)
allocate(A)
!$omp allocate(B) align(256)
allocate(B)
end
! { dg-final { scan-tree-dump "a = __builtin_GOMP_alloc \\(128, 4, 0B\\);" "omplower" } }
! { dg-final { scan-tree-dump "b = __builtin_GOMP_alloc \\(256, 4, 0B\\);" "omplower" } }
! { dg-final { scan-tree-dump "__builtin_GOMP_free \\(b, 0B\\);" "omplower" } }
! { dg-final { scan-tree-dump "__builtin_GOMP_free \\(a, 0B\\);" "omplower" } }

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

3
gcc/tree-core.h
View File

@ -536,9 +536,6 @@ enum omp_clause_code {
/* OpenACC clause: nohost. */
OMP_CLAUSE_NOHOST,
/* OpenMP clause: allocator. */
OMP_CLAUSE_ALLOCATOR,
/* OpenMP clause: uses_allocators. */
OMP_CLAUSE_USES_ALLOCATORS,

14
gcc/tree-pretty-print.cc
View File

@ -815,20 +815,6 @@ dump_omp_clause (pretty_printer *pp, tree clause, int spc, dump_flags_t flags)
pp_right_paren (pp);
break;
case OMP_CLAUSE_ALLOCATOR:
pp_string (pp, "(");
dump_generic_node (pp, OMP_ALLOCATE_DECL (clause),
spc, flags, false);
if (OMP_ALLOCATE_ALLOCATOR (clause))
{
pp_string (pp, ":allocator(");
dump_generic_node (pp, OMP_ALLOCATE_ALLOCATOR (clause),
spc, flags, false);
pp_right_paren (pp);
}
pp_right_paren (pp);
break;
case OMP_CLAUSE_ALLOCATE:
pp_string (pp, "allocate(");
if (OMP_CLAUSE_ALLOCATE_ALLOCATOR (clause))

1
gcc/tree.cc
View File

@ -328,7 +328,6 @@ unsigned const char omp_clause_num_ops[] =
0, /* OMP_CLAUSE_IF_PRESENT */
0, /* OMP_CLAUSE_FINALIZE */
0, /* OMP_CLAUSE_NOHOST */
2, /* OMP_CLAUSE_ALLOCATOR */
3, /* OMP_CLAUSE_USES_ALLOCATORS */
1, /* OMP_CLAUSE_UNROLL_FULL */
1, /* OMP_CLAUSE_UNROLL_NONE */

9
gcc/tree.h
View File

@ -1943,15 +1943,6 @@ class auto_suppress_location_wrappers
#define OMP_CLAUSE_ALLOCATE_ALIGN(NODE) \
OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_ALLOCATE), 2)
/* May be we can use OMP_CLAUSE_DECL but the I am not sure where to place
OMP_CLAUSE_ALLOCATOR in omp_clause_code. */
#define OMP_ALLOCATE_DECL(NODE) \
OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_ALLOCATOR), 0)
#define OMP_ALLOCATE_ALLOCATOR(NODE) \
OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_ALLOCATOR), 1)
/* True if an ALLOCATE clause was present on a combined or composite
construct and the code for splitting the clauses has already performed
checking if the listed variable has explicit privatization on the

7
libgomp/ChangeLog.omp
View File

@ -1,3 +1,10 @@
2023-10-26 Tobias Burnus <tobias@codesourcery.com>
Chung-Lin Tang <cltang@codesourcery.com>
* testsuite/libgomp.fortran/allocate-2a.f90: Add exec stmt.
* testsuite/libgomp.fortran/allocate-4.f90: Update dg-error
* testsuite/libgomp.fortran/allocate-5.f90: Likewise; add exec stmt.
2023-09-20 Tobias Burnus <tobias@codesourcery.com>
Backported from master:

1
libgomp/testsuite/libgomp.fortran/allocate-2a.f90
View File

@ -22,6 +22,7 @@ subroutine foo (x, y, h)
integer (kind=omp_allocator_handle_kind) :: h
integer, allocatable :: var1
!$omp flush ! executable statement before '!$omp allocate'
!$omp allocate (var1) allocator(h)
allocate (var1)

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

36
libgomp/testsuite/libgomp.fortran/allocate-5.f90
View File

@ -22,6 +22,8 @@ subroutine foo(x, y)
integer, allocatable :: var8(:)
integer, allocatable :: var9(:)
x = 1 ! executable statement before '!$omp allocate'
! Don't use a hard-coded value (..., but it does pass the checks).
!$omp allocate (var1) allocator(10_omp_allocator_handle_kind) ! { dg-bogus "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
allocate (var1(x))
@ -30,27 +32,26 @@ subroutine foo(x, y)
!$omp allocate (var1) allocator(10_1) ! { 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 (var2) ! { dg-error "'var2' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
allocate (var3(x)) ! { dg-error "'var3' listed in 'allocate' statement at .1. but it is neither explicitly in listed in the '!.OMP ALLOCATE' directive nor exists a directive without argument list" }
!$omp allocate (x) ! { dg-message "sorry, unimplemented: 'allocate' directive that is not associated with an 'allocate' statement is not supported." }
x = 2
!$omp allocate (x)
x = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
!$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 (var4)
y = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
!$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." }
!$omp allocate
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." }
!$omp allocate (var7) ! { dg-error "'var7' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
!$omp allocate (var8) ! { dg-error "'var8' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
allocate (var6(x))
!$omp allocate (var9)
!$omp allocate (var9) ! { dg-error "'var9' is used in multiple 'allocate' directives at .1." }
!$omp allocate (var9) ! { dg-warning "var9' appears more than once in 'allocate'" }
allocate (var9(x))
end subroutine
@ -70,7 +71,9 @@ function outer(a)
integer :: x
integer, allocatable :: var2
!$omp allocate (var1, var2) ! { dg-error "'var1' is not in the same scope as 'allocate' directive at .1." }
x = 1 ! executable statement before '!$omp allocate'
!$omp allocate (var1, var2) ! { dg-error "Sorry, allocation of allocatable 'var1' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" }
allocate (var1, var2)
inner = x + 10
@ -96,22 +99,21 @@ subroutine bar(s)
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." }
!$omp allocate (mvar1) allocator(a)
allocate (mvar1)
!$omp allocate (mvar2) ! { dg-error "'mvar2' should use predefined allocator at .1." }
!$omp allocate (mvar2)
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." }
!$omp allocate (svar1) allocator(a)
allocate (svar1)
!$omp allocate (svar2) ! { dg-error "'svar2' should use predefined allocator at .1." }
!$omp allocate (svar2)
allocate (svar2)
!$omp allocate (svar3) allocator(omp_low_lat_mem_alloc)
allocate (svar3)
end subroutine