Fortran: Add OpenMP's assume(s) directives
Checks
Commit Message
This patch adds '!$omp assume' and '!$omp assumes' support.
None of the directives is used after resolution.
When we actually start using for 'assumes', it has to be stored in .mod
files. The other question is how to handle 'holds()' expressions with 'assumes'.
-fopenmp-simd: I used a longer wording to imply that not only the 'simd' but
all SIMD directives are enabled.
OK for mainline?
Tobias
PS: For 'assume' with holds clause, the same applies as for Jakub's commit/patch:
"openmp: Add OpenMP assume, assumes and begin/end assumes support"
https://gcc.gnu.org/r13-3020-gd01bd0b0f3b8f4c33c437ff10f0b949200627f56
Namely, it requires that the following - now half-approved - patch is committed:
"<https://gcc.gnu.org/r13-3020-gd01bd0b0f3b8f4c33c437ff10f0b949200627f56Namely,itrequiresthatthefollowing-nowhalf-approved-patchiscommitted:>[PATCH] c++, c: Implement C++23 P1774R8 - Portable assumptions [PR106654]"
https://gcc.gnu.org/pipermail/gcc-patches/2022-September/601991.html
PPS: I intent to take care in a separate patch the new rules for where
OpenMP specification part directives be placed (i.e. after USE/INTENT/IMPORT)
for all delarative + informational routines, the latter includes the 'assumes'
directive.
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
Comments
On Sun, Oct 02, 2022 at 07:47:18PM +0200, Tobias Burnus wrote:
> gcc/ChangeLog:
>
> * doc/invoke.texi (-fopenmp-simd): Document that also 'assume'
> is enabled.
>
> 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 and ST_OMP_ASSUMES.
> (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): Declare.
> (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.
> (gfc_match_omp_assume, gfc_match_omp_assumes): New.
> (gfc_resolve_omp_assumptions): New.
> (resolve_omp_clauses): Call it.
> (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.
> (is_omp_declarative_stmt, is_omp_informational_stmt): New.
> * parse.h (gfc_ascii_statement): Add optional bool arg to prototype.
> (is_omp_declarative_stmt, is_omp_informational_stmt): New 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.
> --- a/gcc/doc/invoke.texi
> +++ b/gcc/doc/invoke.texi
> @@ -2749,9 +2749,9 @@ have support for @option{-pthread}. @option{-fopenmp} implies
> @opindex fopenmp-simd
> @cindex OpenMP SIMD
> @cindex SIMD
> -Enable handling of OpenMP's SIMD directives with @code{#pragma omp}
> -in C/C++ and @code{!$omp} in Fortran. Other OpenMP directives
> -are ignored.
> +Enable handling of OpenMP's SIMD directives and OPENMP's @code{assume} directive
s/OPENMP/OpenMP/
We actually handle more directives, @code{declare reduction},
@code{ordered}, @code{scan}, @code{loop} and combined/composite directives
with @code{simd} as constituent.
> +with @code{#pragma omp} in C/C++ and @code{!$omp} in Fortran. Other OpenMP
> +directives are ignored.
And now in C++ we handle also the attribute syntax (guess we should update
the text for that here as well as in -fopenmp entry).
> @@ -3531,6 +3565,14 @@ show_namespace (gfc_namespace *ns)
> }
> }
>
> + if (ns->omp_assumes)
> + {
> + show_indent ();
> + fprintf (dumpfile, "!$OMP ASSUMES");
> + show_omp_assumes (ns->omp_assumes);
> + }
> +
> +
Just one empty line?
> fputc ('\n', dumpfile);
> show_indent ();
> fputs ("code:", dumpfile);
> diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
> index 4babd77924b..29a443dcd44 100644
> --- a/gcc/fortran/gfortran.h
> +++ b/gcc/fortran/gfortran.h
> @@ -316,7 +316,7 @@ 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, ST_NONE
> };
>
> /* Types of interfaces that we can have. Assignment interfaces are
> @@ -1506,6 +1506,19 @@ 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;
> + locus where;
> + 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 +1542,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 +2159,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 +2930,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 +3593,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 *, const char *, locus *);
> 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 *);
> diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
> index 1f53e0cb67d..2a805815d9c 100644
> --- a/gcc/fortran/match.h
> +++ b/gcc/fortran/match.h
> @@ -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);
> diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
> index ce719bd5d92..df1f046170d 100644
> --- a/gcc/fortran/openmp.cc
> +++ b/gcc/fortran/openmp.cc
> @@ -30,6 +30,9 @@ along with GCC; see the file COPYING3. If not see
> #include "gomp-constants.h"
> #include "target-memory.h" /* For gfc_encode_character. */
>
> +
> +static gfc_statement omp_code_to_statement (gfc_code *);
> +
> /* Match an end of OpenMP directive. End of OpenMP directive is optional
> whitespace, followed by '\n' or comment '!'. */
>
> @@ -111,6 +114,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 +1002,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 +1418,167 @@ 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;
> + switch (gfc_peek_ascii_char ())
> + {
> + case 'a':
> + if (gfc_match ("assumes") == MATCH_YES)
> + st = ST_OMP_ASSUMES;
> + else if (gfc_match ("assume") == MATCH_YES)
> + st = ST_OMP_ASSUME;
> + else if (gfc_match ("atomic") == MATCH_YES)
> + st = ST_OMP_ATOMIC;
Wouldn't this be better table driven (like c_omp_directives
in c-family, though guess for Fortran you can just use spaces
in the name, don't need 3 strings for the separate tokens)?
Because I think absent/contains isn't the only spot where
you need directive names, metadirective is another.
> + if (is_omp_declarative_stmt (st) || is_omp_informational_stmt (st))
> + {
> + 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");
Do you think we should do the same for C/C++?
Right now it doesn't differentiate between invalid directive names and
names of declarative, informational or meta directives.
> + return MATCH_ERROR;
> + }
> + if (is_absent)
> + {
> + (*assume)->n_absent++;
> + (*assume)->absent
> + = (gfc_statement *) xrealloc ((*assume)->absent,
> + sizeof (gfc_statement)
> + * (*assume)->n_absent);
XRESIZEVEC?
But also, resizing each time a single entry is added to the list isn't
good for compile time, would be nice to grow the allocation size in
powers of 2 or so.
> + (*assume)->absent[(*assume)->n_absent - 1] = st;
> + }
> + else
> + {
> + (*assume)->n_contains++;
> + (*assume)->contains
> + = (gfc_statement *) xrealloc ((*assume)->contains,
> + sizeof (gfc_statement)
> + * (*assume)->n_contains);
Likewise.
> + (*assume)->contains[(*assume)->n_contains - 1] = 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;
> +}
>
> /* Match with duplicate check. Matches 'name'. If expr != NULL, it
> then matches '(expr)', otherwise, if open_parens is true,
> @@ -1472,10 +1644,10 @@ static match
> gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
> bool first = true, bool needs_space = true,
> bool openacc = false, bool context_selector = false,
> - bool openmp_target = false)
> + bool openmp_target = false, bool alloc_cp = true)
> {
> bool error = false;
> - gfc_omp_clauses *c = gfc_get_omp_clauses ();
> + gfc_omp_clauses *c;
> locus old_loc;
> /* Determine whether we're dealing with an OpenACC directive that permits
> derived type member accesses. This in particular disallows
> @@ -1487,7 +1659,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
> || (mask & OMP_CLAUSE_HOST_SELF)));
>
> gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
> - *cp = NULL;
> + if (alloc_cp)
> + {
> + c = gfc_get_omp_clauses ();
> + *cp = NULL;
> + }
> + else
> + c = *cp;
> while (1)
> {
> match m = MATCH_NO;
> @@ -1511,6 +1689,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 +1929,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 +2471,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 +2872,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 +4184,42 @@ match_omp (gfc_exec_op op, const omp_mask mask)
> }
>
>
> +match
> +gfc_match_omp_assume (void)
> +{
> + return match_omp (EXEC_OMP_ASSUME, omp_mask (OMP_CLAUSE_ASSUMPTIONS));
> +}
> +
> +
> +match
> +gfc_match_omp_assumes (void)
> +{
> + locus loc = gfc_current_locus;
> + gfc_omp_clauses *c = gfc_get_omp_clauses ();
> + c->assume = gfc_current_ns->omp_assumes;
> + 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), true, true,
> + false, false, false, false) != MATCH_YES)
> + {
> + gfc_current_ns->omp_assumes = NULL;
> + return MATCH_ERROR;
> + }
I don't understand the point of preallocation of gfc_omp_clauses here,
can't it be allocated inside of gfc_match_omp_clauses like everywhere else?
Because otherwise it e.g. leaks if the first error is reported.
> + c->assume->where = loc;
> + gfc_current_ns->omp_assumes = c->assume;
> + c->assume = NULL;
> + gfc_free_omp_clauses (c);
> + return MATCH_YES;
> +}
> +
> +
> match
> gfc_match_omp_critical (void)
> {
> @@ -6505,6 +6784,42 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
> return copy;
> }
>
> +
> +/* Resolve ASSUME's and ASSUMES' assumption clauses. */
> +
> +void
> +gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume, const char *directive,
> + locus *loc)
> +{
> + 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);
> + for (int i = 0; i < assume->n_absent; i++)
> + {
> + for (int j = i + 1; j < assume->n_absent; j++)
> + if (assume->absent[i] == assume->absent[j])
> + gfc_error ("%qs directive mentioned multiple times in %s clause in %s"
> + " directive at %L",
> + gfc_ascii_statement (assume->absent[i], true),
> + "ABSENT", directive, loc);
> + for (int j = 0; j < assume->n_contains; j++)
> + if (assume->absent[i] == assume->contains[j])
> + gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS"
> + " clauses in %s directive at %L",
> + gfc_ascii_statement (assume->absent[i], true),
> + directive, loc);
> + }
> + for (int i = 0; i < assume->n_contains; i++)
> + for (int j = i + 1; j < assume->n_contains; j++)
> + if (assume->contains[i] == assume->contains[j])
> + gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
> + "directive at %L",
> + gfc_ascii_statement (assume->contains[i], true),
> + "CONTAINS", directive, loc);
This is O(n^2)? Can't you use a bitmap or hash map instead?
Otherwise LGTM.
Jakub
Hi Jakub,
On 04.10.22 12:19, Jakub Jelinek wrote:
On Sun, Oct 02, 2022 at 07:47:18PM +0200, Tobias Burnus wrote:
--- a/gcc/doc/invoke.texi
+++ b/gcc/doc/invoke.texi
@@ -2749,9 +2749,9 @@ have support for @option{-pthread}. @option{-fopenmp} implies
@opindex fopenmp-simd
@cindex OpenMP SIMD
@cindex SIMD
-Enable handling of OpenMP's SIMD directives with @code{#pragma omp}
-in C/C++ and @code{!$omp} in Fortran. Other OpenMP directives
-are ignored.
+Enable handling of OpenMP's SIMD directives and OPENMP's @code{assume} directive
s/OPENMP/OpenMP/
We actually handle more directives, @code{declare reduction},
@code{ordered}, @code{scan}, @code{loop} and combined/composite directives
with @code{simd} as constituent.
...
And now in C++ we handle also the attribute syntax (guess we should update
the text for that here as well as in -fopenmp entry).
Updated suggestion attached – I still need to update the main patch.
(I also added 'declare simd' to the list. And I updated Fortran for scan + loop.)
OK?
* * *
Wouldn't this be better table driven (like c_omp_directives
in c-family, though guess for Fortran you can just use spaces
in the name, don't need 3 strings for the separate tokens)?
Because I think absent/contains isn't the only spot where
you need directive names, metadirective is another.
Maybe – I think there are already way to many string repetitions. One problem is that metadirectives permit combined/composite constructs while 'assume(s)' does not. I on purpose did not parse them, but probably in light of Metadirectives, I should.
I will take a look.
+ if (is_omp_declarative_stmt (st) || is_omp_informational_stmt (st))
+ {
+ 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");
Do you think we should do the same for C/C++?
Right now it doesn't differentiate between invalid directive names and
names of declarative, informational or meta directives.
Maybe - it might help users to understand why something went wrong, on the other hand, I do not really think that a user adds 'absent(declare variant)', but I might be wrong.
+ = (gfc_statement *) xrealloc ((*assume)->absent,
+ sizeof (gfc_statement)
+ * (*assume)->n_absent);
XRESIZEVEC?
Aha, that's the macro name!
But also, resizing each time a single entry is added to the list isn't
good for compile time, would be nice to grow the allocation size in
powers of 2 or so.
I only expect a very small number – and did not want to keep track of yet another number.
However, the following should work:
if (old_n_absent = 0)
absent = ... sizeof() * 1
else if (popcount (old_n_absent) == 1)
absent = ... sizeof() * (old_n_absent) * 2)
that allocates: 1, 2, 4, 8, 16, 32, ... without keeping track of the number.
+gfc_match_omp_assumes (void)
+{
+ locus loc = gfc_current_locus;
+ gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ c->assume = gfc_current_ns->omp_assumes;
+ 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), true, true,
+ false, false, false, false) != MATCH_YES)
+ {
+ gfc_current_ns->omp_assumes = NULL;
+ return MATCH_ERROR;
+ }
I don't understand the point of preallocation of gfc_omp_clauses here,
can't it be allocated inside of gfc_match_omp_clauses like everywhere else?
Because otherwise it e.g. leaks if the first error is reported.
This is supposed to handle:
subroutine foo()
!$omp assumes absent(target)
!$omp assumes absent(teams)
end
I did not spot anything which states that it is invalid.
(I might have missed it, however.) And if it is valid,
I assume it is equivalent to:
subroutine foo()
!$omp assumes absent(target, teams)
end
And the simplest way to do the merge seems to use gfc_match_omp_clauses,
which already handles merging 'absent(target) absent(teams)'.
Thus, I pre-populate the clause list with the assumption values from
the previous directive.
Additionally, there shouldn't be a leak as inside gfc_omp_match_clauses is:
gfc_free_omp_clauses (c);
return MATCH_ERROR;
which frees the memory. To avoid double freeing, a possibly pre-existing
'gfc_current_ns->omp_assumes' has to be set to NULL.
The other question is whether the spec is clear, e.g. is the following valid?
!$omp assumes no_openmp
!$omp assumes no_openmp
In each directive, no_openmp is unique but the combination is not (but it
should be fine, here). While for
!$omp assumes absent(target)
!$omp assumes contains(target)
there is surely an issue.
+ for (int i = 0; i < assume->n_contains; i++)
+ for (int j = i + 1; j < assume->n_contains; j++)
+ if (assume->contains[i] == assume->contains[j])
+ gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
+ "directive at %L",
+ gfc_ascii_statement (assume->contains[i], true),
+ "CONTAINS", directive, loc);
This is O(n^2)? Can't you use a bitmap or hash map instead?
How about adding a 'break; after the all the gfc_error instead?
This turns O(n^2) into O(n) and I am pretty sure in the common
case, it is much faster than using a hash or bitmap.
Reason: There 38 permitted directives of which 7 are rejected at parse time,
hence 31 remain. The worst case is to have as input:
dir_1, dir_2, ..., dir_31, dir_31,... dir_31
Thus, there are '(n-1) + (n-2) + ... + (n-30) + 1' iterations until
the first error is found, which is O(n*3O) = O(n).
In the real world, I assume n <= 5 and it seems to be faster to
do 4+3+2+1 = 10 comparisons rather than starting to construct
a hash or a bitmap.
However, if you think it still makes sense to create a bitmap or hash,
I can do it.
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
On Tue, Oct 04, 2022 at 02:26:13PM +0200, Tobias Burnus wrote:
> Hi Jakub,
>
> On 04.10.22 12:19, Jakub Jelinek wrote:
>
> On Sun, Oct 02, 2022 at 07:47:18PM +0200, Tobias Burnus wrote:
>
>
> --- a/gcc/doc/invoke.texi
> +++ b/gcc/doc/invoke.texi
> @@ -2749,9 +2749,9 @@ have support for @option{-pthread}. @option{-fopenmp} implies
> @opindex fopenmp-simd
> @cindex OpenMP SIMD
> @cindex SIMD
> -Enable handling of OpenMP's SIMD directives with @code{#pragma omp}
> -in C/C++ and @code{!$omp} in Fortran. Other OpenMP directives
> -are ignored.
> +Enable handling of OpenMP's SIMD directives and OPENMP's @code{assume} directive
>
>
> s/OPENMP/OpenMP/
>
> We actually handle more directives, @code{declare reduction},
> @code{ordered}, @code{scan}, @code{loop} and combined/composite directives
> with @code{simd} as constituent.
> ...
> And now in C++ we handle also the attribute syntax (guess we should update
> the text for that here as well as in -fopenmp entry).
>
> Updated suggestion attached – I still need to update the main patch.
>
> (I also added 'declare simd' to the list. And I updated Fortran for scan + loop.)
>
> OK?
Ok, thanks.
> Wouldn't this be better table driven (like c_omp_directives
> in c-family, though guess for Fortran you can just use spaces
> in the name, don't need 3 strings for the separate tokens)?
> Because I think absent/contains isn't the only spot where
> you need directive names, metadirective is another.
>
> Maybe – I think there are already way to many string repetitions. One problem is that metadirectives permit combined/composite constructs while 'assume(s)' does not. I on purpose did not parse them, but probably in light of Metadirectives, I should.
>
> I will take a look.
It is true that metadirective supports combined/composite constructs,
and so do we in the C++ attribute case, still we IMHO can use the C/C++
table as is.and it doesn't need to include combined/composite constructs.
The thing is that for the metadirective/C++ attribute case, all we need to
know is to discover the directive category (declarative, stand-alone,
construct, informational, ...) and for that it is enough to parse the
first directive-name in combined/composite constructs. Both metadirectives
and C++ attributes then have the name of the directive followed by clauses
so we effectively have to use the normal parsing of directives/clauses
there (except perhaps not end on end of directive but on unbalanced closing
paren). And then there is the absent/contains case, where we only
allow non-combined/composite, so there we need to try to match the directive
name from the table and make sure it is followed by , or ).
> But also, resizing each time a single entry is added to the list isn't
> good for compile time, would be nice to grow the allocation size in
> powers of 2 or so.
>
> I only expect a very small number – and did not want to keep track of yet another number.
>
> However, the following should work:
>
>
> if (old_n_absent = 0)
> absent = ... sizeof() * 1
> else if (popcount (old_n_absent) == 1)
> absent = ... sizeof() * (old_n_absent) * 2)
Yeah. Or for 0 allocate say 8 and
use (pow2p_hwi (old_n_absent) && old_n_absent >= 8)
in the else if.
> that allocates: 1, 2, 4, 8, 16, 32, ... without keeping track of the number.
>
>
>
> +gfc_match_omp_assumes (void)
> +{
> + locus loc = gfc_current_locus;
> + gfc_omp_clauses *c = gfc_get_omp_clauses ();
> + c->assume = gfc_current_ns->omp_assumes;
> + 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), true, true,
> + false, false, false, false) != MATCH_YES)
> + {
> + gfc_current_ns->omp_assumes = NULL;
> + return MATCH_ERROR;
> + }
>
>
>
> I don't understand the point of preallocation of gfc_omp_clauses here,
> can't it be allocated inside of gfc_match_omp_clauses like everywhere else?
> Because otherwise it e.g. leaks if the first error is reported.
>
> This is supposed to handle:
> subroutine foo()
> !$omp assumes absent(target)
> !$omp assumes absent(teams)
> end
>
> I did not spot anything which states that it is invalid.
> (I might have missed it, however.) And if it is valid,
> I assume it is equivalent to:
>
> subroutine foo()
> !$omp assumes absent(target, teams)
> end
It is not equivalent to that, because while we have the restriction
that the same list item can't appear multiple times on the same directive,
it can appear multiple times on multiple directives.
So,
subroutine foo()
!$omp assumes absent(target, target)
end
or
subroutine foo()
!$omp assumes absent(target) absent(target)
end
etc. are invalid but
subroutine foo()
!$omp assumes absent(target)
!$omp assumes absent(target)
end
is fine (sure, redundant).
> + for (int i = 0; i < assume->n_contains; i++)
> + for (int j = i + 1; j < assume->n_contains; j++)
> + if (assume->contains[i] == assume->contains[j])
> + gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
> + "directive at %L",
> + gfc_ascii_statement (assume->contains[i], true),
> + "CONTAINS", directive, loc);
>
>
>
> This is O(n^2)? Can't you use a bitmap or hash map instead?
>
> How about adding a 'break; after the all the gfc_error instead?
True, I guess I can live with that. It is less user-friendly
because it will print just one of the errors rather than all of them,
though typically one will not have too many repetitions in there and
can fix them one at a time as well.
Jakub
Hi Jakub,
On 04.10.22 14:58, Jakub Jelinek via Gcc-patches wrote:
On Tue, Oct 04, 2022 at 02:26:13PM +0200, Tobias Burnus wrote:
On Sun, Oct 02, 2022 at 07:47:18PM +0200, Tobias Burnus wrote:
--- a/gcc/doc/invoke.texi
+++ b/gcc/doc/invoke.texi
OK?
Ok, thanks.
Committed as https://gcc.gnu.org/r13-3063-g8792047470073df0da4a5b91997d6058193d7676
Wouldn't this be better table driven (like c_omp_directives
in c-family, though guess for Fortran you can just use spaces
in the name, don't need 3 strings for the separate tokens)?
Because I think absent/contains isn't the only spot where
you need directive names, metadirective is another.
Now added. I noted that I have different kinds/categories than you used in c-family/c-omp.c; and my impression that standalone vs. block vs delimited is a different category than informational/meta/...
Maybe – I think there are already way to many string repetitions. One problem is that metadirectives permit combined/composite constructs while 'assume(s)' does not. I on purpose did not parse them, but probably in light of Metadirectives, I should.
I will take a look.
It is true that metadirective supports combined/composite constructs,
and so do we in the C++ attribute case, still we IMHO can use the C/C++
table as is.and it doesn't need to include combined/composite constructs.
The thing is that for the metadirective/C++ attribute case, all we need to
know is to discover the directive category (declarative, stand-alone,
construct, informational, ...) and for that it is enough to parse the
first directive-name in combined/composite constructs.
...
else if (popcount (old_n_absent) == 1)
absent = ... sizeof() * (old_n_absent) * 2)
Yeah. Or for 0 allocate say 8 and
use (pow2p_hwi (old_n_absent) && old_n_absent >= 8)
in the else if.
I used now pow2p_hwi as popcount did not exist (and I didn't want to add an #include or use __builtin_popcount), not that either variant is clearer and it is neither performance critical nor is neither of "(x & -x) == x" and "popcount(x) == 1" slow.
I don't understand the point of preallocation of gfc_omp_clauses here,
...
That's now gone. As I have to check the duplication right after parsing – but before merging, I can no longer do it during resolution. Instead of keeping track of the directives separately, I now moved the checking to the directive parsing itself.
It is not equivalent to that, because while we have the restriction
that the same list item can't appear multiple times on the same directive,
it can appear multiple times on multiple directives.
I am not sure the handling of nested/repeated informational/declarative directives is very clear, but that's a separate issue. (Namely, OpenMP spec issue 3362.)
Updated patch enclosed. And thanks for your comments!
OK?
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
Minor update to just posted patch: the table did not revert all strings where a substring directive name existed, i.e. 'target' vs. 'target update', 'assume' vs. 'assumes'. Now fixed. Otherwise unchanged:
Tobias
On 05.10.22 13:19, Tobias Burnus wrote:
Hi Jakub,
On 04.10.22 14:58, Jakub Jelinek via Gcc-patches wrote:
On Tue, Oct 04, 2022 at 02:26:13PM +0200, Tobias Burnus wrote:
On Sun, Oct 02, 2022 at 07:47:18PM +0200, Tobias Burnus wrote:
--- a/gcc/doc/invoke.texi
+++ b/gcc/doc/invoke.texi
OK?
Ok, thanks.
Committed as https://gcc.gnu.org/r13-3063-g8792047470073df0da4a5b91997d6058193d7676
Wouldn't this be better table driven (like c_omp_directives
in c-family, though guess for Fortran you can just use spaces
in the name, don't need 3 strings for the separate tokens)?
Because I think absent/contains isn't the only spot where
you need directive names, metadirective is another.
Now added. I noted that I have different kinds/categories than you used in c-family/c-omp.c; and my impression that standalone vs. block vs delimited is a different category than informational/meta/...
Maybe – I think there are already way to many string repetitions. One problem is that metadirectives permit combined/composite constructs while 'assume(s)' does not. I on purpose did not parse them, but probably in light of Metadirectives, I should.
I will take a look.
It is true that metadirective supports combined/composite constructs,
and so do we in the C++ attribute case, still we IMHO can use the C/C++
table as is.and it doesn't need to include combined/composite constructs.
The thing is that for the metadirective/C++ attribute case, all we need to
know is to discover the directive category (declarative, stand-alone,
construct, informational, ...) and for that it is enough to parse the
first directive-name in combined/composite constructs.
...
else if (popcount (old_n_absent) == 1)
absent = ... sizeof() * (old_n_absent) * 2)
Yeah. Or for 0 allocate say 8 and
use (pow2p_hwi (old_n_absent) && old_n_absent >= 8)
in the else if.
I used now pow2p_hwi as popcount did not exist (and I didn't want to add an #include or use __builtin_popcount), not that either variant is clearer and it is neither performance critical nor is neither of "(x & -x) == x" and "popcount(x) == 1" slow.
I don't understand the point of preallocation of gfc_omp_clauses here,
...
That's now gone. As I have to check the duplication right after parsing – but before merging, I can no longer do it during resolution. Instead of keeping track of the directives separately, I now moved the checking to the directive parsing itself.
It is not equivalent to that, because while we have the restriction
that the same list item can't appear multiple times on the same directive,
it can appear multiple times on multiple directives.
I am not sure the handling of nested/repeated informational/declarative directives is very clear, but that's a separate issue. (Namely, OpenMP spec issue 3362.)
Updated patch enclosed. And thanks for your comments!
OK?
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
On Wed, Oct 05, 2022 at 02:29:56PM +0200, Tobias Burnus wrote:
> + gfc_error ("!OMP ASSUMES at %C must be in the specification part of a "
s/!OMP/!$OMP/
Otherwise LGTM.
Jakub
Fortran: Add OpenMP's assume(s) directives
gcc/ChangeLog:
* doc/invoke.texi (-fopenmp-simd): Document that also 'assume'
is enabled.
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 and ST_OMP_ASSUMES.
(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): Declare.
(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.
(gfc_match_omp_assume, gfc_match_omp_assumes): New.
(gfc_resolve_omp_assumptions): New.
(resolve_omp_clauses): Call it.
(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.
(is_omp_declarative_stmt, is_omp_informational_stmt): New.
* parse.h (gfc_ascii_statement): Add optional bool arg to prototype.
(is_omp_declarative_stmt, is_omp_informational_stmt): New 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.
gcc/doc/invoke.texi | 6 +-
gcc/fortran/dump-parse-tree.cc | 42 ++++
gcc/fortran/gfortran.h | 22 +-
gcc/fortran/match.h | 2 +
gcc/fortran/openmp.cc | 331 ++++++++++++++++++++++++++-
gcc/fortran/parse.cc | 53 ++++-
gcc/fortran/parse.h | 4 +-
gcc/fortran/resolve.cc | 6 +
gcc/fortran/st.cc | 1 +
gcc/fortran/symbol.cc | 8 +-
gcc/fortran/trans-openmp.cc | 2 +
gcc/fortran/trans.cc | 1 +
gcc/testsuite/gfortran.dg/gomp/assume-1.f90 | 24 ++
gcc/testsuite/gfortran.dg/gomp/assume-2.f90 | 27 +++
gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 | 84 +++++++
gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 | 7 +
libgomp/libgomp.texi | 2 +-
17 files changed, 608 insertions(+), 14 deletions(-)
@@ -2749,9 +2749,9 @@ have support for @option{-pthread}. @option{-fopenmp} implies
@opindex fopenmp-simd
@cindex OpenMP SIMD
@cindex SIMD
-Enable handling of OpenMP's SIMD directives with @code{#pragma omp}
-in C/C++ and @code{!$omp} in Fortran. Other OpenMP directives
-are ignored.
+Enable handling of OpenMP's SIMD directives and OPENMP's @code{assume} directive
+with @code{#pragma omp} in C/C++ and @code{!$omp} in Fortran. Other OpenMP
+directives are ignored.
@item -fpermitted-flt-eval-methods=@var{style}
@opindex fpermitted-flt-eval-methods
@@ -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,14 @@ 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);
@@ -316,7 +316,7 @@ 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, ST_NONE
};
/* Types of interfaces that we can have. Assignment interfaces are
@@ -1506,6 +1506,19 @@ 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;
+ locus where;
+ 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 +1542,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 +2159,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 +2930,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 +3593,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 *, const char *, locus *);
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 *);
@@ -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);
@@ -30,6 +30,9 @@ along with GCC; see the file COPYING3. If not see
#include "gomp-constants.h"
#include "target-memory.h" /* For gfc_encode_character. */
+
+static gfc_statement omp_code_to_statement (gfc_code *);
+
/* Match an end of OpenMP directive. End of OpenMP directive is optional
whitespace, followed by '\n' or comment '!'. */
@@ -111,6 +114,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 +1002,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 +1418,167 @@ 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;
+ switch (gfc_peek_ascii_char ())
+ {
+ case 'a':
+ if (gfc_match ("assumes") == MATCH_YES)
+ st = ST_OMP_ASSUMES;
+ else if (gfc_match ("assume") == MATCH_YES)
+ st = ST_OMP_ASSUME;
+ else if (gfc_match ("atomic") == MATCH_YES)
+ st = ST_OMP_ATOMIC;
+ break;
+ case 'b':
+ if (gfc_match ("barrier") == MATCH_YES)
+ st = ST_OMP_BARRIER;
+ break;
+ case 'c':
+ if (gfc_match ("cancel") == MATCH_YES)
+ st = ST_OMP_CANCEL;
+ else if (gfc_match ("cancellation point") == MATCH_YES)
+ st = ST_OMP_CANCELLATION_POINT;
+ else if (gfc_match ("critical") == MATCH_YES)
+ st = ST_OMP_CRITICAL;
+ break;
+ case 'd':
+ if (gfc_match ("declare reduction") == MATCH_YES)
+ st = ST_OMP_DECLARE_REDUCTION;
+ else if (gfc_match ("declare simd") == MATCH_YES)
+ st = ST_OMP_DECLARE_SIMD;
+ else if (gfc_match ("declare target") == MATCH_YES)
+ st = ST_OMP_DECLARE_TARGET;
+ else if (gfc_match ("declare variant") == MATCH_YES)
+ st = ST_OMP_DECLARE_VARIANT;
+ else if (gfc_match ("depobj") == MATCH_YES)
+ st = ST_OMP_DEPOBJ;
+ else if (gfc_match ("distribute") == MATCH_YES)
+ st = ST_OMP_DISTRIBUTE;
+ else if (gfc_match ("do") == MATCH_YES)
+ st = ST_OMP_DO;
+ break;
+ case 'e':
+ if (gfc_match ("error") == MATCH_YES)
+ st = ST_OMP_ERROR;
+ break;
+ case 'f':
+ if (gfc_match ("flush") == MATCH_YES)
+ st = ST_OMP_FLUSH;
+ break;
+ case 'l':
+ if (gfc_match ("loop") == MATCH_YES)
+ st = ST_OMP_LOOP;
+ break;
+ case 'm':
+ if (gfc_match ("masked") == MATCH_YES)
+ st = ST_OMP_MASKED;
+ break;
+ case 'p':
+ if (gfc_match ("parallel") == MATCH_YES)
+ st = ST_OMP_PARALLEL;
+ break;
+ case 'r':
+ if (gfc_match ("requires") == MATCH_YES)
+ st = ST_OMP_REQUIRES;
+ break;
+ case 's':
+ if (gfc_match ("scan") == MATCH_YES)
+ st = ST_OMP_SCAN;
+ else if (gfc_match ("scope") == MATCH_YES)
+ st = ST_OMP_SCOPE;
+ else if (gfc_match ("sections") == MATCH_YES)
+ st = ST_OMP_SECTIONS;
+ else if (gfc_match ("section") == MATCH_YES)
+ st = ST_OMP_SECTION;
+ else if (gfc_match ("simd") == MATCH_YES)
+ st = ST_OMP_SIMD;
+ else if (gfc_match ("single") == MATCH_YES)
+ st = ST_OMP_SINGLE;
+ break;
+ case 't':
+ if (gfc_match ("target data") == MATCH_YES)
+ st = ST_OMP_TARGET_DATA;
+ if (gfc_match ("target enter data") == MATCH_YES)
+ st = ST_OMP_TARGET_ENTER_DATA;
+ if (gfc_match ("target exit data") == MATCH_YES)
+ st = ST_OMP_TARGET_EXIT_DATA;
+ if (gfc_match ("target update") == MATCH_YES)
+ st = ST_OMP_TARGET_UPDATE;
+ if (gfc_match ("target") == MATCH_YES)
+ st = ST_OMP_TARGET;
+ if (gfc_match ("taskgroup") == MATCH_YES)
+ st = ST_OMP_TASKGROUP;
+ if (gfc_match ("taskloop") == MATCH_YES)
+ st = ST_OMP_TASKLOOP;
+ if (gfc_match ("task") == MATCH_YES)
+ st = ST_OMP_TASK;
+ if (gfc_match ("taskwait") == MATCH_YES)
+ st = ST_OMP_TASKWAIT;
+ if (gfc_match ("taskyield") == MATCH_YES)
+ st = ST_OMP_TASKYIELD;
+ if (gfc_match ("teams") == MATCH_YES)
+ st = ST_OMP_TEAMS;
+ if (gfc_match ("threadprivate") == MATCH_YES)
+ st = ST_OMP_THREADPRIVATE;
+ break;
+ case 'w':
+ if (gfc_match ("workshare") == MATCH_YES)
+ st = ST_OMP_WORKSHARE;
+ default:
+ break;
+ }
+ if (st == ST_NONE)
+ {
+ gfc_error ("Unknown directive at %L", &old_loc);
+ return MATCH_ERROR;
+ }
+ if (is_omp_declarative_stmt (st) || is_omp_informational_stmt (st))
+ {
+ 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)
+ {
+ (*assume)->n_absent++;
+ (*assume)->absent
+ = (gfc_statement *) xrealloc ((*assume)->absent,
+ sizeof (gfc_statement)
+ * (*assume)->n_absent);
+ (*assume)->absent[(*assume)->n_absent - 1] = st;
+ }
+ else
+ {
+ (*assume)->n_contains++;
+ (*assume)->contains
+ = (gfc_statement *) xrealloc ((*assume)->contains,
+ sizeof (gfc_statement)
+ * (*assume)->n_contains);
+ (*assume)->contains[(*assume)->n_contains - 1] = 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;
+}
/* Match with duplicate check. Matches 'name'. If expr != NULL, it
then matches '(expr)', otherwise, if open_parens is true,
@@ -1472,10 +1644,10 @@ static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
bool first = true, bool needs_space = true,
bool openacc = false, bool context_selector = false,
- bool openmp_target = false)
+ bool openmp_target = false, bool alloc_cp = true)
{
bool error = false;
- gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ gfc_omp_clauses *c;
locus old_loc;
/* Determine whether we're dealing with an OpenACC directive that permits
derived type member accesses. This in particular disallows
@@ -1487,7 +1659,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
|| (mask & OMP_CLAUSE_HOST_SELF)));
gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
- *cp = NULL;
+ if (alloc_cp)
+ {
+ c = gfc_get_omp_clauses ();
+ *cp = NULL;
+ }
+ else
+ c = *cp;
while (1)
{
match m = MATCH_NO;
@@ -1511,6 +1689,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 +1929,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 +2471,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 +2872,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 +4184,42 @@ match_omp (gfc_exec_op op, const omp_mask mask)
}
+match
+gfc_match_omp_assume (void)
+{
+ return match_omp (EXEC_OMP_ASSUME, omp_mask (OMP_CLAUSE_ASSUMPTIONS));
+}
+
+
+match
+gfc_match_omp_assumes (void)
+{
+ locus loc = gfc_current_locus;
+ gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ c->assume = gfc_current_ns->omp_assumes;
+ 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), true, true,
+ false, false, false, false) != MATCH_YES)
+ {
+ gfc_current_ns->omp_assumes = NULL;
+ return MATCH_ERROR;
+ }
+ c->assume->where = loc;
+ gfc_current_ns->omp_assumes = c->assume;
+ c->assume = NULL;
+ gfc_free_omp_clauses (c);
+ return MATCH_YES;
+}
+
+
match
gfc_match_omp_critical (void)
{
@@ -6505,6 +6784,42 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
return copy;
}
+
+/* Resolve ASSUME's and ASSUMES' assumption clauses. */
+
+void
+gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume, const char *directive,
+ locus *loc)
+{
+ 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);
+ for (int i = 0; i < assume->n_absent; i++)
+ {
+ for (int j = i + 1; j < assume->n_absent; j++)
+ if (assume->absent[i] == assume->absent[j])
+ gfc_error ("%qs directive mentioned multiple times in %s clause in %s"
+ " directive at %L",
+ gfc_ascii_statement (assume->absent[i], true),
+ "ABSENT", directive, loc);
+ for (int j = 0; j < assume->n_contains; j++)
+ if (assume->absent[i] == assume->contains[j])
+ gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS"
+ " clauses in %s directive at %L",
+ gfc_ascii_statement (assume->absent[i], true),
+ directive, loc);
+ }
+ for (int i = 0; i < assume->n_contains; i++)
+ for (int j = i + 1; j < assume->n_contains; j++)
+ if (assume->contains[i] == assume->contains[j])
+ gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
+ "directive at %L",
+ gfc_ascii_statement (assume->contains[i], true),
+ "CONTAINS", directive, loc);
+}
+
+
/* OpenMP directive resolving routines. */
static void
@@ -7888,6 +8203,13 @@ 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)
+ {
+ const char *name = gfc_ascii_statement (omp_code_to_statement (code),
+ true);
+ gfc_resolve_omp_assumptions (omp_clauses->assume, name, &code->loc);
+ }
}
@@ -9116,6 +9438,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 +9959,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:
@@ -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;
@@ -2751,6 +2765,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 +5534,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 +5670,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 +5894,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:
@@ -6996,6 +7017,32 @@ duplicate_main:
return true;
}
+bool
+is_omp_declarative_stmt (gfc_statement st)
+{
+ switch (st)
+ {
+ case_omp_decl:
+ return true;
+ default:
+ return false;
+ }
+}
+
+bool
+is_omp_informational_stmt (gfc_statement st)
+{
+ switch (st)
+ {
+ case ST_OMP_ASSUME:
+ case ST_OMP_ASSUMES:
+ case ST_OMP_REQUIRES:
+ return true;
+ default:
+ return false;
+ }
+}
+
/* Return true if this state data represents an OpenACC region. */
bool
is_oacc (gfc_state_data *sd)
@@ -66,11 +66,13 @@ 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);
extern bool gfc_matching_function;
match gfc_match_prefix (gfc_typespec *);
+bool is_omp_declarative_stmt (gfc_statement);
+bool is_omp_informational_stmt (gfc_statement);
bool is_oacc (gfc_state_data *);
#endif /* GFC_PARSE_H */
@@ -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,10 @@ gfc_resolve (gfc_namespace *ns)
component_assignment_level = 0;
resolve_codes (ns);
+ if (ns->omp_assumes)
+ gfc_resolve_omp_assumptions (ns->omp_assumes, "ASSUMES",
+ &ns->omp_assumes->where);
+
gfc_current_ns = old_ns;
cs_base = old_cs_base;
ns->resolved = 1;
@@ -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:
@@ -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;
@@ -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:
@@ -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:
new file mode 100644
@@ -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
new file mode 100644
@@ -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 ASSUME directive" }
+ !$omp end assume
+
+ !$omp assume no_openmp_routines, contains (simd) contains ( simd ) ! { dg-error "'SIMD' directive mentioned multiple times in CONTAINS clause in 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 ASSUME directive" }
+ if (i >= 32) then
+ !$omp error at (execution) message ("Should not happen")
+ end if
+ !$omp end assume
+
+ !$omp assume holds (1.0) ! { dg-error "HOLDS expression at .1. must be a logical expression" }
+ !$omp end assume
+end
new file mode 100644
@@ -0,0 +1,84 @@
+! 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
+
+
new file mode 100644
@@ -0,0 +1,7 @@
+module m
+ integer ::x
+ !$omp assumes contains(target) holds(x > 0.0)
+ !$omp assumes absent(target) holds(0.0)
+! { dg-error "HOLDS expression at .1. must be a logical expression" "" { target *-*-* } .-1 }
+! { dg-error "'TARGET' directive mentioned both times in ABSENT and CONTAINS clauses in ASSUMES directive at .1." "" { target *-*-* } .-2 }
+end module
@@ -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