mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-13 11:21:18 +08:00
Code Issues Packages Projects Releases Wiki Activity

Fortran: Add OpenMP's assume(s) directives

Browse Source 
libgomp/ChangeLog:

	* libgomp.texi (OpenMP 5.1 Impl. Status): Mark 'assume' as 'Y'.

gcc/fortran/ChangeLog:

	* dump-parse-tree.cc (show_omp_assumes): New.
	(show_omp_clauses, show_namespace): Call it.
	(show_omp_node, show_code_node): Handle OpenMP ASSUME.
	* gfortran.h (enum gfc_statement): Add ST_OMP_ASSUME,
	ST_OMP_END_ASSUME, ST_OMP_ASSUMES and ST_NOTHING.
	(gfc_exec_op): Add EXEC_OMP_ASSUME.
	(gfc_omp_assumptions): New struct.
	(gfc_get_omp_assumptions): New XCNEW #define.
	(gfc_omp_clauses, gfc_namespace): Add assume member.
	(gfc_resolve_omp_assumptions): New prototype.
	* match.h (gfc_match_omp_assume, gfc_match_omp_assumes): New.
	* openmp.cc (omp_code_to_statement): Forward declare.
	(enum gfc_omp_directive_kind, struct gfc_omp_directive): New.
	(gfc_free_omp_clauses): Free assume member and its struct data.
	(enum omp_mask2): Add OMP_CLAUSE_ASSUMPTIONS.
	(gfc_omp_absent_contains_clause): New.
	(gfc_match_omp_clauses): Call it; optionally use passed
	omp_clauses argument.
	(omp_verify_merge_absent_contains, gfc_match_omp_assume,
	 gfc_match_omp_assumes, gfc_resolve_omp_assumptions): New.
	(resolve_omp_clauses): Call the latter.
	(gfc_resolve_omp_directive, omp_code_to_statement): Handle
	EXEC_OMP_ASSUME.
	* parse.cc (decode_omp_directive): Parse OpenMP ASSUME(S).
	(next_statement, parse_executable, parse_omp_structured_block):
	Handle ST_OMP_ASSUME.
	(case_omp_decl): Add ST_OMP_ASSUMES.
	(gfc_ascii_statement): Handle Assumes, optional return
	string without '!$OMP '/'!$ACC ' prefix.
	* parse.h (gfc_ascii_statement): Add optional bool arg to prototype.
	* resolve.cc (gfc_resolve_blocks, gfc_resolve_code): Add
	EXEC_OMP_ASSUME.
	(gfc_resolve): Resolve ASSUMES directive.
	* symbol.cc (gfc_free_namespace): Free omp_assumes member.
	* st.cc (gfc_free_statement): Handle EXEC_OMP_ASSUME.
	* trans-openmp.cc (gfc_trans_omp_directive): Likewise.
	* trans.cc (trans_code): Likewise.

gcc/testsuite/ChangeLog:

	* gfortran.dg/gomp/assume-1.f90: New test.
	* gfortran.dg/gomp/assume-2.f90: New test.
	* gfortran.dg/gomp/assumes-1.f90: New test.
	* gfortran.dg/gomp/assumes-2.f90: New test.
