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
