OpenMP: Fortran support for metadirectives and dynamic selectors

gcc/fortran/ChangeLog
	PR middle-end/112779
	PR middle-end/113904
	* decl.cc (gfc_match_end): Handle COMP_OMP_BEGIN_METADIRECTIVE and
	COMP_OMP_METADIRECTIVE.
	* dump-parse-tree.cc (show_omp_node): Handle EXEC_OMP_METADIRECTIVE.
	(show_code_node): Likewise.
	* gfortran.h (enum gfc_statement): Add ST_OMP_METADIRECTIVE,
	ST_OMP_BEGIN_METADIRECTIVE, and ST_OMP_END_METADIRECTIVE.
	(struct gfc_omp_clauses): Rename target_first_st_is_teams to
	target_first_st_is_teams_or_meta.
	(struct gfc_omp_variant): New.
	(gfc_get_omp_variant): New.
	(struct gfc_st_label): Add omp_region field.
	(enum gfc_exec_op): Add EXEC_OMP_METADIRECTIVE.
	(struct gfc_code): Add omp_variants fields.
	(gfc_free_omp_variants): Declare.
	(match_omp_directive): Declare.
	(is_omp_declarative_stmt): Declare.
	* io.cc (format_asterisk): Adjust initializer.
	* match.h (gfc_match_omp_begin_metadirective): Declare.
	(gfc_match_omp_metadirective): Declare.
	* openmp.cc (gfc_omp_directives): Uncomment metadirective.
	(gfc_match_omp_eos): Adjust to match context selectors.
	(gfc_free_omp_variants): New.
	(gfc_match_omp_clauses): Remove context_selector parameter and adjust
	to use gfc_match_omp_eos instead.
	(match_omp): Adjust call to gfc_match_omp_clauses.
	(gfc_match_omp_context_selector): Add metadirective_p parameter and
	adjust error-checking.  Adjust matching of simd clauses.
	(gfc_match_omp_context_selector_specification): Adjust parameters
	so it can be used for metadirective as well as declare variant.
	(match_omp_metadirective): New.
	(gfc_match_omp_begin_metadirective): New.
	(gfc_match_omp_metadirective): New.
	(resolve_omp_metadirective): New.
	(resolve_omp_target): Handle metadirectives.
	(gfc_resolve_omp_directive): Handle EXEC_OMP_METADIRECTIVE.
	* parse.cc (gfc_matching_omp_context_selector): New.
	(gfc_in_omp_metadirective_body): New.
	(gfc_omp_region_count): New.
	(decode_omp_directive): Handle ST_OMP_BEGIN_METADIRECTIVE and
	ST_OMP_METADIRECTIVE.
	(match_omp_directive): New.
	(case_omp_structured_block): Define.
	(case_omp_do): Define.
	(gfc_ascii_statement): Handle ST_OMP_BEGIN_METADIRECTIVE,
	ST_OMP_END_METADIRECTIVE, and ST_OMP_METADIRECTIVE.
	(accept_statement):  Handle ST_OMP_METADIRECTIVE and
	ST_OMP_BEGIN_METADIRECTIVE.
	(gfc_omp_end_stmt): New, split from...
	(parse_omp_do): ...here, and...
	(parse_omp_structured_block): ...here.  Handle metadirectives,
	plus "allocate", "atomic", and "dispatch" which were missing.
	(parse_omp_oacc_atomic): Handle "end metadirective".
	(parse_openmp_allocate_block): Likewise.
	(parse_omp_dispatch): Likewise.
	(parse_omp_metadirective_body): New.
	(parse_executable): Handle metadirective.  Use new case macros
	defined above.
	(gfc_parse_file): Initialize metadirective state.
	(is_omp_declarative_stmt): New.
	* parse.h (enum gfc_compile_state): Add COMP_OMP_METADIRECTIVE
	and COMP_OMP_BEGIN_METADIRECTIVE.
	(gfc_omp_end_stmt): Declare.
	(gfc_matching_omp_context_selector): Declare.
	(gfc_in_omp_metadirective_body): Declare.
	(gfc_omp_metadirective_region_count): Declare.
	* resolve.cc (gfc_resolve_code): Handle EXEC_OMP_METADIRECTIVE.
	* st.cc (gfc_free_statement): Likewise.
	* symbol.cc (compare_st_labels): Handle labels within a metadirective
	body.
	(gfc_get_st_label): Likewise.
	* trans-decl.cc (gfc_get_label_decl): Encode the metadirective region
	in the label_name.
	* trans-openmp.cc (gfc_trans_omp_directive): Handle
	EXEC_OMP_METADIRECTIVE.
	(gfc_trans_omp_set_selector): New, split/adapted from code....
	(gfc_trans_omp_declare_variant): ...here.
	(gfc_trans_omp_metadirective): New.
	* trans-stmt.h 	(gfc_trans_omp_metadirective): Declare.
	* trans.cc (trans_code): Handle EXEC_OMP_METADIRECTIVE.