This commit is contained in:
Tobias Burnus 2022-10-05 19:25:27 +02:00
parent 49192c41de
commit e2a2284389
16 changed files with 665 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -36,6 +36,7 @@ along with GCC; see the file COPYING3. If not see
#include "gfortran.h"
#include "constructor.h"
#include "version.h"
#include "parse.h" /* For gfc_ascii_statement. */
/* Keep track of indentation for symbol tree dumps. */
static int show_level = 0;
@ -1458,6 +1459,34 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
gfc_current_ns = ns_curr;
}
static void
show_omp_assumes (gfc_omp_assumptions *assume)
{
for (int i = 0; i < assume->n_absent; i++)
{
fputs (" ABSENT (", dumpfile);
fputs (gfc_ascii_statement (assume->absent[i], true), dumpfile);
fputc (')', dumpfile);
}
for (int i = 0; i < assume->n_contains; i++)
{
fputs (" CONTAINS (", dumpfile);
fputs (gfc_ascii_statement (assume->contains[i], true), dumpfile);
fputc (')', dumpfile);
}
for (gfc_expr_list *el = assume->holds; el; el = el->next)
{
fputs (" HOLDS (", dumpfile);
show_expr (el->expr);
fputc (')', dumpfile);
}
if (assume->no_openmp)
fputs (" NO_OPENMP", dumpfile);
if (assume->no_openmp_routines)
fputs (" NO_OPENMP_ROUTINES", dumpfile);
if (assume->no_parallelism)
fputs (" NO_PARALLELISM", dumpfile);
}
/* Show OpenMP or OpenACC clauses. */
@ -1998,6 +2027,8 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
show_expr (omp_clauses->message);
fputc (')', dumpfile);
}
if (omp_clauses->assume)
show_omp_assumes (omp_clauses->assume);
}
/* Show a single OpenMP or OpenACC directive node and everything underneath it
@ -2027,6 +2058,7 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
case EXEC_OMP_ASSUME: name = "ASSUME"; break;
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
case EXEC_OMP_CANCEL: name = "CANCEL"; break;
@ -2128,6 +2160,7 @@ 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_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_DISTRIBUTE:
@ -3353,6 +3386,7 @@ show_code_node (int level, gfc_code *c)
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
@ -3531,6 +3565,13 @@ show_namespace (gfc_namespace *ns)
}
}
if (ns->omp_assumes)
{
show_indent ();
fprintf (dumpfile, "!$OMP ASSUMES");
show_omp_assumes (ns->omp_assumes);
}
fputc ('\n', dumpfile);
show_indent ();
fputs ("code:", dumpfile);

23
gcc/fortran/gfortran.h
View File

@ -316,7 +316,9 @@ enum gfc_statement
ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD, ST_OMP_MASKED_TASKLOOP,
ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD,
ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
ST_OMP_ERROR, ST_NONE
ST_OMP_ERROR, ST_OMP_ASSUME, ST_OMP_END_ASSUME, ST_OMP_ASSUMES,
/* Note: gfc_match_omp_nothing returns ST_NONE. */
ST_OMP_NOTHING, ST_NONE
};
/* Types of interfaces that we can have. Assignment interfaces are
@ -1506,6 +1508,18 @@ enum gfc_omp_bind_type
OMP_BIND_THREAD
};
typedef struct gfc_omp_assumptions
{
int n_absent, n_contains;
enum gfc_statement *absent, *contains;
gfc_expr_list *holds;
bool no_openmp:1, no_openmp_routines:1, no_parallelism:1;
}
gfc_omp_assumptions;
#define gfc_get_omp_assumptions() XCNEW (gfc_omp_assumptions)
typedef struct gfc_omp_clauses
{
gfc_omp_namelist *lists[OMP_LIST_NUM];
@ -1529,6 +1543,7 @@ typedef struct gfc_omp_clauses
struct gfc_expr *if_exprs[OMP_IF_LAST];
struct gfc_expr *dist_chunk_size;
struct gfc_expr *message;
struct gfc_omp_assumptions *assume;
const char *critical_name;
enum gfc_omp_default_sharing default_sharing;
enum gfc_omp_atomic_op atomic_op;
@ -2145,6 +2160,9 @@ typedef struct gfc_namespace
/* Linked list of !$omp declare variant constructs. */
struct gfc_omp_declare_variant *omp_declare_variant;
/* OpenMP assumptions. */
struct gfc_omp_assumptions *omp_assumes;
/* A hash set for the gfc expressions that have already
been finalized in this namespace. */
@ -2913,7 +2931,7 @@ enum gfc_exec_op
EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE,
EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
EXEC_OMP_ASSUME, EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
EXEC_OMP_END_SINGLE, EXEC_OMP_TASK, EXEC_OMP_TASKWAIT,
EXEC_OMP_TASKYIELD, EXEC_OMP_CANCEL, EXEC_OMP_CANCELLATION_POINT,
EXEC_OMP_TASKGROUP, EXEC_OMP_SIMD, EXEC_OMP_DO_SIMD,
@ -3576,6 +3594,7 @@ void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
void gfc_resolve_omp_assumptions (gfc_omp_assumptions *);
void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool);
void gfc_resolve_omp_local_vars (gfc_namespace *);

2
gcc/fortran/match.h
View File

@ -149,6 +149,8 @@ match gfc_match_oacc_routine (void);
/* OpenMP directive matchers. */
match gfc_match_omp_eos_error (void);
match gfc_match_omp_assume (void);
match gfc_match_omp_assumes (void);
match gfc_match_omp_atomic (void);
match gfc_match_omp_barrier (void);
match gfc_match_omp_cancel (void);

403
gcc/fortran/openmp.cc
View File

@ -29,6 +29,86 @@ along with GCC; see the file COPYING3. If not see
#include "diagnostic.h"
#include "gomp-constants.h"
#include "target-memory.h" /* For gfc_encode_character. */
#include "bitmap.h"
static gfc_statement omp_code_to_statement (gfc_code *);
enum gfc_omp_directive_kind {
GFC_OMP_DIR_DECLARATIVE,
GFC_OMP_DIR_EXECUTABLE,
GFC_OMP_DIR_INFORMATIONAL,
GFC_OMP_DIR_META,
GFC_OMP_DIR_SUBSIDIARY,
GFC_OMP_DIR_UTILITY
};
struct gfc_omp_directive {
const char *name;
enum gfc_omp_directive_kind kind;
gfc_statement st;
};
/* Alphabetically sorted OpenMP clauses, except that longer strings are before
substrings; excludes combined/composite directives. See note for "ordered"
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}, */
{"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES},
{"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME},
{"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC},
{"barrier", GFC_OMP_DIR_EXECUTABLE, ST_OMP_BARRIER},
{"cancellation point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT},
{"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL},
{"critical", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CRITICAL},
/* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */
{"declare reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION},
{"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD},
{"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET},
{"declare variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT},
{"depobj", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DEPOBJ},
/* {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH}, */
{"distribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISTRIBUTE},
{"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO},
/* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
{"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR},
{"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH},
/* {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, */
{"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
{"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
/* {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE}, */
/* Note: gfc_match_omp_nothing returns ST_NONE. */
{"nothing", GFC_OMP_DIR_UTILITY, ST_OMP_NOTHING},
/* Special case; for now map to the first one.
ordered-blockassoc = ST_OMP_ORDERED
ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */
{"ordered", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ORDERED},
{"parallel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_PARALLEL},
{"requires", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_REQUIRES},
{"scan", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SCAN},
{"scope", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SCOPE},
{"sections", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SECTIONS},
{"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION},
{"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD},
{"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE},
{"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA},
{"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA},
{"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA},
{"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE},
{"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET},
{"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP},
{"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT},
{"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD},
{"task", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK},
{"teams", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TEAMS},
{"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE},
/* {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE}, */
/* {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL}, */
{"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE},
};
/* Match an end of OpenMP directive. End of OpenMP directive is optional
whitespace, followed by '\n' or comment '!'. */
@ -111,6 +191,13 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
gfc_free_expr_list (c->wait_list);
gfc_free_expr_list (c->tile_list);
free (CONST_CAST (char *, c->critical_name));
if (c->assume)
{
free (c->assume->absent);
free (c->assume->contains);
gfc_free_expr_list (c->assume->holds);
free (c->assume);
}
free (c);
}
@ -992,6 +1079,7 @@ enum omp_mask2
OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
/* This must come last. */
OMP_MASK2_LAST
};
@ -1407,6 +1495,173 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
return MATCH_YES;
}
static match
gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
{
if (*assume == NULL)
*assume = gfc_get_omp_assumptions ();
do
{
gfc_statement st = ST_NONE;
gfc_gobble_whitespace ();
locus old_loc = gfc_current_locus;
char c = gfc_peek_ascii_char ();
enum gfc_omp_directive_kind kind
= GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
{
if (gfc_omp_directives[i].name[0] > c)
break;
if (gfc_omp_directives[i].name[0] != c)
continue;
if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
{
st = gfc_omp_directives[i].st;
kind = gfc_omp_directives[i].kind;
}
}
gfc_gobble_whitespace ();
c = gfc_peek_ascii_char ();
if (st == ST_NONE || (c != ',' && c != ')'))
{
if (st == ST_NONE)
gfc_error ("Unknown directive at %L", &old_loc);
else
gfc_error ("Invalid combined or composit directive at %L",
&old_loc);
return MATCH_ERROR;
}
if (kind == GFC_OMP_DIR_DECLARATIVE
|| kind == GFC_OMP_DIR_INFORMATIONAL
|| kind == GFC_OMP_DIR_META)
{
gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
"informational and meta directives not permitted",
gfc_ascii_statement (st, true), &old_loc,
is_absent ? "ABSENT" : "CONTAINS");
return MATCH_ERROR;
}
if (is_absent)
{
/* Use exponential allocation; equivalent to pow2p(x). */
int i = (*assume)->n_absent;
int size = ((i == 0) ? 4
: pow2p_hwi (i) == 1 ? i*2 : 0);
if (size != 0)
(*assume)->absent = XRESIZEVEC (gfc_statement,
(*assume)->absent, size);
(*assume)->absent[(*assume)->n_absent++] = st;
}
else
{
int i = (*assume)->n_contains;
int size = ((i == 0) ? 4
: pow2p_hwi (i) == 1 ? i*2 : 0);
if (size != 0)
(*assume)->contains = XRESIZEVEC (gfc_statement,
(*assume)->contains, size);
(*assume)->contains[(*assume)->n_contains++] = st;
}
gfc_gobble_whitespace ();
if (gfc_match(",") == MATCH_YES)
continue;
if (gfc_match(")") == MATCH_YES)
break;
gfc_error ("Expected %<,%> or %<)%> at %C");
return MATCH_ERROR;
}
while (true);
return MATCH_YES;
}
/* Check 'check' argument for duplicated statements in absent and/or contains
clauses. If 'merge', merge them from check to 'merge'. */
static match
omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
gfc_omp_assumptions *merge, locus *loc)
{
if (check == NULL)
return MATCH_YES;
bitmap_head absent_head, contains_head;
bitmap_obstack_initialize (NULL);
bitmap_initialize (&absent_head, &bitmap_default_obstack);
bitmap_initialize (&contains_head, &bitmap_default_obstack);
match m = MATCH_YES;
for (int i = 0; i < check->n_absent; i++)
if (!bitmap_set_bit (&absent_head, check->absent[i]))
{
gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
"directive at %L",
gfc_ascii_statement (check->absent[i], true),
"ABSENT", gfc_ascii_statement (st), loc);
m = MATCH_ERROR;
}
for (int i = 0; i < check->n_contains; i++)
{
if (!bitmap_set_bit (&contains_head, check->contains[i]))
{
gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
"directive at %L",
gfc_ascii_statement (check->contains[i], true),
"CONTAINS", gfc_ascii_statement (st), loc);
m = MATCH_ERROR;
}
if (bitmap_bit_p (&absent_head, check->contains[i]))
{
gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
"clauses in %s directive at %L",
gfc_ascii_statement (check->absent[i], true),
gfc_ascii_statement (st), loc);
m = MATCH_ERROR;
}
}
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (merge == NULL)
return MATCH_YES;
if (merge->absent == NULL && check->absent)
{
merge->n_absent = check->n_absent;
merge->absent = check->absent;
check->absent = NULL;
}
else if (merge->absent && check->absent)
{
check->absent = XRESIZEVEC (gfc_statement, check->absent,
merge->n_absent + check->n_absent);
for (int i = 0; i < merge->n_absent; i++)
if (!bitmap_bit_p (&absent_head, merge->absent[i]))
check->absent[check->n_absent++] = merge->absent[i];
free (merge->absent);
merge->absent = check->absent;
merge->n_absent = check->n_absent;
check->absent = NULL;
}
if (merge->contains == NULL && check->contains)
{
merge->n_contains = check->n_contains;
merge->contains = check->contains;
check->contains = NULL;
}
else if (merge->contains && check->contains)
{
check->contains = XRESIZEVEC (gfc_statement, check->contains,
merge->n_contains + check->n_contains);
for (int i = 0; i < merge->n_contains; i++)
if (!bitmap_bit_p (&contains_head, merge->contains[i]))
check->contains[check->n_contains++] = merge->contains[i];
free (merge->contains);
merge->contains = check->contains;
merge->n_contains = check->n_contains;
check->contains = NULL;
}
return MATCH_YES;
}
/* Match with duplicate check. Matches 'name'. If expr != NULL, it
then matches '(expr)', otherwise, if open_parens is true,
@ -1511,6 +1766,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
case 'a':
end_colon = false;
head = NULL;
if ((mask & OMP_CLAUSE_ASSUMPTIONS)
&& gfc_match ("absent ( ") == MATCH_YES)
{
if (gfc_omp_absent_contains_clause (&c->assume, true)
!= MATCH_YES)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_ALIGNED)
&& gfc_match_omp_variable_list ("aligned (",
&c->lists[OMP_LIST_ALIGNED],
@ -1743,6 +2006,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_ASSUMPTIONS)
&& gfc_match ("contains ( ") == MATCH_YES)
{
if (gfc_omp_absent_contains_clause (&c->assume, false)
!= MATCH_YES)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("copy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
@ -2277,6 +2548,20 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
goto error;
continue;
}
if ((mask & OMP_CLAUSE_ASSUMPTIONS)
&& gfc_match ("holds ( ") == MATCH_YES)
{
gfc_expr *e;
if (gfc_match ("%e )", &e) != MATCH_YES)
goto error;
if (c->assume == NULL)
c->assume = gfc_get_omp_assumptions ();
gfc_expr_list *el = XCNEW (gfc_expr_list);
el->expr = e;
el->next = c->assume->holds;
c->assume->holds = el;
continue;
}
if ((mask & OMP_CLAUSE_HOST_SELF)
&& gfc_match ("host ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
@ -2664,6 +2949,41 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
OMP_MAP_IF_PRESENT, true,
allow_derived))
continue;
if ((mask & OMP_CLAUSE_ASSUMPTIONS)
&& (m = gfc_match_dupl_check (!c->assume
|| !c->assume->no_openmp_routines,
"no_openmp_routines")) == MATCH_YES)
{
if (m == MATCH_ERROR)
goto error;
if (c->assume == NULL)
c->assume = gfc_get_omp_assumptions ();
c->assume->no_openmp_routines = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_ASSUMPTIONS)
&& (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
"no_openmp")) == MATCH_YES)
{
if (m == MATCH_ERROR)
goto error;
if (c->assume == NULL)
c->assume = gfc_get_omp_assumptions ();
c->assume->no_openmp = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_ASSUMPTIONS)
&& (m = gfc_match_dupl_check (!c->assume
|| !c->assume->no_parallelism,
"no_parallelism")) == MATCH_YES)
{
if (m == MATCH_ERROR)
goto error;
if (c->assume == NULL)
c->assume = gfc_get_omp_assumptions ();
c->assume->no_parallelism = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_NOGROUP)
&& (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
!= MATCH_NO)
@ -3941,6 +4261,69 @@ match_omp (gfc_exec_op op, const omp_mask mask)
}
match
gfc_match_omp_assume (void)
{
gfc_omp_clauses *c;
locus loc = gfc_current_locus;
if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
!= MATCH_YES)
|| (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
&loc) != MATCH_YES))
return MATCH_ERROR;
new_st.op = EXEC_OMP_ASSUME;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
gfc_match_omp_assumes (void)
{
gfc_omp_clauses *c;
locus loc = gfc_current_locus;
if (!gfc_current_ns->proc_name
|| (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
&& !gfc_current_ns->proc_name->attr.subroutine
&& !gfc_current_ns->proc_name->attr.function))
{
gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
"subprogram or module");
return MATCH_ERROR;
}
if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
!= MATCH_YES)
|| (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
gfc_current_ns->omp_assumes, &loc)
!= MATCH_YES))
return MATCH_ERROR;
if (gfc_current_ns->omp_assumes == NULL)
{
gfc_current_ns->omp_assumes = c->assume;
c->assume = NULL;
}
else if (gfc_current_ns->omp_assumes && c->assume)
{
gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
gfc_current_ns->omp_assumes->no_openmp_routines
|= c->assume->no_openmp_routines;
gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
{
gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
for ( ; el->next ; el = el->next)
;
el->next = c->assume->holds;
}
else if (c->assume->holds)
gfc_current_ns->omp_assumes->holds = c->assume->holds;
c->assume->holds = NULL;
}
gfc_free_omp_clauses (c);
return MATCH_YES;
}
match
gfc_match_omp_critical (void)
{
@ -6505,6 +6888,20 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
return copy;
}
/* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
is handled during parse time in omp_verify_merge_absent_contains. */
void
gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
{
for (gfc_expr_list *el = assume->holds; el; el = el->next)
if (!gfc_resolve_expr (el->expr) || el->expr->ts.type != BT_LOGICAL)
gfc_error ("HOLDS expression at %L must be a logical expression",
&el->expr->where);
}
/* OpenMP directive resolving routines. */
static void
@ -7888,6 +8285,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
gfc_error ("%<DETACH%> clause at %L must not be used together with "
"%<MERGEABLE%> clause", &omp_clauses->detach->where);
}
if (omp_clauses->assume)
gfc_resolve_omp_assumptions (omp_clauses->assume);
}
@ -9116,6 +9516,8 @@ omp_code_to_statement (gfc_code *code)
return ST_OMP_DO;
case EXEC_OMP_LOOP:
return ST_OMP_LOOP;
case EXEC_OMP_ASSUME:
return ST_OMP_ASSUME;
case EXEC_OMP_ATOMIC:
return ST_OMP_ATOMIC;
case EXEC_OMP_BARRIER:
@ -9635,6 +10037,7 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_TEAMS_LOOP:
resolve_omp_do (code);
break;
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_ERROR:
case EXEC_OMP_MASKED:

31
gcc/fortran/parse.cc
View File

@ -885,6 +885,8 @@ decode_omp_directive (void)
switch (c)
{
case 'a':
matcho ("assumes", gfc_match_omp_assumes, ST_OMP_ASSUMES);
matchs ("assume", gfc_match_omp_assume, ST_OMP_ASSUME);
matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
break;
case 'b':
@ -913,6 +915,7 @@ decode_omp_directive (void)
break;
case 'e':
matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
matchs ("end distribute parallel do simd", gfc_match_omp_eos_error,
@ -1716,6 +1719,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_CRITICAL: \
case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
@ -1733,7 +1737,7 @@ next_statement (void)
#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
case ST_OMP_DECLARE_VARIANT: \
case ST_OMP_DECLARE_VARIANT: case ST_OMP_ASSUMES: \
case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* Block end statements. Errors associated with interchanging these
@ -1925,10 +1929,11 @@ gfc_enclosing_unit (gfc_compile_state * result)
}
/* Translate a statement enum to a string. */
/* Translate a statement enum to a string. If strip_sentinel is true,
the !$OMP/!$ACC sentinel is excluded. */
const char *
gfc_ascii_statement (gfc_statement st)
gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
{
const char *p;
@ -2353,6 +2358,12 @@ gfc_ascii_statement (gfc_statement st)
case ST_OACC_END_ATOMIC:
p = "!$ACC END ATOMIC";
break;
case ST_OMP_ASSUME:
p = "!$OMP ASSUME";
break;
case ST_OMP_ASSUMES:
p = "!$OMP ASSUMES";
break;
case ST_OMP_ATOMIC:
p = "!$OMP ATOMIC";
break;
@ -2401,6 +2412,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_DO_SIMD:
p = "!$OMP DO SIMD";
break;
case ST_OMP_END_ASSUME:
p = "!$OMP END ASSUME";
break;
case ST_OMP_END_ATOMIC:
p = "!$OMP END ATOMIC";
break;
@ -2600,6 +2614,10 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_ORDERED_DEPEND:
p = "!$OMP ORDERED";
break;
case ST_OMP_NOTHING:
/* Note: gfc_match_omp_nothing returns ST_NONE. */
p = "!$OMP NOTHING";
break;
case ST_OMP_PARALLEL:
p = "!$OMP PARALLEL";
break;
@ -2751,6 +2769,8 @@ gfc_ascii_statement (gfc_statement st)
gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
}
if (strip_sentinel && p[0] == '!')
return p + strlen ("!$OMP ");
return p;
}
@ -5518,6 +5538,9 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
switch (omp_st)
{
case ST_OMP_ASSUME:
omp_end_st = ST_OMP_END_ASSUME;
break;
case ST_OMP_PARALLEL:
omp_end_st = ST_OMP_END_PARALLEL;
break;
@ -5651,6 +5674,7 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
parse_forall_block ();
break;
case ST_OMP_ASSUME:
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_MASKED:
case ST_OMP_PARALLEL_MASTER:
@ -5874,6 +5898,7 @@ parse_executable (gfc_statement st)
parse_oacc_structured_block (st);
break;
case ST_OMP_ASSUME:
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_MASKED:
case ST_OMP_PARALLEL_MASTER:

2
gcc/fortran/parse.h
View File

@ -66,7 +66,7 @@ extern gfc_state_data *gfc_state_stack;
int gfc_check_do_variable (gfc_symtree *);
bool gfc_find_state (gfc_compile_state);
gfc_state_data *gfc_enclosing_unit (gfc_compile_state *);
const char *gfc_ascii_statement (gfc_statement);
const char *gfc_ascii_statement (gfc_statement, bool strip_sentinel = false) ;
match gfc_match_enum (void);
match gfc_match_enumerator_def (void);
void gfc_free_enum_history (void);

5
gcc/fortran/resolve.cc
View File

@ -10902,6 +10902,7 @@ 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_ASSUME:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
@ -12376,6 +12377,7 @@ start:
gfc_resolve_oacc_directive (code, ns);
break;
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CANCEL:
@ -17651,6 +17653,9 @@ gfc_resolve (gfc_namespace *ns)
component_assignment_level = 0;
resolve_codes (ns);
if (ns->omp_assumes)
gfc_resolve_omp_assumptions (ns->omp_assumes);
gfc_current_ns = old_ns;
cs_base = old_cs_base;
ns->resolved = 1;

1
gcc/fortran/st.cc
View File

@ -214,6 +214,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
case EXEC_OACC_ROUTINE:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:

8
gcc/fortran/symbol.cc
View File

@ -4071,7 +4071,13 @@ gfc_free_namespace (gfc_namespace *&ns)
f = f->next;
free (current);
}
if (ns->omp_assumes)
{
free (ns->omp_assumes->absent);
free (ns->omp_assumes->contains);
gfc_free_expr_list (ns->omp_assumes->holds);
free (ns->omp_assumes);
}
p = ns->contained;
free (ns);
ns = NULL;

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

@ -7487,6 +7487,8 @@ gfc_trans_omp_directive (gfc_code *code)
{
switch (code->op)
{
case EXEC_OMP_ASSUME:
return gfc_trans_omp_code (code->block->next, true);
case EXEC_OMP_ATOMIC:
return gfc_trans_omp_atomic (code);
case EXEC_OMP_BARRIER:

1
gcc/fortran/trans.cc
View File

@ -2174,6 +2174,7 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_dt_end (code);
break;
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CANCEL:

24
gcc/testsuite/gfortran.dg/gomp/assume-1.f90 Normal file
View File

@ -0,0 +1,24 @@
subroutine foo (i, a)
implicit none
integer, value :: i
integer :: a(:)
integer :: j
j = 7
!$omp assume no_openmp, absent (target, teams) holds (i < 32) holds (i < 32_2)
!$omp end assume
!$omp assume no_openmp_routines, contains (simd)
block
!$omp simd
do j = 1, i
a(i) = j
end do
end block
!$omp assume no_parallelism, contains (error)
if (i >= 32) then
!$omp error at (execution) message ("Should not happen")
end if
!$omp end assume
end

27
gcc/testsuite/gfortran.dg/gomp/assume-2.f90 Normal file
View File

@ -0,0 +1,27 @@
subroutine foo (i, a)
implicit none
integer, value :: i
integer :: a(:)
integer :: j
j = 7
!$omp assume no_openmp, absent (target, teams,target) holds (i < 32) holds (i < 32_2) ! { dg-error "'TARGET' directive mentioned multiple times in ABSENT clause in !.OMP ASSUME directive" }
! !$omp end assume - silence: 'Unexpected !$OMP END ASSUME statement'
!$omp assume no_openmp_routines, contains (simd) contains ( simd ) ! { dg-error "'SIMD' directive mentioned multiple times in CONTAINS clause in !.OMP ASSUME directive" }
block
!$omp simd
do j = 1, i
a(i) = j
end do
end block
!$omp assume no_parallelism, contains (error) absent (error) ! { dg-error "'ERROR' directive mentioned both times in ABSENT and CONTAINS clauses in !.OMP ASSUME directive" }
if (i >= 32) then
!$omp error at (execution) message ("Should not happen")
end if
! !$omp end assume - silence: 'Unexpected !$OMP END ASSUME statement'
!$omp assume holds (1.0) ! { dg-error "HOLDS expression at .1. must be a logical expression" }
!$omp end assume
end

82
gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 Normal file
View File

@ -0,0 +1,82 @@
! All of the following (up to PROGRAM) are okay:
!
subroutine sub
interface
subroutine sub_iterface()
!$omp assumes no_openmp_routines absent(simd) ! OK inferface of an external subroutine/subprogram
end
end interface
!$omp assumes no_openmp_routines absent(simd) ! OK external subroutine/subprogram
contains
subroutine inner_sub
!$omp assumes no_parallelism absent(teams) ! OK internal subroutine/subprogram
end
end
integer function func ()
!$omp assumes no_openmp_routines absent(simd) ! OK external function/subprogram
interface
integer function func_iterface()
!$omp assumes no_openmp_routines absent(simd) ! OK inferface of an external function/subprogram
end
end interface
func = 0
contains
integer function inner_func()
!$omp assumes no_parallelism absent(teams) ! OK internal function/subprogram
inner_sub2 = 0
end
end
module m
integer ::x
!$omp assumes contains(target) holds(x > 0.0)
interface
subroutine mod_mod_sub_iterface()
!$omp assumes no_openmp_routines absent(simd) ! OK inferface of an external subroutine/subprogram
end
integer function mod_mod_func_iterface()
!$omp assumes no_openmp_routines absent(error) ! OK inferface of an external subroutine/subprogram
end
end interface
contains
subroutine mod_sub
interface
subroutine mod_sub_iterface()
!$omp assumes no_openmp_routines absent(simd) ! OK inferface of an external subroutine/subprogram
end
end interface
!$omp assumes no_openmp_routines absent(simd) ! OK module subroutine/subprogram
contains
subroutine mod_inner_sub
!$omp assumes no_parallelism absent(teams) ! OK internal subroutine/subprogram
end
end
integer function mod_func ()
!$omp assumes no_openmp_routines absent(simd) ! OK module function/subprogram
interface
integer function mod_func_iterface()
!$omp assumes no_openmp_routines absent(simd) ! OK inferface of an external function/subprogram
end
end interface
mod_func = 0
contains
integer function mod_inner_func()
!$omp assumes no_parallelism absent(teams) ! OK internal function/subprogram
mod_inner_sub2 = 0
end
end
end module m
! PROGRAM - invalid as:
! main program is a program unit that is not a subprogram
!$omp assumes no_openmp absent(simd) ! { dg-error "must be in the specification part of a subprogram or module" }
block
! invalid: block
!$omp assumes no_openmp absent(target) ! { dg-error "must be in the specification part of a subprogram or module" }
end block
end

19
gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 Normal file
View File

@ -0,0 +1,19 @@
module m
integer ::x
! Nonsense but OpenMP-semantically valid:
!$omp assumes contains(target) holds(x > 0.0)
!$omp assumes absent(target)
!$omp assumes holds(0.0)
! { dg-error "HOLDS expression at .1. must be a logical expression" "" { target *-*-* } .-1 }
end module
module m2
interface
subroutine foo
!$omp assumes contains(target) contains(teams,target) ! { dg-error "'TARGET' directive mentioned multiple times in CONTAINS clause in !.OMP ASSUMES directive" }
!$omp assumes absent(declare target) ! { dg-error "Invalid 'DECLARE TARGET' directive at .1. in ABSENT clause: declarative, informational and meta directives not permitted" }
!$omp assumes absent(parallel) absent(do,simd,parallel,distribute) ! { dg-error "'PARALLEL' directive mentioned multiple times in ABSENT clause in !.OMP ASSUMES directive" }
!$omp assumes contains(barrier,atomic) absent(cancel,simd,atomic,distribute) ! { dg-error "'SIMD' directive mentioned both times in ABSENT and CONTAINS clauses in !.OMP ASSUMES directive" }
end subroutine foo
end interface
end module m2

2
libgomp/libgomp.texi
View File

@ -287,7 +287,7 @@ The OpenMP 4.5 specification is fully supported.
@code{append_args} @tab N @tab
@item @code{dispatch} construct @tab N @tab
@item device-specific ICV settings with environment variables @tab Y @tab
@item @code{assume} directive @tab P @tab Only C/C++
@item @code{assume} directive @tab Y @tab
@item @code{nothing} directive @tab Y @tab
@item @code{error} directive @tab Y @tab
@item @code{masked} construct @tab Y @tab