* [Patch] Fortran: Add OpenMP's assume(s) directives @ 2022-10-02 17:47 Tobias Burnus 2022-10-04 10:19 ` Jakub Jelinek 0 siblings, 1 reply; 7+ messages in thread From: Tobias Burnus @ 2022-10-02 17:47 UTC (permalink / raw) To: gcc-patches, fortran, Jakub Jelinek [-- Attachment #1.1: Type: text/plain, Size: 1525 bytes --] 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 [-- Attachment #2: omp-assume-fortran.diff --] [-- Type: text/x-patch, Size: 38216 bytes --] 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(-) diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index a5dc6377835..e3701555f12 100644 --- 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 +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 diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 40c690c9ae8..bd1fb4bdfd4 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -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); 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; + 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: diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 5b13441912a..cb5d917b886 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -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) diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 7ddea10237f..5bca09d0315 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -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 */ diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index ae7ebb624e4..1e011ee74fc 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -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; diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc index 73f30c2137f..3c8ca66554d 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -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: diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 7a80dfd063b..6050359d521 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -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; diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 8e9d5346b05..21053694f81 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -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: diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 912a206f2ed..8a64882ea9e 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -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: diff --git a/gcc/testsuite/gfortran.dg/gomp/assume-1.f90 b/gcc/testsuite/gfortran.dg/gomp/assume-1.f90 new file mode 100644 index 00000000000..8bd5c723051 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assume-1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gomp/assume-2.f90 b/gcc/testsuite/gfortran.dg/gomp/assume-2.f90 new file mode 100644 index 00000000000..cb800676020 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assume-2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 b/gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 new file mode 100644 index 00000000000..6a50914f185 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 @@ -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 + + diff --git a/gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 b/gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 new file mode 100644 index 00000000000..9e4eabd4977 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 @@ -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 diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi index 2b11f304409..12b6edc0026 100644 --- a/libgomp/libgomp.texi +++ b/libgomp/libgomp.texi @@ -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 ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] Fortran: Add OpenMP's assume(s) directives 2022-10-02 17:47 [Patch] Fortran: Add OpenMP's assume(s) directives Tobias Burnus @ 2022-10-04 10:19 ` Jakub Jelinek 2022-10-04 12:26 ` Tobias Burnus 0 siblings, 1 reply; 7+ messages in thread From: Jakub Jelinek @ 2022-10-04 10:19 UTC (permalink / raw) To: Tobias Burnus; +Cc: gcc-patches, fortran 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 ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] Fortran: Add OpenMP's assume(s) directives 2022-10-04 10:19 ` Jakub Jelinek @ 2022-10-04 12:26 ` Tobias Burnus 2022-10-04 12:58 ` Jakub Jelinek 0 siblings, 1 reply; 7+ messages in thread From: Tobias Burnus @ 2022-10-04 12:26 UTC (permalink / raw) To: Jakub Jelinek; +Cc: gcc-patches, fortran [-- Attachment #1.1: Type: text/plain, Size: 6818 bytes --] 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 [-- Attachment #2: update-fopenmp-simd.diff --] [-- Type: text/x-patch, Size: 4610 bytes --] OpenMP: Update invoke.texi and fix fortran/parse.cc for -fopenmp-simd Split off from the 'Fortran: Add OpenMP's assume(s) directives' patch. gcc/ * doc/invoke.texi (-fopenmp): Mention C++ attribut syntax. (-fopenmp-simd): Likewise; update permitted directives. gcc/fortran/ * parse.cc (decode_omp_directive): Handle '(end) loop' and 'scan' also with -fopenmp-simd. gcc/testsuite/ * gfortran.dg/gomp/openmp-simd-7.f90: New test. gcc/doc/invoke.texi | 12 ++++++++---- gcc/fortran/parse.cc | 6 +++--- gcc/testsuite/gfortran.dg/gomp/openmp-simd-7.f90 | 23 +++++++++++++++++++++++ 3 files changed, 34 insertions(+), 7 deletions(-) diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index a5dc6377835..e0c2c57c9b2 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -2737,7 +2737,8 @@ can be omitted, to use a target-specific default value. @item -fopenmp @opindex fopenmp @cindex OpenMP parallel -Enable handling of OpenMP directives @code{#pragma omp} in C/C++ and +Enable handling of OpenMP directives @code{#pragma omp} in C/C++, +@code{[[omp::directive(...)]]} and @code{[[omp::sequence(...)]]} in C++ and @code{!$omp} in Fortran. When @option{-fopenmp} is specified, the compiler generates parallel code according to the OpenMP Application Program Interface v4.5 @w{@uref{https://www.openmp.org}}. This option @@ -2749,9 +2750,12 @@ 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 @code{simd}, @code{declare simd}, +@code{declare reduction}, @code{assume}, @code{ordered}, @code{scan}, +@code{loop} directives and combined or composite directives with +@code{simd} as constituent with @code{#pragma omp} in C/C++, +@code{[[omp::directive(...)]]} and @code{[[omp::sequence(...)]]} in C++ +and @code{!$omp} in Fortran. Other OpenMP directives are ignored. @item -fpermitted-flt-eval-methods=@var{style} @opindex fpermitted-flt-eval-methods diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 5b13441912a..2e2e9770520 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -924,7 +924,7 @@ decode_omp_directive (void) matcho ("end distribute", gfc_match_omp_eos_error, ST_OMP_END_DISTRIBUTE); matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD); matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO); - matcho ("end loop", gfc_match_omp_eos_error, ST_OMP_END_LOOP); + matchs ("end loop", gfc_match_omp_eos_error, ST_OMP_END_LOOP); matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD); matcho ("end masked taskloop simd", gfc_match_omp_eos_error, ST_OMP_END_MASKED_TASKLOOP_SIMD); @@ -1023,7 +1023,7 @@ decode_omp_directive (void) matcho ("nothing", gfc_match_omp_nothing, ST_NONE); break; case 'l': - matcho ("loop", gfc_match_omp_loop, ST_OMP_LOOP); + matchs ("loop", gfc_match_omp_loop, ST_OMP_LOOP); break; case 'o': if (gfc_match ("ordered depend (") == MATCH_YES @@ -1070,7 +1070,7 @@ decode_omp_directive (void) matcho ("requires", gfc_match_omp_requires, ST_OMP_REQUIRES); break; case 's': - matcho ("scan", gfc_match_omp_scan, ST_OMP_SCAN); + matchs ("scan", gfc_match_omp_scan, ST_OMP_SCAN); matcho ("scope", gfc_match_omp_scope, ST_OMP_SCOPE); matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION); diff --git a/gcc/testsuite/gfortran.dg/gomp/openmp-simd-7.f90 b/gcc/testsuite/gfortran.dg/gomp/openmp-simd-7.f90 new file mode 100644 index 00000000000..d7010bb4288 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/openmp-simd-7.f90 @@ -0,0 +1,23 @@ +! { dg-options "-fno-openmp -fopenmp-simd -fdump-tree-original" } + +subroutine foo (a, b) + integer, contiguous :: a(:), b(:) + integer :: i + !$omp simd reduction (inscan, +:r) + do i = 1, 1024 + r = r + a(i) + !$omp scan inclusive(r) + b(i) = r + end do + !$omp end simd + + !$omp loop + do i = 1, 1024 + a(i) = a(i) + i + end do + !$omp end loop +end + +! { dg-final { scan-tree-dump "#pragma omp simd linear\\(i:1\\) reduction\\(inscan,\\+:r\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp scan inclusive\\(r\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp loop" "original" } } ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] Fortran: Add OpenMP's assume(s) directives 2022-10-04 12:26 ` Tobias Burnus @ 2022-10-04 12:58 ` Jakub Jelinek 2022-10-05 11:19 ` Tobias Burnus 0 siblings, 1 reply; 7+ messages in thread From: Jakub Jelinek @ 2022-10-04 12:58 UTC (permalink / raw) To: Tobias Burnus; +Cc: gcc-patches, fortran 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 ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] Fortran: Add OpenMP's assume(s) directives 2022-10-04 12:58 ` Jakub Jelinek @ 2022-10-05 11:19 ` Tobias Burnus 2022-10-05 12:29 ` Tobias Burnus 0 siblings, 1 reply; 7+ messages in thread From: Tobias Burnus @ 2022-10-05 11:19 UTC (permalink / raw) To: Jakub Jelinek; +Cc: gcc-patches, fortran [-- Attachment #1.1: Type: text/plain, Size: 3155 bytes --] 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 [-- Attachment #2: omp-assume-fortran-v2.diff --] [-- Type: text/x-patch, Size: 41008 bytes --] Fortran: Add OpenMP's assume(s) directives 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. gcc/fortran/dump-parse-tree.cc | 41 +++ gcc/fortran/gfortran.h | 23 +- gcc/fortran/match.h | 2 + gcc/fortran/openmp.cc | 403 +++++++++++++++++++++++++++ gcc/fortran/parse.cc | 31 ++- gcc/fortran/parse.h | 2 +- gcc/fortran/resolve.cc | 5 + 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 | 82 ++++++ gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 | 19 ++ libgomp/libgomp.texi | 2 +- 16 files changed, 665 insertions(+), 8 deletions(-) diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 40c690c9ae8..2f042ab5142 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -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); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 4babd77924b..608dda4bf55 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *); 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..7e7fd30ab26 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -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 (without combined/composite directives). + Watch out for "ordered"! */ + +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}, */ + {"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME}, + {"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES}, + {"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC}, + {"barrier", GFC_OMP_DIR_EXECUTABLE, ST_OMP_BARRIER}, + {"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL}, + {"cancellation point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT}, + {"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 uses 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}, + {"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION}, + {"sections", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SECTIONS}, + {"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", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET}, + {"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE}, + {"taskgroup", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKGROUP}, + {"task", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK}, + {"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP}, + {"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT}, + {"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD}, + {"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: diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 2e2e9770520..f04fd13cc69 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -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: diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 7ddea10237f..013aeaedc03 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -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); diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index ae7ebb624e4..d133bc2d034 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -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; diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc index 73f30c2137f..3c8ca66554d 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -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: diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 7a80dfd063b..6050359d521 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -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; diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 8e9d5346b05..21053694f81 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -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: diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 912a206f2ed..8a64882ea9e 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -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: diff --git a/gcc/testsuite/gfortran.dg/gomp/assume-1.f90 b/gcc/testsuite/gfortran.dg/gomp/assume-1.f90 new file mode 100644 index 00000000000..8bd5c723051 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assume-1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gomp/assume-2.f90 b/gcc/testsuite/gfortran.dg/gomp/assume-2.f90 new file mode 100644 index 00000000000..ca3e04dfe95 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assume-2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 b/gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 new file mode 100644 index 00000000000..3d468dc1c81 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 b/gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 new file mode 100644 index 00000000000..729c9737a1c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 @@ -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 diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi index d170594921f..d8c798cf7a1 100644 --- a/libgomp/libgomp.texi +++ b/libgomp/libgomp.texi @@ -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 ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] Fortran: Add OpenMP's assume(s) directives 2022-10-05 11:19 ` Tobias Burnus @ 2022-10-05 12:29 ` Tobias Burnus 2022-10-05 17:09 ` Jakub Jelinek 0 siblings, 1 reply; 7+ messages in thread From: Tobias Burnus @ 2022-10-05 12:29 UTC (permalink / raw) To: Jakub Jelinek; +Cc: gcc-patches, fortran [-- Attachment #1.1: Type: text/plain, Size: 3416 bytes --] 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 [-- Attachment #2: omp-assume-fortran-v2.diff --] [-- Type: text/x-patch, Size: 41018 bytes --] Fortran: Add OpenMP's assume(s) directives 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. gcc/fortran/dump-parse-tree.cc | 41 +++ gcc/fortran/gfortran.h | 23 +- gcc/fortran/match.h | 2 + gcc/fortran/openmp.cc | 403 +++++++++++++++++++++++++++ gcc/fortran/parse.cc | 31 ++- gcc/fortran/parse.h | 2 +- gcc/fortran/resolve.cc | 5 + 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 | 82 ++++++ gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 | 19 ++ libgomp/libgomp.texi | 2 +- 16 files changed, 665 insertions(+), 8 deletions(-) diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 40c690c9ae8..2f042ab5142 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -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); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 4babd77924b..608dda4bf55 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *); 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..f586460b61a 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -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: diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 2e2e9770520..f04fd13cc69 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -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: diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 7ddea10237f..013aeaedc03 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -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); diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index ae7ebb624e4..d133bc2d034 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -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; diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc index 73f30c2137f..3c8ca66554d 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -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: diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 7a80dfd063b..6050359d521 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -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; diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 8e9d5346b05..21053694f81 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -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: diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 912a206f2ed..8a64882ea9e 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -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: diff --git a/gcc/testsuite/gfortran.dg/gomp/assume-1.f90 b/gcc/testsuite/gfortran.dg/gomp/assume-1.f90 new file mode 100644 index 00000000000..8bd5c723051 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assume-1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gomp/assume-2.f90 b/gcc/testsuite/gfortran.dg/gomp/assume-2.f90 new file mode 100644 index 00000000000..ca3e04dfe95 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assume-2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 b/gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 new file mode 100644 index 00000000000..3d468dc1c81 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assumes-1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 b/gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 new file mode 100644 index 00000000000..729c9737a1c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/assumes-2.f90 @@ -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 diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi index d170594921f..d8c798cf7a1 100644 --- a/libgomp/libgomp.texi +++ b/libgomp/libgomp.texi @@ -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 ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] Fortran: Add OpenMP's assume(s) directives 2022-10-05 12:29 ` Tobias Burnus @ 2022-10-05 17:09 ` Jakub Jelinek 0 siblings, 0 replies; 7+ messages in thread From: Jakub Jelinek @ 2022-10-05 17:09 UTC (permalink / raw) To: Tobias Burnus; +Cc: gcc-patches, fortran 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 ^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2022-10-05 17:09 UTC | newest] Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed) -- links below jump to the message on this page -- 2022-10-02 17:47 [Patch] Fortran: Add OpenMP's assume(s) directives Tobias Burnus 2022-10-04 10:19 ` Jakub Jelinek 2022-10-04 12:26 ` Tobias Burnus 2022-10-04 12:58 ` Jakub Jelinek 2022-10-05 11:19 ` Tobias Burnus 2022-10-05 12:29 ` Tobias Burnus 2022-10-05 17:09 ` Jakub Jelinek
This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).