Fortran: Fixes to OpenMP 'interop' directive parsing support
Handle lists as argument to 'fr' and 'attr'; fix parsing corner cases.
Additionally, 'fr' values are now internally stored as integer, permitting
the diagnoses (warning) for values not defined in the OpenMP additional
definitions document.
PR fortran/116661
gcc/fortran/ChangeLog:
* gfortran.h (gfc_omp_namelist): Rename 'init' members for clarity.
* match.cc (gfc_free_omp_namelist): Handle renaming.
* dump-parse-tree.cc (show_omp_namelist): Update for new format
and features.
* openmp.cc (gfc_match_omp_prefer_type): Parse list to 'fr' and 'attr';
store 'fr' values as integer.
(gfc_match_omp_init): Rename variable names.
gcc/ChangeLog:
* omp-api.h (omp_get_fr_id_from_name, omp_get_name_from_fr_id): New
prototypes.
* omp-general.cc (omp_get_fr_id_from_name, omp_get_name_from_fr_id):
New.
include/ChangeLog:
* gomp-constants.h (GOMP_INTEROP_IFR_LAST,
GOMP_INTEROP_IFR_SEPARATOR, GOMP_INTEROP_IFR_NONE): New.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/interop-1.f90: Extend, update dg-*.
* gfortran.dg/gomp/interop-2.f90: Update dg-error.
* gfortran.dg/gomp/interop-3.f90: Add dg-warning.
gcc/fortran/dump-parse-tree.cc | 84 +++++---
gcc/fortran/gfortran.h | 4 +-
gcc/fortran/match.cc | 10 +-
gcc/fortran/openmp.cc | 305 ++++++++++++++++-----------
gcc/omp-api.h | 3 +
gcc/omp-general.cc | 29 +++
gcc/testsuite/gfortran.dg/gomp/interop-1.f90 | 32 ++-
gcc/testsuite/gfortran.dg/gomp/interop-2.f90 | 2 +-
gcc/testsuite/gfortran.dg/gomp/interop-3.f90 | 2 +-
include/gomp-constants.h | 5 +
10 files changed, 314 insertions(+), 162 deletions(-)
@@ -37,6 +37,8 @@ along with GCC; see the file COPYING3. If not see
#include "constructor.h"
#include "version.h"
#include "parse.h" /* For gfc_ascii_statement. */
+#include "omp-api.h" /* For omp_get_name_from_fr_id. */
+#include "gomp-constants.h" /* For GOMP_INTEROP_IFR_SEPARATOR. */
/* Keep track of indentation for symbol tree dumps. */
static int show_level = 0;
@@ -1537,35 +1539,69 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
}
else if (list_type == OMP_LIST_INIT)
{
- int i = 0;
if (n->u.init.target)
fputs ("target,", dumpfile);
if (n->u.init.targetsync)
fputs ("targetsync,", dumpfile);
- char *prefer_type = n->u.init.str;
- if (n->u.init.len)
- fputs ("prefer_type(", dumpfile);
- if (n->u.init.len)
- while (*prefer_type)
- {
- fputc ('{', dumpfile);
- if (n->u2.interop_int && n->u2.interop_int[i] != 0)
- fprintf (dumpfile, "fr(%d),", n->u2.interop_int[i]);
- else if (prefer_type[0] != ' ' || prefer_type[1] != '\0')
- fprintf (dumpfile, "fr(\"%s\"),", prefer_type);
- prefer_type += 1 + strlen (prefer_type);
-
- while (*prefer_type)
- {
- fprintf (dumpfile, "attr(\"%s\"),", prefer_type);
- prefer_type += 1 + strlen (prefer_type);
- }
- fputc ('}', dumpfile);
- ++prefer_type;
- ++i;
+ if (n->u2.init_interop_fr)
+ {
+ char *attr_str = n->u.init.attr;
+ int idx = 0;
+ int fr_id;
+ fputs ("prefer_type(", dumpfile);
+ do
+ {
+ fr_id = n->u2.init_interop_fr[idx];
+ fputc ('{', dumpfile);
+ if (fr_id != GOMP_INTEROP_IFR_NONE)
+ {
+ fputs ("fr(", dumpfile);
+ do
+ {
+ const char *fr_str = omp_get_name_from_fr_id (fr_id);
+ if (fr_str)
+ fprintf (dumpfile, "\"%s\"", fr_str);
+ else
+ fprintf (dumpfile, "%d", fr_id);
+ fr_id = n->u2.init_interop_fr[++idx];
+ if (fr_id != GOMP_INTEROP_IFR_SEPARATOR)
+ fputc (',', dumpfile);
+ }
+ while (fr_id != GOMP_INTEROP_IFR_SEPARATOR);
+ fputc (')', dumpfile);
+ if (attr_str && (attr_str[0] != ' ' || attr_str[1] != '\0'))
+ fputc (',', dumpfile);
+ }
+ else
+ fr_id = n->u2.init_interop_fr[++idx];
+ if (attr_str && attr_str[0] == ' ' && attr_str[1] == '\0')
+ attr_str += 2;
+ else if (attr_str)
+ {
+ fputs ("attr(\"", dumpfile);
+ do
+ {
+ fputs ((char *) attr_str, dumpfile);
+ fputc ('"', dumpfile);
+ attr_str += strlen (attr_str) + 1;
+ if (attr_str[0] == '\0')
+ break;
+ fputs (",\"", dumpfile);
+ }
+ while (true);
+ fputc (')', dumpfile);
+ }
+ fputc ('}', dumpfile);
+ fr_id = n->u2.init_interop_fr[++idx];
+ if (fr_id == GOMP_INTEROP_IFR_SEPARATOR)
+ break;
+ fputc (',', dumpfile);
+ if (attr_str)
+ ++attr_str;
+ }
+ while (true);
+ fputc (')', dumpfile);
}
- if (n->u.init.len)
- fputc (')', dumpfile);
fputc (':', dumpfile);
}
fprintf (dumpfile, "%s", n->sym ? n->sym->name : "omp_all_memory");
@@ -1389,7 +1389,7 @@ typedef struct gfc_omp_namelist
bool present_modifier;
struct
{
- char *str;
+ char *attr;
int len;
bool target;
bool targetsync;
@@ -1402,7 +1402,7 @@ typedef struct gfc_omp_namelist
gfc_expr *allocator;
struct gfc_symbol *traits_sym;
struct gfc_omp_namelist *duplicate_of;
- int *interop_int;
+ char *init_interop_fr;
} u2;
struct gfc_omp_namelist *next;
locus where;
@@ -5551,7 +5551,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
{
gfc_omp_namelist *n;
gfc_expr *last_allocator = NULL;
- char *last_init_str = NULL;
+ char *last_init_attr = NULL;
for (; name; name = n)
{
@@ -5575,11 +5575,11 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
{ } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */
else if (free_init)
{
- if (name->u.init.str != last_init_str)
+ if (name->u.init.attr != last_init_attr)
{
- last_init_str = name->u.init.str;
- free (name->u.init.str);
- free (name->u2.interop_int);
+ last_init_attr = name->u.init.attr;
+ free (name->u.init.attr);
+ free (name->u2.init_interop_fr);
}
}
else if (name->u2.udr)
@@ -1827,16 +1827,31 @@ error:
where 'fr' takes an integer named constant or a string literal
and 'attr takes a string literal, starting with 'ompx_')
-Document string + int format
-*/
+ For the foreign runtime identifiers, string values are converted to
+ their integer value; unknown string or integer values are set to 0.
+
+ For the simple syntax, pref_int_array contains alternatingly the
+ fr_id integer value and GOMP_INTEROP_IFR_SEPARATOR followed by a
+ GOMP_INTEROP_IFR_SEPARATOR as last item.
+ For the complex syntax, it contains the values associated with a
+ 'fr(...)' followed by GOMP_INTEROP_IFR_SEPARATOR. If there is no
+ 'fr' in a curly-brace block, it is GOMP_INTEROP_IFR_NONE followed
+ by GOMP_INTEROP_IFR_SEPARATOR. An additional GOMP_INTEROP_IFR_SEPARATOR
+ at the end terminates the array.
+
+ For attributes, if the simply syntax is used, it is NULL - likewise if no
+ 'attr' appears. For the complex syntax it is: For reach curly-brace block,
+ it is \0\0 is no attr appears and otherwise a concatenation (including
+ the \0) of all 'attr' strings followed by a tailing '\0'. At the end,
+ another '\0' follows. */
static match
-gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_array)
+gfc_match_omp_prefer_type (char **fr_int_array, char **attr_str, int *attr_str_len)
{
gfc_expr *e;
- size_t cnt = 0;
- std::vector<int> int_list;
- std::string pref_string;
+ int cnt_brace_grp = 0;
+ std::vector<char> int_list;
+ std::string attr_string;
/* New syntax. */
if (gfc_peek_ascii_char () == '{')
do
@@ -1846,8 +1861,8 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
gfc_error ("Expected %<{%> at %C");
return MATCH_ERROR;
}
- std::string attr;
bool fr_found = false;
+ bool attr_found = false;
do
{
if (gfc_match ("fr ( ") == MATCH_YES)
@@ -1859,99 +1874,129 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
return MATCH_ERROR;
}
fr_found = true;
- gfc_symbol *sym = NULL;
- e = NULL;
- locus loc = gfc_current_locus;
- if (gfc_match_symbol (&sym, 0) != MATCH_YES
- || gfc_match (" _") == MATCH_YES)
+ do
{
- gfc_current_locus = loc;
- if (gfc_match_expr (&e) == MATCH_ERROR)
+ if (gfc_match_expr (&e) != MATCH_YES)
return MATCH_ERROR;
- }
- if ((!sym && !e)
- || (e && (!gfc_resolve_expr (e)
- || e->expr_type != EXPR_CONSTANT
- || e->ts.type != BT_CHARACTER
- || e->ts.kind != gfc_default_character_kind
- || e->value.character.length == 0))
- || (sym && (sym->attr.flavor != FL_PARAMETER
- || sym->ts.type != BT_INTEGER
- || !mpz_fits_sint_p (sym->value->value.integer)
- || sym->attr.dimension)))
- {
- gfc_error ("Expected constant integer identifier or "
- "non-empty default-kind character literal at %L",
- &loc);
- gfc_free_expr (e);
+ if (e->expr_type != EXPR_CONSTANT
+ || e->ref != NULL
+ || !gfc_resolve_expr (e)
+ || (e->ts.type != BT_INTEGER
+ && e->ts.type != BT_CHARACTER)
+ || (e->ts.type == BT_INTEGER
+ && (!e->symtree
+ || e->symtree->n.sym->attr.flavor != FL_PARAMETER
+ || !mpz_fits_sint_p (e->value.integer)))
+ || (e->ts.type == BT_CHARACTER
+ && (e->ts.kind != gfc_default_character_kind
+ || e->value.character.length == 0)))
+ {
+ gfc_error ("Expected scalar integer parameter or "
+ "non-empty default-kind character literal "
+ "at %L", &e->where);
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+ gfc_gobble_whitespace ();
+ int val;
+ if (e->ts.type == BT_INTEGER)
+ {
+ val = mpz_get_si (e->value.integer);
+ if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
+ {
+ gfc_warning (OPT_Wopenmp,
+ "Unknown foreign runtime identifier "
+ "%qd at %L", val, &e->where);
+ val = 0;
+ }
+ }
+ else
+ {
+ char *str = XALLOCAVEC (char,
+ e->value.character.length+1);
+ for (int i = 0; i < e->value.character.length + 1; i++)
+ str[i] = e->value.character.string[i];
+ if (memchr (str, '\0', e->value.character.length) != 0)
+ {
+ gfc_error ("Unexpected null character in character "
+ "literal at %L", &e->where);
+ return MATCH_ERROR;
+ }
+ val = omp_get_fr_id_from_name (str);
+ if (val == 0)
+ gfc_warning (OPT_Wopenmp,
+ "Unknown foreign runtime identifier %qs "
+ "at %L", str, &e->where);
+ }
+ int_list.push_back (val);
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (") ") == MATCH_YES)
+ break;
+ gfc_error ("Expected %<,%> or %<)%> at %C");
return MATCH_ERROR;
}
- if (sym)
- {
- for (size_t i = int_list.size(); i < cnt; ++i)
- int_list.push_back (0);
- int_list.push_back (mpz_get_si (sym->value->value.integer));
- pref_string += ' ';
- pref_string += '\0';
- }
- else
- {
- char *str = XALLOCAVEC (char, e->value.character.length+1);
- for (int i = 0; i < e->value.character.length + 1; i++)
- str[i] = e->value.character.string[i];
- if (memchr (str, '\0', e->value.character.length) != 0)
- {
- gfc_error ("Unexpected null character in character "
- "literal at %L", &loc);
- return MATCH_ERROR;
- }
- pref_string += str;
- pref_string += '\0';
- }
+ while (true);
}
else if (gfc_match ("attr ( ") == MATCH_YES)
{
- locus loc = gfc_current_locus;
- if (gfc_match_expr (&e) != MATCH_YES
- || e->expr_type != EXPR_CONSTANT
- || e->ts.type != BT_CHARACTER)
- {
- gfc_error ("Expected default-kind character literal at %L",
- &loc);
- gfc_free_expr (e);
- return MATCH_ERROR;
- }
- char *str = XALLOCAVEC (char, e->value.character.length+1);
- for (int i = 0; i < e->value.character.length + 1; i++)
- str[i] = e->value.character.string[i];
- if (!startswith (str, "ompx_"))
- {
- gfc_error ("Character literal at %L must start with "
- "%<ompx_%>", &e->where);
- gfc_free_expr (e);
- return MATCH_ERROR;
- }
- if (memchr (str, '\0', e->value.character.length) != 0
- || memchr (str, ',', e->value.character.length) != 0)
+ attr_found = true;
+ if (attr_string.empty ())
+ for (int i = 0; i < cnt_brace_grp; ++i)
+ {
+ /* Add dummy elements for previous curly-brace blocks. */
+ attr_string += ' ';
+ attr_string += '\0';
+ attr_string += '\0';
+ }
+ do
{
- gfc_error ("Unexpected null or %<,%> character in "
- "character literal at %L", &e->where);
+ if (gfc_match_expr (&e) != MATCH_YES)
+ return MATCH_ERROR;
+ if (e->expr_type != EXPR_CONSTANT
+ || e->rank != 0
+ || e->ts.type != BT_CHARACTER
+ || e->ts.kind != gfc_default_character_kind)
+ {
+ gfc_error ("Expected default-kind character literal "
+ "at %L", &e->where);
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+ gfc_gobble_whitespace ();
+ char *str = XALLOCAVEC (char, e->value.character.length+1);
+ for (int i = 0; i < e->value.character.length + 1; i++)
+ str[i] = e->value.character.string[i];
+ if (!startswith (str, "ompx_"))
+ {
+ gfc_error ("Character literal at %L must start with "
+ "%<ompx_%>", &e->where);
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+ if (memchr (str, '\0', e->value.character.length) != 0
+ || memchr (str, ',', e->value.character.length) != 0)
+ {
+ gfc_error ("Unexpected null or %<,%> character in "
+ "character literal at %L", &e->where);
+ return MATCH_ERROR;
+ }
+ attr_string += str;
+ attr_string += '\0';
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (") ") == MATCH_YES)
+ break;
+ gfc_error ("Expected %<,%> or %<)%> at %C");
return MATCH_ERROR;
}
- attr += str;
- attr += '\0';
+ while (true);
}
else
{
gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
return MATCH_ERROR;
}
- ++cnt;
- if (gfc_match (") ") != MATCH_YES)
- {
- gfc_error ("Expected %<)%> at %C");
- return MATCH_ERROR;
- }
if (gfc_match (", ") == MATCH_YES)
continue;
if (gfc_match ("} ") == MATCH_YES)
@@ -1960,13 +2005,20 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
return MATCH_ERROR;
}
while (true);
+ ++cnt_brace_grp;
if (!fr_found)
+ int_list.push_back (GOMP_INTEROP_IFR_NONE);
+ int_list.push_back (GOMP_INTEROP_IFR_SEPARATOR);
+ if (!attr_string.empty ())
{
- pref_string += ' ';
- pref_string += '\0';
+ if (!attr_found)
+ {
+ /* Dummy entry. */
+ attr_string += ' ';
+ attr_string += '\0';
+ }
+ attr_string += '\0';
}
- pref_string += attr;
- pref_string += '\0';
if (gfc_match (", ") == MATCH_YES)
continue;
@@ -1982,6 +2034,7 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
if (gfc_match_expr (&e) != MATCH_YES)
return MATCH_ERROR;
if (!gfc_resolve_expr (e)
+ || e->rank != 0
|| e->expr_type != EXPR_CONSTANT
|| (e->ts.type != BT_INTEGER && e->ts.type != BT_CHARACTER)
|| (e->ts.type == BT_INTEGER
@@ -1990,17 +2043,23 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
&& (e->ts.kind != gfc_default_character_kind
|| e->value.character.length == 0)))
{
- gfc_error ("Expected constant integer expression or non-empty "
- "default-kind character literal at %L", &e->where);
+ gfc_error ("Expected constant scalar integer expression or "
+ "non-empty default-kind character literal at %L", &e->where);
gfc_free_expr (e);
return MATCH_ERROR;
}
+ gfc_gobble_whitespace ();
+ int val;
if (e->ts.type == BT_INTEGER)
{
- for (size_t i = int_list.size(); i < cnt; ++i)
- int_list.push_back (0);
- int_list.push_back (mpz_get_si (e->value.integer));
- pref_string += ' ';
+ val = mpz_get_si (e->value.integer);
+ if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
+ {
+ gfc_warning (OPT_Wopenmp,
+ "Unknown foreign runtime identifier %qd at %L",
+ val, &e->where);
+ val = 0;
+ }
}
else
{
@@ -2009,15 +2068,18 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
str[i] = e->value.character.string[i];
if (memchr (str, '\0', e->value.character.length) != 0)
{
- gfc_error ("Unexpected null character in character literal "
- "at %L", &e->where);
+ gfc_error ("Unexpected null character in character "
+ "literal at %L", &e->where);
return MATCH_ERROR;
}
- pref_string += str;
+ val = omp_get_fr_id_from_name (str);
+ if (val == 0)
+ gfc_warning (OPT_Wopenmp,
+ "Unknown foreign runtime identifier %qs at %L",
+ str, &e->where);
}
- pref_string += '\0';
- pref_string += '\0';
- ++cnt;
+ int_list.push_back (val);
+ int_list.push_back (GOMP_INTEROP_IFR_SEPARATOR);
gfc_free_expr (e);
if (gfc_match (", ") == MATCH_YES)
continue;
@@ -2027,19 +2089,16 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
return MATCH_ERROR;
}
while (true);
- if (!int_list.empty())
- for (size_t i = int_list.size(); i < cnt; ++i)
- int_list.push_back (0);
-
- pref_string += '\0';
+ int_list.push_back (GOMP_INTEROP_IFR_SEPARATOR);
+ *fr_int_array = XNEWVEC (char, int_list.size ());
+ memcpy (*fr_int_array, int_list.data (), sizeof (char) * int_list.size ());
- *pref_str_len = pref_string.length();
- *pref_str = XNEWVEC (char, pref_string.length ());
- memcpy (*pref_str, pref_string.data (), pref_string.length ());
- if (!int_list.empty ())
+ if (!attr_string.empty ())
{
- *pref_int_array = XNEWVEC (int, cnt);
- memcpy (*pref_int_array, int_list.data (), sizeof (int) * cnt);
+ attr_string += '\0';
+ *attr_str_len = attr_string.length();
+ *attr_str = XNEWVEC (char, attr_string.length ());
+ memcpy (*attr_str, attr_string.data (), attr_string.length ());
}
return MATCH_YES;
}
@@ -2052,21 +2111,21 @@ static match
gfc_match_omp_init (gfc_omp_namelist **list)
{
bool target = false, targetsync = false;
- char *pref_str = NULL;
- int pref_str_len = 0;
- int *pref_int_array = NULL;
+ char *fr_int_array = NULL;
+ char *attr_str = NULL;
+ int attr_str_len = 0;
match m;
locus old_loc = gfc_current_locus;
do {
if (gfc_match ("prefer_type ( ") == MATCH_YES)
{
- if (pref_str)
+ if (fr_int_array)
{
gfc_error ("Duplicate %<prefer_type%> modifier at %C");
return MATCH_ERROR;
}
- m = gfc_match_omp_prefer_type (&pref_str, &pref_str_len,
- &pref_int_array);
+ m = gfc_match_omp_prefer_type (&fr_int_array, &attr_str,
+ &attr_str_len);
if (m != MATCH_YES)
return m;
if (gfc_match (", ") == MATCH_YES)
@@ -2084,7 +2143,7 @@ gfc_match_omp_init (gfc_omp_namelist **list)
if (gfc_match (": ") == MATCH_YES)
break;
gfc_char_t c = gfc_peek_char ();
- if (!pref_str
+ if (!fr_int_array
&& (c == ')'
|| (gfc_current_form != FORM_FREE
&& (c == '_' || ISALPHA (c)))))
@@ -2103,7 +2162,7 @@ gfc_match_omp_init (gfc_omp_namelist **list)
if (gfc_match (": ") == MATCH_YES)
break;
gfc_char_t c = gfc_peek_char ();
- if (!pref_str
+ if (!fr_int_array
&& (c == ')'
|| (gfc_current_form != FORM_FREE
&& (c == '_' || ISALPHA (c)))))
@@ -2114,7 +2173,7 @@ gfc_match_omp_init (gfc_omp_namelist **list)
gfc_error ("Expected %<,%> or %<:%> at %C");
return MATCH_ERROR;
}
- if (pref_str)
+ if (fr_int_array)
{
gfc_error ("Expected %<target%> or %<targetsync%> at %C");
return MATCH_ERROR;
@@ -2131,9 +2190,9 @@ gfc_match_omp_init (gfc_omp_namelist **list)
{
n->u.init.target = target;
n->u.init.targetsync = targetsync;
- n->u.init.str = pref_str;
- n->u.init.len = pref_str_len;
- n->u2.interop_int = pref_int_array;
+ n->u.init.attr = attr_str;
+ n->u.init.len = attr_str_len;
+ n->u2.init_interop_fr = fr_int_array;
}
return MATCH_YES;
}
@@ -29,4 +29,7 @@ along with GCC; see the file COPYING3. If not see
extern bool omp_runtime_api_procname (const char *name);
extern bool omp_runtime_api_call (const_tree fndecl);
+extern int omp_get_fr_id_from_name (const char *);
+extern const char *omp_get_name_from_fr_id (int);
+
#endif
@@ -3385,6 +3385,35 @@ omp_runtime_api_call (const_tree fndecl)
return omp_runtime_api_procname (IDENTIFIER_POINTER (declname));
}
+/* See "Additional Definitions for the OpenMP API Specification" document;
+ associated IDs are 1, 2, ... */
+static const char* omp_interop_fr_str[] = {"cuda", "cuda_driver", "opencl",
+ "sycl", "hip", "level_zero", "hsa"};
+
+/* Returns the foreign-runtime ID if found or 0 otherwise. */
+
+int
+omp_get_fr_id_from_name (const char *str)
+{
+ static_assert (GOMP_INTEROP_IFR_LAST == ARRAY_SIZE (omp_interop_fr_str), "");
+
+ for (unsigned i = 0; i < ARRAY_SIZE (omp_interop_fr_str); ++i)
+ if (!strcmp (str, omp_interop_fr_str[i]))
+ return i + 1;
+ return 0;
+}
+
+/* Returns the string value to a foreign-runtime integer value or NULL if value
+ is not known. */
+
+const char *
+omp_get_name_from_fr_id (int fr_id)
+{
+ if (fr_id < 1 || fr_id > (int) ARRAY_SIZE (omp_interop_fr_str))
+ return NULL;
+ return omp_interop_fr_str[fr_id-1];
+}
+
namespace omp_addr_tokenizer {
/* We scan an expression by recursive descent, and build a vector of
@@ -28,6 +28,8 @@ implicit none
!$omp requires reverse_offload
+integer(omp_interop_fr_kind), parameter :: ifr_array(2) = [omp_ifr_cuda, omp_ifr_hip]
+
integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5
integer :: x
@@ -37,7 +39,7 @@ integer :: x
!$omp& destroy(obj2, obj3) depend(inout: x) use(obj4, obj5) device(device_num: 0)
!$omp assume contains(interop)
- !$omp interop init(prefer_type("cu"//char(1)//"da") : obj3)
+ !$omp interop init(prefer_type("cu"//char(1)//"da") : obj3) ! { dg-warning "Unknown foreign runtime identifier 'cu\\\\x01da'" }
!$omp end assume
!$omp interop init(prefer_type("cu"//char(0)//"da") : obj3) ! { dg-error "Unexpected null character in character literal" }
@@ -52,11 +54,29 @@ integer :: x
!$omp interop init ( target , prefer_type( { fr("hsa"), attr("ompx_nothing") , fr("hsa" ) }) :obj1) ! { dg-error "Duplicated 'fr' preference-selector-name" }
-!$omp interop init ( prefer_type( 4, omp_ifr_hip*4) : obj1)
-!$omp interop init ( prefer_type( sin(3.3) : obj1) ! { dg-error "Expected constant integer expression or non-empty default-kind character literal" }
-!$omp interop init ( prefer_type( {fr(4) }) : obj1) ! { dg-error "Expected constant integer identifier or non-empty default-kind character literal" }
-!$omp interop init ( prefer_type( {fr(4_"cuda") }) : obj1) ! { dg-error "Expected constant integer identifier or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( 4, omp_ifr_hip*4) : obj1) ! { dg-warning "Unknown foreign runtime identifier '20'" }
+!$omp interop init ( prefer_type( sin(3.3) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(4 ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(4_"cuda" ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
!$omp interop init ( prefer_type( {fr(c_char_"cuda") }) : obj1) ! OK
-!$omp interop init ( prefer_type( {fr(1_"cuda") }) : obj1) ! OK
+!$omp interop init ( prefer_type( {fr(1_"cuda" ) }) : obj1) ! OK
+!$omp interop init ( prefer_type( {fr(omp_ifr_level_zero ) }, {fr(omp_ifr_hip)}) : obj1) ! OK
+!$omp interop init ( prefer_type( {fr(omp_ifr_level_zero + 1) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(x) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(ifr_array ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(ifr_array(1) ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
+
+!$omp interop init ( prefer_type( omp_ifr_level_zero, omp_ifr_hip ) : obj1) ! OK
+!$omp interop init ( prefer_type( omp_ifr_level_zero +1 ) : obj1) ! OK
+!$omp interop init ( prefer_type( x ) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( ifr_array ) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( ifr_array(2) ) : obj1) ! OK
+
+!$omp interop init ( prefer_type( 4, omp_ifr_hip*4) : obj1) ! { dg-warning "Unknown foreign runtime identifier '20'" }
+!$omp interop init ( prefer_type( 4, 1, 3) : obj1)
+
+!$omp interop init ( prefer_type( {fr("cuda","sycl") }, {fr(omp_ifr_hsa,omp_ifr_level_zero)} , {attr("ompx_a") } , {fr(omp_ifr_hip) }) : obj1)
+!$omp interop init ( prefer_type( {fr("cuda","sycl"), attr("ompx_1", "ompx_2"), attr("ompx_3") }, {attr("ompx_4", "ompx_5"),fr(omp_ifr_hsa,omp_ifr_level_zero)} ) : obj1)
+!$omp interop init ( prefer_type( { fr("cuda","sycl"), attr("ompx_1") }, {fr(omp_ifr_hsa,omp_ifr_level_zero)} , {attr("ompx_a") } ) : obj1)
end
@@ -26,7 +26,7 @@ implicit none
integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5
integer :: x
-!$omp interop init ( prefer_type( {fr(1_"") }) : obj1) ! { dg-error "Expected constant integer identifier or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(1_"") }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
!$omp interop init ( prefer_type( {fr(1_"hip") , attr(omp_ifr_cuda) }) : obj1) ! { dg-error "Expected default-kind character literal" }
!$omp interop init ( prefer_type( {fr(1_"hip") , attr("myooption") }) : obj1) ! { dg-error "Character literal at .1. must start with 'ompx_'" }
@@ -33,7 +33,7 @@ integer :: x
!$omp& destroy(obj2, obj3) depend(inout: x) use(obj4, obj5) device(device_num: 0)
!$omp assume contains(interop)
- !$omp interop init(prefer_type("cu"//char(1)//"da") : obj3)
+ !$omp interop init(prefer_type("cu"//char(1)//"da") : obj3) ! { dg-warning "Unknown foreign runtime identifier 'cu\\\\x01da'" }
!$omp end assume
!$omp interop init(obj1, obj2, obj1), use(obj4) destroy(obj4)
@@ -388,6 +388,11 @@ enum gomp_map_kind
#define GOMP_REQUIRES_REVERSE_OFFLOAD 0x80
#define GOMP_REQUIRES_TARGET_USED 0x200
+/* Interop foreign-runtime data. */
+#define GOMP_INTEROP_IFR_LAST 7
+#define GOMP_INTEROP_IFR_SEPARATOR -1
+#define GOMP_INTEROP_IFR_NONE -2
+
/* HSA specific data structures. */
/* Identifiers of device-specific target arguments. */
This patch fixes a couple of issues, like a missing white-space gobbling after matching an expression. It also reorganizes some code to handle 'identifier_"string"' vs. 'identifier' better as there were some diagnostic issues. (OpenMP requires for 'fr' that the argument is either an identifier (that is a scalar integer parameter) or a string; while for the older syntax, it can be any constant integer expression.) However, the two main changes are: * 'fr' and 'attr' actually support a list of arguments. While I believe 'attr("x", "y") and "attr("x"),attr("y")' are semantically identically, supporting more than one (or zero) values for 'fr' required a different encoding. * Jakub additionally suggested that for 'fr', which supports constant integers and string literals, we could pass on integer values – and do some checking. That's what this patch does: Known string values are converted to their associated integer values, others to 0. And if the integer/string value is unknown, a warning is printed [-Wopenmp]. Known values are those in the "OpenMP API Additional Definitions" document, https://www.openmp.org/specifications/ – with the addition of hsa / 7, which has been voted at spec level (no idea about ARB level) but not yet published. Note that that's the warning is based on what is defined there, i.e. 'level_zero' there is no warning, even though GCC does not support it. Obviously, if will add another value next year, GCC 15 will not support it and warn, even if the code is perfectly valid. — But I guess we can live with a warning in that case. Comments, remarks, suggestions? — Especially regarding the internal representation? Tobias PS: Next step will be to get the C/C++ parsing working, which also implies encoding this representation into 'tree'. (Then doing the tree conversion for Fortran.) Once satisfied with that, the middle end + libgomp part that links those bits will come next. And the question whether there should be one call per 'interop' directive or might be multiple (e.g. one per interop object in 'init'/'use'/'destroy').