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.

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 *);

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;
 

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 *);

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;

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

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

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

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

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

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