diff options
Diffstat (limited to 'gcc')
37 files changed, 1351 insertions, 104 deletions
diff --git a/gcc/c-family/c-attribs.cc b/gcc/c-family/c-attribs.cc index 0efa08d..eb76430 100644 --- a/gcc/c-family/c-attribs.cc +++ b/gcc/c-family/c-attribs.cc @@ -575,7 +575,7 @@ const struct attribute_spec c_common_gnu_attributes[] = handle_omp_declare_variant_attribute, NULL }, { "omp declare variant variant", 0, -1, true, false, false, false, handle_omp_declare_variant_attribute, NULL }, - { "omp declare variant adjust_args need_device_ptr", 0, -1, true, false, + { "omp declare variant variant args", 0, -1, true, false, false, false, handle_omp_declare_variant_attribute, NULL }, { "simd", 0, 1, true, false, false, false, diff --git a/gcc/cp/parser.cc b/gcc/cp/parser.cc index 3ec9e41..cd1d9b5 100644 --- a/gcc/cp/parser.cc +++ b/gcc/cp/parser.cc @@ -50060,8 +50060,9 @@ cp_parser_omp_dispatch (cp_parser *parser, cp_token *pragma_tok) default: gcc_unreachable (); } - if (TREE_CODE (*dispatch_call) == FLOAT_EXPR - || TREE_CODE (*dispatch_call) == CONVERT_EXPR) + while (TREE_CODE (*dispatch_call) == FLOAT_EXPR + || TREE_CODE (*dispatch_call) == CONVERT_EXPR + || TREE_CODE (*dispatch_call) == INDIRECT_REF) dispatch_call = &TREE_OPERAND (*dispatch_call, 0); *dispatch_call = build_call_expr_internal_loc (loc, IFN_GOMP_DISPATCH, TREE_TYPE (*dispatch_call), 1, diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 561b4d3..8d31ddf 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 ed02976..3a3328d 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 f38184b..aa495b5 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 @@ -1409,6 +1410,7 @@ typedef struct gfc_omp_namelist bool target; bool targetsync; } init; + bool need_device_ptr; } u; union { @@ -1465,6 +1467,7 @@ enum OMP_LIST_INIT, OMP_LIST_USE, OMP_LIST_DESTROY, + OMP_LIST_ADJUST_ARGS, OMP_LIST_NUM /* Must be the last. */ }; @@ -1612,6 +1615,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; @@ -1741,6 +1746,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. */ @@ -3100,7 +3106,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 @@ -3785,7 +3791,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 3ae7db3..4041613 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 61add9b..73d7803 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 @@ -5305,6 +5333,12 @@ error: } match +gfc_match_omp_dispatch (void) +{ + return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES); +} + +match gfc_match_omp_distribute (void) { return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES); @@ -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 c67e775..f65449d 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 a2f5358..4f7fe8b 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -12277,6 +12277,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: @@ -13997,6 +13998,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: @@ -19340,7 +19342,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 c9550eb..0ee85c4 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 7d3a9ed..814a205 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -2215,6 +2215,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. */ @@ -2464,7 +2466,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 b794066..b04adf3 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 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 86e7dbe..3834986 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -2571,6 +2571,7 @@ trans_code (gfc_code * code, tree cond) case EXEC_OMP_CANCELLATION_POINT: case EXEC_OMP_CRITICAL: case EXEC_OMP_DEPOBJ: + case EXEC_OMP_DISPATCH: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: diff --git a/gcc/gimplify.cc b/gcc/gimplify.cc index 36b29d2..bd324be 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; - 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. @@ -4101,8 +4111,8 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p, bool want_value) 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))) @@ -4331,21 +4341,36 @@ gimplify_call_expr (tree *expr_p, gimple_seq *pre_p, bool want_value) 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 @@ -4356,9 +4381,19 @@ 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 + || 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; } } } @@ -18285,10 +18320,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; @@ -18354,12 +18386,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 { @@ -18375,6 +18402,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 @@ -18382,6 +18410,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) { @@ -18443,6 +18474,11 @@ gimplify_omp_dispatch (tree *expr_p, gimple_seq *pre_p) gimplify_seq_add_stmt (&body, gimple_build_label (base_label)); tree base_call_expr2 = copy_node (base_call_expr); + base_call_expr2 + = build_call_expr_internal_loc (EXPR_LOCATION (base_call_expr2), + IFN_GOMP_DISPATCH, + TREE_TYPE (base_call_expr2), 1, + base_call_expr2); if (TREE_CODE (dispatch_body) == MODIFY_EXPR) { base_call_expr2 = build2 (MODIFY_EXPR, TREE_TYPE (dst), dst, @@ -18470,6 +18506,9 @@ gimplify_omp_dispatch (tree *expr_p, gimple_seq *pre_p) gimplify_seq_add_stmt (&body, gimple_build_label (variant1_label)); tree variant_call_expr = copy_node (base_call_expr); + variant_call_expr = build_call_expr_internal_loc ( + EXPR_LOCATION (variant_call_expr), IFN_GOMP_DISPATCH, + TREE_TYPE (variant_call_expr), 1, variant_call_expr); if (TREE_CODE (dispatch_body) == MODIFY_EXPR) { variant_call_expr = build2 (MODIFY_EXPR, TREE_TYPE (dst), dst, @@ -18484,6 +18523,11 @@ gimplify_omp_dispatch (tree *expr_p, gimple_seq *pre_p) } tree variant_call_expr = base_call_expr; + variant_call_expr + = build_call_expr_internal_loc (EXPR_LOCATION (variant_call_expr), + IFN_GOMP_DISPATCH, + TREE_TYPE (variant_call_expr), 1, + variant_call_expr); if (TREE_CODE (dispatch_body) == MODIFY_EXPR) { variant_call_expr diff --git a/gcc/testsuite/g++.dg/gomp/dispatch-3.C b/gcc/testsuite/g++.dg/gomp/dispatch-3.C index 03fd7dc..90e5c04 100644 --- a/gcc/testsuite/g++.dg/gomp/dispatch-3.C +++ b/gcc/testsuite/g++.dg/gomp/dispatch-3.C @@ -12,6 +12,6 @@ void g(int *x) // ^ only this call to f is a dispatch call } -/* { dg-final { scan-tree-dump "\.GOMP_DISPATCH \\(\\*f \\(\\*f \\(2\\)\\)\\)" "original" } } */ +/* { dg-final { scan-tree-dump "\\*\.GOMP_DISPATCH \\(f \\(\\*f \\(2\\)\\)\\)" "original" } } */ /* { dg-final { scan-tree-dump-times "\.GOMP_DISPATCH" 1 "original" } } */ /* { dg-final { scan-tree-dump-not "\.GOMP_DISPATCH" "gimple" } } */ diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 new file mode 100644 index 0000000..d9f2a67 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 @@ -0,0 +1,45 @@ +! Test parsing of OMP clause adjust_args +! { dg-do compile } + +module main + use iso_c_binding, only: c_ptr, c_funptr + implicit none + integer :: b + interface + integer function f0 (a) + import c_ptr + type(c_ptr), intent(inout) :: a + end function + integer function g (a) + import c_ptr + type(c_ptr), intent(inout) :: a + end function + integer function f1 (i) + integer, intent(in) :: i + end function + + integer function f3 (a) + import c_ptr + type(c_ptr), intent(inout) :: a + !$omp declare variant (f1) match (construct={dispatch}) adjust_args (other: a) ! { dg-error "expected 'nothing' or 'need_device_ptr' at .1." } + end function + integer function f4 (a) + import c_ptr + type(c_ptr), intent(inout) :: a + !$omp declare variant (f0) adjust_args (nothing: a) ! { dg-error "an 'adjust_args' clause at .1. can only be specified if the 'dispatch' selector of the construct selector set appears in the 'match' clause" } + end function + integer function f5 (i) + integer, intent(inout) :: i + !$omp declare variant (f1) match (construct={dispatch}) adjust_args () ! { dg-error "expected 'nothing' or 'need_device_ptr' at .1." } + end function + integer function f6 (i) + integer, intent(inout) :: i + !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing) ! { dg-error "expected argument list at .1." } + end function + integer function f7 (i) + integer, intent(inout) :: i + !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing:) ! { dg-error "expected argument list at .1." } + end function + + end interface +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90 new file mode 100644 index 0000000..c65a483 --- /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 0000000..9a32d2b --- /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 0000000..291bb47 --- /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 0000000..2f44c00 --- /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 0000000..2f44c00 --- /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 0000000..1410fb8 --- /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 0000000..92e8a1f --- /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 0000000..af47e21 --- /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 0000000..02fe54e --- /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 7fc5071..62d2cb9 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 @@ -18,10 +18,10 @@ contains !$omp declare variant match(user={condition(.false.)}) ! { dg-error "expected '\\(' at .1." } end subroutine subroutine f6 () - !$omp declare variant (f1) ! { dg-error "expected 'match' at .1." } + !$omp declare variant (f1) ! { dg-error "expected 'match' or 'adjust_args' at .1." } end subroutine subroutine f7 () - !$omp declare variant (f1) simd ! { dg-error "expected 'match' at .1." } + !$omp declare variant (f1) simd ! { dg-error "expected 'match' or 'adjust_args' at .1." } end subroutine subroutine f8 () !$omp declare variant (f1) match ! { dg-error "expected '\\(' at .1." } @@ -183,7 +183,7 @@ contains !$omp declare variant (f1) match(construct={requires}) ! { dg-warning "unknown selector 'requires' for context selector set 'construct' at .1." } end subroutine subroutine f75 () - !$omp declare variant (f1),match(construct={parallel}) ! { dg-error "expected 'match' at .1." } + !$omp declare variant (f1),match(construct={parallel}) ! { dg-error "expected 'match' or 'adjust_args' at .1." } end subroutine subroutine f76 () !$omp declare variant (f1) match(implementation={atomic_default_mem_order("relaxed")}) ! { dg-error "expected identifier at .1." } diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 new file mode 100644 index 0000000..12c3090 --- /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 0000000..391879c --- /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 0000000..d2d555b --- /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 0000000..84590fd --- /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 0000000..edcd799 --- /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 0000000..f6fead0 --- /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 0000000..98e200f --- /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 0000000..6b40af6 --- /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 0000000..e8c3a35 --- /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 0000000..bd421e7 --- /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 0000000..cc051a8 --- /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" } } |