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,
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,
}
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
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;
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:
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:
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)
/* 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
bool target;
bool targetsync;
} init;
+ bool need_device_ptr;
} u;
union
{
OMP_LIST_INIT,
OMP_LIST_USE,
OMP_LIST_DESTROY,
+ OMP_LIST_ADJUST_ARGS,
OMP_LIST_NUM /* Must be the last. */
};
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;
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. */
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
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 *);
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);
{"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) */
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);
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);
}
}
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
};
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)
#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
return MATCH_ERROR;
}
+match
+gfc_match_omp_dispatch (void)
+{
+ return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
+}
+
match
gfc_match_omp_distribute (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;
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
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;
}
"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)
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)
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. */
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);
return ST_OMP_TILE;
case EXEC_OMP_UNROLL:
return ST_OMP_UNROLL;
+ case EXEC_OMP_DISPATCH:
+ return ST_OMP_DISPATCH;
default:
gcc_unreachable ();
}
#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. */
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
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
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);
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,
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: \
case ST_OMP_DEPOBJ:
p = "!$OMP DEPOBJ";
break;
+ case ST_OMP_DISPATCH:
+ p = "!$OMP DISPATCH";
+ break;
case ST_OMP_DISTRIBUTE:
p = "!$OMP DISTRIBUTE";
break;
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;
}
+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
st = parse_omp_oacc_atomic (true);
continue;
+ case ST_OMP_DISPATCH:
+ st = parse_omp_dispatch ();
+ continue;
+
default:
return st;
}
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:
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:
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);
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:
return decl;
}
+static void
+create_function_arglist (gfc_symbol *sym);
/* Get a basic decl for an external function. */
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;
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;
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)
{
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:
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);
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 args"),
+ build_tree_list (need_device_ptr_list,
+ NULL_TREE /*need_device_addr */),
+ DECL_ATTRIBUTES (variant));
}
}
}
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:
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);
/* 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.
tree dispatch_append_args = NULL_TREE;
tree dispatch_adjust_args_list = NULL_TREE;
if (flag_openmp
+ && omp_dispatch_p
&& gimplify_omp_ctxp != NULL
- && gimplify_omp_ctxp->code == OMP_DISPATCH
&& !gimplify_omp_ctxp->in_call_args
&& EXPR_P (CALL_EXPR_FN (*expr_p))
&& DECL_P (TREE_OPERAND (CALL_EXPR_FN (*expr_p), 0)))
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 (&dispatch_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 (&dispatch_device_num, pre_p, loc);
- call = gimple_build_call (fn, 2, *arg_p,
+ call = gimple_build_call (fn, 2, actual_ptr,
dispatch_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
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;
}
}
}
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;
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
{
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
|| 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)
{
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,
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,
}
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
// ^ 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" } } */
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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 }
!$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." }
!$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." }
--- /dev/null
+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
--- /dev/null
+! { 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" } }
--- /dev/null
+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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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" } }
+
--- /dev/null
+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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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 *-*-* } } }
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+! { 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" } }
projects / thirdparty / gcc.git / commitdiff
