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.
This commit is contained in:
Tobias Burnus
parent
508ef58524
commit
99988464fc
10 changed files with 314 additions and 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)
|
||||
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 ("Expected default-kind character literal at %L",
|
||||
&loc);
|
||||
gfc_free_expr (e);
|
||||
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;
|
||||
}
|
||||
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 += 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);
|
||||
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_string += '\0';
|
||||
|
||||
*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. */
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue