https://gcc.gnu.org/g:7c3b4ed268209484a2928a6d85fce995008f1378
commit 7c3b4ed268209484a2928a6d85fce995008f1378 Author: Tobias Burnus <[email protected]> Date: Mon Jun 22 10:03:26 2026 +0200 Fortran/OpenMP: Split-off resolve_omp_allocate_clauses Move the code for ALLOCATE clause checking out of resolve_omp_clauses into a new function. Additionally, the all-enclosing if condition block is replaced by an early return; likewise, an inner if condition block that stretched to the end of the outer one is replaced by a second early return. Hence, a lot of code could be shifted 4 or 8 columns to the left. Except for the re-indentation, the early exit changes to the two if conditions and to two variable declarations, the code is identical. gcc/fortran/ChangeLog: * openmp.cc (resolve_omp_allocate_clauses): New function for resolving 'allocate' clauses, splitt-off from ... (resolve_omp_clauses): ... here. Call the new function. Suggested-by: Julian Brown <[email protected]> (cherry picked from commit aa4a1608ea2744108ec62e7baba99c7fa99800ad) Diff: --- gcc/fortran/openmp.cc | 463 ++++++++++++++++++++++++++------------------------ 1 file changed, 237 insertions(+), 226 deletions(-) diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 3ca46aa62a4b..6072fbe47eb9 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -9206,6 +9206,242 @@ gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume) } +/* Resolve the OpenMP ALLOCATE clauses. */ + +static void +resolve_omp_allocate_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, + gfc_namespace *ns) +{ + gfc_omp_namelist *n; + enum gfc_omp_list_type list; + + if (!omp_clauses->lists[OMP_LIST_ALLOCATE]) + return; + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + { + if (n->u2.allocator + && (!gfc_resolve_expr (n->u2.allocator) + || n->u2.allocator->ts.type != BT_INTEGER + || n->u2.allocator->rank != 0 + || n->u2.allocator->ts.kind != gfc_c_intptr_kind)) + { + gfc_error ("Expected integer expression of the " + "%<omp_allocator_handle_kind%> kind at %L", + &n->u2.allocator->where); + break; + } + if (!n->u.align) + continue; + HOST_WIDE_INT alignment = 0; + if (!gfc_resolve_expr (n->u.align) + || n->u.align->ts.type != BT_INTEGER + || n->u.align->rank != 0 + || n->u.align->expr_type != EXPR_CONSTANT + || gfc_extract_hwi (n->u.align, &alignment) + || alignment <= 0 + || !pow2p_hwi (alignment)) + { + gfc_error ("ALIGN requires a scalar positive constant integer " + "alignment expression at %L that is a power of two", + &n->u.align->where); + break; + } + } + + /* Check for 2 things here. + 1. There is no duplication of variable in allocate clause. + 2. Variable in allocate clause are also present in some + privatization clase (non-composite case). */ + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + if (n->sym) + n->sym->mark = 0; + + gfc_omp_namelist *prev = NULL; + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; ) + { + if (n->sym == NULL) + { + n = n->next; + continue; + } + if (n->sym->mark == 1) + { + gfc_warning (OPT_Wopenmp, "%qs appears more than once in " + "%<allocate%> at %L" , n->sym->name, &n->where); + /* We have already seen this variable so it is a duplicate. + Remove it. */ + if (prev != NULL && prev->next == n) + { + prev->next = n->next; + n->next = NULL; + gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE); + n = prev->next; + } + continue; + } + n->sym->mark = 1; + prev = n; + n = n->next; + } + + /* Non-composite constructs. */ + if (code && code->op < EXEC_OMP_DO_SIMD) + { + for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM; + list = gfc_omp_list_type (list + 1)) + switch (list) + { + case OMP_LIST_PRIVATE: + case OMP_LIST_FIRSTPRIVATE: + case OMP_LIST_LASTPRIVATE: + case OMP_LIST_REDUCTION: + case OMP_LIST_REDUCTION_INSCAN: + case OMP_LIST_REDUCTION_TASK: + case OMP_LIST_IN_REDUCTION: + case OMP_LIST_TASK_REDUCTION: + case OMP_LIST_LINEAR: + for (n = omp_clauses->lists[list]; n; n = n->next) + n->sym->mark = 0; + break; + default: + break; + } + + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + if (n->sym->mark == 1) + gfc_error ("%qs specified in %<allocate%> clause at %L but not " + "in an explicit privatization clause", + n->sym->name, &n->where); + } + if (!(code + && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE) + && code->block + && code->block->next + && code->block->next->op == EXEC_ALLOCATE)) + return; + + if (code->op == EXEC_OMP_ALLOCATE) + gfc_warning (OPT_Wdeprecated_openmp, + "The use of one or more %<allocate%> directives with " + "an associated %<allocate%> statement at %L is " + "deprecated since OpenMP 5.2, use an %<allocators%> " + "directive", &code->loc); + gfc_alloc *a; + gfc_omp_namelist *n_null = NULL; + bool missing_allocator = false; + gfc_symbol *missing_allocator_sym = NULL; + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + { + if (n->u2.allocator == NULL) + { + if (!missing_allocator_sym) + missing_allocator_sym = n->sym; + missing_allocator = true; + } + if (n->sym == NULL) + { + n_null = n; + continue; + } + if (n->sym->attr.codimension) + gfc_error ("Unexpected coarray %qs in %<allocate%> at %L", + n->sym->name, &n->where); + for (a = code->block->next->ext.alloc.list; a; a = a->next) + if (a->expr->expr_type == EXPR_VARIABLE + && a->expr->symtree->n.sym == n->sym) + { + gfc_ref *ref; + for (ref = a->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + if (ref == NULL) + break; + } + if (a == NULL) + gfc_error ("%qs specified in %<allocate%> at %L but not " + "in the associated ALLOCATE statement", + n->sym->name, &n->where); + } + /* If there is an ALLOCATE directive without list argument, a + namelist with its allocator/align clauses and n->sym = NULL is + created during parsing; here, we add all not otherwise specified + items from the Fortran allocate to that list. + For an ALLOCATORS directive, not listed items use the normal + Fortran way. + The behavior of an ALLOCATE directive that does not list all + arguments but there is no directive without list argument is not + well specified. Thus, we reject such code below. In OpenMP 5.2 + the executable ALLOCATE directive is deprecated and in 6.0 + deleted such that no spec clarification is to be expected. */ + for (a = code->block->next->ext.alloc.list; a; a = a->next) + if (a->expr->expr_type == EXPR_VARIABLE) + { + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + if (a->expr->symtree->n.sym == n->sym) + { + gfc_ref *ref; + for (ref = a->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + if (ref == NULL) + break; + } + if (n == NULL && n_null == NULL) + { + /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether + that should use the default allocator of OpenMP or the + Fortran allocator. Thus, just reject it. */ + if (code->op == EXEC_OMP_ALLOCATE) + gfc_error ("%qs listed in %<allocate%> statement at %L " + "but it is neither explicitly in listed in " + "the %<!$OMP ALLOCATE%> directive nor exists" + " a directive without argument list", + a->expr->symtree->n.sym->name, + &a->expr->where); + break; + } + if (n == NULL) + { + if (a->expr->symtree->n.sym->attr.codimension) + gfc_error ("Unexpected coarray %qs in %<allocate%> at " + "%L, implicitly listed in %<!$OMP ALLOCATE%>" + " at %L", a->expr->symtree->n.sym->name, + &a->expr->where, &n_null->where); + break; + } + } + gfc_namespace *prog_unit = ns; + while (prog_unit->parent) + prog_unit = prog_unit->parent; + gfc_namespace *fn_ns = ns; + while (fn_ns) + { + if (ns->proc_name + && (ns->proc_name->attr.subroutine + || ns->proc_name->attr.function)) + break; + fn_ns = fn_ns->parent; + } + if (missing_allocator + && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) + && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target) + || omp_clauses->contained_in_target_construct)) + { + if (code->op == EXEC_OMP_ALLOCATORS) + gfc_error ("ALLOCATORS directive at %L inside a target region " + "must specify an ALLOCATOR modifier for %qs", + &code->loc, missing_allocator_sym->name); + else if (missing_allocator_sym) + gfc_error ("ALLOCATE directive at %L inside a target region " + "must specify an ALLOCATOR clause for %qs", + &code->loc, missing_allocator_sym->name); + else + gfc_error ("ALLOCATE directive at %L inside a target region " + "must specify an ALLOCATOR clause", &code->loc); + } +} + + /* OpenMP directive resolving routines. */ static void @@ -9757,232 +9993,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n->sym->mark = 1; } - if (omp_clauses->lists[OMP_LIST_ALLOCATE]) - { - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - { - if (n->u2.allocator - && (!gfc_resolve_expr (n->u2.allocator) - || n->u2.allocator->ts.type != BT_INTEGER - || n->u2.allocator->rank != 0 - || n->u2.allocator->ts.kind != gfc_c_intptr_kind)) - { - gfc_error ("Expected integer expression of the " - "%<omp_allocator_handle_kind%> kind at %L", - &n->u2.allocator->where); - break; - } - if (!n->u.align) - continue; - HOST_WIDE_INT alignment = 0; - if (!gfc_resolve_expr (n->u.align) - || n->u.align->ts.type != BT_INTEGER - || n->u.align->rank != 0 - || n->u.align->expr_type != EXPR_CONSTANT - || gfc_extract_hwi (n->u.align, &alignment) - || alignment <= 0 - || !pow2p_hwi (alignment)) - { - gfc_error ("ALIGN requires a scalar positive constant integer " - "alignment expression at %L that is a power of two", - &n->u.align->where); - break; - } - } - - /* Check for 2 things here. - 1. There is no duplication of variable in allocate clause. - 2. Variable in allocate clause are also present in some - privatization clase (non-composite case). */ - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - if (n->sym) - n->sym->mark = 0; - - gfc_omp_namelist *prev = NULL; - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; ) - { - if (n->sym == NULL) - { - n = n->next; - continue; - } - if (n->sym->mark == 1) - { - gfc_warning (OPT_Wopenmp, "%qs appears more than once in " - "%<allocate%> at %L" , n->sym->name, &n->where); - /* We have already seen this variable so it is a duplicate. - Remove it. */ - if (prev != NULL && prev->next == n) - { - prev->next = n->next; - n->next = NULL; - gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE); - n = prev->next; - } - continue; - } - n->sym->mark = 1; - prev = n; - n = n->next; - } - - /* Non-composite constructs. */ - if (code && code->op < EXEC_OMP_DO_SIMD) - { - for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM; - list = gfc_omp_list_type (list + 1)) - switch (list) - { - case OMP_LIST_PRIVATE: - case OMP_LIST_FIRSTPRIVATE: - case OMP_LIST_LASTPRIVATE: - case OMP_LIST_REDUCTION: - case OMP_LIST_REDUCTION_INSCAN: - case OMP_LIST_REDUCTION_TASK: - case OMP_LIST_IN_REDUCTION: - case OMP_LIST_TASK_REDUCTION: - case OMP_LIST_LINEAR: - for (n = omp_clauses->lists[list]; n; n = n->next) - n->sym->mark = 0; - break; - default: - break; - } - - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - if (n->sym->mark == 1) - gfc_error ("%qs specified in %<allocate%> clause at %L but not " - "in an explicit privatization clause", - n->sym->name, &n->where); - } - if (code - && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE) - && code->block - && code->block->next - && code->block->next->op == EXEC_ALLOCATE) - { - if (code->op == EXEC_OMP_ALLOCATE) - gfc_warning (OPT_Wdeprecated_openmp, - "The use of one or more %<allocate%> directives with " - "an associated %<allocate%> statement at %L is " - "deprecated since OpenMP 5.2, use an %<allocators%> " - "directive", &code->loc); - gfc_alloc *a; - gfc_omp_namelist *n_null = NULL; - bool missing_allocator = false; - gfc_symbol *missing_allocator_sym = NULL; - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - { - if (n->u2.allocator == NULL) - { - if (!missing_allocator_sym) - missing_allocator_sym = n->sym; - missing_allocator = true; - } - if (n->sym == NULL) - { - n_null = n; - continue; - } - if (n->sym->attr.codimension) - gfc_error ("Unexpected coarray %qs in %<allocate%> at %L", - n->sym->name, &n->where); - for (a = code->block->next->ext.alloc.list; a; a = a->next) - if (a->expr->expr_type == EXPR_VARIABLE - && a->expr->symtree->n.sym == n->sym) - { - gfc_ref *ref; - for (ref = a->expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - break; - if (ref == NULL) - break; - } - if (a == NULL) - gfc_error ("%qs specified in %<allocate%> at %L but not " - "in the associated ALLOCATE statement", - n->sym->name, &n->where); - } - /* If there is an ALLOCATE directive without list argument, a - namelist with its allocator/align clauses and n->sym = NULL is - created during parsing; here, we add all not otherwise specified - items from the Fortran allocate to that list. - For an ALLOCATORS directive, not listed items use the normal - Fortran way. - The behavior of an ALLOCATE directive that does not list all - arguments but there is no directive without list argument is not - well specified. Thus, we reject such code below. In OpenMP 5.2 - the executable ALLOCATE directive is deprecated and in 6.0 - deleted such that no spec clarification is to be expected. */ - for (a = code->block->next->ext.alloc.list; a; a = a->next) - if (a->expr->expr_type == EXPR_VARIABLE) - { - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - if (a->expr->symtree->n.sym == n->sym) - { - gfc_ref *ref; - for (ref = a->expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - break; - if (ref == NULL) - break; - } - if (n == NULL && n_null == NULL) - { - /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether - that should use the default allocator of OpenMP or the - Fortran allocator. Thus, just reject it. */ - if (code->op == EXEC_OMP_ALLOCATE) - gfc_error ("%qs listed in %<allocate%> statement at %L " - "but it is neither explicitly in listed in " - "the %<!$OMP ALLOCATE%> directive nor exists" - " a directive without argument list", - a->expr->symtree->n.sym->name, - &a->expr->where); - break; - } - if (n == NULL) - { - if (a->expr->symtree->n.sym->attr.codimension) - gfc_error ("Unexpected coarray %qs in %<allocate%> at " - "%L, implicitly listed in %<!$OMP ALLOCATE%>" - " at %L", a->expr->symtree->n.sym->name, - &a->expr->where, &n_null->where); - break; - } - } - gfc_namespace *prog_unit = ns; - while (prog_unit->parent) - prog_unit = prog_unit->parent; - gfc_namespace *fn_ns = ns; - while (fn_ns) - { - if (ns->proc_name - && (ns->proc_name->attr.subroutine - || ns->proc_name->attr.function)) - break; - fn_ns = fn_ns->parent; - } - if (missing_allocator - && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) - && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target) - || omp_clauses->contained_in_target_construct)) - { - if (code->op == EXEC_OMP_ALLOCATORS) - gfc_error ("ALLOCATORS directive at %L inside a target region " - "must specify an ALLOCATOR modifier for %qs", - &code->loc, missing_allocator_sym->name); - else if (missing_allocator_sym) - gfc_error ("ALLOCATE directive at %L inside a target region " - "must specify an ALLOCATOR clause for %qs", - &code->loc, missing_allocator_sym->name); - else - gfc_error ("ALLOCATE directive at %L inside a target region " - "must specify an ALLOCATOR clause", &code->loc); - } - - } - } + resolve_omp_allocate_clauses (code, omp_clauses, ns); /* OpenACC reductions. */ if (openacc)
