Hi Tobias,
Replying to your last two messages here and attaching revised patches.
On 16/12/2024 22:34, Tobias Burnus wrote:
I have not looked in depth at the patch, but managed to
write C-ism code, which caused a segfault (due to a missing "call"),
after gfortran issued a reasonable error. Can you fix it
and, just to make sure, add it as another testcase?
foo.f90:18:7:
18 | g(a,b,c)
| 1
Error: ‘g’ at (1) is not a variable
foo.f90:20:3:
20 | end
| 1
Error: Unexpected END statement at (1)
Segmentation fault
* * *
The problem seems to be that during parsing,
the location data is NULL, which the error diagnostic
does not like:
(gdb) p gfc_current_locus
$33 = {nextc = 0x0, u = {lb = 0x0, location = 0}}
(gdb) p gfc_at_eof()
$36 = true
and st == ST_NONE.
I think the simplest is to check for the last one,
and then return early. This will then print:
foo.f90:18:7:
18 | g(a,b,c)
| 1
Error: ‘g’ at (1) is not a variable
foo.f90:20:3:
20 | end
| 1
Error: Unexpected END statement at (1)
f951: Error: Unexpected end of file in ‘foo.f90’
When the if st is ST_NONE then return check is added:
+static gfc_statement
+parse_omp_dispatch (void)
+{
...
+ st = next_statement ();
+ if (st == ST_NONE)
+ return st;
+ if (st == ST_CALL || st == ST_ASSIGNMENT)
+ accept_statement (st);
+ else
Fixed as suggested. Added testcase.
* * *
Handling of `adjust_args` across translation units is missing due to
PR115271.
Namely, https://gcc.gnu.org/PR115271 is about not storing 'declare variant'
inside
module files; when repeating the decl in an interface, it obviously works as
* * *
I think the patch is now okay, but I want to re-read it tomorrow - thus, please
hold off for a couple of ours.
Possibly, others have comments as well :-)
* * *
TODO: We need to handle 'type(C), dimension(:)' - but I wonder
whether that shouldn't be handled as part of 'use_device_addr'
and we need to check whether the spec has to be updated.
I filed the OpenMP lang-spec Issue #4443.
... and we eventually have to handle 'need_device_addr'/'has_device_addr', but
those are follow-up topics.
Keeping an eye on the open issue.
On 17/12/2024 14:11, Tobias Burnus wrote:
Additional comments: Can you hoist the condition out of the loop in:
+ for (gfc_omp_namelist *n = *head; n != NULL; n = n->next) + if
(need_device_ptr_p) + n->u.need_device_ptr = true;
Sure.
* * *
I was about to complain that it didn't handle VALUE + OPTIONAL
correctly, but that's a generic gfortran bug (or two):
->https://gcc.gnu.org/PR118080
* * *
There is a bug - 'nowait' is not propagated. Trying:
!$omp dispatch depend(inout:x) nowait
call g(a)
!$omp end dispatch
gives (-fdump-tree-gimple): #pragma omp taskwait depend(inout:&x) nowait
but doing the equivalent !$omp dispatch depend(inout:x) call g(a) !$omp
end dispatch nowait gives: #pragma omp taskwait depend(inout:&x) i.e.
the 'nowait' got lost. * * *
Fixed and added testcase.
Similar the original C code, which to my knowledge is now
fixed + tested for, there is an issue related to handling nested
function calls.
I think the attached testcase is fine, but it segfaults unless
the default device is the initial device. The problem is that
the pointer conversion also happens for the inner function but
it should only do so for the outer one.
See attached testcase. – I think it can be seen by looking at the
dump (and adding an -fdump-tree-gimple + scan test probably won't
harm, as not everyone has a GPU and we might implement map as
selfmap on APUs).
This is actually not specific to the Fortran FE. So I had to modify the
middle end and the C++ parser as well. See attached pactches.
Otherwise LGTM.
Tobias
Thanks,
--
PA
From e470fc10269d9bb0a4b263c18f03e289973807c4 Mon Sep 17 00:00:00 2001
From: Paul-Antoine Arras <par...@baylibre.com>
Date: Fri, 24 May 2024 19:13:50 +0200
Subject: [PATCH 1/4] 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.
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:.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/dispatch-1.f90: New test.
* testsuite/libgomp.fortran/dispatch-2.f90: New test.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/declare-variant-2.f90: Update dg-error.
* gfortran.dg/gomp/declare-variant-21.f90: New test (xfail).
* gfortran.dg/gomp/declare-variant-21-aux.f90: New test.
* 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/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-10.f90: New test.
---
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 +
.../gfortran.dg/gomp/adjust-args-1.f90 | 45 ++++
.../gfortran.dg/gomp/adjust-args-10.f90 | 78 +++++++
.../gfortran.dg/gomp/adjust-args-2.f90 | 18 ++
.../gfortran.dg/gomp/adjust-args-2a.f90 | 36 ++++
.../gfortran.dg/gomp/adjust-args-3.f90 | 27 +++
.../gfortran.dg/gomp/adjust-args-4.f90 | 58 +++++
.../gfortran.dg/gomp/adjust-args-5.f90 | 58 +++++
.../gfortran.dg/gomp/adjust-args-6.f90 | 16 ++
.../gfortran.dg/gomp/adjust-args-7.f90 | 17 ++
.../gfortran.dg/gomp/adjust-args-8.f90 | 51 +++++
.../gfortran.dg/gomp/adjust-args-9.f90 | 25 +++
.../gfortran.dg/gomp/declare-variant-2.f90 | 6 +-
.../gomp/declare-variant-21-aux.f90 | 25 +++
.../gfortran.dg/gomp/declare-variant-21.f90 | 22 ++
gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 | 77 +++++++
.../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 +++
.../gfortran.dg/gomp/dispatch-9a.f90 | 27 +++
.../testsuite/libgomp.fortran/dispatch-1.f90 | 120 +++++++++++
.../testsuite/libgomp.fortran/dispatch-2.f90 | 69 ++++++
38 files changed, 1542 insertions(+), 26 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-10.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-2a.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-6.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-7.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-8.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-9.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-21-aux.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-10.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-9.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-9a.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/dispatch-1.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/dispatch-2.f90
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 8e6adfe2829..eec86ccde62 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2201,6 +2201,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
@@ -2238,6 +2250,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;
@@ -2342,6 +2357,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:
@@ -3575,6 +3591,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 405074ecb02..8770d12727c 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5630,6 +5630,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 d08439019a3..db23f7a46d2 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -324,7 +324,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
@@ -1407,6 +1408,7 @@ typedef struct gfc_omp_namelist
bool target;
bool targetsync;
} init;
+ bool need_device_ptr;
} u;
union
{
@@ -1463,6 +1465,7 @@ enum
OMP_LIST_INIT,
OMP_LIST_USE,
OMP_LIST_DESTROY,
+ OMP_LIST_ADJUST_ARGS,
OMP_LIST_NUM /* Must be the last. */
};
@@ -1610,6 +1613,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;
@@ -1739,6 +1744,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. */
@@ -3098,7 +3104,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_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
@@ -3783,7 +3789,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_omp_save_and_clear_state (struct gfc_omp_saved_state *);
void gfc_omp_restore_state (struct gfc_omp_saved_state *);
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 13972bfe3e1..77c73097968 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -163,6 +163,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 6ef571eea8e..47c1ded4e44 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) */
@@ -183,6 +183,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);
@@ -326,6 +328,8 @@ 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, false, false, false,
+ false);
free (current);
}
}
@@ -1122,6 +1126,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
};
@@ -3624,6 +3630,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)
@@ -4991,6 +5016,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
@@ -5304,6 +5332,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)
{
@@ -6538,6 +6572,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;
@@ -6554,13 +6589,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
@@ -6573,18 +6624,56 @@ gfc_match_omp_declare_variant (void)
return MATCH_ERROR;
}
- if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
- return MATCH_ERROR;
-
- if (gfc_match (" )") != MATCH_YES)
+ if (ccode == match)
{
- gfc_error ("expected %<)%> at %C");
- return MATCH_ERROR;
+ has_match = true;
+ if (gfc_match_omp_context_selector_specification (odv)
+ != MATCH_YES)
+ return MATCH_ERROR;
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected %<)%> at %C");
+ return MATCH_ERROR;
+ }
+ }
+ else if (ccode == adjust_args)
+ {
+ 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;
}
@@ -8038,7 +8127,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)
@@ -8220,6 +8309,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)
@@ -9227,14 +9336,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. */
@@ -10896,6 +11009,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);
@@ -11872,6 +11986,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 ();
}
@@ -12287,6 +12403,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. */
@@ -12403,18 +12554,23 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
code->ext.omp_clauses->if_present = false;
resolve_omp_clauses (code, code->ext.omp_clauses, 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
@@ -12424,6 +12580,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 d2fe22d0edc..466866daf50 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -1058,6 +1058,7 @@ decode_omp_directive (void)
break;
case 'd':
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);
@@ -1073,6 +1074,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,
@@ -1932,7 +1934,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: \
@@ -2614,6 +2616,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;
@@ -2644,6 +2649,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;
@@ -6259,6 +6267,46 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
}
+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
@@ -6461,6 +6509,10 @@ parse_executable (gfc_statement st)
st = parse_omp_oacc_atomic (true);
continue;
+ case ST_OMP_DISPATCH:
+ st = parse_omp_dispatch ();
+ continue;
+
default:
return st;
}
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index f892d809d20..21ae2b9851c 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11655,6 +11655,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:
@@ -13379,6 +13380,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:
@@ -18721,7 +18723,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 48e4258d10d..90784a8854a 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 d69c8430484..82594e01831 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2206,6 +2206,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. */
@@ -2455,7 +2457,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 a23788a9c57..d08b26e7d45 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -4282,6 +4282,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;
@@ -6409,6 +6439,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)
{
@@ -8333,6 +8470,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:
@@ -8646,6 +8785,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);
@@ -8662,6 +8813,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 604cb53f417..29aee83bbe4 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -2561,6 +2561,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/testsuite/gfortran.dg/gomp/adjust-args-1.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
new file mode 100644
index 00000000000..d9f2a670a68
--- /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-10.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-10.f90
new file mode 100644
index 00000000000..d9062b43785
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-10.f90
@@ -0,0 +1,78 @@
+! { dg-do compile }
+! { 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 omp_lib
+ use iso_c_binding
+ 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
+ !$omp target is_device_ptr(y1, y2, z1, z2) map(from: 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
+ 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" } }
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 00000000000..c65a4839ca5
--- /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 00000000000..9a32d2b7d92
--- /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 00000000000..291bb47aaa2
--- /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 00000000000..2f44c0026db
--- /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 00000000000..2f44c0026db
--- /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 00000000000..1410fb8bae0
--- /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 00000000000..92e8a1f8fd4
--- /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 00000000000..af47e2175eb
--- /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 00000000000..02fe54ece70
--- /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 7fc5071feff..62d2cb96fac 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/declare-variant-21-aux.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21-aux.f90
new file mode 100644
index 00000000000..59b55e0bb85
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21-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/gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90
new file mode 100644
index 00000000000..0a89c8ff231
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90
@@ -0,0 +1,22 @@
+! { dg-do run }
+! { dg-additional-sources declare-variant-21-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/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90
new file mode 100644
index 00000000000..12c30904131
--- /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 00000000000..391879c7c24
--- /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 00000000000..d2d555b5932
--- /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 00000000000..84590fd883a
--- /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 00000000000..edcd799a718
--- /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 00000000000..f6fead0dae2
--- /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 00000000000..98e200f3757
--- /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 00000000000..6b40af6f315
--- /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 00000000000..e8c3a351365
--- /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 00000000000..bd421e7239a
--- /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 00000000000..cc051a8851a
--- /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/testsuite/libgomp.fortran/dispatch-1.f90 b/libgomp/testsuite/libgomp.fortran/dispatch-1.f90
new file mode 100644
index 00000000000..7b2f03f9d68
--- /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 00000000000..042b4d9f06d
--- /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
--
2.45.2
From 2107f1c4b4944de5dec90dd422b1cf2b7a880c53 Mon Sep 17 00:00:00 2001
From: Paul-Antoine Arras <par...@baylibre.com>
Date: Mon, 23 Dec 2024 15:46:40 +0100
Subject: [PATCH 3/4] C++ fix
---
gcc/cp/parser.cc | 5 +++--
gcc/testsuite/g++.dg/gomp/dispatch-3.C | 2 +-
2 files changed, 4 insertions(+), 3 deletions(-)
diff --git a/gcc/cp/parser.cc b/gcc/cp/parser.cc
index 88641c373e2..6dc9fb0d9dc 100644
--- a/gcc/cp/parser.cc
+++ b/gcc/cp/parser.cc
@@ -49990,8 +49990,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/testsuite/g++.dg/gomp/dispatch-3.C b/gcc/testsuite/g++.dg/gomp/dispatch-3.C
index 03fd7dc6f6c..90e5c04c3f0 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" } } */
--
2.45.2
From ded722713136c63617983bf63af3e79ad0976b1e Mon Sep 17 00:00:00 2001
From: Paul-Antoine Arras <par...@baylibre.com>
Date: Mon, 23 Dec 2024 15:48:45 +0100
Subject: [PATCH 4/4] ME fixes
---
gcc/gimplify.cc | 164 +++++++++++++++++++++++++-----------------------
1 file changed, 87 insertions(+), 77 deletions(-)
diff --git a/gcc/gimplify.cc b/gcc/gimplify.cc
index bf1c590d8e6..cde45178e5e 100644
--- a/gcc/gimplify.cc
+++ b/gcc/gimplify.cc
@@ -3857,7 +3857,7 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p, bool want_value)
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);
@@ -3870,69 +3870,79 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p, bool want_value)
/* 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;
+
+ 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;
}
-
- 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;
}
/* This may be a call to a builtin function.
@@ -4098,8 +4108,8 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p, bool want_value)
tree dispatch_interop = NULL_TREE;
if (flag_openmp
+ && omp_dispatch_p
&& gimplify_omp_ctxp != NULL
- && gimplify_omp_ctxp->code == OMP_DISPATCH
&& gimplify_omp_ctxp->clauses
&& (dispatch_interop = omp_find_clause (gimplify_omp_ctxp->clauses,
OMP_CLAUSE_INTEROP)) != NULL_TREE)
@@ -4126,9 +4136,8 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p, bool want_value)
{
tree *arg_p = &CALL_EXPR_ARG (*expr_p, i);
tree adjust_args_list;
- if (flag_openmp && gimplify_omp_ctxp != NULL
- && gimplify_omp_ctxp->code == OMP_DISPATCH
- && !gimplify_omp_ctxp->in_call_args
+ if (flag_openmp
+ && omp_dispatch_p
&& !integer_zerop (*arg_p)
&& EXPR_P (CALL_EXPR_FN (*expr_p))
&& DECL_P (TREE_OPERAND (CALL_EXPR_FN (*expr_p), 0))
@@ -4136,7 +4145,7 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p, bool want_value)
"omp declare variant variant adjust_args",
DECL_ATTRIBUTES (
TREE_OPERAND (CALL_EXPR_FN (*expr_p), 0))))
- != NULL_TREE)
+ != NULL_TREE)
{
tree arg_types = TYPE_ARG_TYPES (
TREE_TYPE (TREE_OPERAND (CALL_EXPR_FN (*expr_p), 0)));
@@ -4243,17 +4252,18 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p, bool want_value)
// device_num)
tree fn = builtin_decl_explicit (
BUILT_IN_OMP_GET_MAPPED_PTR);
- gimplify_arg (arg_p, pre_p, loc);
+ tree arg_decl = (TREE_CODE (*arg_p) == ADDR_EXPR)
+ ? TREE_OPERAND (*arg_p, 0)
+ : *arg_p;
+ gimplify_arg (&arg_decl, 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, arg_decl,
+ 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
@@ -4264,9 +4274,13 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p, bool want_value)
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)
+ mapped_arg = build_fold_addr_expr (mapped_arg);
+ *arg_p = mapped_arg;
}
}
}
@@ -18193,10 +18207,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;
@@ -18262,12 +18273,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
{
@@ -18283,6 +18289,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
@@ -18290,6 +18297,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)
{
--
2.45.2
