https://gcc.gnu.org/g:1985a02ef74582d7cdcb2c139aa7d22a9c619dc3
commit 1985a02ef74582d7cdcb2c139aa7d22a9c619dc3
Author: Paul-Antoine Arras <par...@baylibre.com>
Date: Fri May 24 19:13:50 2024 +0200
OpenMP: Fortran front-end support for dispatch + adjust_args
This patch adds support for the `dispatch` construct and the `adjust_args`
clause to the Fortran front-end.
Handling of `adjust_args` across translation units is missing due to
PR115271.
Minor modifications to the C++ FE and the ME are also folded into this
patch as
a side effect of the Fortran work.
gcc/c-family/ChangeLog:
* c-attribs.cc: (c_common_gnu_attributes): Rename "omp declare
variant
variant adjust_args" into "omp declare variant variant args" to also
accommodate append_args.
gcc/cp/ChangeLog:
* parser.cc (cp_parser_omp_dispatch): Handle INDIRECT_REF.
gcc/fortran/ChangeLog:
* dump-parse-tree.cc (show_omp_clauses): Handle novariants and
nocontext
clauses.
(show_omp_node): Handle EXEC_OMP_DISPATCH.
(show_code_node): Likewise.
* frontend-passes.cc (gfc_code_walker): Handle novariants and
nocontext.
* gfortran.h (enum gfc_statement): Add ST_OMP_DISPATCH.
(symbol_attribute): Add omp_declare_variant_need_device_ptr.
(gfc_omp_clauses): Add novariants and nocontext.
(gfc_omp_declare_variant): Add need_device_ptr_arg_list.
(enum gfc_exec_op): Add EXEC_OMP_DISPATCH.
* match.h (gfc_match_omp_dispatch): Declare.
* openmp.cc (gfc_free_omp_clauses): Free novariants and nocontext
clauses.
(gfc_free_omp_declare_variant_list): Free need_device_ptr_arg_list
namelist.
(enum omp_mask2): Add OMP_CLAUSE_NOVARIANTS and
OMP_CLAUSE_NOCONTEXT.
(gfc_match_omp_clauses): Handle OMP_CLAUSE_NOVARIANTS and
OMP_CLAUSE_NOCONTEXT.
(OMP_DISPATCH_CLAUSES): Define.
(gfc_match_omp_dispatch): New function.
(gfc_match_omp_declare_variant): Parse adjust_args.
(resolve_omp_clauses): Handle adjust_args, novariants and nocontext.
Adjust handling of OMP_LIST_IS_DEVICE_PTR.
(icode_code_error_callback): Handle EXEC_OMP_DISPATCH.
(omp_code_to_statement): Likewise.
(resolve_omp_dispatch): New function.
(gfc_resolve_omp_directive): Handle EXEC_OMP_DISPATCH.
* parse.cc (decode_omp_directive): Match dispatch.
(next_statement): Handle ST_OMP_DISPATCH.
(gfc_ascii_statement): Likewise.
(parse_omp_dispatch): New function.
(parse_executable): Handle ST_OMP_DISPATCH.
* resolve.cc (gfc_resolve_blocks): Handle EXEC_OMP_DISPATCH.
* st.cc (gfc_free_statement): Likewise.
* trans-decl.cc (create_function_arglist): Declare.
(gfc_get_extern_function_decl): Call it.
* trans-openmp.cc (gfc_trans_omp_clauses): Handle novariants and
nocontext.
(replace_omp_dispatch_call): New function.
(gfc_trans_omp_dispatch): New function.
(gfc_trans_omp_directive): Handle EXEC_OMP_DISPATCH.
(gfc_trans_omp_declare_variant): Handle adjust_args.
* trans.cc (trans_code): Handle EXEC_OMP_DISPATCH:.
gcc/ChangeLog:
* gimplify.cc (gimplify_call_expr): Fix handling of need_device_ptr
for
type(c_ptr). Fix handling of nested function calls in a dispatch
region.
(find_ifn_gomp_dispatch): Return the IFN without stripping it.
(gimplify_omp_dispatch): Keep IFN_GOMP_DISPATCH until
gimplify_call_expr.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/declare-variant-2-aux.f90: New test.
* testsuite/libgomp.fortran/declare-variant-2.f90: New test (xfail).
* testsuite/libgomp.fortran/dispatch-1.f90: New test.
* testsuite/libgomp.fortran/dispatch-2.f90: New test.
* testsuite/libgomp.fortran/dispatch-3.f90: New test.
gcc/testsuite/ChangeLog:
* g++.dg/gomp/dispatch-3.C: Update scan dumps.
* gfortran.dg/gomp/declare-variant-2.f90: Update dg-error.
* gfortran.dg/gomp/adjust-args-1.f90: New test.
* gfortran.dg/gomp/adjust-args-2.f90: New test.
* gfortran.dg/gomp/adjust-args-2a.f90: New test.
* gfortran.dg/gomp/adjust-args-3.f90: New test.
* gfortran.dg/gomp/adjust-args-4.f90: New test.
* gfortran.dg/gomp/adjust-args-5.f90: New test.
* gfortran.dg/gomp/adjust-args-6.f90: New test.
* gfortran.dg/gomp/adjust-args-7.f90: New test.
* gfortran.dg/gomp/adjust-args-8.f90: New test.
* gfortran.dg/gomp/adjust-args-9.f90: New test.
* gfortran.dg/gomp/dispatch-1.f90: New test.
* gfortran.dg/gomp/dispatch-2.f90: New test.
* gfortran.dg/gomp/dispatch-3.f90: New test.
* gfortran.dg/gomp/dispatch-4.f90: New test.
* gfortran.dg/gomp/dispatch-5.f90: New test.
* gfortran.dg/gomp/dispatch-6.f90: New test.
* gfortran.dg/gomp/dispatch-7.f90: New test.
* gfortran.dg/gomp/dispatch-8.f90: New test.
* gfortran.dg/gomp/dispatch-9.f90: New test.
* gfortran.dg/gomp/dispatch-9a.f90: New test.
* gfortran.dg/gomp/dispatch-10.f90: New test.
(cherry picked from commit bca8b13bd7bc3dbe07004664ba3411a2f2991f5c)
Diff:
---
gcc/ChangeLog.omp | 11 ++
gcc/c-family/ChangeLog.omp | 9 +
gcc/c-family/c-attribs.cc | 2 +-
gcc/cp/ChangeLog.omp | 7 +
gcc/cp/parser.cc | 5 +-
gcc/fortran/ChangeLog.omp | 49 +++++
gcc/fortran/dump-parse-tree.cc | 17 ++
gcc/fortran/frontend-passes.cc | 2 +
gcc/fortran/gfortran.h | 12 +-
gcc/fortran/match.h | 1 +
gcc/fortran/openmp.cc | 204 +++++++++++++++++++--
gcc/fortran/parse.cc | 54 +++++-
gcc/fortran/resolve.cc | 4 +-
gcc/fortran/st.cc | 1 +
gcc/fortran/trans-decl.cc | 9 +-
gcc/fortran/trans-openmp.cc | 197 ++++++++++++++++++++
gcc/fortran/trans.cc | 1 +
gcc/gimplify.cc | 192 +++++++++++--------
gcc/testsuite/ChangeLog.omp | 29 +++
gcc/testsuite/g++.dg/gomp/dispatch-3.C | 2 +-
gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 | 45 +++++
gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90 | 18 ++
gcc/testsuite/gfortran.dg/gomp/adjust-args-2a.f90 | 36 ++++
gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90 | 27 +++
gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90 | 58 ++++++
gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90 | 58 ++++++
gcc/testsuite/gfortran.dg/gomp/adjust-args-6.f90 | 16 ++
gcc/testsuite/gfortran.dg/gomp/adjust-args-7.f90 | 17 ++
gcc/testsuite/gfortran.dg/gomp/adjust-args-8.f90 | 51 ++++++
gcc/testsuite/gfortran.dg/gomp/adjust-args-9.f90 | 25 +++
.../gfortran.dg/gomp/declare-variant-2.f90 | 6 +-
gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 | 77 ++++++++
gcc/testsuite/gfortran.dg/gomp/dispatch-10.f90 | 21 +++
gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90 | 79 ++++++++
gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90 | 39 ++++
gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90 | 19 ++
gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90 | 25 +++
gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90 | 22 +++
gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90 | 26 +++
gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90 | 36 ++++
gcc/testsuite/gfortran.dg/gomp/dispatch-9.f90 | 24 +++
gcc/testsuite/gfortran.dg/gomp/dispatch-9a.f90 | 27 +++
libgomp/ChangeLog.omp | 11 ++
.../libgomp.fortran/declare-variant-2-aux.f90 | 25 +++
.../libgomp.fortran/declare-variant-2.f90 | 22 +++
libgomp/testsuite/libgomp.fortran/dispatch-1.f90 | 120 ++++++++++++
libgomp/testsuite/libgomp.fortran/dispatch-2.f90 | 69 +++++++
libgomp/testsuite/libgomp.fortran/dispatch-3.f90 | 80 ++++++++
48 files changed, 1782 insertions(+), 105 deletions(-)
diff --git a/gcc/ChangeLog.omp b/gcc/ChangeLog.omp
index f8a43011f549..bda3e3de82fd 100644
--- a/gcc/ChangeLog.omp
+++ b/gcc/ChangeLog.omp
@@ -1,3 +1,14 @@
+2025-01-27 Paul-Antoine Arras <par...@baylibre.com>
+
+ Backported from master:
+ 2025-01-02 Paul-Antoine Arras <par...@baylibre.com>
+
+ * gimplify.cc (gimplify_call_expr): Fix handling of need_device_ptr for
+ type(c_ptr). Fix handling of nested function calls in a dispatch region.
+ (find_ifn_gomp_dispatch): Return the IFN without stripping it.
+ (gimplify_omp_dispatch): Keep IFN_GOMP_DISPATCH until
+ gimplify_call_expr.
+
2025-01-24 Paul-Antoine Arras <par...@baylibre.com>
Backported from master:
diff --git a/gcc/c-family/ChangeLog.omp b/gcc/c-family/ChangeLog.omp
index 7f249b657250..75a1c1795410 100644
--- a/gcc/c-family/ChangeLog.omp
+++ b/gcc/c-family/ChangeLog.omp
@@ -1,3 +1,12 @@
+2025-01-27 Paul-Antoine Arras <par...@baylibre.com>
+
+ Backported from master:
+ 2025-01-02 Paul-Antoine Arras <par...@baylibre.com>
+
+ * c-attribs.cc: (c_common_gnu_attributes): Rename "omp declare variant
+ variant adjust_args" into "omp declare variant variant args" to also
+ accommodate append_args.
+
2025-01-27 Paul-Antoine Arras <par...@baylibre.com>
Backported from master:
diff --git a/gcc/c-family/c-attribs.cc b/gcc/c-family/c-attribs.cc
index 4e9a9007fcaa..af31487742bf 100644
--- a/gcc/c-family/c-attribs.cc
+++ b/gcc/c-family/c-attribs.cc
@@ -556,7 +556,7 @@ const struct attribute_spec c_common_gnu_attributes[] =
handle_omp_declare_variant_attribute, NULL },
{ "omp declare variant variant", 0, -1, true, false, false, false,
handle_omp_declare_variant_attribute, NULL },
- { "omp declare variant adjust_args need_device_ptr", 0, -1, true, false,
+ { "omp declare variant variant args", 0, -1, true, false,
false, false,
handle_omp_declare_variant_attribute, NULL },
{ "simd", 0, 1, true, false, false, false,
diff --git a/gcc/cp/ChangeLog.omp b/gcc/cp/ChangeLog.omp
index 01483816e018..95aa7a78283e 100644
--- a/gcc/cp/ChangeLog.omp
+++ b/gcc/cp/ChangeLog.omp
@@ -1,3 +1,10 @@
+2025-01-27 Paul-Antoine Arras <par...@baylibre.com>
+
+ Backported from master:
+ 2025-01-02 Paul-Antoine Arras <par...@baylibre.com>
+
+ * parser.cc (cp_parser_omp_dispatch): Handle INDIRECT_REF.
+
2025-01-27 Paul-Antoine Arras <par...@baylibre.com>
Backported from master:
diff --git a/gcc/cp/parser.cc b/gcc/cp/parser.cc
index b1c17a451d79..9c40ceacce35 100644
--- a/gcc/cp/parser.cc
+++ b/gcc/cp/parser.cc
@@ -49805,8 +49805,9 @@ cp_parser_omp_dispatch (cp_parser *parser, cp_token
*pragma_tok)
default:
gcc_unreachable ();
}
- if (TREE_CODE (*dispatch_call) == FLOAT_EXPR
- || TREE_CODE (*dispatch_call) == CONVERT_EXPR)
+ while (TREE_CODE (*dispatch_call) == FLOAT_EXPR
+ || TREE_CODE (*dispatch_call) == CONVERT_EXPR
+ || TREE_CODE (*dispatch_call) == INDIRECT_REF)
dispatch_call = &TREE_OPERAND (*dispatch_call, 0);
*dispatch_call = build_call_expr_internal_loc (loc, IFN_GOMP_DISPATCH,
TREE_TYPE (*dispatch_call), 1,
diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index 5a99b7d37f07..6b92d87bd68f 100644
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,52 @@
+2025-01-27 Paul-Antoine Arras <par...@baylibre.com>
+
+ Backported from master:
+ 2025-01-02 Paul-Antoine Arras <par...@baylibre.com>
+
+ * dump-parse-tree.cc (show_omp_clauses): Handle novariants and nocontext
+ clauses.
+ (show_omp_node): Handle EXEC_OMP_DISPATCH.
+ (show_code_node): Likewise.
+ * frontend-passes.cc (gfc_code_walker): Handle novariants and nocontext.
+ * gfortran.h (enum gfc_statement): Add ST_OMP_DISPATCH.
+ (symbol_attribute): Add omp_declare_variant_need_device_ptr.
+ (gfc_omp_clauses): Add novariants and nocontext.
+ (gfc_omp_declare_variant): Add need_device_ptr_arg_list.
+ (enum gfc_exec_op): Add EXEC_OMP_DISPATCH.
+ * match.h (gfc_match_omp_dispatch): Declare.
+ * openmp.cc (gfc_free_omp_clauses): Free novariants and nocontext
+ clauses.
+ (gfc_free_omp_declare_variant_list): Free need_device_ptr_arg_list
+ namelist.
+ (enum omp_mask2): Add OMP_CLAUSE_NOVARIANTS and OMP_CLAUSE_NOCONTEXT.
+ (gfc_match_omp_clauses): Handle OMP_CLAUSE_NOVARIANTS and
+ OMP_CLAUSE_NOCONTEXT.
+ (OMP_DISPATCH_CLAUSES): Define.
+ (gfc_match_omp_dispatch): New function.
+ (gfc_match_omp_declare_variant): Parse adjust_args.
+ (resolve_omp_clauses): Handle adjust_args, novariants and nocontext.
+ Adjust handling of OMP_LIST_IS_DEVICE_PTR.
+ (icode_code_error_callback): Handle EXEC_OMP_DISPATCH.
+ (omp_code_to_statement): Likewise.
+ (resolve_omp_dispatch): New function.
+ (gfc_resolve_omp_directive): Handle EXEC_OMP_DISPATCH.
+ * parse.cc (decode_omp_directive): Match dispatch.
+ (next_statement): Handle ST_OMP_DISPATCH.
+ (gfc_ascii_statement): Likewise.
+ (parse_omp_dispatch): New function.
+ (parse_executable): Handle ST_OMP_DISPATCH.
+ * resolve.cc (gfc_resolve_blocks): Handle EXEC_OMP_DISPATCH.
+ * st.cc (gfc_free_statement): Likewise.
+ * trans-decl.cc (create_function_arglist): Declare.
+ (gfc_get_extern_function_decl): Call it.
+ * trans-openmp.cc (gfc_trans_omp_clauses): Handle novariants and
+ nocontext.
+ (replace_omp_dispatch_call): New function.
+ (gfc_trans_omp_dispatch): New function.
+ (gfc_trans_omp_directive): Handle EXEC_OMP_DISPATCH.
+ (gfc_trans_omp_declare_variant): Handle adjust_args.
+ * trans.cc (trans_code): Handle EXEC_OMP_DISPATCH:.
+
2025-01-23 Paul-Antoine Arras <par...@baylibre.com>
Backported from master:
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index f09fb4eb6abc..60c03cf0b733 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2218,6 +2218,18 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
}
fputc (')', dumpfile);
}
+ if (omp_clauses->novariants)
+ {
+ fputs (" NOVARIANTS(", dumpfile);
+ show_expr (omp_clauses->novariants);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->nocontext)
+ {
+ fputs (" NOCONTEXT(", dumpfile);
+ show_expr (omp_clauses->nocontext);
+ fputc (')', dumpfile);
+ }
}
/* Show a single OpenMP or OpenACC directive node and everything underneath it
@@ -2255,6 +2267,9 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OMP_CANCEL: name = "CANCEL"; break;
case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
+ case EXEC_OMP_DISPATCH:
+ name = "DISPATCH";
+ break;
case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break;
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
name = "DISTRIBUTE PARALLEL DO"; break;
@@ -2360,6 +2375,7 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
@@ -3612,6 +3628,7 @@ show_code_node (int level, gfc_code *c)
case EXEC_OMP_BARRIER:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DEPOBJ:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
index 3c06018fdbbf..1a0ef50b91dd 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5669,6 +5669,8 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn,
walk_expr_fn_t exprfn,
WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
WALK_SUBEXPR (co->ext.omp_clauses->priority);
WALK_SUBEXPR (co->ext.omp_clauses->detach);
+ WALK_SUBEXPR (co->ext.omp_clauses->novariants);
+ WALK_SUBEXPR (co->ext.omp_clauses->nocontext);
for (idx = 0; idx < ARRAY_SIZE (list_types); idx++)
for (n = co->ext.omp_clauses->lists[list_types[idx]];
n; n = n->next)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ed1acf667b4f..97ed99c8b195 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -325,7 +325,8 @@ enum gfc_statement
/* Note: gfc_match_omp_nothing returns ST_NONE. */
ST_OMP_NOTHING, ST_NONE,
ST_OMP_UNROLL, ST_OMP_END_UNROLL,
- ST_OMP_TILE, ST_OMP_END_TILE, ST_OMP_INTEROP
+ ST_OMP_TILE, ST_OMP_END_TILE, ST_OMP_INTEROP, ST_OMP_DISPATCH,
+ ST_OMP_END_DISPATCH
};
/* Types of interfaces that we can have. Assignment interfaces are
@@ -1397,6 +1398,7 @@ typedef struct gfc_omp_namelist
bool target;
bool targetsync;
} init;
+ bool need_device_ptr;
} u;
union
{
@@ -1454,6 +1456,7 @@ enum
OMP_LIST_INIT,
OMP_LIST_USE,
OMP_LIST_DESTROY,
+ OMP_LIST_ADJUST_ARGS,
OMP_LIST_NUM /* Must be the last. */
};
@@ -1599,6 +1602,8 @@ typedef struct gfc_omp_clauses
struct gfc_expr *depobj;
struct gfc_expr *dist_chunk_size;
struct gfc_expr *message;
+ struct gfc_expr *novariants;
+ struct gfc_expr *nocontext;
struct gfc_omp_assumptions *assume;
struct gfc_expr_list *sizes_list;
const char *critical_name;
@@ -1729,6 +1734,7 @@ typedef struct gfc_omp_declare_variant
struct gfc_symtree *variant_proc_symtree;
gfc_omp_set_selector *set_selectors;
+ gfc_omp_namelist *adjust_args_list;
bool checked_p : 1; /* Set if previously checked for errors. */
bool error_p : 1; /* Set if error found in directive. */
@@ -3115,7 +3121,7 @@ enum gfc_exec_op
EXEC_OMP_PARALLEL_MASKED_TASKLOOP, EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
EXEC_OMP_MASKED_TASKLOOP, EXEC_OMP_MASKED_TASKLOOP_SIMD, EXEC_OMP_SCOPE,
EXEC_OMP_UNROLL, EXEC_OMP_TILE, EXEC_OMP_METADIRECTIVE, EXEC_OMP_INTEROP,
- EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS
+ EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS, EXEC_OMP_DISPATCH
};
typedef struct gfc_code
@@ -3807,7 +3813,7 @@ void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *,
bool);
void gfc_resolve_omp_local_vars (gfc_namespace *);
void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *);
void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
-void gfc_resolve_omp_declare_simd (gfc_namespace *);
+void gfc_resolve_omp_declare (gfc_namespace *);
void gfc_resolve_omp_udrs (gfc_symtree *);
void gfc_resolve_omp_udms (gfc_symtree *);
void gfc_omp_instantiate_mappers (gfc_code *, gfc_omp_clauses *,
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 929fe73e7c98..e9137b4eed74 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -165,6 +165,7 @@ match gfc_match_omp_declare_simd (void);
match gfc_match_omp_declare_target (void);
match gfc_match_omp_declare_variant (void);
match gfc_match_omp_depobj (void);
+match gfc_match_omp_dispatch (void);
match gfc_match_omp_distribute (void);
match gfc_match_omp_distribute_parallel_do (void);
match gfc_match_omp_distribute_parallel_do_simd (void);
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 6567e0269a2e..1411521ed9c2 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -74,7 +74,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = {
{"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}, */
+ {"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) */
@@ -192,6 +192,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
gfc_free_expr (c->num_tasks);
gfc_free_expr (c->priority);
gfc_free_expr (c->detach);
+ gfc_free_expr (c->novariants);
+ gfc_free_expr (c->nocontext);
gfc_free_expr (c->async_expr);
gfc_free_expr (c->gang_num_expr);
gfc_free_expr (c->gang_static_expr);
@@ -331,6 +333,7 @@ gfc_free_omp_declare_variant_list (gfc_omp_declare_variant
*list)
gfc_omp_declare_variant *current = list;
list = list->next;
gfc_free_omp_set_selector_list (current->set_selectors);
+ gfc_free_omp_namelist (current->adjust_args_list);
free (current);
}
}
@@ -1143,6 +1146,8 @@ enum omp_mask2
OMP_CLAUSE_INIT, /* OpenMP 5.1. */
OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */
OMP_CLAUSE_USE, /* OpenMP 5.1. */
+ OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */
+ OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */
/* This must come last. */
OMP_MASK2_LAST
};
@@ -3783,6 +3788,25 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const
omp_mask mask,
c->assume->no_parallelism = needs_space = true;
continue;
}
+
+ if ((mask & OMP_CLAUSE_NOVARIANTS)
+ && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
+ &c->novariants))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NOCONTEXT)
+ && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
+ &c->nocontext))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
if ((mask & OMP_CLAUSE_NOGROUP)
&& (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
!= MATCH_NO)
@@ -5153,6 +5177,9 @@ cleanup:
#define OMP_INTEROP_CLAUSES \
(omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
| OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
+#define OMP_DISPATCH_CLAUSES
\
+ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS
\
+ | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT)
static match
@@ -5466,6 +5493,12 @@ error:
return MATCH_ERROR;
}
+match
+gfc_match_omp_dispatch (void)
+{
+ return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
+}
+
match
gfc_match_omp_distribute (void)
{
@@ -6865,6 +6898,7 @@ gfc_match_omp_declare_variant (void)
odv = gfc_get_omp_declare_variant ();
odv->where = gfc_current_locus;
odv->variant_proc_symtree = variant_proc_st;
+ odv->adjust_args_list = NULL;
odv->base_proc_symtree = base_proc_st;
odv->next = NULL;
odv->error_p = false;
@@ -6881,13 +6915,29 @@ gfc_match_omp_declare_variant (void)
return MATCH_ERROR;
}
+ bool has_match = false, has_adjust_args = false;
+ locus adjust_args_loc;
+
for (;;)
{
- if (gfc_match (" match") != MATCH_YES)
+ enum clause
+ {
+ match,
+ adjust_args
+ } ccode;
+
+ if (gfc_match (" match") == MATCH_YES)
+ ccode = match;
+ else if (gfc_match (" adjust_args") == MATCH_YES)
+ {
+ ccode = adjust_args;
+ adjust_args_loc = gfc_current_locus;
+ }
+ else
{
if (first_p)
{
- gfc_error ("expected %<match%> at %C");
+ gfc_error ("expected %<match%> or %<adjust_args%> at %C");
return MATCH_ERROR;
}
else
@@ -6900,20 +6950,57 @@ gfc_match_omp_declare_variant (void)
return MATCH_ERROR;
}
- if (gfc_match_omp_context_selector_specification (&odv->set_selectors,
+ if (ccode == match)
+ {
+ has_match = true;
+ if (gfc_match_omp_context_selector_specification (&odv->set_selectors,
false)
- != MATCH_YES)
- return MATCH_ERROR;
-
- if (gfc_match (" )") != MATCH_YES)
+ != MATCH_YES)
+ return MATCH_ERROR;
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected %<)%> at %C");
+ return MATCH_ERROR;
+ }
+ }
+ else if (ccode == adjust_args)
{
- gfc_error ("expected %<)%> at %C");
- return MATCH_ERROR;
+ has_adjust_args = true;
+ bool need_device_ptr_p;
+ if (gfc_match (" nothing") == MATCH_YES)
+ need_device_ptr_p = false;
+ else if (gfc_match (" need_device_ptr") == MATCH_YES)
+ need_device_ptr_p = true;
+ else
+ {
+ gfc_error ("expected %<nothing%> or %<need_device_ptr%> at %C");
+ return MATCH_ERROR;
+ }
+ gfc_omp_namelist **head = NULL;
+ if (gfc_match_omp_variable_list (" :", &odv->adjust_args_list, false,
+ NULL, &head)
+ != MATCH_YES)
+ {
+ gfc_error ("expected argument list at %C");
+ return MATCH_ERROR;
+ }
+ if (need_device_ptr_p)
+ for (gfc_omp_namelist *n = *head; n != NULL; n = n->next)
+ n->u.need_device_ptr = true;
}
first_p = false;
}
+ if (has_adjust_args && !has_match)
+ {
+ gfc_error ("an %<adjust_args%> clause at %L can only be specified if the
"
+ "%<dispatch%> selector of the construct selector set appears "
+ "in the %<match%> clause",
+ &adjust_args_loc);
+ return MATCH_ERROR;
+ }
+
return MATCH_YES;
}
@@ -9234,7 +9321,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
"DEVICE_RESIDENT", "LINK", "USE_DEVICE",
"CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
"NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
- "USES_ALLOCATORS", "INIT", "USE", "DESTROY" };
+ "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "ADJUST_ARGS" };
STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
if (omp_clauses == NULL)
@@ -9418,6 +9505,26 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
&expr->where);
}
+ if (omp_clauses->novariants)
+ {
+ gfc_expr *expr = omp_clauses->novariants;
+ if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
+ || expr->rank != 0)
+ gfc_error (
+ "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ if_without_mod = true;
+ }
+ if (omp_clauses->nocontext)
+ {
+ gfc_expr *expr = omp_clauses->nocontext;
+ if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
+ || expr->rank != 0)
+ gfc_error (
+ "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ if_without_mod = true;
+ }
if (omp_clauses->num_threads)
resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
if (omp_clauses->chunk_size)
@@ -9717,14 +9824,18 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
last = NULL;
for (n = omp_clauses->lists[list]; n != NULL; )
{
- if (n->sym->ts.type == BT_DERIVED
- && n->sym->ts.u.derived->ts.is_iso_c
- && code->op != EXEC_OMP_TARGET)
+ if ((n->sym->ts.type != BT_DERIVED
+ || !n->sym->ts.u.derived->ts.is_iso_c
+ || (n->sym->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_PTR))
+ && code->op == EXEC_OMP_DISPATCH)
/* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
gfc_error ("List item %qs in %s clause at %L must be of "
"TYPE(C_PTR)", n->sym->name, name, &n->where);
else if (n->sym->ts.type != BT_DERIVED
- || !n->sym->ts.u.derived->ts.is_iso_c)
+ || !n->sym->ts.u.derived->ts.is_iso_c
+ || (n->sym->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_PTR))
{
/* For TARGET, non-C_PTR are deprecated and handled as
has_device_addr. */
@@ -11399,6 +11510,7 @@ icode_code_error_callback (gfc_code **codep,
case EXEC_OMP_MASKED_TASKLOOP_SIMD:
case EXEC_OMP_SCOPE:
case EXEC_OMP_ERROR:
+ case EXEC_OMP_DISPATCH:
gfc_error ("%s cannot contain OpenMP directive in intervening code "
"at %L",
state->name, &code->loc);
@@ -12388,6 +12500,8 @@ omp_code_to_statement (gfc_code *code)
return ST_OMP_TILE;
case EXEC_OMP_UNROLL:
return ST_OMP_UNROLL;
+ case EXEC_OMP_DISPATCH:
+ return ST_OMP_DISPATCH;
default:
gcc_unreachable ();
}
@@ -12822,6 +12936,41 @@ resolve_omp_target (gfc_code *code)
#undef GFC_IS_TEAMS_CONSTRUCT
}
+static void
+resolve_omp_dispatch (gfc_code *code)
+{
+ gfc_code *next = code->block->next;
+ if (next == NULL)
+ return;
+
+ gfc_exec_op op = next->op;
+ gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
+ if (op != EXEC_CALL
+ && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
+ gfc_error (
+ "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
+ "call with optional assignment",
+ &code->loc);
+
+ if ((op == EXEC_CALL && next->resolved_sym != NULL
+ && next->resolved_sym->attr.proc_pointer)
+ || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
+ gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
+ "procedure pointer",
+ &code->loc);
+
+ gfc_omp_declare_variant *odv = gfc_current_ns->omp_declare_variant;
+ if (odv != NULL)
+ for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
+ if (n->sym->ts.type != BT_DERIVED || !n->sym->ts.u.derived->ts.is_iso_c
+ || (n->sym->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR))
+ {
+ gfc_error (
+ "argument list item %qs in %<need_device_ptr%> at %L must be of "
+ "TYPE(C_PTR)",
+ n->sym->name, &n->where);
+ }
+}
/* Resolve OpenMP directive clauses and check various requirements
of each directive. */
@@ -12941,18 +13090,23 @@ gfc_resolve_omp_directive (gfc_code *code,
gfc_namespace *ns)
case EXEC_OMP_METADIRECTIVE:
resolve_omp_metadirective (code, ns);
break;
+ case EXEC_OMP_DISPATCH:
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code, code->ext.omp_clauses, ns);
+ resolve_omp_dispatch (code);
+ break;
default:
break;
}
}
-/* Resolve !$omp declare simd constructs in NS. */
+/* Resolve !$omp declare {variant|simd} constructs in NS.
+ Note that !$omp declare target is resolved in resolve_symbol. */
void
-gfc_resolve_omp_declare_simd (gfc_namespace *ns)
+gfc_resolve_omp_declare (gfc_namespace *ns)
{
gfc_omp_declare_simd *ods;
-
for (ods = ns->omp_declare_simd; ods; ods = ods->next)
{
if (ods->proc_name != NULL
@@ -12962,6 +13116,20 @@ gfc_resolve_omp_declare_simd (gfc_namespace *ns)
if (ods->clauses)
resolve_omp_clauses (NULL, ods->clauses, ns);
}
+
+ gfc_omp_declare_variant *odv;
+ for (odv = ns->omp_declare_variant; odv; odv = odv->next)
+ for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
+ if (n->u.need_device_ptr
+ && (!gfc_resolve_expr (n->expr) || n->sym->ts.type != BT_DERIVED
+ || !n->sym->ts.u.derived->ts.is_iso_c
+ || (n->sym->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)))
+ {
+ gfc_error (
+ "argument list item %qs in %<need_device_ptr%> at %L must be of "
+ "TYPE(C_PTR)",
+ n->sym->name, &n->where);
+ }
}
struct omp_udr_callback_data
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index fa731cec0ca7..2af580784c9d 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -1071,6 +1071,7 @@ decode_omp_directive (void)
matchds ("declare reduction", gfc_match_omp_declare_reduction,
ST_OMP_DECLARE_REDUCTION);
matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ);
+ matcho ("dispatch", gfc_match_omp_dispatch, ST_OMP_DISPATCH);
matchs ("distribute parallel do simd",
gfc_match_omp_distribute_parallel_do_simd,
ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD);
@@ -1086,6 +1087,7 @@ decode_omp_directive (void)
matcho ("end allocators", gfc_match_omp_eos_error,
ST_OMP_END_ALLOCATORS);
matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
+ matcho ("end dispatch", gfc_match_omp_end_nowait, ST_OMP_END_DISPATCH);
matchs ("end distribute parallel do simd", gfc_match_omp_eos_error,
ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD);
matcho ("end distribute parallel do", gfc_match_omp_eos_error,
@@ -1959,7 +1961,7 @@ next_statement (void)
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_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \
- case ST_OMP_TILE: case ST_OMP_UNROLL: \
+ case ST_OMP_TILE: case ST_OMP_UNROLL: case ST_OMP_DISPATCH: \
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: \
@@ -2685,6 +2687,9 @@ gfc_ascii_statement (gfc_statement st, bool
strip_sentinel)
case ST_OMP_DEPOBJ:
p = "!$OMP DEPOBJ";
break;
+ case ST_OMP_DISPATCH:
+ p = "!$OMP DISPATCH";
+ break;
case ST_OMP_DISTRIBUTE:
p = "!$OMP DISTRIBUTE";
break;
@@ -2715,6 +2720,9 @@ gfc_ascii_statement (gfc_statement st, bool
strip_sentinel)
case ST_OMP_END_CRITICAL:
p = "!$OMP END CRITICAL";
break;
+ case ST_OMP_END_DISPATCH:
+ p = "!$OMP END DISPATCH";
+ break;
case ST_OMP_END_DISTRIBUTE:
p = "!$OMP END DISTRIBUTE";
break;
@@ -6383,6 +6391,46 @@ parse_omp_metadirective_body (gfc_statement omp_st)
return next_st;
}
+static gfc_statement
+parse_omp_dispatch (void)
+{
+ gfc_statement st;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+
+ accept_statement (ST_OMP_DISPATCH);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ st = next_statement ();
+ if (st == ST_NONE)
+ return st;
+ if (st == ST_CALL || st == ST_ASSIGNMENT)
+ accept_statement (st);
+ else
+ {
+ gfc_error ("%<OMP DISPATCH%> directive must be followed by a procedure "
+ "call with optional assignment at %C");
+ reject_statement ();
+ }
+ pop_state ();
+ st = next_statement ();
+ if (st == ST_OMP_END_DISPATCH)
+ {
+ if (cp->ext.omp_clauses->nowait && new_st.ext.omp_bool)
+ gfc_error_now ("Duplicated NOWAIT clause on !$OMP DISPATCH and !$OMP "
+ "END DISPATCH at %C");
+ cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
+ accept_statement (st);
+ st = next_statement ();
+ }
+ return st;
+}
+
/* Accept a series of executable statements. We return the first
statement that doesn't fit to the caller. Any block statements are
passed on to the correct handler, which usually passes the buck
@@ -6537,6 +6585,10 @@ parse_executable (gfc_statement st)
st = parse_omp_oacc_atomic (true);
continue;
+ case ST_OMP_DISPATCH:
+ st = parse_omp_dispatch ();
+ continue;
+
case ST_OMP_METADIRECTIVE:
case ST_OMP_BEGIN_METADIRECTIVE:
st = parse_omp_metadirective_body (st);
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index ac81f10f1516..6db384d26d32 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11403,6 +11403,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
@@ -13099,6 +13100,7 @@ start:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_FLUSH:
case EXEC_OMP_DEPOBJ:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
@@ -18443,7 +18445,7 @@ resolve_types (gfc_namespace *ns)
gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
- gfc_resolve_omp_declare_simd (ns);
+ gfc_resolve_omp_declare (ns);
gfc_resolve_omp_udrs (ns->omp_udr_root);
diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc
index 6db632b00c04..0aebafb6c6cd 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -222,6 +222,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DEPOBJ:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 3d0431cac10b..2b68789bf085 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2166,6 +2166,8 @@ get_proc_pointer_decl (gfc_symbol *sym)
return decl;
}
+static void
+create_function_arglist (gfc_symbol *sym);
/* Get a basic decl for an external function. */
@@ -2417,7 +2419,12 @@ module_sym:
if (sym->formal_ns->omp_declare_simd)
gfc_trans_omp_declare_simd (sym->formal_ns);
if (flag_openmp)
- gfc_trans_omp_declare_variant (sym->formal_ns);
+ {
+ // We need DECL_ARGUMENTS to put attributes on, in case some arguments
+ // need adjustment
+ create_function_arglist (sym->formal_ns->proc_name);
+ gfc_trans_omp_declare_variant (sym->formal_ns);
+ }
}
return fndecl;
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index d96dc17a05f4..d4465e40bbe7 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -6574,6 +6574,36 @@ gfc_trans_omp_clauses (stmtblock_t *block,
gfc_omp_clauses *clauses,
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
+ if (clauses->novariants)
+ {
+ tree novariants_var;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, clauses->novariants);
+ gfc_add_block_to_block (block, &se.pre);
+ novariants_var = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+
+ c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOVARIANTS);
+ OMP_CLAUSE_NOVARIANTS_EXPR (c) = novariants_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ if (clauses->nocontext)
+ {
+ tree nocontext_var;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, clauses->nocontext);
+ gfc_add_block_to_block (block, &se.pre);
+ nocontext_var = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+
+ c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOCONTEXT);
+ OMP_CLAUSE_NOCONTEXT_EXPR (c) = nocontext_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
if (clauses->num_threads)
{
tree num_threads;
@@ -8706,6 +8736,113 @@ gfc_trans_omp_depobj (gfc_code *code)
return gfc_finish_block (&block);
}
+/* Callback for walk_tree to find an OMP dispatch call and wrap it into an
+ * IFN_GOMP_DISPATCH. */
+
+static tree
+replace_omp_dispatch_call (tree *tp, int *, void *decls_p)
+{
+ tree t = *tp;
+ tree decls = (tree) decls_p;
+ tree orig_fn_decl = TREE_PURPOSE (decls);
+ tree dup_fn_decl = TREE_VALUE (decls);
+ if (TREE_CODE (t) == CALL_EXPR)
+ {
+ if (CALL_EXPR_FN (t) == dup_fn_decl)
+ CALL_EXPR_FN (t) = orig_fn_decl;
+ else if (TREE_CODE (CALL_EXPR_FN (t)) == ADDR_EXPR
+ && TREE_OPERAND (CALL_EXPR_FN (t), 0) == dup_fn_decl)
+ TREE_OPERAND (CALL_EXPR_FN (t), 0) = dup_fn_decl;
+ else
+ return NULL_TREE;
+ *tp = build_call_expr_internal_loc (input_location, IFN_GOMP_DISPATCH,
+ TREE_TYPE (t), 1, t);
+ return *tp;
+ }
+
+ return NULL_TREE;
+}
+
+static tree
+gfc_trans_omp_dispatch (gfc_code *code)
+{
+ stmtblock_t block;
+ gfc_code *next = code->block->next;
+ // assume ill-formed "function dispatch structured
+ // block" have already been rejected by resolve_omp_dispatch
+ gcc_assert (next->op == EXEC_CALL || next->op == EXEC_ASSIGN);
+
+ // Make duplicate decl for dispatch function call to make it easy to spot
+ // after translation
+ gfc_symbol *orig_fn_sym;
+ gfc_expr *call_expr = next->op == EXEC_CALL ? next->expr1 : next->expr2;
+ if (call_expr != NULL) // function
+ {
+ if (call_expr->value.function.isym != NULL) // dig into convert
intrinsics
+ call_expr = call_expr->value.function.actual->expr;
+ gcc_assert (call_expr->expr_type == EXPR_FUNCTION);
+ orig_fn_sym = call_expr->value.function.esym
+ ? call_expr->value.function.esym
+ : call_expr->symtree->n.sym;
+ }
+ else // subroutine
+ {
+ orig_fn_sym = next->resolved_sym;
+ }
+ if (!orig_fn_sym->backend_decl)
+ gfc_get_symbol_decl (orig_fn_sym);
+ gfc_symbol dup_fn_sym = *orig_fn_sym;
+ dup_fn_sym.backend_decl = copy_node (orig_fn_sym->backend_decl);
+ if (call_expr != NULL)
+ call_expr->value.function.esym = &dup_fn_sym;
+ else
+ next->resolved_sym = &dup_fn_sym;
+
+ tree body = gfc_trans_code (next);
+
+ // Walk the tree to find the duplicate decl, wrap IFN call and replace
+ // dup decl with original
+ tree fn_decls
+ = build_tree_list (orig_fn_sym->backend_decl, dup_fn_sym.backend_decl);
+ tree dispatch_call
+ = walk_tree (&body, replace_omp_dispatch_call, fn_decls, NULL);
+ gcc_assert (dispatch_call != NULL_TREE);
+
+ gfc_start_block (&block);
+ tree omp_clauses
+ = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc);
+
+ // Extract depend clauses and create taskwait
+ tree depend_clauses = NULL_TREE;
+ tree *depend_clauses_ptr = &depend_clauses;
+ for (tree c = omp_clauses; c; c = OMP_CLAUSE_CHAIN (c))
+ {
+ if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_DEPEND)
+ {
+ *depend_clauses_ptr = c;
+ depend_clauses_ptr = &OMP_CLAUSE_CHAIN (c);
+ }
+ }
+ if (depend_clauses != NULL_TREE)
+ {
+ tree stmt = make_node (OMP_TASK);
+ TREE_TYPE (stmt) = void_node;
+ OMP_TASK_CLAUSES (stmt) = depend_clauses;
+ OMP_TASK_BODY (stmt) = NULL_TREE;
+ SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
+ gfc_add_expr_to_block (&block, stmt);
+ }
+
+ tree stmt = make_node (OMP_DISPATCH);
+ SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
+ TREE_TYPE (stmt) = void_type_node;
+ OMP_DISPATCH_BODY (stmt) = body;
+ OMP_DISPATCH_CLAUSES (stmt) = omp_clauses;
+
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
static tree
gfc_trans_omp_error (gfc_code *code)
{
@@ -10822,6 +10959,8 @@ gfc_trans_omp_directive (gfc_code *code)
case EXEC_OMP_UNROLL:
return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
NULL);
+ case EXEC_OMP_DISPATCH:
+ return gfc_trans_omp_dispatch (code);
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
case EXEC_OMP_DISTRIBUTE_SIMD:
@@ -11151,6 +11290,18 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
variant_proc_sym = NULL;
}
}
+ if (odv->adjust_args_list != NULL
+ && omp_get_context_selector (set_selectors,
+ OMP_TRAIT_SET_CONSTRUCT,
+ OMP_TRAIT_CONSTRUCT_DISPATCH)
+ == NULL_TREE)
+ {
+ gfc_error ("an %<adjust_args%> clause can only be specified if "
+ "the %<dispatch%> selector of the construct "
+ "selector set appears in the %<match%> clause at %L",
+ &odv->where);
+ variant_proc_sym = NULL;
+ }
if (variant_proc_sym != NULL)
{
gfc_set_sym_referenced (variant_proc_sym);
@@ -11168,6 +11319,52 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
DECL_ATTRIBUTES (base_fn_decl)
= tree_cons (id, build_tree_list (variant, set_selectors),
DECL_ATTRIBUTES (base_fn_decl));
+
+ // Handle adjust_args
+ tree need_device_ptr_list = make_node (TREE_LIST);
+ vec<gfc_symbol *> adjust_args_list = vNULL;
+ for (gfc_omp_namelist *arg_list = odv->adjust_args_list;
+ arg_list != NULL; arg_list = arg_list->next)
+ {
+ if (!arg_list->sym->attr.dummy)
+ {
+ gfc_error (
+ "list item %qs at %L is not a dummy argument",
+ arg_list->sym->name, &arg_list->where);
+ continue;
+ }
+ if (adjust_args_list.contains (arg_list->sym))
+ {
+ gfc_error ("%qs at %L is specified more than once",
+ arg_list->sym->name, &arg_list->where);
+ continue;
+ }
+ adjust_args_list.safe_push (arg_list->sym);
+ if (arg_list->u.need_device_ptr)
+ {
+ int idx;
+ gfc_formal_arglist *arg;
+ for (arg = ns->proc_name->formal, idx = 0;
+ arg != NULL; arg = arg->next, idx++)
+ if (arg->sym == arg_list->sym)
+ break;
+ gcc_assert (arg != NULL);
+ need_device_ptr_list = chainon (
+ need_device_ptr_list,
+ build_tree_list (
+ NULL_TREE,
+ build_int_cst (
+ integer_type_node,
+ idx))); // Store 0-based argument index,
+ // as in gimplify_call_expr
+ }
+ }
+
+ DECL_ATTRIBUTES (variant) = tree_cons (
+ get_identifier ("omp declare variant variant adjust_args"),
+ build_tree_list (need_device_ptr_list,
+ NULL_TREE /*need_device_addr */),
+ DECL_ATTRIBUTES (variant));
}
}
}
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 4d8e3ad05c99..cb5baec9cea0 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -2584,6 +2584,7 @@ trans_code (gfc_code * code, tree cond)
case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DEPOBJ:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
diff --git a/gcc/gimplify.cc b/gcc/gimplify.cc
index b5f54ad7cf1a..06995d9172d2 100644
--- a/gcc/gimplify.cc
+++ b/gcc/gimplify.cc
@@ -4075,7 +4075,7 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p,
fallback_t fallback)
enum gimplify_status ret;
int i, nargs;
gcall *call;
- bool builtin_va_start_p = false;
+ bool builtin_va_start_p = false, omp_dispatch_p = false;
location_t loc = EXPR_LOCATION (*expr_p);
gcc_assert (TREE_CODE (*expr_p) == CALL_EXPR);
@@ -4088,69 +4088,79 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p,
fallback_t fallback)
/* Gimplify internal functions created in the FEs. */
if (CALL_EXPR_FN (*expr_p) == NULL_TREE)
{
- if (want_value)
- return GS_ALL_DONE;
-
- nargs = call_expr_nargs (*expr_p);
enum internal_fn ifn = CALL_EXPR_IFN (*expr_p);
- auto_vec<tree> vargs (nargs);
-
- if (ifn == IFN_ASSUME)
+ if (ifn == IFN_GOMP_DISPATCH)
{
- if (simple_condition_p (CALL_EXPR_ARG (*expr_p, 0)))
- {
- /* If the [[assume (cond)]]; condition is simple
- enough and can be evaluated unconditionally
- without side-effects, expand it as
- if (!cond) __builtin_unreachable (); */
- tree fndecl = builtin_decl_explicit (BUILT_IN_UNREACHABLE);
- *expr_p = build3 (COND_EXPR, void_type_node,
- CALL_EXPR_ARG (*expr_p, 0), void_node,
- build_call_expr_loc (EXPR_LOCATION (*expr_p),
- fndecl, 0));
- return GS_OK;
- }
- /* If not optimizing, ignore the assumptions. */
- if (!optimize || seen_error ())
+ gcc_assert (gimplify_omp_ctxp->code == OMP_DISPATCH);
+ *expr_p = CALL_EXPR_ARG (*expr_p, 0);
+ omp_dispatch_p = true;
+ }
+ else
+ {
+ if (want_value)
+ return GS_ALL_DONE;
+
+ nargs = call_expr_nargs (*expr_p);
+ auto_vec<tree> vargs (nargs);
+
+ if (ifn == IFN_ASSUME)
{
+ if (simple_condition_p (CALL_EXPR_ARG (*expr_p, 0)))
+ {
+ /* If the [[assume (cond)]]; condition is simple
+ enough and can be evaluated unconditionally
+ without side-effects, expand it as
+ if (!cond) __builtin_unreachable (); */
+ tree fndecl = builtin_decl_explicit (BUILT_IN_UNREACHABLE);
+ *expr_p
+ = build3 (COND_EXPR, void_type_node,
+ CALL_EXPR_ARG (*expr_p, 0), void_node,
+ build_call_expr_loc (EXPR_LOCATION (*expr_p),
+ fndecl, 0));
+ return GS_OK;
+ }
+ /* If not optimizing, ignore the assumptions. */
+ if (!optimize || seen_error ())
+ {
+ *expr_p = NULL_TREE;
+ return GS_ALL_DONE;
+ }
+ /* Temporarily, until gimple lowering, transform
+ .ASSUME (cond);
+ into:
+ [[assume (guard)]]
+ {
+ guard = cond;
+ }
+ such that gimple lowering can outline the condition into
+ a separate function easily. */
+ tree guard = create_tmp_var (boolean_type_node);
+ *expr_p = build2 (MODIFY_EXPR, void_type_node, guard,
+ gimple_boolify (CALL_EXPR_ARG (*expr_p, 0)));
+ *expr_p = build3 (BIND_EXPR, void_type_node, NULL, *expr_p, NULL);
+ push_gimplify_context ();
+ gimple_seq body = NULL;
+ gimple *g = gimplify_and_return_first (*expr_p, &body);
+ pop_gimplify_context (g);
+ g = gimple_build_assume (guard, body);
+ gimple_set_location (g, loc);
+ gimplify_seq_add_stmt (pre_p, g);
*expr_p = NULL_TREE;
return GS_ALL_DONE;
}
- /* Temporarily, until gimple lowering, transform
- .ASSUME (cond);
- into:
- [[assume (guard)]]
- {
- guard = cond;
- }
- such that gimple lowering can outline the condition into
- a separate function easily. */
- tree guard = create_tmp_var (boolean_type_node);
- *expr_p = build2 (MODIFY_EXPR, void_type_node, guard,
- gimple_boolify (CALL_EXPR_ARG (*expr_p, 0)));
- *expr_p = build3 (BIND_EXPR, void_type_node, NULL, *expr_p, NULL);
- push_gimplify_context ();
- gimple_seq body = NULL;
- gimple *g = gimplify_and_return_first (*expr_p, &body);
- pop_gimplify_context (g);
- g = gimple_build_assume (guard, body);
- gimple_set_location (g, loc);
- gimplify_seq_add_stmt (pre_p, g);
- *expr_p = NULL_TREE;
- return GS_ALL_DONE;
- }
- for (i = 0; i < nargs; i++)
- {
- gimplify_arg (&CALL_EXPR_ARG (*expr_p, i), pre_p,
- EXPR_LOCATION (*expr_p));
- vargs.quick_push (CALL_EXPR_ARG (*expr_p, i));
- }
+ for (i = 0; i < nargs; i++)
+ {
+ gimplify_arg (&CALL_EXPR_ARG (*expr_p, i), pre_p,
+ EXPR_LOCATION (*expr_p));
+ vargs.quick_push (CALL_EXPR_ARG (*expr_p, i));
+ }
- gcall *call = gimple_build_call_internal_vec (ifn, vargs);
- gimple_call_set_nothrow (call, TREE_NOTHROW (*expr_p));
- gimplify_seq_add_stmt (pre_p, call);
- return GS_ALL_DONE;
+ gcall *call = gimple_build_call_internal_vec (ifn, vargs);
+ gimple_call_set_nothrow (call, TREE_NOTHROW (*expr_p));
+ gimplify_seq_add_stmt (pre_p, call);
+ return GS_ALL_DONE;
+ }
}
/* This may be a call to a builtin function.
@@ -4415,21 +4425,36 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p,
fallback_t fallback)
gimplify_seq_add_stmt (pre_p, call);
}
- // mapped_arg = omp_get_mapped_ptr (arg,
+ // We want to emit the following statement:
+ // mapped_arg = omp_get_mapped_ptr (arg,
// device_num)
+ // but arg has to be the actual pointer, not a
+ // reference or a conversion expression.
+ tree actual_ptr
+ = (TREE_CODE (*arg_p) == ADDR_EXPR)
+ ? TREE_OPERAND (*arg_p, 0)
+ : *arg_p;
+ if (TREE_CODE (actual_ptr) == NOP_EXPR
+ && TREE_CODE (
+ TREE_TYPE (TREE_OPERAND (actual_ptr, 0)))
+ == REFERENCE_TYPE)
+ {
+ actual_ptr = TREE_OPERAND (actual_ptr, 0);
+ actual_ptr = build1 (INDIRECT_REF,
+ TREE_TYPE (actual_ptr),
+ actual_ptr);
+ }
+ gimplify_arg (&actual_ptr, pre_p, loc);
+ gimplify_arg (&device_num, pre_p, loc);
tree fn = builtin_decl_explicit (
BUILT_IN_OMP_GET_MAPPED_PTR);
- gimplify_arg (arg_p, pre_p, loc);
- gimplify_arg (&device_num, pre_p, loc);
- call
- = gimple_build_call (fn, 2, *arg_p, device_num);
+ call = gimple_build_call (fn, 2, actual_ptr,
+ device_num);
tree mapped_arg = create_tmp_var (
gimple_call_return_type (call));
gimple_call_set_lhs (call, mapped_arg);
gimplify_seq_add_stmt (pre_p, call);
- *arg_p = mapped_arg;
-
// gimplify_call_expr might be called several
// times on the same call, which would result in
// duplicated calls to omp_get_default_device and
@@ -4440,9 +4465,19 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p,
fallback_t fallback)
tree c
= build_omp_clause (input_location,
OMP_CLAUSE_IS_DEVICE_PTR);
- OMP_CLAUSE_DECL (c) = *arg_p;
+ OMP_CLAUSE_DECL (c) = mapped_arg;
OMP_CLAUSE_CHAIN (c) = gimplify_omp_ctxp->clauses;
gimplify_omp_ctxp->clauses = c;
+
+ if (TREE_CODE (*arg_p) == ADDR_EXPR
+ || TREE_CODE (TREE_TYPE (actual_ptr))
+ == REFERENCE_TYPE)
+ mapped_arg = build_fold_addr_expr (mapped_arg);
+ else if (TREE_CODE (*arg_p) == NOP_EXPR)
+ mapped_arg
+ = build1 (NOP_EXPR, TREE_TYPE (*arg_p),
+ mapped_arg);
+ *arg_p = mapped_arg;
}
}
}
@@ -19363,10 +19398,7 @@ find_ifn_gomp_dispatch (tree *tp, int *, void *modify)
tree t = *tp;
if (TREE_CODE (t) == CALL_EXPR && CALL_EXPR_IFN (t) == IFN_GOMP_DISPATCH)
- {
- *tp = CALL_EXPR_ARG (t, 0);
- return *(tree *) modify ? *(tree *) modify : *tp;
- }
+ return *(tree *) modify ? *(tree *) modify : *tp;
if (TREE_CODE (t) == MODIFY_EXPR)
*(tree *) modify = *tp;
@@ -19432,12 +19464,7 @@ gimplify_omp_dispatch (tree *expr_p, gimple_seq *pre_p)
base_call_expr
= walk_tree (&stmt, find_ifn_gomp_dispatch, &modify, NULL);
if (base_call_expr != NULL_TREE)
- {
- tsi_link_before (&tsi, base_call_expr, TSI_CONTINUE_LINKING);
- tsi_next (&tsi);
- tsi_delink (&tsi);
- break;
- }
+ break;
}
else
{
@@ -19453,6 +19480,7 @@ gimplify_omp_dispatch (tree *expr_p, gimple_seq *pre_p)
dst = TREE_OPERAND (base_call_expr, 0);
base_call_expr = TREE_OPERAND (base_call_expr, 1);
}
+
while (TREE_CODE (base_call_expr) == FLOAT_EXPR
|| TREE_CODE (base_call_expr) == CONVERT_EXPR
|| TREE_CODE (base_call_expr) == COMPLEX_EXPR
@@ -19460,6 +19488,9 @@ gimplify_omp_dispatch (tree *expr_p, gimple_seq *pre_p)
|| TREE_CODE (base_call_expr) == NOP_EXPR)
base_call_expr = TREE_OPERAND (base_call_expr, 0);
+ gcc_assert (CALL_EXPR_IFN (base_call_expr) == IFN_GOMP_DISPATCH);
+ base_call_expr = CALL_EXPR_ARG (base_call_expr, 0);
+
tree base_fndecl = get_callee_fndecl (base_call_expr);
if (base_fndecl != NULL_TREE)
{
@@ -19530,6 +19561,11 @@ gimplify_omp_dispatch (tree *expr_p, gimple_seq *pre_p)
gimplify_seq_add_stmt (&body, gimple_build_label (base_label));
tree base_call_expr2 = copy_node (base_call_expr);
+ base_call_expr2
+ = build_call_expr_internal_loc (EXPR_LOCATION (base_call_expr2),
+ IFN_GOMP_DISPATCH,
+ TREE_TYPE (base_call_expr2), 1,
+ base_call_expr2);
if (TREE_CODE (dispatch_body) == MODIFY_EXPR)
{
base_call_expr2 = build2 (MODIFY_EXPR, TREE_TYPE (dst), dst,
@@ -19557,6 +19593,9 @@ gimplify_omp_dispatch (tree *expr_p, gimple_seq *pre_p)
gimplify_seq_add_stmt (&body,
gimple_build_label (variant1_label));
tree variant_call_expr = copy_node (base_call_expr);
+ variant_call_expr = build_call_expr_internal_loc (
+ EXPR_LOCATION (variant_call_expr), IFN_GOMP_DISPATCH,
+ TREE_TYPE (variant_call_expr), 1, variant_call_expr);
if (TREE_CODE (dispatch_body) == MODIFY_EXPR)
{
variant_call_expr = build2 (MODIFY_EXPR, TREE_TYPE (dst), dst,
@@ -19571,6 +19610,11 @@ gimplify_omp_dispatch (tree *expr_p, gimple_seq *pre_p)
}
tree variant_call_expr = base_call_expr;
+ variant_call_expr
+ = build_call_expr_internal_loc (EXPR_LOCATION (variant_call_expr),
+ IFN_GOMP_DISPATCH,
+ TREE_TYPE (variant_call_expr), 1,
+ variant_call_expr);
if (TREE_CODE (dispatch_body) == MODIFY_EXPR)
{
variant_call_expr
diff --git a/gcc/testsuite/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index ccec4308bf22..70a249e0ea00 100644
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,32 @@
+2025-01-27 Paul-Antoine Arras <par...@baylibre.com>
+
+ Backported from master:
+ 2025-01-02 Paul-Antoine Arras <par...@baylibre.com>
+
+ * g++.dg/gomp/dispatch-3.C: Update scan dumps.
+ * gfortran.dg/gomp/declare-variant-2.f90: Update dg-error.
+ * gfortran.dg/gomp/adjust-args-1.f90: New test.
+ * gfortran.dg/gomp/adjust-args-2.f90: New test.
+ * gfortran.dg/gomp/adjust-args-2a.f90: New test.
+ * gfortran.dg/gomp/adjust-args-3.f90: New test.
+ * gfortran.dg/gomp/adjust-args-4.f90: New test.
+ * gfortran.dg/gomp/adjust-args-5.f90: New test.
+ * gfortran.dg/gomp/adjust-args-6.f90: New test.
+ * gfortran.dg/gomp/adjust-args-7.f90: New test.
+ * gfortran.dg/gomp/adjust-args-8.f90: New test.
+ * gfortran.dg/gomp/adjust-args-9.f90: New test.
+ * gfortran.dg/gomp/dispatch-1.f90: New test.
+ * gfortran.dg/gomp/dispatch-2.f90: New test.
+ * gfortran.dg/gomp/dispatch-3.f90: New test.
+ * gfortran.dg/gomp/dispatch-4.f90: New test.
+ * gfortran.dg/gomp/dispatch-5.f90: New test.
+ * gfortran.dg/gomp/dispatch-6.f90: New test.
+ * gfortran.dg/gomp/dispatch-7.f90: New test.
+ * gfortran.dg/gomp/dispatch-8.f90: New test.
+ * gfortran.dg/gomp/dispatch-9.f90: New test.
+ * gfortran.dg/gomp/dispatch-9a.f90: New test.
+ * gfortran.dg/gomp/dispatch-10.f90: New test.
+
2025-01-27 Paul-Antoine Arras <par...@baylibre.com>
Backported from master:
diff --git a/gcc/testsuite/g++.dg/gomp/dispatch-3.C
b/gcc/testsuite/g++.dg/gomp/dispatch-3.C
index 03fd7dc6f6ce..90e5c04c3f0c 100644
--- a/gcc/testsuite/g++.dg/gomp/dispatch-3.C
+++ b/gcc/testsuite/g++.dg/gomp/dispatch-3.C
@@ -12,6 +12,6 @@ void g(int *x)
// ^ only this call to f is a dispatch call
}
-/* { dg-final { scan-tree-dump "\.GOMP_DISPATCH \\(\\*f \\(\\*f \\(2\\)\\)\\)"
"original" } } */
+/* { dg-final { scan-tree-dump "\\*\.GOMP_DISPATCH \\(f \\(\\*f \\(2\\)\\)\\)"
"original" } } */
/* { dg-final { scan-tree-dump-times "\.GOMP_DISPATCH" 1 "original" } } */
/* { dg-final { scan-tree-dump-not "\.GOMP_DISPATCH" "gimple" } } */
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
new file mode 100644
index 000000000000..d9f2a670a683
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
@@ -0,0 +1,45 @@
+! Test parsing of OMP clause adjust_args
+! { dg-do compile }
+
+module main
+ use iso_c_binding, only: c_ptr, c_funptr
+ implicit none
+ integer :: b
+ interface
+ integer function f0 (a)
+ import c_ptr
+ type(c_ptr), intent(inout) :: a
+ end function
+ integer function g (a)
+ import c_ptr
+ type(c_ptr), intent(inout) :: a
+ end function
+ integer function f1 (i)
+ integer, intent(in) :: i
+ end function
+
+ integer function f3 (a)
+ import c_ptr
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args
(other: a) ! { dg-error "expected 'nothing' or 'need_device_ptr' at .1." }
+ end function
+ integer function f4 (a)
+ import c_ptr
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (f0) adjust_args (nothing: a) ! { dg-error "an
'adjust_args' clause at .1. can only be specified if the 'dispatch' selector of
the construct selector set appears in the 'match' clause" }
+ end function
+ integer function f5 (i)
+ integer, intent(inout) :: i
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args
() ! { dg-error "expected 'nothing' or 'need_device_ptr' at .1." }
+ end function
+ integer function f6 (i)
+ integer, intent(inout) :: i
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args
(nothing) ! { dg-error "expected argument list at .1." }
+ end function
+ integer function f7 (i)
+ integer, intent(inout) :: i
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args
(nothing:) ! { dg-error "expected argument list at .1." }
+ end function
+
+ end interface
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
new file mode 100644
index 000000000000..c65a4839ca5d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
@@ -0,0 +1,18 @@
+! Test resolution of OMP clause adjust_args
+! { dg-do compile }
+
+module main
+ implicit none
+interface
+subroutine f1 (i)
+ integer, intent(inout) :: i
+end subroutine
+end interface
+contains
+
+ subroutine f3 (i)
+ integer, intent(inout) :: i
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args
(nothing: z) ! { dg-error "Symbol 'z' at .1. has no IMPLICIT type" }
+ end subroutine
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-2a.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2a.f90
new file mode 100644
index 000000000000..9a32d2b7d92f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2a.f90
@@ -0,0 +1,36 @@
+! Test resolution of OMP clause adjust_args
+! { dg-do compile }
+
+module main
+ use iso_c_binding, only: c_ptr, c_funptr
+ implicit none
+ interface
+ subroutine f1 (i)
+ integer, intent(inout) :: i
+ end subroutine
+ subroutine h (a)
+ import c_funptr
+ type(c_funptr), intent(inout) :: a
+ end subroutine
+ end interface
+contains
+
+ subroutine f9 (i)
+ integer, intent(inout) :: i
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args
(need_device_ptr: i) ! { dg-error "argument list item 'i' in 'need_device_ptr'
at .1. must be of TYPE.C_PTR." }
+ end subroutine
+ subroutine f13 (a)
+ type(c_funptr), intent(inout) :: a
+ !$omp declare variant (h) match (construct={dispatch}) adjust_args
(need_device_ptr: a) ! { dg-error "argument list item 'a' in 'need_device_ptr'
at .1. must be of TYPE.C_PTR." }
+ end subroutine
+
+ subroutine test
+ integer :: i
+ type(c_funptr) :: a
+ !$omp dispatch
+ call f9(i)
+ !$omp dispatch
+ call f13(a)
+ end subroutine
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
new file mode 100644
index 000000000000..291bb47aaa25
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
@@ -0,0 +1,27 @@
+! Test translation of OMP clause adjust_args
+! { dg-do compile }
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+ type(c_ptr) :: b
+
+contains
+ subroutine base2 (a)
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (variant2) match (construct={parallel}) adjust_args
(need_device_ptr: a) ! { dg-error "an 'adjust_args' clause can only be
specified if the 'dispatch' selector of the construct selector set appears in
the 'match' clause at .1." }
+ end subroutine
+ subroutine base3 (a)
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (variant2) match (construct={dispatch}) adjust_args
(need_device_ptr: a) adjust_args (need_device_ptr: a) ! { dg-error "'a' at .1.
is specified more than once" }
+ end subroutine
+ subroutine base4 (a)
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (variant2) match (construct={dispatch}) adjust_args
(need_device_ptr: b) ! { dg-error "list item 'b' at .1. is not a dummy
argument" }
+ end subroutine
+
+ subroutine variant2 (a)
+ type(c_ptr), intent(inout) :: a
+ end subroutine
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
new file mode 100644
index 000000000000..2f44c0026dbf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
@@ -0,0 +1,58 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+
+ type :: struct
+ integer :: a
+ real :: b
+ end type
+
+ interface
+ integer function f(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ end function
+ integer function f0(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ !$omp declare variant (f) match (construct={dispatch}) &
+ !$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b,
c)
+ end function
+ integer function f1(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ !$omp declare variant (f) match (construct={dispatch}) &
+ !$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b)
adjust_args (need_device_ptr: c)
+ end function
+ end interface
+
+contains
+subroutine test
+ integer :: a
+ type(c_ptr) :: b
+ type(c_ptr) :: c(2)
+ type(struct) :: s
+
+ s%a = f0 (a, b, c)
+ !$omp dispatch
+ s%a = f0 (a, b, c)
+
+ s%b = f1 (a, b, c)
+ !$omp dispatch
+ s%b = f1 (a, b, c)
+
+end subroutine
+end module
+
+! { dg-final { scan-tree-dump-times "__builtin_omp_get_default_device \\(\\);"
2 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr
\\(parm\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr
\\(b\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90
new file mode 100644
index 000000000000..2f44c0026dbf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90
@@ -0,0 +1,58 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+
+ type :: struct
+ integer :: a
+ real :: b
+ end type
+
+ interface
+ integer function f(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ end function
+ integer function f0(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ !$omp declare variant (f) match (construct={dispatch}) &
+ !$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b,
c)
+ end function
+ integer function f1(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ !$omp declare variant (f) match (construct={dispatch}) &
+ !$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b)
adjust_args (need_device_ptr: c)
+ end function
+ end interface
+
+contains
+subroutine test
+ integer :: a
+ type(c_ptr) :: b
+ type(c_ptr) :: c(2)
+ type(struct) :: s
+
+ s%a = f0 (a, b, c)
+ !$omp dispatch
+ s%a = f0 (a, b, c)
+
+ s%b = f1 (a, b, c)
+ !$omp dispatch
+ s%b = f1 (a, b, c)
+
+end subroutine
+end module
+
+! { dg-final { scan-tree-dump-times "__builtin_omp_get_default_device \\(\\);"
2 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr
\\(parm\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr
\\(b\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-6.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-6.f90
new file mode 100644
index 000000000000..1410fb8bae0f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-6.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+
+! Check that duplicate adjust_args list items are reported
+
+module m
+ use iso_c_binding
+ implicit none (type, external)
+contains
+ subroutine foo(x,y)
+ type(C_ptr), value :: x, y
+ !$omp declare variant(bar) match ( construct = { dispatch } )
adjust_args(nothing : x ,y ) adjust_args(need_device_ptr : y ) !{ dg-error
"'y' at .1. is specified more than once" }
+ end
+ subroutine bar(a,b)
+ type(C_ptr), value :: a, b ! OK
+ end
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-7.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-7.f90
new file mode 100644
index 000000000000..92e8a1f8fd4e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-7.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+
+! Ensure that type(C_ptr) check is done at resolve rather than parse time
+
+
+module m
+ use iso_c_binding
+ implicit none (type, external)
+contains
+ subroutine foo(x,y)
+ !$omp declare variant(bar) match ( construct = { dispatch } )
adjust_args(nothing : x ) adjust_args(need_device_ptr : y )
+ type(C_ptr), value :: x, y
+ end
+ subroutine bar(a,b)
+ type(C_ptr), value :: a, b
+ end
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-8.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-8.f90
new file mode 100644
index 000000000000..af47e2175eb5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-8.f90
@@ -0,0 +1,51 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! Check that __builtin_omp_get_default_device and __builtin_omp_get_mapped_ptr
+! are called with the right arguments depending on is_device_ptr. By default,
+! Fortran passes arguments by reference, so it is important to check that:
+! (1) __builtin_omp_get_mapped_ptr arguments are the actual pointers; and
+! (2) f1 arguments are references to pointers.
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f1 (p, p2)
+ import :: c_ptr
+ type(c_ptr), intent(out) :: p
+ type(c_ptr), intent(in) :: p2
+ end subroutine
+ subroutine f2 (p, p2)
+ import :: c_ptr
+ type(c_ptr), intent(out) :: p
+ type(c_ptr), intent(in) :: p2
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args
(need_device_ptr: p, p2)
+ end subroutine
+ end interface
+ contains
+
+ subroutine test ()
+ type(c_ptr) :: p, p2
+
+ ! Note there are multiple matches because every variable capturing matches
in addition,
+ ! i.e. scan-tree-dump-times = 1 plus number of captures used for backward
references.
+ !
+ ! For the first scan-tree-dump, on some targets the
__builtin_omp_get_mapped_ptr get
+ ! swapped.
+
+ !$omp dispatch
+ ! { dg-final { scan-tree-dump-times "#pragma omp dispatch.*(D\.\[0-9]+) =
__builtin_omp_get_default_device \\(\\);\[ \t\n\r]*(p2?\.\[0-9]) = p2?;\[
\t\n\r]*(D\.\[0-9]+) = __builtin_omp_get_mapped_ptr \\(\\2, \\1\\);\[
\t\n\r]*(D\.\[0-9]+) = \\3;\[ \t\n\r]*(p2?\.\[0-9]) = p2?;\[
\t\n\r]*(D\.\[0-9]+) = __builtin_omp_get_mapped_ptr \\(\\5, \\1\\);\[
\t\n\r]*(D\.\[0-9]+) = \\6;\[ \t\n\r]*f1 \\((?:&\\7, &\\4|&\\4, &\\7)\\);" 8
"gimple" } }
+ call f2 (p, p2)
+ !$omp dispatch is_device_ptr(p)
+ ! { dg-final { scan-tree-dump-times "#pragma omp dispatch
is_device_ptr\\(p\\).*(D\.\[0-9]+) = __builtin_omp_get_default_device \\(\\);\[
\t\n\r]*(p2\.\[0-9]) = p2;\[ \t\n\r]*(D\.\[0-9]+) =
__builtin_omp_get_mapped_ptr \\(\\2, \\1\\);\[ \t\n\r]*(D\.\[0-9]+) = \\3;\[
\t\n\r]*f1 \\(&p, &\\4\\);" 5 "gimple" } }
+ call f2 (p, p2)
+ !$omp dispatch is_device_ptr(p2)
+ ! { dg-final { scan-tree-dump-times "#pragma omp dispatch
is_device_ptr\\(p2\\).*(D\.\[0-9]+) = __builtin_omp_get_default_device
\\(\\);\[ \t\n\r]*(p\.\[0-9]) = p;\[ \t\n\r]*(D\.\[0-9]+) =
__builtin_omp_get_mapped_ptr \\(\\2, \\1\\);\[ \t\n\r]*(D\.\[0-9]+) = \\3;\[
\t\n\r]*f1 \\(&\\4, &p2\\);" 5 "gimple" } }
+ call f2 (p, p2)
+ !$omp dispatch is_device_ptr(p, p2)
+ ! { dg-final { scan-tree-dump-times "#pragma omp dispatch
is_device_ptr\\(p\\) is_device_ptr\\(p2\\)\[ \t\n\r\{]*p = {CLOBBER};\[
\t\n\r]*f1 \\(&p, &p2\\);" 1 "gimple" } }
+ call f2 (p, p2)
+ end subroutine
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-9.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-9.f90
new file mode 100644
index 000000000000..02fe54ece700
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-9.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+
+! Check that a missing call does not cause a segfault
+
+module m
+use iso_c_binding
+implicit none(type,external)
+contains
+subroutine f(x,y,z)
+ type(c_ptr) :: x,y,z
+end
+subroutine g(x,y,z)
+ type(c_ptr) :: x,y,z
+ !$omp declare variant(f) adjust_args(need_device_ptr: x,y)
adjust_args(nothing : z,x) match(construct={dispatch})
+end
+end
+
+use m
+implicit none(type,external)
+ type(c_ptr) :: a,b,c
+ !$omp dispatch
+ g(a,b,c) ! { dg-error "'g' at .1. is not a variable" }
+ ! Should be: call g(a,b,c)
+end ! { dg-error "Unexpected END statement at .1." }
+! { dg-error "Unexpected end of file in .*" "" { target *-*-* } 0 }
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
index 7fc5071feff6..62d2cb96fac3 100644
--- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
@@ -18,10 +18,10 @@ contains
!$omp declare variant match(user={condition(.false.)}) ! { dg-error
"expected '\\(' at .1." }
end subroutine
subroutine f6 ()
- !$omp declare variant (f1) ! { dg-error "expected 'match' at .1." }
+ !$omp declare variant (f1) ! { dg-error "expected 'match' or 'adjust_args'
at .1." }
end subroutine
subroutine f7 ()
- !$omp declare variant (f1) simd ! { dg-error "expected 'match' at .1." }
+ !$omp declare variant (f1) simd ! { dg-error "expected 'match' or
'adjust_args' at .1." }
end subroutine
subroutine f8 ()
!$omp declare variant (f1) match ! { dg-error "expected '\\(' at .1." }
@@ -183,7 +183,7 @@ contains
!$omp declare variant (f1) match(construct={requires}) ! { dg-warning
"unknown selector 'requires' for context selector set 'construct' at .1." }
end subroutine
subroutine f75 ()
- !$omp declare variant (f1),match(construct={parallel}) ! { dg-error
"expected 'match' at .1." }
+ !$omp declare variant (f1),match(construct={parallel}) ! { dg-error
"expected 'match' or 'adjust_args' at .1." }
end subroutine
subroutine f76 ()
!$omp declare variant (f1)
match(implementation={atomic_default_mem_order("relaxed")}) ! { dg-error
"expected identifier at .1." }
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90
new file mode 100644
index 000000000000..12c309041317
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90
@@ -0,0 +1,77 @@
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+ contains
+
+ subroutine f1 ()
+ integer :: a, b, arr(10)
+ real :: x
+ complex :: c
+ character :: ch
+ logical :: bool
+ type :: struct
+ integer :: a
+ real :: b
+ end type
+ type(struct) :: s
+ type(c_ptr) :: p
+
+ interface
+ subroutine f0 (a, c, bool, s)
+ import :: struct
+ integer, intent(in) :: a
+ complex, intent(out) :: c
+ logical, intent(inout) :: bool
+ type(struct) :: s
+ end subroutine
+ integer function f2 (arr, x, ch, b)
+ integer, intent(inout) :: arr(:)
+ real, intent(in) :: x
+ character, intent(out) :: ch
+ real :: b
+ end function
+ subroutine f3 (p)
+ import :: c_ptr
+ type(c_ptr) :: p
+ end subroutine
+ integer function f4 ()
+ end function
+ end interface
+
+ !$omp dispatch
+ b = f2(arr, x, ch, s%b)
+ !$omp dispatch
+ c = f2(arr(:5), x * 2.4, ch, s%b)
+ !$omp dispatch
+ arr(1) = f2(arr, x, ch, s%b)
+ !$omp dispatch
+ s%a = f2(arr, x, ch, s%b)
+ !$omp dispatch
+ x = f2(arr, x, ch, s%b)
+ !$omp dispatch
+ call f0(a, c, bool, s)
+ !$omp dispatch
+ call f0(f4(), c, bool, s)
+
+ !$omp dispatch nocontext(.TRUE.)
+ call f0(a, c, bool, s)
+ !$omp dispatch nocontext(arr(2) < 10)
+ call f0(a, c, bool, s)
+ !$omp dispatch novariants(.FALSE.)
+ call f0(a, c, bool, s)
+ !$omp dispatch novariants(bool)
+ call f0(a, c, bool, s)
+ !$omp dispatch nowait
+ call f0(a, c, bool, s)
+ !$omp dispatch device(arr(9))
+ call f0(a, c, bool, s)
+ !$omp dispatch device(a + a)
+ call f0(a, c, bool, s)
+ !$omp dispatch device(-25373654)
+ call f0(a, c, bool, s)
+ !$omp dispatch is_device_ptr(p)
+ call f3(p)
+ !$omp dispatch depend(in: a, c, bool) depend(inout: s, arr(:3))
+ call f0(a, c, bool, s)
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-10.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-10.f90
new file mode 100644
index 000000000000..391879c7c243
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-10.f90
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" }
+
+! Check that the right call to f is wrapped in a GOMP_DISPATCH internal
function
+! before translation and that it is stripped during gimplification.
+
+subroutine g(x,f)
+ interface
+ integer function f(y)
+ allocatable :: f
+ integer :: y
+ end
+ end interface
+ integer, allocatable :: X(:)
+
+ !$omp dispatch
+ x(f(3)) = f(f(2))
+end
+
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = \.GOMP_DISPATCH \\(f
\\(&D\.\[0-9]+\\)\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = f \\(&D\.\[0-9]+\\);" 1
"gimple" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90
new file mode 100644
index 000000000000..d2d555b59325
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90
@@ -0,0 +1,79 @@
+module main
+ use iso_c_binding, only: c_funptr
+ implicit none
+ contains
+
+ subroutine f1 ()
+ integer :: a, b, arr(10)
+ real :: x
+ complex :: c
+ character :: ch
+ logical :: bool
+ type :: struct
+ integer :: a
+ real :: b
+ end type
+ type(struct) :: s
+ type(c_funptr) :: p
+
+ interface
+ subroutine f0 (a, c, bool, s)
+ import :: struct
+ integer, intent(in) :: a
+ complex, intent(out) :: c
+ logical, intent(inout) :: bool
+ type(struct) :: s
+ end subroutine
+ integer function f2 (arr, x, ch, b)
+ integer, intent(inout) :: arr(:)
+ real, intent(in) :: x
+ character, intent(out) :: ch
+ real :: b
+ end function
+ end interface
+ procedure(f0), pointer:: fp => NULL()
+
+ !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1.
must be followed by a procedure call with optional assignment" }
+50 b = f2(arr, x, ch, s%b) + a
+ !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1.
must be followed by a procedure call with optional assignment" }
+ a = b
+ !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1.
must be followed by a procedure call with optional assignment" }
+ b = Not (2)
+ !$omp dispatch
+ !$omp threadprivate(a) !{ dg-error "'OMP DISPATCH' directive must be
followed by a procedure call with optional assignment at .1." }
+ a = f2(arr, x, ch, s%b)
+ !$omp dispatch
+ print *, 'This is not allowed here.' !{ dg-error "'OMP DISPATCH'
directive must be followed by a procedure call with optional assignment at .1."
}
+ !$omp dispatch
+ goto 50 !{ dg-error "'OMP DISPATCH' directive must be
followed by a procedure call with optional assignment at .1." }
+ !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1.
cannot be followed by a procedure pointer" }
+ call fp(a, c, bool, s)
+
+ !$omp dispatch nocontext(s) !{ dg-error "NOCONTEXT clause at .1. requires
a scalar LOGICAL expression" }
+ call f0(a, c, bool, s)
+ !$omp dispatch nocontext(a, b) !{ dg-error "Invalid expression after
'nocontext.' at .1." }
+ call f0(a, c, bool, s)
+ !$omp dispatch nocontext(a) nocontext(b) !{ dg-error "Duplicated
'nocontext' clause at .1." }
+ call f0(a, c, bool, s)
+ !$omp dispatch novariants(s) !{ dg-error "NOVARIANTS clause at .1.
requires a scalar LOGICAL expression" }
+ call f0(a, c, bool, s)
+ !$omp dispatch novariants(a, b) !{ dg-error "Invalid expression after
'novariants.' at .1." }
+ call f0(a, c, bool, s)
+ !$omp dispatch novariants(a) novariants(b) !{ dg-error "Duplicated
'novariants' clause at .1." }
+ call f0(a, c, bool, s)
+ !$omp dispatch nowait nowait !{ dg-error "Duplicated 'nowait' clause at
.1." }
+ call f0(a, c, bool, s)
+ !$omp dispatch device(x) !{ dg-error "DEVICE clause at .1. requires a
scalar INTEGER expression" }
+ call f0(a, c, bool, s)
+ !$omp dispatch device(arr) !{ dg-error "DEVICE clause at .1. requires a
scalar INTEGER expression" }
+ call f0(a, c, bool, s)
+ !$omp dispatch is_device_ptr(x) !{ dg-error "List item 'x' in
IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." }
+ call f0(a, c, bool, s)
+ !$omp dispatch is_device_ptr(arr) !{ dg-error "List item 'arr' in
IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." }
+ call f0(a, c, bool, s)
+ !$omp dispatch is_device_ptr(p) !{ dg-error "List item 'p' in
IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." }
+ call f0(a, c, bool, s)
+ !$omp dispatch depend(inout: f0) !{ dg-error "Object 'f0' is not a
variable at .1." }
+ call f0(a, c, bool, s)
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90
new file mode 100644
index 000000000000..84590fd883ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ implicit none
+ interface
+ integer function f0 ()
+ end function
+
+ integer function f1 ()
+ end function
+
+ integer function f2 ()
+ !$omp declare variant (f0) match (construct={dispatch})
+ !$omp declare variant (f1) match (implementation={vendor(gnu)})
+ end function
+ end interface
+ contains
+
+ integer function test ()
+ integer :: a
+
+ !$omp dispatch
+ a = f2 ()
+ !$omp dispatch novariants(.TRUE.)
+ a = f2 ()
+ !$omp dispatch novariants(.FALSE.)
+ a = f2 ()
+ !$omp dispatch nocontext(.TRUE.)
+ a = f2 ()
+ !$omp dispatch nocontext(.FALSE.)
+ a = f2 ()
+ end function
+end module
+
+
+! { dg-final { scan-tree-dump-times "a = f0 \\\(\\\);" 3 "gimple" } }
+! { dg-final { scan-tree-dump-times "a = f1 \\\(\\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "a = f2 \\\(\\\);" 1 "gimple" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90
new file mode 100644
index 000000000000..edcd799a718a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ implicit none
+ interface
+ subroutine f2 ()
+ end subroutine
+ end interface
+ contains
+
+ subroutine test ()
+ !$omp dispatch ! { dg-final { scan-tree-dump-not "#pragma omp task"
"gimple" } }
+ call f2 ()
+ !$omp dispatch nowait ! { dg-final { scan-tree-dump-not "nowait" "gimple" } }
+ call f2 ()
+ end subroutine
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90
new file mode 100644
index 000000000000..f6fead0dae2e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ implicit none
+ interface
+ subroutine f2 (a)
+ integer, intent(in) :: a
+ end subroutine
+ end interface
+ contains
+
+ subroutine test ()
+ integer :: a
+
+ !$omp dispatch device(-25373654)
+ ! { dg-final { scan-tree-dump-times "__builtin_omp_set_default_device
\\(-25373654\\);" 1 "gimple" } }
+ call f2 (a)
+ !$omp dispatch device(a + a)
+ ! { dg-final { scan-tree-dump-times "(D\.\[0-9]+) = a.\[0-9_]+ \\*
2;.*#pragma omp dispatch.*__builtin_omp_set_default_device \\(\\1\\);.*f2
\\(&a\\)" 2 "gimple" } }
+ call f2 (a)
+ end subroutine
+end module
+
+! { dg-final { scan-tree-dump-times "(D\.\[0-9]+) =
__builtin_omp_get_default_device \\(\\);.*__builtin_omp_set_default_device
\\(\\1\\);" 4 "gimple" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90
new file mode 100644
index 000000000000..98e200f37571
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90
@@ -0,0 +1,22 @@
+! { dg-do compile }
+
+! Check for proper error recovery in resolve_omp_dispatch
+
+module m
+ use iso_c_binding
+ implicit none (type, external)
+contains
+ subroutine foo(x,y)
+ !$omp declare variant(bar) match ( construct = { dispatch } )
+ type(C_ptr), value :: x, y
+ end
+ subroutine bar(a,b)
+ type(C_ptr), value :: a, b
+ end
+end
+
+use m
+ integer :: y, z
+ !$omp dispatch device(5)
+ call foo(c_loc(y),c_loc(z)) !{ dg-error "Argument X at .1. to C_LOC shall
have either the POINTER or the TARGET attribute" }
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90
new file mode 100644
index 000000000000..6b40af6f315b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-ompexp" }
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f2 (p)
+ import :: c_ptr
+ type(c_ptr), intent(out) :: p
+ end subroutine
+ end interface
+ contains
+
+ subroutine test ()
+ type(c_ptr) :: p
+
+ !$omp dispatch
+ ! { dg-final { scan-tree-dump-not "__builtin_GOMP_task " "ompexp" } }
+ call f2 (p)
+ !$omp dispatch depend(inout: p)
+ ! { dg-final { scan-tree-dump-times "(D\.\[0-9]+)\\\[2] = &p;\[
\n]*__builtin_GOMP_taskwait_depend \\(&\\1\\);" 2 "ompexp" } }
+ call f2 (p)
+ end subroutine
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90
new file mode 100644
index 000000000000..e8c3a3513656
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90
@@ -0,0 +1,36 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! Check that, when the novariants or nocontext clauses cannot be evaluated at
+! compile time, both variants are emitted.
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ integer function f0 ()
+ end function
+ integer function f1 ()
+ end function
+ integer function f2 ()
+ !$omp declare variant (f0) match (construct={dispatch})
+ !$omp declare variant (f1) match (implementation={vendor(gnu)})
+ end function
+ end interface
+ contains
+
+ subroutine test ()
+ integer :: a, n
+
+ !$omp dispatch novariants(n < 1024) nocontext(n > 1024)
+ a = f2 ()
+ end subroutine
+end module
+
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = n <= 1023;" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = n > 1024;" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch novariants\\(0\\)
nocontext\\(0\\)" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "a = f2 \\\(\\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "a = f1 \\\(\\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "a = f0 \\\(\\\);" 1 "gimple" } }
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-9.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-9.f90
new file mode 100644
index 000000000000..bd421e7239aa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-9.f90
@@ -0,0 +1,24 @@
+module m
+contains
+subroutine f1 (ar)
+ integer :: arr(10)
+end
+subroutine f0 (ar)
+ integer :: arr(10)
+ !$omp declare variant (f1) match (construct={dispatch})
+end
+end module
+
+subroutine call_it(ctx, arr)
+ logical :: ctx
+ integer :: arr(:)
+ !$omp dispatch nocontext(ctx)
+ call f0(arr)
+ !$omp end dispatch ! valid since 5.2
+ !$omp dispatch nocontext(ctx)
+ call f0(arr)
+ !$omp end dispatch nowait ! likewise valid (unless there is a 'nowait' at
'!$omp dispatch')
+ !$omp dispatch nowait
+ call f0(arr)
+ !$omp end dispatch nowait !{ dg-error "Duplicated NOWAIT clause on !.OMP
DISPATCH and !.OMP END DISPATCH at .1." }
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-9a.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-9a.f90
new file mode 100644
index 000000000000..cc051a8851a0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-9a.f90
@@ -0,0 +1,27 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module m
+contains
+subroutine f1 (ar)
+ integer :: arr(10)
+end
+subroutine f0 (ar)
+ integer :: arr(10)
+ !$omp declare variant (f1) match (construct={dispatch})
+end
+end module
+
+subroutine call_it(x, arr)
+ logical :: x
+ integer :: arr(:)
+ !$omp dispatch depend(inout:x) nowait
+ call f0(arr)
+ !$omp end dispatch ! valid since 5.2
+ !$omp dispatch depend(inout:x)
+ call f0(arr)
+ !$omp end dispatch nowait ! likewise valid (unless there is a 'nowait' at
'!$omp dispatch')
+end
+
+! { dg-final { scan-tree-dump-times "#pragma omp taskwait depend\\(inout:x\\)
nowait" 2 "gimple" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch nowait" 2 "gimple" }
}
diff --git a/libgomp/ChangeLog.omp b/libgomp/ChangeLog.omp
index 65232a1b8612..d3c73a8e7ee1 100644
--- a/libgomp/ChangeLog.omp
+++ b/libgomp/ChangeLog.omp
@@ -1,3 +1,14 @@
+2025-01-27 Paul-Antoine Arras <par...@baylibre.com>
+
+ Backported from master:
+ 2025-01-02 Paul-Antoine Arras <par...@baylibre.com>
+
+ * testsuite/libgomp.fortran/declare-variant-2-aux.f90: New test.
+ * testsuite/libgomp.fortran/declare-variant-2.f90: New test (xfail).
+ * testsuite/libgomp.fortran/dispatch-1.f90: New test.
+ * testsuite/libgomp.fortran/dispatch-2.f90: New test.
+ * testsuite/libgomp.fortran/dispatch-3.f90: New test.
+
2025-01-27 Paul-Antoine Arras <par...@baylibre.com>
Backported from master:
diff --git a/libgomp/testsuite/libgomp.fortran/declare-variant-2-aux.f90
b/libgomp/testsuite/libgomp.fortran/declare-variant-2-aux.f90
new file mode 100644
index 000000000000..59b55e0bb853
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/declare-variant-2-aux.f90
@@ -0,0 +1,25 @@
+! { dg-do compile { target skip-all-targets } }
+
+! Test XFAILed due to https://gcc.gnu.org/PR115271
+
+
+subroutine base_proc (a)
+ use iso_c_binding, only: c_ptr
+ type(c_ptr), intent(inout) :: a
+end subroutine
+
+program main
+ use iso_c_binding, only: c_ptr
+ use my_mod
+ implicit none
+
+ type(c_ptr) :: a
+
+
+ call base_proc(a)
+ !call variant_proc(a)
+
+ !$omp dispatch
+ call base_proc(a)
+
+end program main
diff --git a/libgomp/testsuite/libgomp.fortran/declare-variant-2.f90
b/libgomp/testsuite/libgomp.fortran/declare-variant-2.f90
new file mode 100644
index 000000000000..b49833ddf724
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/declare-variant-2.f90
@@ -0,0 +1,22 @@
+! { dg-do run }
+! { dg-additional-sources declare-variant-2-aux.f90 }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module my_mod
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine base_proc (a)
+ use iso_c_binding, only: c_ptr
+ type(c_ptr), intent(inout) :: a
+ end subroutine
+ end interface
+
+contains
+ subroutine variant_proc (a)
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (base_proc) match (construct={dispatch})
adjust_args(need_device_ptr: a)
+ end subroutine
+end module
+
+! { dg-final { scan-tree-dump "variant_proc \\(&a\\)" "gimple" { xfail *-*-* }
} }
diff --git a/libgomp/testsuite/libgomp.fortran/dispatch-1.f90
b/libgomp/testsuite/libgomp.fortran/dispatch-1.f90
new file mode 100644
index 000000000000..7b2f03f9d687
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/dispatch-1.f90
@@ -0,0 +1,120 @@
+module procedures
+ use iso_c_binding, only: c_ptr, c_f_pointer
+ use omp_lib
+ implicit none
+
+ contains
+
+ function foo(bv, av, n) result(res)
+ implicit none
+ integer :: res, n, i
+ type(c_ptr) :: bv
+ type(c_ptr) :: av
+ real(8), pointer :: fp_bv(:), fp_av(:) ! Fortran pointers for array access
+ !$omp declare variant(bar) match(construct={dispatch})
adjust_args(need_device_ptr: bv, av)
+ !$omp declare variant(baz) match(implementation={vendor(gnu)})
+
+ ! Associate C pointers with Fortran pointers
+ call c_f_pointer(bv, fp_bv, [n])
+ call c_f_pointer(av, fp_av, [n])
+
+ ! Perform operations using Fortran pointers
+ do i = 1, n
+ fp_bv(i) = fp_av(i) * i
+ end do
+ res = -1
+ end function foo
+
+ function baz(d_bv, d_av, n) result(res)
+ implicit none
+ integer :: res, n, i
+ type(c_ptr) :: d_bv
+ type(c_ptr) :: d_av
+ real(8), pointer :: fp_bv(:), fp_av(:) ! Fortran pointers for array access
+
+ ! Associate C pointers with Fortran pointers
+ call c_f_pointer(d_bv, fp_bv, [n])
+ call c_f_pointer(d_av, fp_av, [n])
+
+ !$omp distribute parallel do
+ do i = 1, n
+ fp_bv(i) = fp_av(i) * i
+ end do
+ res = -3
+ end function baz
+
+ function bar(d_bv, d_av, n) result(res)
+ implicit none
+ integer :: res, n, i
+ type(c_ptr) :: d_bv
+ type(c_ptr) :: d_av
+ real(8), pointer :: fp_bv(:), fp_av(:) ! Fortran pointers for array access
+
+ ! Associate C pointers with Fortran pointers
+ call c_f_pointer(d_bv, fp_bv, [n])
+ call c_f_pointer(d_av, fp_av, [n])
+
+ ! Perform operations on target
+ do i = 1, n
+ fp_bv(i) = fp_av(i) * i
+ end do
+ res = -2
+ end function bar
+
+ function test(n) result(res)
+ use iso_c_binding, only: c_ptr, c_loc
+ implicit none
+ integer :: n, res, i, f, ff, last_dev
+ real(8), allocatable, target :: av(:), bv(:), d_bv(:)
+ real(8), parameter :: e = 2.71828d0
+ type(c_ptr) :: c_av, c_bv, c_d_bv
+
+ allocate(av(n), bv(n), d_bv(n))
+
+ ! Initialize arrays
+ do i = 1, n
+ av(i) = e * i
+ bv(i) = 0.0d0
+ d_bv(i) = 0.0d0
+ end do
+
+ last_dev = omp_get_num_devices() - 1
+
+ c_av = c_loc(av)
+ c_d_bv = c_loc(d_bv)
+ !$omp target data map(to: av(:n)) map(from: d_bv(:n)) device(last_dev)
if(n == 1024)
+ !$omp dispatch nocontext(n > 1024) novariants(n < 1024) device(last_dev)
+ f = foo(c_d_bv, c_av, n)
+ !$omp end target data
+
+ c_bv = c_loc(bv)
+ ff = foo(c_bv, c_loc(av), n)
+
+ ! Verify results
+ do i = 1, n
+ if (d_bv(i) /= bv(i)) then
+ write(0,*) 'ERROR at ', i, ': ', d_bv(i), ' (act) != ', bv(i), ' (exp)'
+ res = 1
+ return
+ end if
+ end do
+
+ res = f
+ deallocate(av, bv, d_bv)
+ end function test
+end module procedures
+
+program main
+ use procedures
+ implicit none
+ integer :: ret
+
+ ret = test(1023)
+ if (ret /= -1) stop 1
+
+ ret = test(1024)
+ if (ret /= -2) stop 1
+
+ ret = test(1025)
+ if (ret /= -3) stop 1
+end program main
diff --git a/libgomp/testsuite/libgomp.fortran/dispatch-2.f90
b/libgomp/testsuite/libgomp.fortran/dispatch-2.f90
new file mode 100644
index 000000000000..042b4d9f06d6
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/dispatch-2.f90
@@ -0,0 +1,69 @@
+module m
+ use iso_c_binding
+ implicit none (type, external)
+ type(c_ptr) :: ref1, ref2, ref3, ref4
+contains
+ subroutine foo(v, w, x, y)
+ type(C_ptr) :: v, w, x, y
+ value :: w, y
+ optional :: x, y
+ !$omp declare variant(bar) match ( construct = { dispatch } ) &
+ !$omp& adjust_args(need_device_ptr : v, w, x, y )
+ stop 1 ! should not get called
+ end
+ subroutine bar(a, b, c, d)
+ type(C_ptr) :: a, b, c, d
+ value :: b, d
+ optional :: c, d
+ if (.not. c_associated (a, ref1)) stop 2
+ if (.not. c_associated (b, ref2)) stop 3
+ if (.not. c_associated (c, ref3)) stop 3
+ if (.not. c_associated (d, ref4)) stop 3
+ end
+end
+
+program main
+ use omp_lib
+ use m
+ implicit none (type, external)
+ integer, target :: a, b, c, d
+ type(c_ptr) :: v, w, y, z
+ integer :: dev
+
+ do dev = -1, omp_get_num_devices ()
+ print *, 'dev ', dev
+
+ ! Cross check (1)
+ ref1 = omp_target_alloc (32_c_size_t, dev)
+ ref2 = omp_target_alloc (32_c_size_t, dev)
+ ref3 = omp_target_alloc (32_c_size_t, dev)
+ ref4 = omp_target_alloc (32_c_size_t, dev)
+ call bar (ref1, ref2, ref3, ref4)
+ call omp_target_free (ref1, dev)
+ call omp_target_free (ref2, dev)
+ call omp_target_free (ref3, dev)
+ call omp_target_free (ref4, dev)
+
+ v = c_loc(a)
+ w = c_loc(b)
+ y = c_loc(b)
+ z = c_loc(b)
+
+ !$omp target enter data device(dev) map(a, b, c, d)
+
+ ! Cross check (2)
+ ! This should be effectively identical to 'dispatch'
+ !$omp target data device(dev) use_device_ptr(v, w, y, z)
+ ref1 = v
+ ref2 = w
+ ref3 = y
+ ref4 = z
+ call bar (v, w, y, z)
+ !$omp end target data
+
+ !$omp dispatch device(dev)
+ call foo (v, w, y, z)
+
+ !$omp target exit data device(dev) map(a, b, c, d)
+ end do
+end
diff --git a/libgomp/testsuite/libgomp.fortran/dispatch-3.f90
b/libgomp/testsuite/libgomp.fortran/dispatch-3.f90
new file mode 100644
index 000000000000..4a914da1ccc3
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/dispatch-3.f90
@@ -0,0 +1,80 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! Check that nested function calls in a dispatch region are handled correctly,
+! i.e. that the adjust_args clause is applied only to the outer call.
+
+module m
+ use iso_c_binding
+ use omp_lib
+ implicit none(type,external)
+contains
+ integer function f(x, y1, y2, z1, z2)
+ allocatable :: f
+ integer, value :: x
+ type(c_ptr), value :: y1, y2
+ type(c_ptr) :: z1, z2
+
+ if (x == 1) then ! HOST
+ block
+ integer, pointer :: iy1, iy2, iz1, iz2
+ call c_f_pointer (y1, iy1)
+ call c_f_pointer (y2, iy2)
+ call c_f_pointer (z1, iz1)
+ call c_f_pointer (z2, iz2)
+ f = (iy1 + iy2) + 10 * (iz1+iz2)
+ end block
+ else
+ allocate(f)
+ !$omp target is_device_ptr(y1, y2, z1, z2) map(tofrom: f)
+ block
+ integer, pointer :: iy1, iy2, iz1, iz2
+ call c_f_pointer (y1, iy1)
+ call c_f_pointer (y2, iy2)
+ call c_f_pointer (z1, iz1)
+ call c_f_pointer (z2, iz2)
+ f = -(iy1+iy2)*23 -127 * (iz1+iz2) - x * 3
+ end block
+ end if
+ end
+
+ integer function g(x, y1, y2, z1, z2)
+ !$omp declare variant(f) match(construct={dispatch})
adjust_args(need_device_ptr : y1, y2, z1, z2)
+ allocatable :: g
+ integer, value :: x
+ type(c_ptr), value :: y1, y2
+ type(c_ptr) :: z1, z2
+ g = x
+ stop 2 ! should not get called
+ end
+end
+
+program main
+ use m
+ implicit none (type, external)
+ integer, target :: v1, v2
+ integer :: res, ref
+ v1 = 5
+ v2 = 11
+
+ ref = 5*2 + 10 * 11*2
+ ref = -(5*2)*23 -127 * (11*2) - ref * 3
+
+ !$omp target data map(v1,v2)
+ res = func (c_loc(v1), c_loc(v1), c_loc(v2), c_loc(v2))
+ !$omp end target data
+
+ if (res /= ref) stop 1
+contains
+integer function func(x1, x2, x3, x4)
+ use m
+ implicit none(type,external)
+ type(c_ptr) :: x1, x2, x3, x4
+ value :: x1, x3
+
+ !$omp dispatch
+ func = g(g(1,x1,x2,x3,x4), x1,x2,x3,x4)
+end
+end
+
+! { dg-final { scan-tree-dump-times "__builtin_omp_get_mapped_ptr" 4 "gimple"
} }