gcc/testsuite/ChangeLog
	PR middle-end/112779
	PR middle-end/113904
	* gfortran.dg/gomp/metadirective-1.f90: New.
	* gfortran.dg/gomp/metadirective-10.f90: New.
	* gfortran.dg/gomp/metadirective-11.f90: New.
	* gfortran.dg/gomp/metadirective-12.f90: New.
	* gfortran.dg/gomp/metadirective-13.f90: New.
	* gfortran.dg/gomp/metadirective-2.f90: New.
	* gfortran.dg/gomp/metadirective-3.f90: New.
	* gfortran.dg/gomp/metadirective-4.f90: New.
	* gfortran.dg/gomp/metadirective-5.f90: New.
	* gfortran.dg/gomp/metadirective-6.f90: New.
	* gfortran.dg/gomp/metadirective-7.f90: New.
	* gfortran.dg/gomp/metadirective-8.f90: New.
	* gfortran.dg/gomp/metadirective-9.f90: New.
	* gfortran.dg/gomp/metadirective-construct.f90: New.
	* gfortran.dg/gomp/metadirective-no-score.f90: New.
	* gfortran.dg/gomp/pure-1.f90 (func_metadirective): New.
	(func_metadirective_2): New.
	(func_metadirective_3): New.
	* gfortran.dg/gomp/pure-2.f90 (func_metadirective): Delete.

libgomp/ChangeLog
	PR middle-end/112779
	PR middle-end/113904
	* testsuite/libgomp.fortran/metadirective-1.f90: New.
	* testsuite/libgomp.fortran/metadirective-2.f90: New.
	* testsuite/libgomp.fortran/metadirective-3.f90: New.
	* testsuite/libgomp.fortran/metadirective-4.f90: New.
	* testsuite/libgomp.fortran/metadirective-5.f90: New.
	* testsuite/libgomp.fortran/metadirective-6.f90: New.

Co-Authored-By: Kwok Cheung Yeung <kcy@codesourcery.com>
Co-Authored-By: Sandra Loosemore <sandra@codesourcery.com>
Co-Authored-By: Tobias Burnus <tobias@codesourcery.com>
Co-Authored-By: Paul-Antoine Arras <pa@codesourcery.com>

1 files changed, 275 insertions, 37 deletions

diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 5eef5eb..b1684f8 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -83,7 +83,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = {
   {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP},
   {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
   {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
-  /* {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE}, */
+  {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE},
   /* Note: gfc_match_omp_nothing returns ST_NONE.  */
   {"nothing", GFC_OMP_DIR_UTILITY, ST_OMP_NOTHING},
   /* Special case; for now map to the first one.
@@ -116,7 +116,8 @@ static const struct gfc_omp_directive gfc_omp_directives[] = {
 
 
 /* Match an end of OpenMP directive.  End of OpenMP directive is optional
-   whitespace, followed by '\n' or comment '!'.  */
+   whitespace, followed by '\n' or comment '!'.  In the special case where a
+   context selector is being matched, match against ')' instead.  */
 
 static match
 gfc_match_omp_eos (void)
@@ -127,17 +128,25 @@ gfc_match_omp_eos (void)
   old_loc = gfc_current_locus;
   gfc_gobble_whitespace ();
 
-  c = gfc_next_ascii_char ();
-  switch (c)
+  if (gfc_matching_omp_context_selector)
     {
-    case '!':
-      do
-	c = gfc_next_ascii_char ();
-      while (c != '\n');
-      /* Fall through */
+      if (gfc_peek_ascii_char () == ')')
+	return MATCH_YES;
+    }
+  else
+    {
+      c = gfc_next_ascii_char ();
+      switch (c)
+	{
+	case '!':
+	  do
+	    c = gfc_next_ascii_char ();
+	  while (c != '\n');
+	  /* Fall through */
 
-    case '\n':
-      return MATCH_YES;
+	case '\n':
+	  return MATCH_YES;
+	}
     }
 
   gfc_current_locus = old_loc;
@@ -349,6 +358,19 @@ gfc_free_omp_udr (gfc_omp_udr *omp_udr)
     }
 }
 
+/* Free variants of an !$omp metadirective construct.  */
+
+void
+gfc_free_omp_variants (gfc_omp_variant *variant)
+{
+  while (variant)
+    {
+      gfc_omp_variant *next_variant = variant->next;
+      gfc_free_omp_set_selector_list (variant->selectors);
+      free (variant);
+      variant = next_variant;
+    }
+}
 
 static gfc_omp_udr *
 gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
@@ -2321,8 +2343,7 @@ gfc_match_dupl_atomic (bool not_dupl, const char *name)
 static match
 gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 		       bool first = true, bool needs_space = true,
-		       bool openacc = false, bool context_selector = false,
-		       bool openmp_target = false)
+		       bool openacc = false, bool openmp_target = false)
 {
   bool error = false;
   gfc_omp_clauses *c = gfc_get_omp_clauses ();
@@ -4384,9 +4405,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
     }
 
 end:
