On 29/10/2025 18:44, Tobias Burnus wrote:
Paul-Antoine Arras wrote:
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
reference elsewhere.
This patch fixes it by rebinding such labels to the outer region.
This does not seem to work in general:
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
Here is a revamped version of the patch that should handle properly more
cases.
* * *
Not necessarily in this patch, but I think it would be good if
the following worked as well:
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
which seems to be a somewhat sensible usage pattern.
But admittedly, it is not the same issue as PR122369
and could also be deferred (i.e. a new PR created for it).
I have now created a new PR for that: https://gcc.gnu.org/PR122508.
Thanks,
--
PA
From c71a9597b2cfeac6bcde82149a62e005f7b2da37 Mon Sep 17 00:00:00 2001
From: Paul-Antoine Arras <[email protected]>
Date: Tue, 28 Oct 2025 17:27:47 +0100
Subject: [PATCH] OpenMP/Fortran: Rebind labels after metadirective body
[PR122369]
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
reference elsewhere.
This patch fixes it by rebinding such labels to the outer region.
PR fortran/122369
gcc/fortran/ChangeLog:
* gfortran.h (gfc_rebind_label): Declare new function.
* parse.cc (parse_omp_metadirective_body): Rebind labels to the outer
region.
* symbol.cc (gfc_rebind_label): Define new function.
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.
---
gcc/fortran/gfortran.h | 1 +
gcc/fortran/parse.cc | 28 +++++++++++
gcc/fortran/symbol.cc | 47 +++++++++++++++++++
gcc/testsuite/gfortran.dg/gomp/pr122369-1.f90 | 12 +++++
gcc/testsuite/gfortran.dg/gomp/pr122369-2.f90 | 36 ++++++++++++++
gcc/testsuite/gfortran.dg/gomp/pr122369-3.f90 | 22 +++++++++
6 files changed, 146 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/gomp/pr122369-1.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/pr122369-2.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/pr122369-3.f90
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 19473dfa791..f1c4db23d00 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 b29f6900841..cd206659c74 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -6522,6 +6522,18 @@ parse_omp_metadirective_body (gfc_statement omp_st)
gfc_statement next_st = ST_NONE;
locus next_loc;
+ int old_omp_metadirective_region_count = gfc_omp_metadirective_region_count;
+
+ bool has_outer_metadirective = false;
+ for (gfc_state_data *p = gfc_state_stack; p; p = p->previous)
+ if (p->state == COMP_OMP_BEGIN_METADIRECTIVE
+ || p->state == COMP_OMP_METADIRECTIVE)
+ {
+ has_outer_metadirective = true;
+ break;
+ }
+ if (!has_outer_metadirective)
+ old_omp_metadirective_region_count = 0;
while (variant)
{
@@ -6611,6 +6623,22 @@ parse_omp_metadirective_body (gfc_statement omp_st)
variant = variant->next;
}
+ if (gfc_statement_label)
+ gfc_statement_label = gfc_rebind_label (gfc_statement_label,
+ old_omp_metadirective_region_count);
+ 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,
+ old_omp_metadirective_region_count);
+ if (new_st.label1)
+ new_st.label1
+ = gfc_rebind_label (new_st.label1, old_omp_metadirective_region_count);
+ if (new_st.here)
+ new_st.here
+ = gfc_rebind_label (new_st.here, old_omp_metadirective_region_count);
+
if (saw_error)
{
if (omp_st == ST_OMP_METADIRECTIVE)
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 8211d926cf6..fe8feaa6838 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -2799,6 +2799,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,
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 00000000000..68c9d8e7aa0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-1.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+
+! 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 00000000000..aa6dba48250
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-2.f90
@@ -0,0 +1,36 @@
+! { dg-do compile }
+
+! 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 00000000000..09937f123a5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-3.f90
@@ -0,0 +1,22 @@
+! { dg-do compile }
+
+! 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
--
2.51.0
