diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/gfortran.h | 10 | ||||
| -rw-r--r-- | gcc/fortran/openmp.cc | 247 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.cc | 23 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.cc | 214 |
4 files changed, 409 insertions, 85 deletions
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 5fe1276..557c5c7 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1412,7 +1412,15 @@ typedef struct gfc_omp_namelist bool target; bool targetsync; } init; - bool need_device_ptr; + struct + { + bool need_ptr:1; + bool need_addr:1; + bool range_start:1; + bool omp_num_args_plus:1; + bool omp_num_args_minus:1; + bool error_p:1; + } adj_args; } u; union { diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index e8df9d6..c30ab99 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -6718,21 +6718,21 @@ gfc_match_omp_declare_variant (void) enum clause { - match, - adjust_args, - append_args + clause_match, + clause_adjust_args, + clause_append_args } ccode; if (gfc_match ("match") == MATCH_YES) - ccode = match; + ccode = clause_match; else if (gfc_match ("adjust_args") == MATCH_YES) { - ccode = adjust_args; + ccode = clause_adjust_args; adjust_args_loc = gfc_current_locus; } else if (gfc_match ("append_args") == MATCH_YES) { - ccode = append_args; + ccode = clause_append_args; append_args_loc = gfc_current_locus; } else @@ -6741,13 +6741,13 @@ gfc_match_omp_declare_variant (void) break; } - if (gfc_match (" (") != MATCH_YES) + if (gfc_match (" ( ") != MATCH_YES) { gfc_error ("expected %<(%> at %C"); return MATCH_ERROR; } - if (ccode == match) + if (ccode == clause_match) { if (has_match) { @@ -6766,32 +6766,160 @@ gfc_match_omp_declare_variant (void) return MATCH_ERROR; } } - else if (ccode == adjust_args) + else if (ccode == clause_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) + bool need_device_ptr_p = false; + bool need_device_addr_p = false; + if (gfc_match ("nothing ") == MATCH_YES) + ; + else if (gfc_match ("need_device_ptr ") == MATCH_YES) need_device_ptr_p = true; + else if (gfc_match ("need_device_addr ") == MATCH_YES) + need_device_addr_p = true; else { - gfc_error ("expected %<nothing%> or %<need_device_ptr%> at %C"); + gfc_error ("expected %<nothing%>, %<need_device_ptr%> or " + "%<need_device_addr%> 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) + if (gfc_match (": ") != MATCH_YES) { - gfc_error ("expected argument list at %C"); + gfc_error ("expected %<:%> 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; + gfc_omp_namelist *tail = NULL; + bool need_range = false, have_range = false; + while (true) + { + gfc_omp_namelist *p = gfc_get_omp_namelist (); + p->where = gfc_current_locus; + p->u.adj_args.need_ptr = need_device_ptr_p; + p->u.adj_args.need_addr = need_device_addr_p; + if (tail) + { + tail->next = p; + tail = tail->next; + } + else + { + gfc_omp_namelist **q = &odv->adjust_args_list; + if (*q) + { + for (; (*q)->next; q = &(*q)->next) + ; + (*q)->next = p; + } + else + *q = p; + tail = p; + } + if (gfc_match (": ") == MATCH_YES) + { + if (have_range) + { + gfc_error ("unexpected %<:%> at %C"); + return MATCH_ERROR; + } + p->u.adj_args.range_start = have_range = true; + need_range = false; + continue; + } + if (have_range && gfc_match (", ") == MATCH_YES) + { + have_range = false; + continue; + } + if (have_range && gfc_match (") ") == MATCH_YES) + break; + locus saved_loc = gfc_current_locus; + + /* Without ranges, only arg names or integer literals permitted; + handle literals here as gfc_match_expr simplifies the expr. */ + if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES) + { + gfc_gobble_whitespace (); + char c = gfc_peek_ascii_char (); + if (c != ')' && c != ',' && c != ':') + { + gfc_free_expr (p->expr); + p->expr = NULL; + gfc_current_locus = saved_loc; + } + } + if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES) + { + if (!have_range) + p->u.adj_args.range_start = need_range = true; + else + need_range = false; + + locus saved_loc2 = gfc_current_locus; + gfc_gobble_whitespace (); + char c = gfc_peek_ascii_char (); + if (c == '+' || c == '-') + { + if (gfc_match ("+ %e", &p->expr) == MATCH_YES) + p->u.adj_args.omp_num_args_plus = true; + else if (gfc_match ("- %e", &p->expr) == MATCH_YES) + p->u.adj_args.omp_num_args_minus = true; + else if (!gfc_error_check ()) + { + gfc_error ("expected constant integer expression " + "at %C"); + p->u.adj_args.error_p = true; + return MATCH_ERROR; + } + p->where = gfc_get_location_range (&saved_loc, 1, + &saved_loc, 1, + &gfc_current_locus); + } + else + { + p->where = gfc_get_location_range (&saved_loc, 1, + &saved_loc, 1, + &saved_loc2); + p->u.adj_args.omp_num_args_plus = true; + } + } + else if (!p->expr) + { + match m = gfc_match_expr (&p->expr); + if (m != MATCH_YES) + { + gfc_error ("expected dummy parameter name, " + "%<omp_num_args%> or constant positive integer" + " at %C"); + p->u.adj_args.error_p = true; + return MATCH_ERROR; + } + if (p->expr->expr_type == EXPR_CONSTANT && !have_range) + need_range = true; /* Constant expr but not literal. */ + p->where = p->expr->where; + } + else + p->where = p->expr->where; + gfc_gobble_whitespace (); + match m = gfc_match (": "); + if (need_range && m != MATCH_YES) + { + gfc_error ("expected %<:%> at %C"); + return MATCH_ERROR; + } + if (m == MATCH_YES) + { + p->u.adj_args.range_start = have_range = true; + need_range = false; + continue; + } + need_range = have_range = false; + if (gfc_match (", ") == MATCH_YES) + continue; + if (gfc_match (") ") == MATCH_YES) + break; + } } - else if (ccode == append_args) + else if (ccode == clause_append_args) { if (has_append_args) { @@ -12817,18 +12945,6 @@ resolve_omp_dispatch (gfc_code *code) 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 @@ -12977,18 +13093,59 @@ gfc_resolve_omp_declare (gfc_namespace *ns) } gfc_omp_declare_variant *odv; + gfc_omp_namelist *range_begin = NULL; 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); - } + { + if ((n->expr == NULL + && (range_begin + || n->u.adj_args.range_start + || n->u.adj_args.omp_num_args_plus + || n->u.adj_args.omp_num_args_minus)) + || n->u.adj_args.error_p) + { + } + else if (range_begin + || n->u.adj_args.range_start + || n->u.adj_args.omp_num_args_plus + || n->u.adj_args.omp_num_args_minus) + { + if (!n->expr + || !gfc_resolve_expr (n->expr) + || n->expr->expr_type != EXPR_CONSTANT + || n->expr->ts.type != BT_INTEGER + || n->expr->rank != 0 + || mpz_sgn (n->expr->value.integer) < 0 + || ((n->u.adj_args.omp_num_args_plus + || n->u.adj_args.omp_num_args_minus) + && mpz_sgn (n->expr->value.integer) == 0)) + { + if (n->u.adj_args.omp_num_args_plus + || n->u.adj_args.omp_num_args_minus) + gfc_error ("Expected constant non-negative scalar integer " + "offset expression at %L", &n->where); + else + gfc_error ("For range-based %<adjust_args%>, a constant " + "positive scalar integer expression is required " + "at %L", &n->where); + } + } + else if (n->expr + && n->expr->expr_type == EXPR_CONSTANT + && n->expr->ts.type == BT_INTEGER + && mpz_sgn (n->expr->value.integer) > 0) + { + } + else if (!n->expr + || !gfc_resolve_expr (n->expr) + || n->expr->expr_type != EXPR_VARIABLE) + gfc_error ("Expected dummy parameter name or a positive integer " + "at %L", &n->where); + else if (n->expr->expr_type == EXPR_VARIABLE) + n->sym = n->expr->symtree->n.sym; + + range_begin = n->u.adj_args.range_start ? n : NULL; + } } struct omp_udr_callback_data diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 0acf0e9..ebb63a4 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -6131,6 +6131,19 @@ create_module_nml_decl (gfc_symbol *sym) } } +static void +gfc_handle_omp_declare_variant (gfc_symbol * sym) +{ + if (sym->attr.external + && sym->formal_ns + && sym->formal_ns->omp_declare_variant) + { + gfc_namespace *ns = gfc_current_ns; + gfc_current_ns = sym->ns; + gfc_get_symbol_decl (sym); + gfc_current_ns = ns; + } +} /* Generate all the required code for module variables. */ @@ -6155,6 +6168,11 @@ gfc_generate_module_vars (gfc_namespace * ns) if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors) generate_coarray_init (ns); + /* For OpenMP, ensure that declare variant in INTERFACE is is processed + especially as some late diagnostic is only done on tree level. */ + if (flag_openmp) + gfc_traverse_ns (ns, gfc_handle_omp_declare_variant); + cur_module = NULL; gfc_trans_use_stmts (ns); @@ -8005,6 +8023,11 @@ gfc_generate_function_code (gfc_namespace * ns) gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym); } + /* For OpenMP, ensure that declare variant in INTERFACE is is processed + especially as some late diagnostic is only done on tree level. */ + if (flag_openmp) + gfc_traverse_ns (ns, gfc_handle_omp_declare_variant); + gfc_generate_contained_functions (ns); has_coarray_vars_or_accessors = caf_accessor_head != NULL; diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 580d583..233cc0f 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -8913,6 +8913,7 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) NULL_TREE, false)) { tree need_device_ptr_list = NULL_TREE; + tree need_device_addr_list = NULL_TREE; tree append_args_tree = NULL_TREE; tree id = get_identifier ("omp declare variant base"); tree variant = gfc_get_symbol_decl (variant_proc_sym); @@ -8926,13 +8927,14 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) if (ns->proc_name->ts.type == BT_CHARACTER) arg_idx_offset++; } + int nargs = 0; + for (gfc_formal_arglist *arg + = gfc_sym_get_dummy_args (ns->proc_name); + arg; arg = arg->next) + nargs++; if (odv->append_args_list) { - int append_arg_no = arg_idx_offset; - gfc_formal_arglist *arg; - for (arg = gfc_sym_get_dummy_args (ns->proc_name); arg; - arg = arg->next) - append_arg_no++; + int append_arg_no = arg_idx_offset + nargs; tree last_arg = NULL_TREE; for (gfc_omp_namelist *n = odv->append_args_list; n != NULL; n = n->next) @@ -8965,59 +8967,193 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) else append_args_tree = last_arg = t; } - /* Store as (purpose = arg number to be used for inserting - and value = list of interop items. */ + /* Store as 'purpose' = arg number to be used for inserting + and 'value' = list of interop items. */ append_args_tree = build_tree_list ( build_int_cst (integer_type_node, append_arg_no), append_args_tree); } - - if (odv->adjust_args_list) - 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) + int from, to; + if (arg_list->expr == NULL || arg_list->sym) + from = ((arg_list->u.adj_args.omp_num_args_minus + || arg_list->u.adj_args.omp_num_args_plus) + ? nargs : 1); + else { - gfc_error ( - "list item %qs at %L is not a dummy argument", - arg_list->sym->name, &arg_list->where); - continue; + if (arg_list->u.adj_args.omp_num_args_plus) + mpz_add_ui (arg_list->expr->value.integer, + arg_list->expr->value.integer, nargs); + if (arg_list->u.adj_args.omp_num_args_minus) + mpz_ui_sub (arg_list->expr->value.integer, nargs, + arg_list->expr->value.integer); + if (mpz_sgn (arg_list->expr->value.integer) <= 0) + { + gfc_warning (OPT_Wopenmp, + "Expected positive argument index " + "at %L", &arg_list->where); + from = 1; + } + else + from + = (mpz_fits_sint_p (arg_list->expr->value.integer) + ? mpz_get_si (arg_list->expr->value.integer) + : INT_MAX); + if (from > nargs) + gfc_warning (OPT_Wopenmp, + "Argument index at %L exceeds number " + "of arguments %d", &arg_list->where, + nargs); } - if (adjust_args_list.contains (arg_list->sym)) + locus loc = arg_list->where; + if (!arg_list->u.adj_args.range_start) + to = from; + else { - gfc_error ("%qs at %L is specified more than once", - arg_list->sym->name, &arg_list->where); - continue; + loc = gfc_get_location_range (&arg_list->where, 0, + &arg_list->where, 0, + &arg_list->next->where); + if (arg_list->next->expr == NULL) + to = nargs; + else + { + if (arg_list->next->u.adj_args.omp_num_args_plus) + mpz_add_ui (arg_list->next->expr->value.integer, + arg_list->next->expr->value.integer, + nargs); + if (arg_list->next->u.adj_args.omp_num_args_minus) + mpz_ui_sub (arg_list->next->expr->value.integer, + nargs, + arg_list->next->expr->value.integer); + if (mpz_sgn (arg_list->next->expr->value.integer) + <= 0) + { + gfc_warning (OPT_Wopenmp, + "Expected positive argument " + "index at %L", &loc); + to = 0; + } + else + to = mpz_get_si ( + arg_list->next->expr->value.integer); + } + if (from > to && to != 0) + gfc_warning (OPT_Wopenmp, + "Upper argument index smaller than " + "lower one at %L", &loc); + if (to > nargs) + to = nargs; + arg_list = arg_list->next; } - adjust_args_list.safe_push (arg_list->sym); - if (arg_list->u.need_device_ptr) + if (from > nargs) + continue; + /* Change to zero based index. */ + from--; to--; + gfc_formal_arglist *arg = ns->proc_name->formal; + if (!arg_list->sym && to >= from) + for (int idx = 0; idx < from; idx++) + arg = arg->next; + for (int idx = from; idx <= to; idx++) { - 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); - // Store 0-based argument index, - // as in gimplify_call_expr - need_device_ptr_list = chainon ( - need_device_ptr_list, - build_tree_list ( - NULL_TREE, - build_int_cst ( - integer_type_node, - idx + arg_idx_offset))); + if (idx > from) + arg = arg->next; + if (arg_list->sym) + { + for (arg = ns->proc_name->formal, idx = 0; + arg != NULL; arg = arg->next, idx++) + if (arg->sym == arg_list->sym) + break; + if (!arg || !arg_list->sym->attr.dummy) + { + gfc_error ("List item %qs at %L, declared at " + "%L, is not a dummy argument", + arg_list->sym->name, &loc, + &arg_list->sym->declared_at); + continue; + } + } + if (arg_list->u.adj_args.need_ptr + && (arg->sym->ts.f90_type != BT_VOID + || !arg->sym->ts.u.derived->ts.is_iso_c + || (arg->sym->ts.u.derived->intmod_sym_id + != ISOCBINDING_PTR) + || arg->sym->attr.dimension)) + { + gfc_error ("Argument %qs at %L to list item in " + "%<need_device_ptr%> at %L must be a " + "scalar of TYPE(C_PTR)", + arg->sym->name, + &arg->sym->declared_at, &loc); + if (!arg->sym->attr.value) + inform (gfc_get_location (&loc), + "Consider using %<need_device_addr%> " + "instead"); + continue; + } + if (arg_list->u.adj_args.need_addr + && arg->sym->attr.value) + { + gfc_error ("Argument %qs at %L to list item in " + "%<need_device_addr%> at %L must not " + "have the VALUE attribute", + arg->sym->name, + &arg->sym->declared_at, &loc); + continue; + } + if (adjust_args_list.contains (arg->sym)) + { + gfc_error ("%qs at %L is specified more than " + "once", arg->sym->name, &loc); + continue; + } + adjust_args_list.safe_push (arg->sym); + + if (arg_list->u.adj_args.need_addr) + { + /* TODO: Has to to support OPTIONAL and array + descriptors; should check for CLASS, coarrays? + Reject "abc" and 123 as actual arguments (in + gimplify.cc or in the FE? Reject noncontiguous + actuals? Cf. also PR C++/118859. + Also check array-valued type(c_ptr). */ + static bool warned = false; + if (!warned) + sorry_at (gfc_get_location (&loc), + "%<need_device_addr%> not yet " + "supported"); + warned = true; + continue; + } + if (arg_list->u.adj_args.need_ptr + || arg_list->u.adj_args.need_addr) + { + // Store 0-based argument index, + // as in gimplify_call_expr + tree t + = build_tree_list ( + NULL_TREE, + build_int_cst (integer_type_node, + idx + arg_idx_offset)); + if (arg_list->u.adj_args.need_ptr) + need_device_ptr_list + = chainon (need_device_ptr_list, t); + else + need_device_addr_list + = chainon (need_device_addr_list, t); + } } } tree t = NULL_TREE; - if (need_device_ptr_list || append_args_tree) + if (need_device_ptr_list + || need_device_addr_list + || append_args_tree) { t = build_tree_list (need_device_ptr_list, - NULL_TREE /*need_device_addr */), + need_device_addr_list), TREE_CHAIN (t) = append_args_tree; DECL_ATTRIBUTES (variant) = tree_cons ( get_identifier ("omp declare variant variant args"), t, |