-  if (error
-      || (context_selector && gfc_peek_ascii_char () != ')')
-      || (!context_selector && gfc_match_omp_eos () != MATCH_YES))
+  if (error || gfc_match_omp_eos () != MATCH_YES)
     {
       if (!gfc_error_flag_test ())
 	gfc_error ("Failed to match clause at %C");
@@ -5100,7 +5119,7 @@ static match
 match_omp (gfc_exec_op op, const omp_mask mask)
 {
   gfc_omp_clauses *c;
-  if (gfc_match_omp_clauses (&c, mask, true, true, false, false,
+  if (gfc_match_omp_clauses (&c, mask, true, true, false,
 			     op == EXEC_OMP_TARGET) != MATCH_YES)
     return MATCH_ERROR;
   new_st.op = op;
@@ -6295,7 +6314,8 @@ gfc_match_omp_interop (void)
      score(score-expression)  */
 
 match
-gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
+gfc_match_omp_context_selector (gfc_omp_set_selector *oss,
+				bool metadirective_p)
 {
   do
     {
@@ -6455,14 +6475,31 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
 		  || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
 		      && otp->expr->ts.type != BT_INTEGER)
 		  || otp->expr->rank != 0
-		  || otp->expr->expr_type != EXPR_CONSTANT)
+		  || (!metadirective_p
+		      && otp->expr->expr_type != EXPR_CONSTANT))
 		{
-		  if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
-		    gfc_error ("property must be a constant logical expression "
-			       "at %C");
+		  if (metadirective_p)
+		    {
+		      if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
+			gfc_error ("property must be a "
+				   "logical expression at %L",
+				   &otp->expr->where);
+		      else
+			gfc_error ("property must be an "
+				   "integer expression at %L",
+				   &otp->expr->where);
+		    }
 		  else
-		    gfc_error ("property must be a constant integer expression "
-			       "at %C");
+		    {
+		      if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
+			gfc_error ("property must be a constant "
+				   "logical expression at %L",
+				   &otp->expr->where);
+		      else
+			gfc_error ("property must be a constant "
+				   "integer expression at %L",
+				   &otp->expr->where);
+		    }
 		  return MATCH_ERROR;
 		}
 	      /* Device number must be conforming, which includes
@@ -6482,14 +6519,17 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
 	      {
 		if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
 		  {
+		    gfc_matching_omp_context_selector = true;
 		    if (gfc_match_omp_clauses (&otp->clauses,
 					       OMP_DECLARE_SIMD_CLAUSES,
-					       true, false, false, true)
+					       true, false, false)
 			!= MATCH_YES)
 		      {
+			gfc_matching_omp_context_selector = false;
 			gfc_error ("expected simd clause at %C");
 			return MATCH_ERROR;
 		      }
+		    gfc_matching_omp_context_selector = false;
 		  }
 		else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
 		  {
@@ -6546,7 +6586,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
      user  */
 
 match
-gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
+gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head,
+					      bool metadirective_p)
 {
   do
     {
@@ -6579,11 +6620,11 @@ gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
 	}
 
       gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
-      oss->next = odv->set_selectors;
+      oss->next = *oss_head;
       oss->code = set;
-      odv->set_selectors = oss;
+      *oss_head = oss;
 
-      if (gfc_match_omp_context_selector (oss) != MATCH_YES)
+      if (gfc_match_omp_context_selector (oss, metadirective_p) != MATCH_YES)
 	return MATCH_ERROR;
 
       m = gfc_match (" }");
@@ -6714,7 +6755,8 @@ gfc_match_omp_declare_variant (void)
 	      return MATCH_ERROR;
 	    }
 	  has_match = true;
-	  if (gfc_match_omp_context_selector_specification (odv)
+	  if (gfc_match_omp_context_selector_specification (&odv->set_selectors,
+							    false)
 	      != MATCH_YES)
 	    return MATCH_ERROR;
 	  if (gfc_match (" )") != MATCH_YES)
@@ -6831,6 +6873,167 @@ gfc_match_omp_declare_variant (void)
 }
 
 
+static match
+match_omp_metadirective (bool begin_p)
+{
+  locus old_loc = gfc_current_locus;
+  gfc_omp_variant *variants_head;
+  gfc_omp_variant **next_variant = &variants_head;
+  bool default_seen = false;
+
+  /* Parse the context selectors.  */
+  for (;;)
+    {
+      bool default_p = false;
+      gfc_omp_set_selector *selectors = NULL;
+
+      gfc_gobble_whitespace ();
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      gfc_match_char (',');
+      gfc_gobble_whitespace ();
+
+      locus variant_locus = gfc_current_locus;
+
+      if (gfc_match (" default ( ") == MATCH_YES)
+	default_p = true;
+      else if (gfc_match (" otherwise ( ") == MATCH_YES)
+	default_p = true;
+      else if (gfc_match (" when ( ") != MATCH_YES)
+	{
+	  gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
+	  gfc_current_locus = old_loc;
+	  return MATCH_ERROR;
+	}
+
+      if (default_p && default_seen)
+	{
+	  gfc_error ("too many %<otherwise%> or %<default%> clauses "
+		     "in %<metadirective%> at %C");
+	  gfc_current_locus = old_loc;
+	  return MATCH_ERROR;
+	}
+      else if (default_seen)
+	{
+	  gfc_error ("%<otherwise%> or %<default%> clause "
+		     "must appear last in %<metadirective%> at %C");
+	  gfc_current_locus = old_loc;
+	  return MATCH_ERROR;
+	}
+
+      if (!default_p)
+	{
+	  if (gfc_match_omp_context_selector_specification (&selectors, true)
+	      != MATCH_YES)
+	    return MATCH_ERROR;
+
+	  if (gfc_match (" : ") != MATCH_YES)
+	    {
+	      gfc_error ("expected %<:%> at %C");
+	      gfc_current_locus = old_loc;
+	      return MATCH_ERROR;
+	    }
+
+	  gfc_commit_symbols ();
+	}
+
+      gfc_matching_omp_context_selector = true;
+      gfc_statement directive = match_omp_directive ();
+      gfc_matching_omp_context_selector = false;
+
+      if (is_omp_declarative_stmt (directive))
+	sorry ("declarative directive variants are not supported");
+
+      if (gfc_error_flag_test ())
+	{
+	  gfc_current_locus = old_loc;
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_match (" )") != MATCH_YES)
+	{
+	  gfc_error ("Expected %<)%> at %C");
+	  gfc_current_locus = old_loc;
+	  return MATCH_ERROR;
+	}
+
+      gfc_commit_symbols ();
+
+      if (begin_p
+	  && directive != ST_NONE
+	  && gfc_omp_end_stmt (directive) == ST_NONE)
+	{
+	  gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
+		     "at %C must have a corresponding end directive");
+	  gfc_current_locus = old_loc;
+	  return MATCH_ERROR;
+	}
+
+      if (default_p)
+	default_seen = true;
+
+      gfc_omp_variant *omv = gfc_get_omp_variant ();
+      omv->selectors = selectors;
+      omv->stmt = directive;
+      omv->where = variant_locus;
+
+      if (directive == ST_NONE)
+	{
+	  /* The directive was a 'nothing' directive.  */
+	  omv->code = gfc_get_code (EXEC_CONTINUE);
+	  omv->code->ext.omp_clauses = NULL;
+	}
+      else
+	{
+	  omv->code = gfc_get_code (new_st.op);
+	  omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
+	  /* Prevent the OpenMP clauses from being freed via NEW_ST.  */
+	  new_st.ext.omp_clauses = NULL;
+	}
+
+      *next_variant = omv;
+      next_variant = &omv->next;
+    }
+
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
+      gfc_current_locus = old_loc;
+      return MATCH_ERROR;
+    }
+
+  /* Add a 'default (nothing)' clause if no default is explicitly given.  */
+  if (!default_seen)
+    {
+      gfc_omp_variant *omv = gfc_get_omp_variant ();
+      omv->stmt = ST_NONE;
+      omv->code = gfc_get_code (EXEC_CONTINUE);
+      omv->code->ext.omp_clauses = NULL;
+      omv->where = old_loc;
+      omv->selectors = NULL;
+
+      *next_variant = omv;
+      next_variant = &omv->next;
+    }
+
+  new_st.op = EXEC_OMP_METADIRECTIVE;
+  new_st.ext.omp_variants = variants_head;
+
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_begin_metadirective (void)
+{
+  return match_omp_metadirective (true);
+}
+
+match
+gfc_match_omp_metadirective (void)
+{
+  return match_omp_metadirective (false);
+}
+
 match
 gfc_match_omp_threadprivate (void)
 {
@@ -11987,6 +12190,19 @@ resolve_omp_do (gfc_code *code)
 				  non_generated_count);
 }
 
