https://gcc.gnu.org/g:7fa8420170b7a8ca40d7414ddcddaed425442cee
commit r16-5027-g7fa8420170b7a8ca40d7414ddcddaed425442cee Author: Paul-Antoine Arras <[email protected]> Date: Tue Oct 28 17:27:47 2025 +0100 OpenMP/Fortran: Revamp handling of labels in metadirectives [PR122369,PR122508] When a label is matched in the first statement after the end of a metadirective body, it is bound to the associated region. However this prevents it from being referenced elsewhere. This patch fixes it by rebinding such labels to the outer region. It also ensures that labels defined in an outer region can be referenced in a metadirective body. PR fortran/122369 PR fortran/122508 gcc/fortran/ChangeLog: * gfortran.h (gfc_rebind_label): Declare new function. * parse.cc (parse_omp_metadirective_body): Rebind labels to the outer region. Maintain a vector of metadirective regions. (gfc_parse_file): Initialise it. * parse.h (GFC_PARSE_H): Declare it. * symbol.cc (gfc_get_st_label): Look for existing labels in outer metadirective regions. (gfc_rebind_label): Define new function. (gfc_define_st_label): Accept duplicate labels in metadirective body. (gfc_reference_st_label): Accept shared DO termination labels in metadirective body. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/pr122369-1.f90: New test. * gfortran.dg/gomp/pr122369-2.f90: New test. * gfortran.dg/gomp/pr122369-3.f90: New test. * gfortran.dg/gomp/pr122369-4.f90: New test. * gfortran.dg/gomp/pr122508-1.f90: New test. * gfortran.dg/gomp/pr122508-2.f90: New test. Diff: --- gcc/fortran/gfortran.h | 1 + gcc/fortran/parse.cc | 28 ++++++++++ gcc/fortran/parse.h | 3 + gcc/fortran/symbol.cc | 79 ++++++++++++++++++++++----- gcc/testsuite/gfortran.dg/gomp/pr122369-1.f90 | 13 +++++ gcc/testsuite/gfortran.dg/gomp/pr122369-2.f90 | 37 +++++++++++++ gcc/testsuite/gfortran.dg/gomp/pr122369-3.f90 | 23 ++++++++ gcc/testsuite/gfortran.dg/gomp/pr122369-4.f90 | 16 ++++++ gcc/testsuite/gfortran.dg/gomp/pr122508-1.f90 | 17 ++++++ gcc/testsuite/gfortran.dg/gomp/pr122508-2.f90 | 22 ++++++++ 10 files changed, 226 insertions(+), 13 deletions(-) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 19473dfa791e..f1c4db23d00c 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3760,6 +3760,7 @@ gfc_st_label *gfc_get_st_label (int); void gfc_free_st_label (gfc_st_label *); void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *); bool gfc_reference_st_label (gfc_st_label *, gfc_sl_type); +gfc_st_label *gfc_rebind_label (gfc_st_label *, int); gfc_namespace *gfc_get_namespace (gfc_namespace *, int); gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *); diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index b29f69008417..f987f4640233 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -60,6 +60,7 @@ bool gfc_in_omp_metadirective_body; /* Each metadirective body in the translation unit is given a unique number, used to ensure that labels in the body have unique names. */ int gfc_omp_metadirective_region_count; +vec<int> gfc_omp_metadirective_region_stack; /* TODO: Re-order functions to kill these forward decls. */ static void check_statement_label (gfc_statement); @@ -6542,6 +6543,9 @@ parse_omp_metadirective_body (gfc_statement omp_st) gfc_in_omp_metadirective_body = true; gfc_omp_metadirective_region_count++; + gfc_omp_metadirective_region_stack.safe_push ( + gfc_omp_metadirective_region_count); + switch (variant->stmt) { case_omp_structured_block: @@ -6603,6 +6607,28 @@ parse_omp_metadirective_body (gfc_statement omp_st) *variant->code = *gfc_state_stack->head; pop_state (); + gfc_omp_metadirective_region_stack.pop (); + int outer_omp_metadirective_region + = gfc_omp_metadirective_region_stack.last (); + + /* Rebind labels in the last statement -- which is the first statement + past the end of the metadirective body -- to the outer region. */ + if (gfc_statement_label) + gfc_statement_label = gfc_rebind_label (gfc_statement_label, + outer_omp_metadirective_region); + if ((new_st.op == EXEC_READ || new_st.op == EXEC_WRITE) + && new_st.ext.dt->format_label + && new_st.ext.dt->format_label != &format_asterisk) + new_st.ext.dt->format_label + = gfc_rebind_label (new_st.ext.dt->format_label, + outer_omp_metadirective_region); + if (new_st.label1) + new_st.label1 + = gfc_rebind_label (new_st.label1, outer_omp_metadirective_region); + if (new_st.here) + new_st.here + = gfc_rebind_label (new_st.here, outer_omp_metadirective_region); + gfc_commit_symbols (); gfc_warning_check (); if (variant->next) @@ -7578,6 +7604,8 @@ gfc_parse_file (void) gfc_statement_label = NULL; gfc_omp_metadirective_region_count = 0; + gfc_omp_metadirective_region_stack.truncate (0); + gfc_omp_metadirective_region_stack.safe_push (0); gfc_in_omp_metadirective_body = false; gfc_matching_omp_context_selector = false; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 7bf0fa497e92..70ffcbda2a20 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -22,6 +22,8 @@ along with GCC; see the file COPYING3. If not see #ifndef GFC_PARSE_H #define GFC_PARSE_H +#include "vec.h" + /* Enum for what the compiler is currently doing. */ enum gfc_compile_state { @@ -76,6 +78,7 @@ extern bool gfc_matching_function; extern bool gfc_matching_omp_context_selector; extern bool gfc_in_omp_metadirective_body; extern int gfc_omp_metadirective_region_count; +extern vec<int> gfc_omp_metadirective_region_stack; match gfc_match_prefix (gfc_typespec *); bool is_oacc (gfc_state_data *); diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 8211d926cf63..b4d3ed6394db 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -2753,8 +2753,7 @@ gfc_get_st_label (int labelno) { gfc_st_label *lp; gfc_namespace *ns; - int omp_region = (gfc_in_omp_metadirective_body - ? gfc_omp_metadirective_region_count : 0); + int omp_region = gfc_omp_metadirective_region_stack.last (); if (gfc_current_state () == COMP_DERIVED) ns = gfc_current_block ()->f2k_derived; @@ -2768,22 +2767,28 @@ gfc_get_st_label (int labelno) } /* First see if the label is already in this namespace. */ - lp = ns->st_labels; - while (lp) + gcc_checking_assert (gfc_omp_metadirective_region_stack.length () > 0); + for (int omp_region_idx = gfc_omp_metadirective_region_stack.length () - 1; + omp_region_idx >= 0; omp_region_idx--) { - if (lp->omp_region == omp_region) + int omp_region2 = gfc_omp_metadirective_region_stack[omp_region_idx]; + lp = ns->st_labels; + while (lp) { - if (lp->value == labelno) - return lp; - if (lp->value < labelno) + if (lp->omp_region == omp_region2) + { + if (lp->value == labelno) + return lp; + if (lp->value < labelno) + lp = lp->left; + else + lp = lp->right; + } + else if (lp->omp_region < omp_region2) lp = lp->left; else lp = lp->right; } - else if (lp->omp_region < omp_region) - lp = lp->left; - else - lp = lp->right; } lp = XCNEW (gfc_st_label); @@ -2799,6 +2804,53 @@ gfc_get_st_label (int labelno) return lp; } +/* Rebind a statement label to a new OpenMP region. If a label with the same + value already exists in the new region, update it and return it. Otherwise, + move the label to the new region. */ + +gfc_st_label * +gfc_rebind_label (gfc_st_label *label, int new_omp_region) +{ + gfc_st_label *lp = label->ns->st_labels; + int labelno = label->value; + + while (lp) + { + if (lp->omp_region == new_omp_region) + { + if (lp->value == labelno) + { + if (lp == label) + return label; + if (lp->defined == ST_LABEL_UNKNOWN + && label->defined != ST_LABEL_UNKNOWN) + lp->defined = label->defined; + if (lp->referenced == ST_LABEL_UNKNOWN + && label->referenced != ST_LABEL_UNKNOWN) + lp->referenced = label->referenced; + if (lp->format == NULL && label->format != NULL) + lp->format = label->format; + gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels); + return lp; + } + if (lp->value < labelno) + lp = lp->left; + else + lp = lp->right; + } + else if (lp->omp_region < new_omp_region) + lp = lp->left; + else + lp = lp->right; + } + + gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels); + label->left = nullptr; + label->right = nullptr; + label->omp_region = new_omp_region; + gfc_insert_bbt (&label->ns->st_labels, label, compare_st_labels); + return label; +} /* Called when a statement with a statement label is about to be accepted. We add the label to the list of the current namespace, @@ -2812,7 +2864,7 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) labelno = lp->value; - if (lp->defined != ST_LABEL_UNKNOWN) + if (lp->defined != ST_LABEL_UNKNOWN && !gfc_in_omp_metadirective_body) gfc_error ("Duplicate statement label %d at %L and %L", labelno, &lp->where, label_locus); else @@ -2897,6 +2949,7 @@ gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type) } if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET + && !gfc_in_omp_metadirective_body && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, "Shared DO termination label %d at %C", labelno)) return false; diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122369-1.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122369-1.f90 new file mode 100644 index 000000000000..bf4cbd5f0f9a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-label" } + +! Check that a format label referenced in the first statement past a +! metadirective body is bound to the outer region. + +!$omp metadirective when(user={condition(.true.)}: target teams & +!$omp& distribute parallel do) + DO JCHECK = 1, MNMIN + END DO + WRITE(6,366) PCHECK, UCHECK, VCHECK + 366 FORMAT(/, ' Vcheck = ',E12.4,/) + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122369-2.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122369-2.f90 new file mode 100644 index 000000000000..041d79001c45 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-2.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-label" } + +! Check that a statement label that ends a loop in the first statement past a +! metadirective body is bound to the outer region. + +implicit none +integer :: i, j +logical :: cond1, cond2 +integer :: A(0:10,0:5), B(0:10,0:5) + +cond1 = .true. +cond2 = .true. + +!$omp metadirective when(user={condition(cond1)} : parallel do collapse(2)) + do 50 j = 0, 5 +!$omp metadirective when(user={condition(.false.)} : simd) + do 51 i = 0, 10 + A(i,j) = i*10 + j + 51 continue + 50 continue + + do 55 i = 0, 5 + 55 continue + +!$omp begin metadirective when(user={condition(cond2)} : parallel do collapse(2)) + do 60 j = 0, 5 +!$omp metadirective when(user={condition(.false.)} : simd) + do 61 i = 0, 10 + B(i,j) = i*10 + j + 61 continue + 60 continue +!$omp end metadirective + + do 70 j = 0, 5 + 70 continue +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122369-3.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122369-3.f90 new file mode 100644 index 000000000000..61225db2cfff --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-label" } + +! Check that a statement label defined in the first statement past a +! metadirective body is bound to the outer region. + + +integer :: cnt, x + +cnt = 0 +!$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + x = 5 +!$omp end metadirective +1234 format("Hello") +write(*,1234) + +!$omp begin metadirective when(user={condition(x > 0)} : parallel) + x = 5 +!$omp end metadirective +4567 print *, 'hello', cnt +cnt = cnt + 1 +if (cnt < 2) goto 4567 +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122369-4.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122369-4.f90 new file mode 100644 index 000000000000..ff5b68308d5a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-label" } + +! Check that a format label defined in the first statement after a nested +! metadirective body can be referenced correctly. + +integer :: cnt, x +cnt = 0 +!$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + !$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + x = 5 + !$omp end metadirective + 1234 format("Hello") + write(*,1234) +!$omp end metadirective +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122508-1.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122508-1.f90 new file mode 100644 index 000000000000..c64a86409fbf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122508-1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-label" } + +! Check that a format label defined outside a metadirective body can be +! referenced correctly inside the metadirective body. + +implicit none +integer :: cnt +1345 format("The count is ", g0) + +cnt = 0 +write(*,1345) cnt + +!$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + write(*,1345) cnt +!$omp end metadirective +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122508-2.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122508-2.f90 new file mode 100644 index 000000000000..45287116952e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122508-2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } + +! Check that redefining labels across metadirective regions triggers a +! diagnostic. + +implicit none +integer :: cnt +1345 format("The count is ", g0) + +cnt = 0 +write(*,1345) cnt + +!$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + 6789 format("The count is ", g0) + !$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + 1345 print *, 'nested' ! { dg-error "Label 1345 at .1. already referenced as a format label" } + 6789 print *, 'world' + !$omp end metadirective + write(*,1345) cnt ! { dg-error "Label 1345 at .1. previously used as branch target" } + write(*,6789) cnt ! { dg-error "Label 6789 at .1. previously used as branch target" } +!$omp end metadirective +end
