openmp, fortran: Add support for OpenMP declare variant directive in Fortran

2021-10-14  Kwok Cheung Yeung  <kcy@codesourcery.com>

gcc/c-family/

	* c-omp.c (c_omp_check_context_selector): Rename to
	omp_check_context_selector and move to omp-general.c.
	(c_omp_mark_declare_variant): Rename to omp_mark_declare_variant and
	move to omp-general.c.

gcc/c/

	* c-parser.c (c_finish_omp_declare_variant): Change call from
	c_omp_check_context_selector to omp_check_context_selector. Change
	call from c_omp_mark_declare_variant to omp_mark_declare_variant.

gcc/cp/

	* decl.c (omp_declare_variant_finalize_one): Change call from
	c_omp_mark_declare_variant to omp_mark_declare_variant.
	* parser.c (cp_finish_omp_declare_variant): Change call from
	c_omp_check_context_selector to omp_check_context_selector.

gcc/fortran/

	* gfortran.h (enum gfc_statement): Add ST_OMP_DECLARE_VARIANT.
	(enum gfc_omp_trait_property_kind): New.
	(struct gfc_omp_trait_property): New.
	(gfc_get_omp_trait_property): New macro.
	(struct gfc_omp_selector): New.
	(gfc_get_omp_selector): New macro.
	(struct gfc_omp_set_selector): New.
	(gfc_get_omp_set_selector): New macro.
	(struct gfc_omp_declare_variant): New.
	(gfc_get_omp_declare_variant): New macro.
	(struct gfc_namespace): Add omp_declare_variant field.
	(gfc_free_omp_declare_variant_list): New prototype.
	* match.h (gfc_match_omp_declare_variant): New prototype.
	* openmp.c (gfc_free_omp_trait_property_list): New.
	(gfc_free_omp_selector_list): New.
	(gfc_free_omp_set_selector_list): New.
	(gfc_free_omp_declare_variant_list): New.
	(gfc_match_omp_clauses): Add extra optional argument.  Handle end of
	clauses for context selectors.
	(omp_construct_selectors, omp_device_selectors,
	omp_implementation_selectors, omp_user_selectors): New.
	(gfc_match_omp_context_selector): New.
	(gfc_match_omp_context_selector_specification): New.
	(gfc_match_omp_declare_variant): New.
	* parse.c: Include tree-core.h and omp-general.h.
	(decode_omp_directive): Handle 'declare variant'.
	(case_omp_decl): Include ST_OMP_DECLARE_VARIANT.
	(gfc_ascii_statement): Handle ST_OMP_DECLARE_VARIANT.
	(gfc_parse_file): Initialize omp_requires_mask.
	* symbol.c (gfc_free_namespace): Call
	gfc_free_omp_declare_variant_list.
	* trans-decl.c (gfc_get_extern_function_decl): Call
	gfc_trans_omp_declare_variant.
	(gfc_create_function_decl): Call gfc_trans_omp_declare_variant.
	* trans-openmp.c (gfc_trans_omp_declare_variant): New.
	* trans-stmt.h (gfc_trans_omp_declare_variant): New prototype.

gcc/

	* omp-general.c (omp_check_context_selector):  Move from c-omp.c.
	(omp_mark_declare_variant): Move from c-omp.c.
	(omp_context_name_list_prop): Update for Fortran strings.
	* omp-general.h (omp_check_context_selector): New prototype.
	(omp_mark_declare_variant): New prototype.

gcc/testsuite/

	* gfortran.dg/gomp/declare-variant-1.f90: New test.
	* gfortran.dg/gomp/declare-variant-10.f90: New test.
	* gfortran.dg/gomp/declare-variant-11.f90: New test.
	* gfortran.dg/gomp/declare-variant-12.f90: New test.
	* gfortran.dg/gomp/declare-variant-13.f90: New test.
	* gfortran.dg/gomp/declare-variant-14.f90: New test.
	* gfortran.dg/gomp/declare-variant-15.f90: New test.
	* gfortran.dg/gomp/declare-variant-16.f90: New test.
	* gfortran.dg/gomp/declare-variant-17.f90: New test.
	* gfortran.dg/gomp/declare-variant-18.f90: New test.
	* gfortran.dg/gomp/declare-variant-19.f90: New test.
	* gfortran.dg/gomp/declare-variant-2.f90: New test.
	* gfortran.dg/gomp/declare-variant-2a.f90: New test.
	* gfortran.dg/gomp/declare-variant-3.f90: New test.
	* gfortran.dg/gomp/declare-variant-4.f90: New test.
	* gfortran.dg/gomp/declare-variant-5.f90: New test.
	* gfortran.dg/gomp/declare-variant-6.f90: New test.
	* gfortran.dg/gomp/declare-variant-7.f90: New test.
	* gfortran.dg/gomp/declare-variant-8.f90: New test.
	* gfortran.dg/gomp/declare-variant-9.f90: New test.

libgomp/

	* testsuite/libgomp.fortran/declare-variant-1.f90: New test.

1 files changed, 142 insertions, 1 deletions

diff --git a/gcc/omp-general.c b/gcc/omp-general.c
index 3e5ca94..4452755 100644
--- a/gcc/omp-general.c
+++ b/gcc/omp-general.c
@@ -1095,6 +1095,146 @@ omp_maybe_offloaded (void)
   return false;
 }
 
