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.
(cherry picked from commit
7fa8420170b7a8ca40d7414ddcddaed425442cee)
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 *);
/* 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);
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:
*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)
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;
#ifndef GFC_PARSE_H
#define GFC_PARSE_H
+#include "vec.h"
+
/* Enum for what the compiler is currently doing. */
enum gfc_compile_state
{
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 *);
{
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;
}
/* 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);
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,
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
}
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;
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
