@@ -2570,12 +2570,16 @@ show_namespace (gfc_namespace *ns)
for (eq = ns->equiv; eq; eq = eq->next)
show_equiv (eq);
- if (ns->oacc_declare_clauses)
+ if (ns->oacc_declare)
{
+ struct gfc_oacc_declare *decl;
/* Dump !$ACC DECLARE clauses. */
- show_indent ();
- fprintf (dumpfile, "!$ACC DECLARE");
- show_omp_clauses (ns->oacc_declare_clauses);
+ for (decl = ns->oacc_declare; decl; decl = decl->next)
+ {
+ show_indent ();
+ fprintf (dumpfile, "!$ACC DECLARE");
+ show_omp_clauses (decl->clauses);
+ }
}
fputc ('\n', dumpfile);
@@ -222,6 +222,7 @@ typedef enum
ST_OACC_END_LOOP, ST_OACC_DECLARE, ST_OACC_UPDATE, ST_OACC_WAIT,
ST_OACC_CACHE, ST_OACC_KERNELS_LOOP, ST_OACC_END_KERNELS_LOOP,
ST_OACC_ENTER_DATA, ST_OACC_EXIT_DATA, ST_OACC_ROUTINE,
+ ST_OACC_ATOMIC, ST_OACC_END_ATOMIC,
ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_ATOMIC,
ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED,
ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS,
@@ -1242,10 +1243,14 @@ 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;
+ int dtype;
+ struct gfc_omp_clauses *dtype_clauses;
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, acc_collapse:1, bind:1;
+ unsigned num_gangs:1, num_workers:1, vector_length:1, tile:1;
locus loc;
}
@@ -1253,6 +1258,17 @@ gfc_omp_clauses;
#define gfc_get_omp_clauses() XCNEW (gfc_omp_clauses)
+/* Node in the linked list used for storing !$oacc declare constructs. */
+
+typedef struct gfc_oacc_declare
+{
+ struct gfc_oacc_declare *next;
+ locus where;
+ gfc_omp_clauses *clauses;
+}
+gfc_oacc_declare;
+#define gfc_get_oacc_declare() XCNEW (gfc_oacc_declare)
+
/* Node in the linked list used for storing !$omp declare simd constructs. */
@@ -1592,6 +1608,16 @@ gfc_dt_list;
/* A list of all derived types. */
extern gfc_dt_list *gfc_derived_types;
+typedef struct gfc_oacc_routine_name
+{
+ struct gfc_symbol *sym;
+ struct gfc_omp_clauses *clauses;
+ struct gfc_oacc_routine_name *next;
+}
+gfc_oacc_routine_name;
+
+#define gfc_get_oacc_routine_name() XCNEW (gfc_oacc_routine_name)
+
/* A namespace describes the contents of procedure, module, interface block
or BLOCK construct. */
/* ??? Anything else use these? */
@@ -1656,7 +1682,13 @@ typedef struct gfc_namespace
struct gfc_data *data, *old_data;
/* !$ACC DECLARE clauses. */
- gfc_omp_clauses *oacc_declare_clauses;
+ struct gfc_oacc_declare *oacc_declare;
+
+ /* !$ACC ROUTINE clauses. */
+ gfc_omp_clauses *oacc_routine_clauses;
+
+ /* !$ACC ROUTINE names. */
+ gfc_oacc_routine_name *oacc_routine_names;
gfc_charlen *cl_list, *old_cl_list;
@@ -1703,6 +1735,9 @@ typedef struct gfc_namespace
/* Set to 1 for !$OMP DECLARE REDUCTION namespaces. */
unsigned omp_udr_ns:1;
+
+ /* Set to 1 for !$ACC ROUTINE namespaces. */
+ unsigned oacc_routine:1;
}
gfc_namespace;
@@ -2331,10 +2366,11 @@ typedef enum
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
EXEC_LOCK, EXEC_UNLOCK,
- EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP,
+ EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP, EXEC_OACC_ROUTINE,
EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS, EXEC_OACC_DATA, EXEC_OACC_HOST_DATA,
EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE,
- EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA,
+ EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA, EXEC_OACC_ATOMIC,
+ EXEC_OACC_DECLARE,
EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
@@ -2416,6 +2452,7 @@ typedef struct gfc_code
int stop_code;
gfc_entry_list *entry;
gfc_omp_clauses *omp_clauses;
+ gfc_oacc_declare *oacc_declare;
const char *omp_name;
gfc_omp_namelist *omp_namelist;
bool omp_bool;
@@ -2923,6 +2960,7 @@ gfc_expr *gfc_get_parentheses (gfc_expr *);
/* openmp.c */
struct gfc_omp_saved_state { void *ptrs[2]; int ints[1]; };
void gfc_free_omp_clauses (gfc_omp_clauses *);
+void gfc_free_oacc_declares (struct gfc_oacc_declare *);
void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
@@ -3231,4 +3269,8 @@ int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *);
void gfc_convert_mpz_to_signed (mpz_t, int);
+/* trans-decl.c */
+
+void insert_oacc_declare (gfc_namespace *);
+
#endif /* GCC_GFORTRAN_H */
@@ -123,6 +123,7 @@ gfc_common_head *gfc_get_common (const char *, int);
/* openmp.c. */
/* OpenACC directive matchers. */
+match gfc_match_oacc_atomic (void);
match gfc_match_oacc_cache (void);
match gfc_match_oacc_wait (void);
match gfc_match_oacc_update (void);
@@ -92,6 +92,25 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
free (c);
}
+/* Free oacc_declare structures. */
+
+void
+gfc_free_oacc_declares (struct gfc_oacc_declare *oc)
+{
+ struct gfc_oacc_declare *decl = oc;
+
+ do
+ {
+ struct gfc_oacc_declare *next;
+
+ next = decl->next;
+ gfc_free_omp_clauses (decl->clauses);
+ free (decl);
+ decl = next;
+ }
+ while (decl);
+}
+
/* Free expression list. */
void
gfc_free_expr_list (gfc_expr_list *list)
@@ -447,21 +466,26 @@ match_oacc_clause_gang (gfc_omp_clauses *cp)
#define OMP_CLAUSE_INDEPENDENT ((uint64_t) 1 << 49)
#define OMP_CLAUSE_USE_DEVICE ((uint64_t) 1 << 50)
#define OMP_CLAUSE_DEVICE_RESIDENT ((uint64_t) 1 << 51)
-#define OMP_CLAUSE_HOST_SELF ((uint64_t) 1 << 52)
+#define OMP_CLAUSE_HOST ((uint64_t) 1 << 52)
#define OMP_CLAUSE_OACC_DEVICE ((uint64_t) 1 << 53)
#define OMP_CLAUSE_WAIT ((uint64_t) 1 << 54)
#define OMP_CLAUSE_DELETE ((uint64_t) 1 << 55)
#define OMP_CLAUSE_AUTO ((uint64_t) 1 << 56)
#define OMP_CLAUSE_TILE ((uint64_t) 1 << 57)
+#define OMP_CLAUSE_BIND ((uint64_t) 1 << 58)
+#define OMP_CLAUSE_NOHOST ((uint64_t) 1 << 59)
+#define OMP_CLAUSE_DEVICE_TYPE ((uint64_t) 1 << 60)
/* Helper function for OpenACC and OpenMP clauses involving memory
mapping. */
static bool
-gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op)
+gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
+ bool allow_sections = true)
{
gfc_omp_namelist **head = NULL;
- if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true)
+ if (gfc_match_omp_variable_list ("", list, false, NULL, &head,
+ allow_sections)
== MATCH_YES)
{
gfc_omp_namelist *n;
@@ -478,11 +502,14 @@ gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op)
static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
- bool first = true, bool needs_space = true,
- bool openacc = false)
+ uint64_t dtype_mask, bool first = true,
+ bool needs_space = true, bool openacc = false)
{
- gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ gfc_omp_clauses *base_clauses, *c = gfc_get_omp_clauses ();
locus old_loc;
+ bool scan_dtype = false;
+
+ base_clauses = c;
*cp = NULL;
while (1)
@@ -531,7 +558,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
if ((mask & OMP_CLAUSE_VECTOR_LENGTH) && c->vector_length_expr == NULL
&& gfc_match ("vector_length ( %e )", &c->vector_length_expr)
== MATCH_YES)
- continue;
+ {
+ c->vector_length = 1;
+ continue;
+ }
if ((mask & OMP_CLAUSE_VECTOR) && !c->vector)
if (gfc_match ("vector") == MATCH_YES)
{
@@ -596,11 +626,17 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
}
if ((mask & OMP_CLAUSE_NUM_GANGS) && c->num_gangs_expr == NULL
&& gfc_match ("num_gangs ( %e )", &c->num_gangs_expr) == MATCH_YES)
- continue;
+ {
+ c->num_gangs = 1;
+ continue;
+ }
if ((mask & OMP_CLAUSE_NUM_WORKERS) && c->num_workers_expr == NULL
&& gfc_match ("num_workers ( %e )", &c->num_workers_expr)
== MATCH_YES)
- continue;
+ {
+ c->num_workers = 1;
+ continue;
+ }
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("copy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
@@ -680,6 +716,18 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
continue;
}
}
+ if ((mask & OMP_CLAUSE_BIND) && c->routine_bind == NULL
+ && gfc_match ("bind ( %s )", &c->routine_bind) == MATCH_YES)
+ {
+ c->bind = 1;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NOHOST) && !c->nohost
+ && gfc_match ("nohost") == MATCH_YES)
+ {
+ c->nohost = true;
+ continue;
+ }
if ((mask & OMP_CLAUSE_USE_DEVICE)
&& gfc_match_omp_variable_list ("use_device (",
&c->lists[OMP_LIST_USE_DEVICE], true)
@@ -696,15 +744,20 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FORCE_TO))
continue;
- if ((mask & OMP_CLAUSE_HOST_SELF)
+ if ((mask & OMP_CLAUSE_HOST)
&& (gfc_match ("host ( ") == MATCH_YES
- || gfc_match ("self ( ") == MATCH_YES)
+ || gfc_match ("self ( ") == MATCH_YES) /* "self" is a synonym for
+ "host". */
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
OMP_MAP_FORCE_FROM))
continue;
if ((mask & OMP_CLAUSE_TILE)
+ && !c->tile_list
&& match_oacc_expr_list ("tile (", &c->tile_list, true) == MATCH_YES)
- continue;
+ {
+ c->tile = 1;
+ continue;
+ }
if ((mask & OMP_CLAUSE_SEQ) && !c->seq
&& gfc_match ("seq") == MATCH_YES)
{
@@ -856,13 +909,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
if ((mask & OMP_CLAUSE_DEFAULT)
&& c->default_sharing == OMP_DEFAULT_UNKNOWN)
{
- if (gfc_match ("default ( shared )") == MATCH_YES)
+ if (!openacc && gfc_match ("default ( shared )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_SHARED;
- else if (gfc_match ("default ( private )") == MATCH_YES)
+ else if (!openacc && gfc_match ("default ( private )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_PRIVATE;
else if (gfc_match ("default ( none )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_NONE;
- else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
+ else if (!openacc
+ && gfc_match ("default ( firstprivate )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
continue;
@@ -938,6 +992,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
}
c->collapse = collapse;
gfc_free_expr (cexpr);
+ c->acc_collapse = 1;
continue;
}
}
@@ -1083,6 +1138,47 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
if ((mask & OMP_CLAUSE_DEVICE) && c->device == NULL
&& gfc_match ("device ( %e )", &c->device) == MATCH_YES)
continue;
+ if (((mask & OMP_CLAUSE_DEVICE_TYPE) || scan_dtype)
+ && (gfc_match ("device_type ( ") == MATCH_YES
+ || gfc_match ("dtype ( ") == MATCH_YES))
+ {
+ int device = GOMP_DEVICE_NONE;
+ gfc_omp_clauses *t = gfc_get_omp_clauses ();
+
+ c->dtype_clauses = t;
+ c = t;
+
+ if (gfc_match (" * ") == MATCH_YES)
+ device = GOMP_DEVICE_DEFAULT;
+ else
+ {
+ char n[GFC_MAX_SYMBOL_LEN + 1];
+
+ while (gfc_match (" %n ", n) == MATCH_YES)
+ {
+ if (!strcasecmp ("nvidia", n))
+ device = GOMP_DEVICE_NVIDIA_PTX;
+ else
+ {
+ /* The OpenACC technical committee advises compilers
+ to silently ignore unknown devices. */
+ }
+ gfc_match (" , ");
+ }
+ }
+
+ /* Consume the trailing ')'. */
+ if (gfc_match (" ) ") != MATCH_YES)
+ {
+ gfc_error ("expected %<)%>");
+ continue;
+ }
+
+ c->dtype = device;
+ mask = dtype_mask;
+ scan_dtype = true;
+ continue;
+ }
if ((mask & OMP_CLAUSE_THREAD_LIMIT) && c->thread_limit == NULL
&& gfc_match ("thread_limit ( %e )", &c->thread_limit) == MATCH_YES)
continue;
@@ -1129,11 +1225,82 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
if (gfc_match_omp_eos () != MATCH_YES)
{
- gfc_free_omp_clauses (c);
+ gfc_omp_clauses *t;
+ c = base_clauses->dtype_clauses;
+ while (c)
+ {
+ t = c->dtype_clauses;
+ gfc_free_omp_clauses (c);
+ c = t;
+ }
+ gfc_free_omp_clauses (base_clauses);
return MATCH_ERROR;
}
- *cp = c;
+ /* Filter out the device_type clauses. */
+ if (base_clauses->dtype_clauses)
+ {
+ gfc_omp_clauses *t;
+ gfc_omp_clauses *seen_default = NULL;
+ gfc_omp_clauses *seen_nvidia = NULL;
+
+ /* Scan for device_type clauses. */
+ c = base_clauses->dtype_clauses;
+ while (c)
+ {
+ if (c->dtype == GOMP_DEVICE_DEFAULT)
+ {
+ if (seen_default)
+ gfc_error ("duplicate device_type (*)");
+ else
+ seen_default = c;
+ }
+ else if (c->dtype == GOMP_DEVICE_NVIDIA_PTX)
+ {
+ if (seen_nvidia)
+ gfc_error ("duplicate device_type (nvidia)");
+ else
+ seen_nvidia = c;
+ }
+ c = c->dtype_clauses;
+ }
+
+ /* Update the clauses in the original set of clauses. */
+ c = seen_nvidia ? seen_nvidia : seen_default;
+ if (c)
+ {
+#define acc_clause0(mask) do if (c->mask) { base_clauses->mask = 1; } while (0)
+#define acc_clause1(mask, expr, type) do if (c->mask) { type t; \
+ base_clauses->mask = 1; t = base_clauses->expr; \
+ base_clauses->expr = c->expr; c->expr = t; } while (0)
+
+ acc_clause1 (acc_collapse, collapse, int);
+ acc_clause1 (gang, gang_expr, gfc_expr *);
+ acc_clause1 (worker, worker_expr, gfc_expr *);
+ acc_clause1 (vector, vector_expr, gfc_expr *);
+ acc_clause0 (par_auto);
+ acc_clause0 (independent);
+ acc_clause0 (seq);
+ acc_clause1 (tile, tile_list, gfc_expr_list *);
+ acc_clause1 (async, async_expr, gfc_expr *);
+ acc_clause1 (wait, wait_list, gfc_expr_list *);
+ acc_clause1 (num_gangs, num_gangs_expr, gfc_expr *);
+ acc_clause1 (num_workers, num_workers_expr, gfc_expr *);
+ acc_clause1 (vector_length, vector_length_expr, gfc_expr *);
+ acc_clause1 (bind, routine_bind, gfc_symbol *);
+ }
+
+ /* Remove the device_type clauses. */
+ c = base_clauses->dtype_clauses;
+ while (c)
+ {
+ t = c->dtype_clauses;
+ gfc_free_omp_clauses (c);
+ c = t;
+ }
+ }
+
+ *cp = base_clauses;
return MATCH_YES;
}
@@ -1145,13 +1312,15 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
| OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
| OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
| OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE \
- | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
+ | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT \
+ | OMP_CLAUSE_DEVICE_TYPE)
#define OACC_KERNELS_CLAUSES \
(OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_DEVICEPTR \
| OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
| OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
| OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
- | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
+ | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT \
+ | OMP_CLAUSE_DEVICE_TYPE)
#define OACC_DATA_CLAUSES \
(OMP_CLAUSE_IF | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
| OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
@@ -1162,7 +1331,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
(OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
| OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
| OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
- | OMP_CLAUSE_TILE)
+ | OMP_CLAUSE_TILE | OMP_CLAUSE_DEVICE_TYPE)
#define OACC_PARALLEL_LOOP_CLAUSES \
(OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
#define OACC_KERNELS_LOOP_CLAUSES \
@@ -1175,8 +1344,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
| OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
| OMP_CLAUSE_PRESENT_OR_CREATE)
#define OACC_UPDATE_CLAUSES \
- (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
- | OMP_CLAUSE_OACC_DEVICE | OMP_CLAUSE_WAIT)
+ (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
+ | OMP_CLAUSE_OACC_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_DEVICE_TYPE)
#define OACC_ENTER_DATA_CLAUSES \
(OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT | OMP_CLAUSE_COPYIN \
| OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT_OR_COPYIN \
@@ -1186,14 +1355,35 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
| OMP_CLAUSE_DELETE)
#define OACC_WAIT_CLAUSES \
(OMP_CLAUSE_ASYNC)
+#define OACC_ROUTINE_CLAUSES \
+ (OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ \
+ | OMP_CLAUSE_BIND | OMP_CLAUSE_OACC_DEVICE | OMP_CLAUSE_NOHOST \
+ | OMP_CLAUSE_DEVICE_TYPE)
+
+#define OACC_LOOP_CLAUSE_DEVICE_TYPE_MASK \
+ (OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
+ | OMP_CLAUSE_VECTOR | OMP_CLAUSE_AUTO | OMP_CLAUSE_INDEPENDENT \
+ | OMP_CLAUSE_SEQ | OMP_CLAUSE_TILE)
+#define OACC_KERNELS_CLAUSE_DEVICE_TYPE_MASK \
+ (OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT)
+#define OACC_PARALLEL_CLAUSE_DEVICE_TYPE_MASK \
+ (OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS | OMP_CLAUSE_NUM_WORKERS \
+ | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_WAIT)
+#define OACC_ROUTINE_CLAUSE_DEVICE_TYPE_MASK \
+ (OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
+ | OMP_CLAUSE_SEQ | OMP_CLAUSE_BIND)
+#define OACC_UPDATE_CLAUSE_DEVICE_TYPE_MASK \
+ (OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT)
match
gfc_match_oacc_parallel_loop (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_PARALLEL_LOOP_CLAUSES, false, false,
- true) != MATCH_YES)
+ if (gfc_match_omp_clauses (&c, OACC_PARALLEL_LOOP_CLAUSES,
+ OACC_PARALLEL_CLAUSE_DEVICE_TYPE_MASK
+ | OACC_LOOP_CLAUSE_DEVICE_TYPE_MASK, false,
+ false, true) != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OACC_PARALLEL_LOOP;
@@ -1206,7 +1396,9 @@ match
gfc_match_oacc_parallel (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_PARALLEL_CLAUSES, false, false, true)
+ if (gfc_match_omp_clauses (&c, OACC_PARALLEL_CLAUSES,
+ OACC_PARALLEL_CLAUSE_DEVICE_TYPE_MASK, false,
+ false, true)
!= MATCH_YES)
return MATCH_ERROR;
@@ -1220,8 +1412,10 @@ match
gfc_match_oacc_kernels_loop (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_KERNELS_LOOP_CLAUSES, false, false,
- true) != MATCH_YES)
+ if (gfc_match_omp_clauses (&c, OACC_KERNELS_LOOP_CLAUSES,
+ OACC_KERNELS_CLAUSE_DEVICE_TYPE_MASK
+ | OACC_LOOP_CLAUSE_DEVICE_TYPE_MASK, false,
+ false, true) != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OACC_KERNELS_LOOP;
@@ -1234,7 +1428,9 @@ match
gfc_match_oacc_kernels (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_KERNELS_CLAUSES, false, false, true)
+ if (gfc_match_omp_clauses (&c, OACC_KERNELS_CLAUSES,
+ OACC_KERNELS_CLAUSE_DEVICE_TYPE_MASK, false,
+ false, true)
!= MATCH_YES)
return MATCH_ERROR;
@@ -1248,7 +1444,7 @@ match
gfc_match_oacc_data (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_DATA_CLAUSES, false, false, true)
+ if (gfc_match_omp_clauses (&c, OACC_DATA_CLAUSES, 0, false, false, true)
!= MATCH_YES)
return MATCH_ERROR;
@@ -1262,7 +1458,7 @@ match
gfc_match_oacc_host_data (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_HOST_DATA_CLAUSES, false, false, true)
+ if (gfc_match_omp_clauses (&c, OACC_HOST_DATA_CLAUSES, 0, false, false, true)
!= MATCH_YES)
return MATCH_ERROR;
@@ -1276,7 +1472,9 @@ match
gfc_match_oacc_loop (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_LOOP_CLAUSES, false, false, true)
+ if (gfc_match_omp_clauses (&c, OACC_LOOP_CLAUSES,
+ OACC_LOOP_CLAUSE_DEVICE_TYPE_MASK, false, false,
+ true)
!= MATCH_YES)
return MATCH_ERROR;
@@ -1290,12 +1488,90 @@ match
gfc_match_oacc_declare (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
+ gfc_omp_namelist *n;
+ gfc_namespace *ns = gfc_current_ns;
+ gfc_oacc_declare *new_oc, *oc;
+ locus where = gfc_current_locus;
+
+ if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, 0, false, false, true)
!= MATCH_YES)
return MATCH_ERROR;
- new_st.ext.omp_clauses = c;
- new_st.ext.omp_clauses->loc = gfc_current_locus;
+ for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
+ {
+ gfc_symbol *s = n->sym;
+
+ if (s->ns->proc_name && s->ns->proc_name->attr.proc == PROC_MODULE)
+ {
+ if (n->u.map_op != OMP_MAP_FORCE_ALLOC
+ && n->u.map_op != OMP_MAP_FORCE_TO)
+ {
+ gfc_error ("Invalid clause in module with "
+ "$!ACC DECLARE at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ if (s->attr.in_common)
+ {
+ gfc_error ("Unsupported: variable in a common block with "
+ "$!ACC DECLARE at %C");
+ return MATCH_ERROR;
+ }
+
+ if (s->attr.use_assoc)
+ {
+ gfc_error ("Unsupported: variable is USE-associated with "
+ "$!ACC DECLARE at %C");
+ return MATCH_ERROR;
+ }
+
+ if ((s->attr.dimension || s->attr.codimension)
+ && s->attr.dummy && s->as->type != AS_EXPLICIT)
+ {
+ gfc_error ("Unsupported: assumed-size dummy array with "
+ "$!ACC DECLARE at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ new_oc = gfc_get_oacc_declare ();
+ new_oc->next = ns->oacc_declare;
+ new_oc->where = where;
+ new_oc->clauses = c;
+
+ for (oc = new_oc; oc; oc = oc->next)
+ {
+ c = oc->clauses;
+ for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
+ n->sym->mark = 0;
+ }
+
+ for (oc = new_oc; oc; oc = oc->next)
+ {
+ c = oc->clauses;
+ for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
+ {
+ if (n->sym->mark)
+ {
+ gfc_error ("Symbol %qs present on multiple clauses at %C",
+ n->sym->name);
+ return MATCH_ERROR;
+ }
+ else
+ n->sym->mark = 1;
+ }
+ }
+
+ for (oc = new_oc; oc; oc = oc->next)
+ {
+ c = oc->clauses;
+ for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
+ n->sym->mark = 1;
+ }
+
+ ns->oacc_declare = new_oc;
+
return MATCH_YES;
}
@@ -1304,10 +1580,21 @@ match
gfc_match_oacc_update (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
+ locus here = gfc_current_locus;
+
+ if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES,
+ OACC_UPDATE_CLAUSE_DEVICE_TYPE_MASK, false,
+ false, true)
!= MATCH_YES)
return MATCH_ERROR;
+ if (!c->lists[OMP_LIST_MAP])
+ {
+ gfc_error ("%<acc update%> must contain at least one "
+ "%<device%> or %<host/self%> clause at %L", &here);
+ return MATCH_ERROR;
+ }
+
new_st.op = EXEC_OACC_UPDATE;
new_st.ext.omp_clauses = c;
return MATCH_YES;
@@ -1318,7 +1605,7 @@ match
gfc_match_oacc_enter_data (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_ENTER_DATA_CLAUSES, false, false, true)
+ if (gfc_match_omp_clauses (&c, OACC_ENTER_DATA_CLAUSES, 0, false, false, true)
!= MATCH_YES)
return MATCH_ERROR;
@@ -1332,7 +1619,7 @@ match
gfc_match_oacc_exit_data (void)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OACC_EXIT_DATA_CLAUSES, false, false, true)
+ if (gfc_match_omp_clauses (&c, OACC_EXIT_DATA_CLAUSES, 0, false, false, true)
!= MATCH_YES)
return MATCH_ERROR;
@@ -1349,7 +1636,7 @@ gfc_match_oacc_wait (void)
gfc_expr_list *wait_list = NULL, *el;
match_oacc_expr_list (" (", &wait_list, true);
- gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, false, false, true);
+ gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, 0, false, false, true);
if (gfc_match_omp_eos () != MATCH_YES)
{
@@ -1389,7 +1676,8 @@ gfc_match_oacc_cache (void)
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
match m = gfc_match_omp_variable_list (" (",
- &c->lists[OMP_LIST_CACHE], true);
+ &c->lists[OMP_LIST_CACHE], true,
+ NULL, NULL, true);
if (m != MATCH_YES)
{
gfc_free_omp_clauses(c);
@@ -1414,8 +1702,10 @@ match
gfc_match_oacc_routine (void)
{
locus old_loc;
- gfc_symbol *sym;
+ gfc_symbol *sym = NULL;
match m;
+ gfc_omp_clauses *c = NULL;
+ gfc_oacc_routine_name *n = NULL;
old_loc = gfc_current_locus;
@@ -1430,52 +1720,73 @@ gfc_match_oacc_routine (void)
goto cleanup;
}
- if (m == MATCH_NO
- && gfc_current_ns->proc_name
- && gfc_match_omp_eos () == MATCH_YES)
+ if (m == MATCH_YES)
+ {
+ /* Scan for a function name/string. */
+ m = gfc_match_symbol (&sym, 0);
+
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ if (!sym->attr.external && !sym->attr.function && !sym->attr.subroutine)
+ {
+ gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, invalid"
+ " function name %qs", sym->name);
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ 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;
+ }
+ }
+
+ if (sym != 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;
+ }
+ else if (gfc_current_ns->proc_name)
{
if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
gfc_current_ns->proc_name->name,
&old_loc))
goto cleanup;
- return MATCH_YES;
}
+ else
+ gcc_unreachable ();
- if (m != MATCH_YES)
- return m;
+ if (gfc_match_omp_eos () == MATCH_YES)
+ return MATCH_YES;
- /* Scan for a function name. */
- m = gfc_match_symbol (&sym, 0);
+ if (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES,
+ OACC_ROUTINE_CLAUSE_DEVICE_TYPE_MASK, false,
+ false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
- if (m != MATCH_YES)
- {
- gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
- gfc_current_locus = old_loc;
- return MATCH_ERROR;
- }
-
- if (!sym->attr.external && !sym->attr.function && !sym->attr.subroutine)
- {
- gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, invalid"
- " function name %qs", sym->name);
- gfc_current_locus = old_loc;
- return MATCH_ERROR;
- }
+ if (n)
+ n->clauses = c;
+ else if (gfc_current_ns->oacc_routine)
+ gfc_current_ns->oacc_routine_clauses = c;
- 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;
- }
-
- if (gfc_match_omp_eos () != MATCH_YES)
- {
- gfc_error ("Unexpected junk after !$ACC ROUTINE at %C");
- goto cleanup;
- }
- return MATCH_YES;
+ new_st.op = EXEC_OACC_ROUTINE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
cleanup:
gfc_current_locus = old_loc;
@@ -1524,7 +1835,7 @@ static match
match_omp (gfc_exec_op op, unsigned int mask)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
+ if (gfc_match_omp_clauses (&c, mask, 0) != MATCH_YES)
return MATCH_ERROR;
new_st.op = op;
new_st.ext.omp_clauses = c;
@@ -1627,7 +1938,7 @@ gfc_match_omp_declare_simd (void)
if (gfc_match (" ( %s ) ", &proc_name) != MATCH_YES)
return MATCH_ERROR;
- if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
+ if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, 0, true,
false) != MATCH_YES)
return MATCH_ERROR;
@@ -2450,9 +2761,8 @@ gfc_match_omp_ordered (void)
return MATCH_YES;
}
-
-match
-gfc_match_omp_atomic (void)
+static match
+gfc_match_omp_oacc_atomic (bool omp_p)
{
gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
int seq_cst = 0;
@@ -2490,13 +2800,24 @@ gfc_match_omp_atomic (void)
gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
return MATCH_ERROR;
}
- new_st.op = EXEC_OMP_ATOMIC;
+ new_st.op = (omp_p ? EXEC_OMP_ATOMIC : EXEC_OACC_ATOMIC);
if (seq_cst)
op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST);
new_st.ext.omp_atomic = op;
return MATCH_YES;
}
+match
+gfc_match_oacc_atomic (void)
+{
+ return gfc_match_omp_oacc_atomic (false);
+}
+
+match
+gfc_match_omp_atomic (void)
+{
+ return gfc_match_omp_oacc_atomic (true);
+}
match
gfc_match_omp_barrier (void)
@@ -2549,7 +2870,7 @@ gfc_match_omp_cancel (void)
enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
if (kind == OMP_CANCEL_UNKNOWN)
return MATCH_ERROR;
- if (gfc_match_omp_clauses (&c, OMP_CLAUSE_IF, false) != MATCH_YES)
+ if (gfc_match_omp_clauses (&c, OMP_CLAUSE_IF, 0, false) != MATCH_YES)
return MATCH_ERROR;
c->cancel = kind;
new_st.op = EXEC_OMP_CANCEL;
@@ -2606,7 +2927,7 @@ gfc_match_omp_end_single (void)
new_st.ext.omp_bool = true;
return MATCH_YES;
}
- if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
+ if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE, 0) != MATCH_YES)
return MATCH_ERROR;
new_st.op = EXEC_OMP_END_SINGLE;
new_st.ext.omp_clauses = c;
@@ -2686,10 +3007,6 @@ check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
if (sym->as && sym->as->type == AS_ASSUMED_RANK)
gfc_error ("Assumed rank array %qs in %s clause at %L",
sym->name, name, &loc);
- if (sym->as && sym->as->type == AS_DEFERRED && sym->attr.pointer
- && !sym->attr.contiguous)
- gfc_error ("Noncontiguous deferred shape array %qs in %s clause at %L",
- sym->name, name, &loc);
}
static void
@@ -4302,6 +4619,8 @@ oacc_code_to_statement (gfc_code *code)
{
switch (code->op)
{
+ case EXEC_OACC_ATOMIC:
+ return ST_OACC_ATOMIC;
case EXEC_OACC_PARALLEL:
return ST_OACC_PARALLEL;
case EXEC_OACC_KERNELS:
@@ -4514,22 +4833,8 @@ resolve_oacc_loop_blocks (gfc_code *code)
if (code->ext.omp_clauses->vector)
gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code->loc);
}
- if (!code->ext.omp_clauses->tile_list)
- {
- if (code->ext.omp_clauses->gang)
- {
- if (code->ext.omp_clauses->worker)
- gfc_error ("Clause GANG conflicts with WORKER at %L", &code->loc);
- if (code->ext.omp_clauses->vector)
- gfc_error ("Clause GANG conflicts with VECTOR at %L", &code->loc);
- }
- if (code->ext.omp_clauses->worker)
- if (code->ext.omp_clauses->vector)
- gfc_error ("Clause WORKER conflicts with VECTOR at %L", &code->loc);
- }
- else if (code->ext.omp_clauses->gang
- && code->ext.omp_clauses->worker
- && code->ext.omp_clauses->vector)
+ if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
+ && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
"vectors at the same time at %L", &code->loc);
@@ -4599,48 +4904,52 @@ resolve_oacc_loop (gfc_code *code)
}
-static void
-resolve_oacc_cache (gfc_code *code ATTRIBUTE_UNUSED)
-{
- sorry ("Sorry, !$ACC cache unimplemented yet");
-}
-
-
void
gfc_resolve_oacc_declare (gfc_namespace *ns)
{
int list;
gfc_omp_namelist *n;
locus loc;
+ gfc_oacc_declare *oc;
- if (ns->oacc_declare_clauses == NULL)
+ if (ns->oacc_declare == NULL)
return;
- loc = ns->oacc_declare_clauses->loc;
+ for (oc = ns->oacc_declare; oc; oc = oc->next)
+ {
+ loc = oc->where;
- for (list = OMP_LIST_DEVICE_RESIDENT;
- list <= OMP_LIST_DEVICE_RESIDENT; list++)
- for (n = ns->oacc_declare_clauses->lists[list]; n; n = n->next)
- {
- n->sym->mark = 0;
- if (n->sym->attr.flavor == FL_PARAMETER)
- gfc_error ("PARAMETER object %qs is not allowed at %L", n->sym->name, &loc);
- }
+ for (list = OMP_LIST_DEVICE_RESIDENT;
+ list <= OMP_LIST_DEVICE_RESIDENT; list++)
+ for (n = oc->clauses->lists[list]; n; n = n->next)
+ {
+ n->sym->mark = 0;
+ if (n->sym->attr.flavor == FL_PARAMETER)
+ gfc_error ("PARAMETER object %qs is not allowed at %L",
+ n->sym->name, &loc);
+ }
- for (list = OMP_LIST_DEVICE_RESIDENT;
- list <= OMP_LIST_DEVICE_RESIDENT; list++)
- for (n = ns->oacc_declare_clauses->lists[list]; n; n = n->next)
- {
- if (n->sym->mark)
- gfc_error ("Symbol %qs present on multiple clauses at %L",
- n->sym->name, &loc);
- else
- n->sym->mark = 1;
- }
+ for (list = OMP_LIST_DEVICE_RESIDENT;
+ list <= OMP_LIST_DEVICE_RESIDENT; list++)
+ for (n = oc->clauses->lists[list]; n; n = n->next)
+ {
+ if (n->sym->mark)
+ gfc_error ("Symbol %qs present on multiple clauses at %L",
+ n->sym->name, &loc);
+ else
+ n->sym->mark = 1;
+ }
- for (n = ns->oacc_declare_clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n;
- n = n->next)
- check_array_not_assumed (n->sym, loc, "DEVICE_RESIDENT");
+ for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
+ check_array_not_assumed (n->sym, loc, "DEVICE_RESIDENT");
+
+ for (n = oc->clauses->lists[OMP_LIST_MAP]; n; n = n->next)
+ {
+ if (n->expr && n->expr->ref->type == REF_ARRAY)
+ gfc_error ("Subarray: %qs not allowed in $!ACC DECLARE at %L",
+ n->sym->name, &loc);
+ }
+ }
}
@@ -4667,8 +4976,8 @@ gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
case EXEC_OACC_LOOP:
resolve_oacc_loop (code);
break;
- case EXEC_OACC_CACHE:
- resolve_oacc_cache (code);
+ case EXEC_OACC_ATOMIC:
+ resolve_omp_atomic (code);
break;
default:
break;
@@ -615,6 +615,9 @@ decode_oacc_directive (void)
switch (c)
{
+ case 'a':
+ match ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC);
+ break;
case 'c':
match ("cache", gfc_match_oacc_cache, ST_OACC_CACHE);
break;
@@ -623,6 +626,7 @@ decode_oacc_directive (void)
match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE);
break;
case 'e':
+ match ("end atomic", gfc_match_omp_eos, ST_OACC_END_ATOMIC);
match ("end data", gfc_match_omp_eos, ST_OACC_END_DATA);
match ("end host_data", gfc_match_omp_eos, ST_OACC_END_HOST_DATA);
match ("end kernels loop", gfc_match_omp_eos, ST_OACC_END_KERNELS_LOOP);
@@ -1351,7 +1355,8 @@ next_statement (void)
case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
case ST_CRITICAL: \
case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
- case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: case ST_OACC_KERNELS_LOOP
+ case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
+ case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC
/* Declaration statements */
@@ -1359,7 +1364,7 @@ next_statement (void)
case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \
- case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE
+ case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
@@ -1380,7 +1385,7 @@ push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
p->head = p->tail = NULL;
p->do_variable = NULL;
if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT)
- p->ext.oacc_declare_clauses = NULL;
+ p->ext.oacc_declare = NULL;
/* If this the state of a construct like BLOCK, DO or IF, the corresponding
construct statement was accepted right before pushing the state. Thus,
@@ -1909,6 +1914,12 @@ gfc_ascii_statement (gfc_statement st)
case ST_OACC_ROUTINE:
p = "!$ACC ROUTINE";
break;
+ case ST_OACC_ATOMIC:
+ p = "!ACC ATOMIC";
+ break;
+ case ST_OACC_END_ATOMIC:
+ p = "!ACC END ATOMIC";
+ break;
case ST_OMP_ATOMIC:
p = "!$OMP ATOMIC";
break;
@@ -2410,7 +2421,6 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
case ST_PUBLIC:
case ST_PRIVATE:
case ST_DERIVED_DECL:
- case ST_OACC_DECLARE:
case_decl:
if (p->state >= ORDER_EXEC)
goto order;
@@ -3312,19 +3322,6 @@ declSt:
st = next_statement ();
goto loop;
- case ST_OACC_DECLARE:
- if (!verify_st_order(&ss, st, false))
- {
- reject_statement ();
- st = next_statement ();
- goto loop;
- }
- if (gfc_state_stack->ext.oacc_declare_clauses == NULL)
- gfc_state_stack->ext.oacc_declare_clauses = new_st.ext.omp_clauses;
- accept_statement (st);
- st = next_statement ();
- goto loop;
-
default:
break;
}
@@ -4190,14 +4187,24 @@ parse_omp_do (gfc_statement omp_st)
/* Parse the statements of OpenMP atomic directive. */
static gfc_statement
-parse_omp_atomic (void)
+parse_omp_oacc_atomic (bool omp_p)
{
- gfc_statement st;
+ gfc_statement st, st_atomic, st_end_atomic;
gfc_code *cp, *np;
gfc_state_data s;
int count;
- accept_statement (ST_OMP_ATOMIC);
+ if (omp_p)
+ {
+ st_atomic = ST_OMP_ATOMIC;
+ st_end_atomic = ST_OMP_END_ATOMIC;
+ }
+ else
+ {
+ st_atomic = ST_OACC_ATOMIC;
+ st_end_atomic = ST_OACC_END_ATOMIC;
+ }
+ accept_statement (st_atomic);
cp = gfc_state_stack->tail;
push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
@@ -4224,7 +4231,7 @@ parse_omp_atomic (void)
pop_state ();
st = next_statement ();
- if (st == ST_OMP_END_ATOMIC)
+ if (st == st_end_atomic)
{
gfc_clear_new_st ();
gfc_commit_symbols ();
@@ -4518,7 +4525,7 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
continue;
case ST_OMP_ATOMIC:
- st = parse_omp_atomic ();
+ st = parse_omp_oacc_atomic (true);
continue;
default:
@@ -4737,8 +4744,12 @@ parse_executable (gfc_statement st)
return st;
continue;
+ case ST_OACC_ATOMIC:
+ st = parse_omp_oacc_atomic (false);
+ continue;
+
case ST_OMP_ATOMIC:
- st = parse_omp_atomic ();
+ st = parse_omp_oacc_atomic (true);
continue;
default:
@@ -5024,13 +5035,6 @@ contains:
done:
gfc_current_ns->code = gfc_state_stack->head;
- if (gfc_state_stack->state == COMP_PROGRAM
- || gfc_state_stack->state == COMP_MODULE
- || gfc_state_stack->state == COMP_SUBROUTINE
- || gfc_state_stack->state == COMP_FUNCTION
- || gfc_state_stack->state == COMP_BLOCK)
- gfc_current_ns->oacc_declare_clauses
- = gfc_state_stack->ext.oacc_declare_clauses;
}
@@ -5568,6 +5572,7 @@ is_oacc (gfc_state_data *sd)
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
+ case EXEC_OACC_ROUTINE:
return true;
default:
@@ -49,7 +49,7 @@ typedef struct gfc_state_data
union
{
gfc_st_label *end_do_label;
- gfc_omp_clauses *oacc_declare_clauses;
+ struct gfc_oacc_declare *oacc_declare;
}
ext;
}
@@ -9209,6 +9209,9 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
+ case EXEC_OACC_ATOMIC:
+ case EXEC_OACC_ROUTINE:
+ case EXEC_OACC_DECLARE:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DISTRIBUTE:
@@ -10385,6 +10388,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
"expression", &code->expr1->where);
break;
+ case EXEC_OACC_ATOMIC:
case EXEC_OACC_PARALLEL_LOOP:
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
@@ -10397,6 +10401,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
+ case EXEC_OACC_DECLARE:
gfc_resolve_oacc_directive (code, ns);
break;
@@ -185,6 +185,11 @@ gfc_free_statement (gfc_code *p)
gfc_free_forall_iterator (p->ext.forall_iterator);
break;
+ case EXEC_OACC_DECLARE:
+ if (p->ext.oacc_declare)
+ gfc_free_oacc_declares (p->ext.oacc_declare);
+ break;
+
case EXEC_OACC_PARALLEL_LOOP:
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
@@ -197,6 +202,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
+ case EXEC_OACC_ROUTINE:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_DISTRIBUTE:
@@ -240,6 +246,7 @@ gfc_free_statement (gfc_code *p)
gfc_free_omp_namelist (p->ext.omp_namelist);
break;
+ case EXEC_OACC_ATOMIC:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_MASTER:
@@ -5750,6 +5750,61 @@ is_ieee_module_used (gfc_namespace *ns)
}
+static gfc_code *
+find_end (gfc_code *code)
+{
+ gcc_assert (code);
+
+ if (code->op == EXEC_END_PROCEDURE)
+ return code;
+
+ if (code->next)
+ {
+ if (code->next->op == EXEC_END_PROCEDURE)
+ return code;
+ else
+ return find_end (code->next);
+ }
+
+ return NULL;
+}
+
+
+void
+insert_oacc_declare (gfc_namespace *ns)
+{
+ gfc_code *code;
+
+ code = XCNEW (gfc_code);
+ code->op = EXEC_OACC_DECLARE;
+ code->loc = ns->oacc_declare->where;
+
+ code->ext.oacc_declare = ns->oacc_declare;
+
+ code->block = XCNEW (gfc_code);
+ code->block->op = EXEC_OACC_DECLARE;
+ code->block->loc = ns->oacc_declare->where;
+
+ if (ns->code)
+ {
+ gfc_code *c;
+
+ c = find_end (ns->code);
+ if (c)
+ {
+ code->next = c->next;
+ c->next = NULL;
+ }
+
+ code->block->next = ns->code;
+ code->block->ext.oacc_declare = NULL;
+ }
+
+ ns->code = code;
+ ns->oacc_declare = NULL;
+}
+
+
/* Generate code for a function. */
void
@@ -5887,11 +5942,8 @@ gfc_generate_function_code (gfc_namespace * ns)
add_argument_checking (&body, sym);
/* Generate !$ACC DECLARE directive. */
- if (ns->oacc_declare_clauses)
- {
- tree tmp = gfc_trans_oacc_declare (&body, ns);
- gfc_add_expr_to_block (&body, tmp);
- }
+ if (ns->oacc_declare)
+ insert_oacc_declare (ns);
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
@@ -563,7 +563,8 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
stmtblock_t block, cond_block;
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
- || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
+ || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR
+ || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION);
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
@@ -1725,7 +1726,7 @@ gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
gfc_se se;
tree result;
- gfc_init_se (&se, NULL );
+ gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (block, &se.pre);
result = gfc_evaluate_now (se.expr, block);
@@ -2528,7 +2529,12 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
}
if (clauses->seq)
{
- c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_SEQ);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ if (clauses->par_auto)
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_AUTO);
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
if (clauses->independent)
@@ -2572,6 +2578,21 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var;
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
+ if (clauses->tile_list)
+ {
+ vec<tree, va_gc> *tvec;
+ gfc_expr_list *el;
+
+ vec_alloc (tvec, 4);
+
+ for (el = clauses->tile_list; el; el = el->next)
+ vec_safe_push (tvec, gfc_convert_expr_to_tree (block, el->expr));
+
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_TILE);
+ OMP_CLAUSE_TILE_LIST (c) = build_tree_list_vec (tvec);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ tvec->truncate (0);
+ }
if (clauses->vector)
{
if (clauses->vector_expr)
@@ -2714,7 +2735,7 @@ gfc_trans_oacc_executable_directive (gfc_code *code)
gfc_start_block (&block);
oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
code->loc);
- stmt = build1_loc (input_location, construct_code, void_type_node,
+ stmt = build1_loc (input_location, construct_code, void_type_node,
oacc_clauses);
gfc_add_expr_to_block (&block, stmt);
return gfc_finish_block (&block);
@@ -3465,10 +3486,6 @@ gfc_trans_oacc_combined_directive (gfc_code *code)
poplevel (0, 0);
stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
oacc_clauses);
- if (code->op == EXEC_OACC_KERNELS_LOOP)
- OACC_KERNELS_COMBINED (stmt) = 1;
- else
- OACC_PARALLEL_COMBINED (stmt) = 1;
gfc_add_expr_to_block (&block, stmt);
return gfc_finish_block (&block);
}
@@ -4363,13 +4380,30 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
}
tree
-gfc_trans_oacc_declare (stmtblock_t *block, gfc_namespace *ns)
+gfc_trans_oacc_declare (gfc_code *code)
{
- tree oacc_clauses;
- oacc_clauses = gfc_trans_omp_clauses (block, ns->oacc_declare_clauses,
- ns->oacc_declare_clauses->loc);
- return build1_loc (ns->oacc_declare_clauses->loc.lb->location,
- OACC_DECLARE, void_type_node, oacc_clauses);
+ stmtblock_t block;
+ struct gfc_oacc_declare *d;
+ tree stmt, clauses = NULL_TREE;
+
+ gfc_start_block (&block);
+
+ for (d = code->ext.oacc_declare; d; d = d->next)
+ {
+ tree t;
+
+ t = gfc_trans_omp_clauses (&block, d->clauses, d->clauses->loc);
+
+ if (clauses)
+ OMP_CLAUSE_CHAIN (clauses) = t;
+ else
+ clauses = t;
+ }
+
+ stmt = gfc_trans_omp_code (code->block->next, true);
+ stmt = build2_loc (input_location, OACC_DATA, void_type_node, stmt, clauses);
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
}
tree
@@ -4395,6 +4429,10 @@ gfc_trans_oacc_directive (gfc_code *code)
return gfc_trans_oacc_executable_directive (code);
case EXEC_OACC_WAIT:
return gfc_trans_oacc_wait_directive (code);
+ case EXEC_OACC_ATOMIC:
+ return gfc_trans_omp_atomic (code);
+ case EXEC_OACC_DECLARE:
+ return gfc_trans_oacc_declare (code);
default:
gcc_unreachable ();
}
@@ -1588,11 +1588,8 @@ gfc_trans_block_construct (gfc_code* code)
code->exit_label = exit_label;
/* Generate !$ACC DECLARE directive. */
- if (ns->oacc_declare_clauses)
- {
- tree tmp = gfc_trans_oacc_declare (&body, ns);
- gfc_add_expr_to_block (&body, tmp);
- }
+ if (ns->oacc_declare)
+ insert_oacc_declare (ns);
gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
@@ -67,7 +67,7 @@ void gfc_trans_omp_declare_simd (gfc_namespace *);
/* trans-openacc.c */
tree gfc_trans_oacc_directive (gfc_code *);
-tree gfc_trans_oacc_declare (stmtblock_t *block, gfc_namespace *);
+tree gfc_trans_oacc_declare (gfc_namespace *);
/* trans-io.c */
tree gfc_trans_open (gfc_code *);
@@ -1932,6 +1932,7 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_omp_directive (code);
break;
+ case EXEC_OACC_ATOMIC:
case EXEC_OACC_CACHE:
case EXEC_OACC_WAIT:
case EXEC_OACC_UPDATE:
@@ -1944,6 +1945,7 @@ trans_code (gfc_code * code, tree cond)
case EXEC_OACC_PARALLEL_LOOP:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
+ case EXEC_OACC_DECLARE:
res = gfc_trans_oacc_directive (code);
break;