+static void
+resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
+{
+  gfc_omp_variant *variant = code->ext.omp_variants;
+
+  while (variant)
+    {
+      gfc_code *variant_code = variant->code;
+      gfc_resolve_code (variant_code, ns);
+      variant = variant->next;
+    }
+}
+
 
 static gfc_statement
 omp_code_to_statement (gfc_code *code)
@@ -12538,13 +12754,32 @@ resolve_omp_target (gfc_code *code)
   gfc_code *c = code->block->next;
   if (c->op == EXEC_BLOCK)
     c = c->ext.block.ns->code;
-  if (code->ext.omp_clauses->target_first_st_is_teams
-      && ((GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
-	  || (c->op == EXEC_BLOCK
-	      && c->next
-	      && GFC_IS_TEAMS_CONSTRUCT (c->next->op)
-	      && c->next->next == NULL)))
-    return;
+  if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
+    {
+      if (c->op == EXEC_OMP_METADIRECTIVE)
+	{
+	  struct gfc_omp_variant *mc
+	    = c->ext.omp_variants;
+	  /* All mc->(next...->)code should be identical with regards
+	     to the diagnostic below.  */
+	  do
+	    {
+	      if (mc->stmt != ST_NONE
+		  && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
+		{
+		  if (c->next == NULL && mc->code->next == NULL)
+		    return;
+		  c = mc->code;
+		  break;
+		}
+	      mc = mc->next;
+	    }
+	  while (mc);
+	}
+      else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
+	return;
+    }
+
   while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
     c = c->next;
   if (c)
@@ -12714,6 +12949,9 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
 	resolve_omp_clauses (code, code->ext.omp_clauses, ns);
       resolve_omp_dispatch (code);
       break;
+    case EXEC_OMP_METADIRECTIVE:
+      resolve_omp_metadirective (code, ns);
+      break;
     default:
       break;
     }