Hi Tobias,
Here is a revamped patch as well as some inline replies.
On 31/10/2025 17:41, Tobias Burnus wrote:
Hi PA,
Paul-Antoine Arras wrote:
On 29/10/2025 18:44, Tobias Burnus wrote:
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.
There is still a warning with -Wall:
Warning: Label 4567 at (1) defined but not used [-Wunused-label]
Warning: Label 1234 at (1) defined but not used [-Wunused-label]
That's handled by gfc_reference_st_label, but the question is:
why doesn't this work here?
* * *
It seems as if this is due parsing the body multiple times. I see
in the first call to gfc_rebind_label:
(gdb) p label->ns->st_labels
$20 = (gfc_st_label *) 0x3752060
(gdb) p *label->ns->st_labels
$17 = {priority = 32547, left = 0x3757d00, right = 0x0, value = 1234, defined =
ST_LABEL_FORMAT, referenced = ST_LABEL_UNKNOWN, format = 0x3757a30,
backend_decl = 0x0, where = {nextc = 0x37402f0, u = {lb = 0x37402c0, location =
57934528}}, ns = 0x3750520, omp_region = 1}
(gdb) p *label->ns->st_labels->left
$18 = {priority = 20296, left = 0x0, right = 0x0, value = 1234, defined =
ST_LABEL_FORMAT, referenced = ST_LABEL_UNKNOWN, format = 0x3757e70,
backend_decl = 0x0, where = {nextc = 0x37402f0, u = {lb = 0x37402c0, location =
57934528}}, ns = 0x3750520, omp_region = 2}
The call is:
gfc_rebind_label (label=0x3757d00, new_omp_region=new_omp_region@entry=0)
Thus, only the st_labels->left is fixed, st_labels remains (unused) in
the wrong scope.
* * *
This is fixed if you move the label handling a few lines up
above the '}' of the 'while (variant)' loop.
Fixed as suggested.
* * *
However, we still run into the same issue that I alluded
in PR122508. We need the use the following value for
omp_region:
1111 FORMAT("outside") ! → omp_region = 0
!$omp metadirective when(... : parallel)
2222 FORMAT("outer") ! → omp_region = 1 (parallel), 2 (nothing)
!$omp metadirective when(... : parallel)
3333 FORMAT("inner")
! → omp_region = 3 (parallel,parallel)
! → omp_region = 4 (parallel,nothing)
! → omp_region = 5 (nothing,parallel)
! → omp_region = 6 (nothing,nothing)
!$omp end parallel
4444 FORMAT("outer 2") ! → omp_region = 1 (parallel), 2 (nothing)
!$omp end parallel
5555 FORMAT("outside 2") ! → omp_region = 0
Currently, we get (without -Wall or with moving it
to 'variant'):
9 | write(*,1234)
| 1
Error: FORMAT label 1234 at (1) not defined with:
For:
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
And likewise for the second testcase in the file,
just with 4 times:
Error: Label 4567 referenced at (1) is never defined
Added testcase. Fixed in the attached patch.
* * *
BTW: Can you add -Wall or -Wunused-label to all testcases?
Done.
* * *
1345 format("The count is ", g0)
...
!$omp begin metadirective when(user={condition(cnt > 0)} : parallel)
write(*,1345) cnt
!$omp end metadirective
end
I have now created a new PR for that: https://gcc.gnu.org/PR122508.
I have attached a draft patch. For the simple case of
a single metadirective it works fine. - It fails if
one nests them.
Currently we have only the latest used label available -
but we need at least the last parent one for this use
and for PR122508, we need to find all previous ones.
Thus, maybe something like:
vec<int> gfc_omp_metadirective_region_count
or
std::vector<int> gfc_omp_metadirective_region_count
where we push/pop the current count value.
And a separate variable which keeps track of the used
version.
* * *
BTW: Please consider to handle PR122508 as part of this
issue; it seems as if doing so using a stack as mentioned
above + tweaking the existing patch to PR122508 (+ adding
the two tests) should be straight forward.
The attached patch should now incorporate your draft and handle PR122508
as well.
Thanks,
--
PA
From 39fba473358978837abf9b340ec84017c4dcf549 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: 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.
---
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 ++++
9 files changed, 204 insertions(+), 13 deletions(-)
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
create mode 100644 gcc/testsuite/gfortran.dg/gomp/pr122369-4.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/pr122508-1.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..f987f464023 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 7bf0fa497e9..70ffcbda2a2 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 8211d926cf6..b4d3ed6394d 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 00000000000..d7213600629
--- /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 00000000000..e920c98f57b
--- /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 00000000000..1542b890bd1
--- /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 00000000000..ff5b68308d5
--- /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 00000000000..7ba85cdf45d
--- /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
--
2.51.0
