2016-11-11 Cesar Philippidis <cesar@codesourcery.com>
gcc/fortran/
* gfortran.h (enum oacc_function): Make OACC_FUNCTION_SEQ the last
entry the enum.
(oacc_function_types): Declare.
(symbol_attribute): Add oacc_function, oacc_function_nohost members.
(gfc_omp_clauses): Add routine_bind, nohost, bind members.
(gfc_oacc_routine_name): Add loc.
(gfc_resolve_oacc_routine_call): Declare.
(gfc_resolve_oacc_routines): Declare.
* module.c (oacc_function): New DECL_MIO_NAME.
(mio_symbol_attribute): Set the oacc_function attribute.
* openmp.c (enum omp_mask2): Add OMP_CLAUSE_BIND and OMP_CLAUSE_NOHOST.
(gfc_match_omp_clauses): Likewise.
(OACC_ROUTINE_CLAUSES): Add OMP_CLAUSE_BIND and OMP_CLAUSE_NOHOST.
(gfc_oacc_routine_dims): Change the type of oacc_function from unsigned
to an ENUM_BITFIELD.Move gfc_error to gfc_match_oacc_routine. Return
OACC_FUNCTION_NONE on error.
(gfc_match_oacc_routine): Make error reporting more
precise. Defer rejection of non-function and subroutine symbols
until gfc_resolve_oacc_routines.
(struct fortran_omp_context): Add a dims member.
(gfc_resolve_oacc_blocks): Update ctx->dims.
(gfc_resolve_oacc_routine_call): New function.
(gfc_resolve_oacc_routines): New function.
* resolve.c (resolve_function): Call gfc_resolve_oacc_routine_call.
(resolve_call): Likewise.
(resolve_codes): Call gfc_resolve_oacc_routines.
* symbol.c (oacc_function_types): Define.
* trans-decl.c (add_attributes_to_decl): Update to handle the
retyped oacc_function attribute.
@@ -314,6 +314,15 @@ enum save_state
{ SAVE_NONE = 0, SAVE_EXPLICIT, SAVE_IMPLICIT
};
+/* Flags to keep track of ACC routine states. */
+enum oacc_function
+{ OACC_FUNCTION_NONE = 0,
+ OACC_FUNCTION_GANG,
+ OACC_FUNCTION_WORKER,
+ OACC_FUNCTION_VECTOR,
+ OACC_FUNCTION_SEQ
+};
+
/* Strings for all symbol attributes. We use these for dumping the
parse tree, in error messages, and also when reading and writing
modules. In symbol.c. */
@@ -323,6 +332,7 @@ extern const mstring intents[];
extern const mstring access_types[];
extern const mstring ifsrc_types[];
extern const mstring save_status[];
+extern const mstring oacc_function_types[];
/* Strings for DTIO procedure names. In symbol.c. */
extern const mstring dtio_procs[];
@@ -882,7 +892,8 @@ typedef struct
unsigned oacc_declare_link:1;
/* This is an OpenACC acclerator function at level N - 1 */
- unsigned oacc_function:3;
+ ENUM_BITFIELD (oacc_function) oacc_function:3;
+ unsigned oacc_function_nohost:1;
/* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */
unsigned ext_attr:EXT_ATTR_NUM;
@@ -1310,10 +1321,11 @@ typedef struct gfc_omp_clauses
struct gfc_expr *num_gangs_expr;
struct gfc_expr *num_workers_expr;
struct gfc_expr *vector_length_expr;
+ struct gfc_symbol *routine_bind;
gfc_expr_list *wait_list;
gfc_expr_list *tile_list;
unsigned async:1, gang:1, worker:1, vector:1, seq:1, independent:1;
- unsigned wait:1, par_auto:1, gang_static:1;
+ unsigned wait:1, par_auto:1, gang_static:1, nohost:1, bind:1;
locus loc;
}
@@ -1691,6 +1703,7 @@ typedef struct gfc_oacc_routine_name
struct gfc_symbol *sym;
struct gfc_omp_clauses *clauses;
struct gfc_oacc_routine_name *next;
+ locus loc;
}
gfc_oacc_routine_name;
@@ -3067,6 +3080,8 @@ void gfc_resolve_oacc_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_oacc_declare (gfc_namespace *);
void gfc_resolve_oacc_parallel_loop_blocks (gfc_code *, gfc_namespace *);
void gfc_resolve_oacc_blocks (gfc_code *, gfc_namespace *);
+void gfc_resolve_oacc_routine_call (gfc_symbol *, locus *);
+void gfc_resolve_oacc_routines (gfc_namespace *);
/* expr.c */
void gfc_free_actual_arglist (gfc_actual_arglist *);
@@ -2097,6 +2097,7 @@ DECL_MIO_NAME (procedure_type)
DECL_MIO_NAME (ref_type)
DECL_MIO_NAME (sym_flavor)
DECL_MIO_NAME (sym_intent)
+DECL_MIO_NAME (oacc_function)
#undef DECL_MIO_NAME
/* Symbol attributes are stored in list with the first three elements
@@ -2118,6 +2119,8 @@ mio_symbol_attribute (symbol_attribute *attr)
attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
attr->save = MIO_NAME (save_state) (attr->save, save_status);
+ attr->oacc_function = MIO_NAME (oacc_function) (attr->oacc_function,
+ oacc_function_types);
ext_attr = attr->ext_attr;
mio_integer ((int *) &ext_attr);
@@ -6166,11 +6169,9 @@ create_intrinsic_function (const char *name, int id,
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (tmp_symtree)
{
- if (tmp_symtree->n.sym && tmp_symtree->n.sym->module
- && strcmp (modname, tmp_symtree->n.sym->module) == 0)
- return;
- gfc_error ("Symbol %qs at %C already declared", name);
- return;
+ if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+ return;
+ gfc_error ("Symbol %qs already declared", name);
}
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
@@ -813,6 +813,8 @@ enum omp_mask2
OMP_CLAUSE_DELETE,
OMP_CLAUSE_AUTO,
OMP_CLAUSE_TILE,
+ OMP_CLAUSE_BIND,
+ OMP_CLAUSE_NOHOST,
/* This must come last. */
OMP_MASK2_LAST
};
@@ -1015,6 +1017,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
continue;
}
break;
+ case 'b':
+ if ((mask & OMP_CLAUSE_BIND) && c->routine_bind == NULL
+ && gfc_match ("bind ( %s )", &c->routine_bind) == MATCH_YES)
+ {
+ c->bind = 1;
+ continue;
+ }
+ break;
case 'c':
if ((mask & OMP_CLAUSE_COLLAPSE)
&& !c->collapse)
@@ -1434,6 +1444,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
c->nogroup = needs_space = true;
continue;
}
+ if ((mask & OMP_CLAUSE_NOHOST) && !c->nohost
+ && gfc_match ("nohost") == MATCH_YES)
+ {
+ c->nohost = true;
+ continue;
+ }
if ((mask & OMP_CLAUSE_NOTINBRANCH)
&& !c->notinbranch
&& !c->inbranch
@@ -1975,7 +1991,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
omp_mask (OMP_CLAUSE_ASYNC)
#define OACC_ROUTINE_CLAUSES \
(omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
- | OMP_CLAUSE_SEQ)
+ | OMP_CLAUSE_SEQ | OMP_CLAUSE_BIND | OMP_CLAUSE_NOHOST)
static match
@@ -2232,44 +2248,55 @@ gfc_match_oacc_cache (void)
return MATCH_YES;
}
-/* Determine the loop level for a routine. */
+/* Determine the loop level for a routine. Returns OACC_FUNCTION_NONE
+ if any error is detected. */
-static int
+static oacc_function
gfc_oacc_routine_dims (gfc_omp_clauses *clauses)
{
int level = -1;
+ oacc_function ret = OACC_FUNCTION_SEQ;
if (clauses)
{
unsigned mask = 0;
if (clauses->gang)
- level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level);
+ {
+ level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level);
+ ret = OACC_FUNCTION_GANG;
+ }
if (clauses->worker)
- level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level);
+ {
+ level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level);
+ ret = OACC_FUNCTION_WORKER;
+ }
if (clauses->vector)
- level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level);
+ {
+ level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level);
+ ret = OACC_FUNCTION_VECTOR;
+ }
if (clauses->seq)
level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level);
if (mask != (mask & -mask))
- gfc_error ("Multiple loop axes specified for routine");
+ ret = OACC_FUNCTION_NONE;
}
- if (level < 0)
- level = GOMP_DIM_MAX;
-
- return level;
+ return ret;
}
match
gfc_match_oacc_routine (void)
{
locus old_loc;
- gfc_symbol *sym = NULL;
match m;
+ gfc_intrinsic_sym *isym = NULL;
+ gfc_symbol *sym = NULL;
gfc_omp_clauses *c = NULL;
gfc_oacc_routine_name *n = NULL;
+ oacc_function dims = OACC_FUNCTION_NONE;
+ bool seen_error = false;
old_loc = gfc_current_locus;
@@ -2287,45 +2314,52 @@ gfc_match_oacc_routine (void)
if (m == MATCH_YES)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symtree *st;
+ gfc_symtree *st = NULL;
m = gfc_match_name (buffer);
if (m == MATCH_YES)
{
- st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+ if ((isym = gfc_find_function (buffer)) == NULL
+ && (isym = gfc_find_subroutine (buffer)) == NULL)
+ {
+ st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+ if (st == NULL && gfc_current_ns->proc_name->attr.contained
+ && gfc_current_ns->parent)
+ st = gfc_find_symtree (gfc_current_ns->parent->sym_root,
+ buffer);
+ }
if (st)
{
sym = st->n.sym;
if (strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
sym = NULL;
}
-
- if (st == NULL
- || (sym
- && !sym->attr.external
- && !sym->attr.function
- && !sym->attr.subroutine))
+ else if (isym == NULL)
{
- gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
- "invalid function name %s",
- (sym) ? sym->name : buffer);
- gfc_current_locus = old_loc;
- return MATCH_ERROR;
+ gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, "
+ "invalid function name %qs", &old_loc, buffer);\
+ goto cleanup;
+
}
+
+ /* Set sym to NULL if it matches the current procedure's
+ name. This will simplify the check for duplicate ACC
+ ROUTINE attributes. */
+ if (gfc_current_ns->proc_name
+ && !strcmp (buffer, gfc_current_ns->proc_name->name))
+ sym = NULL;
}
else
{
- gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
- gfc_current_locus = old_loc;
- return MATCH_ERROR;
+ gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L", &old_loc);
+ goto cleanup;
}
if (gfc_match_char (')') != MATCH_YES)
{
- gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
- " ')' after NAME");
- gfc_current_locus = old_loc;
- return MATCH_ERROR;
+ gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, expecting"
+ " ')' after NAME", &old_loc);
+ goto cleanup;
}
}
@@ -2334,26 +2368,89 @@ gfc_match_oacc_routine (void)
!= MATCH_YES))
return MATCH_ERROR;
- if (sym != NULL)
+ /* Scan for invalid routine geometry. */
+ dims = gfc_oacc_routine_dims (c);
+ if (dims == OACC_FUNCTION_NONE)
+ {
+ gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %L",
+ &old_loc);
+
+ /* Don't abort early, because it's important to let the user
+ know of any potential duplicate routine directives. */
+ seen_error = true;
+ }
+
+ if (isym != NULL)
{
- n = gfc_get_oacc_routine_name ();
- n->sym = sym;
- n->clauses = NULL;
- n->next = NULL;
- if (gfc_current_ns->oacc_routine_names != NULL)
- n->next = gfc_current_ns->oacc_routine_names;
-
- gfc_current_ns->oacc_routine_names = n;
+ if (c && (c->gang || c->worker || c->vector))
+ {
+ gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME ) "
+ "at %L, with incompatible clauses specifying the level "
+ "of parallelism", &old_loc);
+ goto cleanup;
+ }
+ /* The intrinsic symbol has been marked with a SEQ, or with no clause at
+ all, which is OK. */
+ }
+ else if (sym != NULL)
+ {
+ bool needs_entry = true;
+
+ /* Scan for any repeated routine directives on 'sym' and report
+ an error if necessary. TODO: Extend this function to scan
+ for compatible DEVICE_TYPE dims. */
+ for (n = gfc_current_ns->oacc_routine_names; n; n = n->next)
+ if (n->sym == sym)
+ {
+ needs_entry = false;
+ if (dims != gfc_oacc_routine_dims (n->clauses))
+ {
+ gfc_error ("$!ACC ROUTINE already applied at %L", &old_loc);
+ goto cleanup;
+ }
+ }
+
+ if (needs_entry)
+ {
+ n = gfc_get_oacc_routine_name ();
+ n->sym = sym;
+ n->clauses = c;
+ n->next = NULL;
+ n->loc = old_loc;
+
+ if (gfc_current_ns->oacc_routine_names != NULL)
+ n->next = gfc_current_ns->oacc_routine_names;
+
+ gfc_current_ns->oacc_routine_names = n;
+ }
+
+ if (seen_error)
+ goto cleanup;
}
else if (gfc_current_ns->proc_name)
{
+ if (gfc_current_ns->proc_name->attr.oacc_function != OACC_FUNCTION_NONE
+ && !seen_error)
+ {
+ gfc_error ("!$ACC ROUTINE already applied at %L", &old_loc);
+ goto cleanup;
+ }
+
if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
gfc_current_ns->proc_name->name,
&old_loc))
goto cleanup;
+
gfc_current_ns->proc_name->attr.oacc_function
- = gfc_oacc_routine_dims (c) + 1;
+ = seen_error ? OACC_FUNCTION_SEQ : dims;
+ gfc_current_ns->proc_name->attr.oacc_function_nohost
+ = c ? c->nohost : false;
+
+ if (seen_error)
+ goto cleanup;
}
+ else
+ gcc_unreachable ();
if (n)
n->clauses = c;
@@ -5263,6 +5360,7 @@ struct fortran_omp_context
hash_set<gfc_symbol *> *private_iterators;
struct fortran_omp_context *previous;
bool is_openmp;
+ oacc_function dims;
} *omp_current_ctx;
static gfc_code *omp_current_do_code;
static int omp_current_do_collapse;
@@ -5926,6 +6024,7 @@ void
gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
{
fortran_omp_context ctx;
+ oacc_function dims = OACC_FUNCTION_NONE;
resolve_oacc_loop_blocks (code);
@@ -5934,6 +6033,21 @@ gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
ctx.private_iterators = new hash_set<gfc_symbol *>;
ctx.previous = omp_current_ctx;
ctx.is_openmp = false;
+
+ if (code->ext.omp_clauses->gang)
+ dims = OACC_FUNCTION_GANG;
+ if (code->ext.omp_clauses->worker)
+ dims = OACC_FUNCTION_WORKER;
+ if (code->ext.omp_clauses->vector)
+ dims = OACC_FUNCTION_VECTOR;
+ if (code->ext.omp_clauses->seq)
+ dims = OACC_FUNCTION_SEQ;
+
+ if (dims == OACC_FUNCTION_NONE && ctx.previous != NULL
+ && !ctx.previous->is_openmp)
+ dims = ctx.previous->dims;
+
+ ctx.dims = dims;
omp_current_ctx = &ctx;
gfc_resolve_blocks (code->block, ns);
@@ -6285,3 +6399,54 @@ gfc_resolve_omp_udrs (gfc_symtree *st)
for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
gfc_resolve_omp_udr (omp_udr);
}
+
+/* Ensure that any calls to OpenACC routines respects the current
+ level of parallelism of the innermost loop. */
+
+void
+gfc_resolve_oacc_routine_call (gfc_symbol *sym, locus *loc)
+{
+ gfc_oacc_routine_name *n = NULL;
+ oacc_function loop_dims = OACC_FUNCTION_NONE;
+ oacc_function routine_dims;
+
+ if (!omp_current_ctx)
+ return;
+
+ loop_dims = omp_current_ctx->dims;
+
+ if (omp_current_ctx->is_openmp || loop_dims == OACC_FUNCTION_NONE)
+ return;
+
+ for (n = gfc_current_ns->oacc_routine_names; n; n = n->next)
+ if (n->sym == sym)
+ break;
+
+ if (n == NULL)
+ return;
+
+ routine_dims = gfc_oacc_routine_dims (n->clauses);
+
+ if (routine_dims == OACC_FUNCTION_SEQ)
+ return;
+ if (routine_dims <= loop_dims)
+ gfc_error ("Insufficient !$ACC LOOP parallelism available to call "
+ "%qs at %L", sym->name, loc);
+}
+
+void
+gfc_resolve_oacc_routines (gfc_namespace *ns)
+{
+ gfc_oacc_routine_name *routines = NULL;
+
+ for (routines = ns->oacc_routine_names; routines; routines = routines->next)
+ {
+ gfc_symbol *sym = routines->sym;
+
+ if (!sym->attr.external
+ && !sym->attr.function
+ && !sym->attr.subroutine)
+ gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, "
+ "invalid function name %qs", &routines->loc, sym->name);
+ }
+}
@@ -3153,6 +3153,11 @@ resolve_function (gfc_expr *expr)
/* typebound procedure: Assume the worst. */
gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
+ /* Calls to OpenACC routines have imposed restrictions on gang,
+ worker and vector parallelism. */
+ if (sym)
+ gfc_resolve_oacc_routine_call (sym, &expr->where);
+
return t;
}
@@ -3496,6 +3501,11 @@ resolve_call (gfc_code *c)
/* Typebound procedure: Assume the worst. */
gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
+ /* Calls to OpenACC routines have imposed restrictions on gang,
+ worker and vector parallelism. */
+ if (csym)
+ gfc_resolve_oacc_routine_call (csym, &c->loc);
+
return t;
}
@@ -16024,6 +16034,7 @@ resolve_codes (gfc_namespace *ns)
bitmap_obstack_initialize (&labels_obstack);
gfc_resolve_oacc_declare (ns);
+ gfc_resolve_oacc_routines (ns);
gfc_resolve_code (ns->code, ns);
bitmap_obstack_release (&labels_obstack);
@@ -96,6 +96,15 @@ const mstring dtio_procs[] =
minit ("_dtio_unformatted_write", DTIO_WUF),
};
+const mstring oacc_function_types[] =
+{
+ minit ("NONE", OACC_FUNCTION_NONE),
+ minit ("OACC_FUNCTION_SEQ", OACC_FUNCTION_SEQ),
+ minit ("OACC_FUNCTION_GANG", OACC_FUNCTION_GANG),
+ minit ("OACC_FUNCTION_WORKER", OACC_FUNCTION_WORKER),
+ minit ("OACC_FUNCTION_VECTOR", OACC_FUNCTION_VECTOR)
+};
+
/* This is to make sure the backend generates setup code in the correct
order. */
@@ -46,6 +46,7 @@ along with GCC; see the file COPYING3. If not see
#include "trans-stmt.h"
#include "gomp-constants.h"
#include "gimplify.h"
+#include "omp-low.h"
#define MAX_LABEL_VALUE 99999
@@ -1380,19 +1381,38 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list)
list = tree_cons (get_identifier ("omp declare target link"),
NULL_TREE, list);
else if (sym_attr.omp_declare_target)
- list = tree_cons (get_identifier ("omp declare target"),
- NULL_TREE, list);
-
- if (sym_attr.oacc_function)
{
- tree dims = NULL_TREE;
- int ix;
- int level = sym_attr.oacc_function - 1;
+ tree c = NULL_TREE;
+ if (sym_attr.oacc_function_nohost)
+ c = build_omp_clause (/* TODO */ input_location,
+ OMP_CLAUSE_NOHOST);
+ list = tree_cons (get_identifier ("omp declare target"), c, list);
+ }
+ if (sym_attr.oacc_function)
- for (ix = GOMP_DIM_MAX; ix--;)
- dims = tree_cons (build_int_cst (boolean_type_node, ix >= level),
- integer_zero_node, dims);
+ if (sym_attr.oacc_function != OACC_FUNCTION_NONE)
+ {
+ omp_clause_code code = OMP_CLAUSE_ERROR;
+ tree clause, dims;
+
+ switch (sym_attr.oacc_function)
+ {
+ case OACC_FUNCTION_GANG:
+ code = OMP_CLAUSE_GANG;
+ break;
+ case OACC_FUNCTION_WORKER:
+ code = OMP_CLAUSE_WORKER;
+ break;
+ case OACC_FUNCTION_VECTOR:
+ code = OMP_CLAUSE_VECTOR;
+ break;
+ case OACC_FUNCTION_SEQ:
+ default:
+ code = OMP_CLAUSE_SEQ;
+ }
+ clause = build_omp_clause (UNKNOWN_LOCATION, code);
+ dims = build_oacc_routine_dims (clause);
list = tree_cons (get_identifier ("oacc function"),
dims, list);
}