+
+/* Diagnose errors in an OpenMP context selector, return CTX if
+   it is correct or error_mark_node otherwise.  */
+
+tree
+omp_check_context_selector (location_t loc, tree ctx)
+{
+  /* Each trait-set-selector-name can only be specified once.
+     There are just 4 set names.  */
+  for (tree t1 = ctx; t1; t1 = TREE_CHAIN (t1))
+    for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2))
+      if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2))
+	{
+	  error_at (loc, "selector set %qs specified more than once",
+		    IDENTIFIER_POINTER (TREE_PURPOSE (t1)));
+	  return error_mark_node;
+	}
+  for (tree t = ctx; t; t = TREE_CHAIN (t))
+    {
+      /* Each trait-selector-name can only be specified once.  */
+      if (list_length (TREE_VALUE (t)) < 5)
+	{
+	  for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
+	    for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2))
+	      if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2))
+		{
+		  error_at (loc,
+			    "selector %qs specified more than once in set %qs",
+			    IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
+			    IDENTIFIER_POINTER (TREE_PURPOSE (t)));
+		  return error_mark_node;
+		}
+	}
+      else
+	{
+	  hash_set<tree> pset;
+	  for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
+	    if (pset.add (TREE_PURPOSE (t1)))
+	      {
+		error_at (loc,
+			  "selector %qs specified more than once in set %qs",
+			  IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
+			  IDENTIFIER_POINTER (TREE_PURPOSE (t)));
+		return error_mark_node;
+	      }
+	}
+
+      static const char *const kind[] = {
+	"host", "nohost", "cpu", "gpu", "fpga", "any", NULL };
+      static const char *const vendor[] = {
+	"amd", "arm", "bsc", "cray", "fujitsu", "gnu", "ibm", "intel",
+	"llvm", "nvidia", "pgi", "ti", "unknown", NULL };
+      static const char *const extension[] = { NULL };
+      static const char *const atomic_default_mem_order[] = {
+	"seq_cst", "relaxed", "acq_rel", NULL };
+      struct known_properties { const char *set; const char *selector;
+				const char *const *props; };
+      known_properties props[] = {
+	{ "device", "kind", kind },
+	{ "implementation", "vendor", vendor },
+	{ "implementation", "extension", extension },
+	{ "implementation", "atomic_default_mem_order",
+	  atomic_default_mem_order } };
+      for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
+	for (unsigned i = 0; i < ARRAY_SIZE (props); i++)
+	  if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
+					   props[i].selector)
+	      && !strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)),
+					      props[i].set))
+	    for (tree t2 = TREE_VALUE (t1); t2; t2 = TREE_CHAIN (t2))
+	      for (unsigned j = 0; ; j++)
+		{
+		  if (props[i].props[j] == NULL)
+		    {
+		      if (TREE_PURPOSE (t2)
+			  && !strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+				      " score"))
+			break;
+		      if (props[i].props == atomic_default_mem_order)
+			{
+			  error_at (loc,
+				    "incorrect property %qs of %qs selector",
+				    IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+				    "atomic_default_mem_order");
+			  return error_mark_node;
+			}
+		      else if (TREE_PURPOSE (t2))
+			warning_at (loc, 0,
+				    "unknown property %qs of %qs selector",
+				    IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+				    props[i].selector);
+		      else
+			warning_at (loc, 0,
+				    "unknown property %qE of %qs selector",
+				    TREE_VALUE (t2), props[i].selector);
+		      break;
+		    }
+		  else if (TREE_PURPOSE (t2) == NULL_TREE)
+		    {
+		      const char *str = TREE_STRING_POINTER (TREE_VALUE (t2));
+		      if (!strcmp (str, props[i].props[j])
+			  && ((size_t) TREE_STRING_LENGTH (TREE_VALUE (t2))
+			      == strlen (str) + (lang_GNU_Fortran () ? 0 : 1)))
+			break;
+		    }
+		  else if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+				    props[i].props[j]))
+		    break;
+		}
+    }
+  return ctx;
+}
+
+
+/* Register VARIANT as variant of some base function marked with
+   #pragma omp declare variant.  CONSTRUCT is corresponding construct
+   selector set.  */
+
+void
+omp_mark_declare_variant (location_t loc, tree variant, tree construct)
+{
+  tree attr = lookup_attribute ("omp declare variant variant",
+				DECL_ATTRIBUTES (variant));
+  if (attr == NULL_TREE)
+    {
+      attr = tree_cons (get_identifier ("omp declare variant variant"),
+			unshare_expr (construct),
+			DECL_ATTRIBUTES (variant));
+      DECL_ATTRIBUTES (variant) = attr;
+      return;
+    }
+  if ((TREE_VALUE (attr) != NULL_TREE) != (construct != NULL_TREE)
+      || (construct != NULL_TREE
+	  && omp_context_selector_set_compare ("construct", TREE_VALUE (attr),
+					       construct)))
+    error_at (loc, "%qD used as a variant with incompatible %<construct%> "
+		   "selector sets", variant);
+}
+
+
 /* Return a name from PROP, a property in selectors accepting
    name lists.  */
 
@@ -1106,7 +1246,8 @@ omp_context_name_list_prop (tree prop)
   else
     {
       const char *ret = TREE_STRING_POINTER (TREE_VALUE (prop));
-      if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop)) == strlen (ret) + 1)
+      if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop))
+	  == strlen (ret) + (lang_GNU_Fortran () ? 0 : 1))
 	return ret;
       return NULL;
     }