#include "match.h"
#include "parse.h"
#include "hash-set.h"
+#include "diagnostic.h"
+#include "gomp-constants.h"
/* Match an end of OpenMP directive. End of OpenMP directive is optional
whitespace, followed by '\n' or comment '!'. */
gfc_free_expr (c->device);
gfc_free_expr (c->thread_limit);
gfc_free_expr (c->dist_chunk_size);
+ gfc_free_expr (c->async_expr);
+ gfc_free_expr (c->gang_expr);
+ gfc_free_expr (c->worker_expr);
+ gfc_free_expr (c->vector_expr);
+ gfc_free_expr (c->num_gangs_expr);
+ gfc_free_expr (c->num_workers_expr);
+ gfc_free_expr (c->vector_length_expr);
for (i = 0; i < OMP_LIST_NUM; i++)
gfc_free_omp_namelist (c->lists[i]);
+ gfc_free_expr_list (c->wait_list);
+ gfc_free_expr_list (c->tile_list);
free (c);
}
+/* Free expression list. */
+void
+gfc_free_expr_list (gfc_expr_list *list)
+{
+ gfc_expr_list *n;
+
+ for (; list; list = n)
+ {
+ n = list->next;
+ free (list);
+ }
+}
+
/* Free an !$omp declare simd construct list. */
void
return MATCH_ERROR;
}
-#define OMP_CLAUSE_PRIVATE (1U << 0)
-#define OMP_CLAUSE_FIRSTPRIVATE (1U << 1)
-#define OMP_CLAUSE_LASTPRIVATE (1U << 2)
-#define OMP_CLAUSE_COPYPRIVATE (1U << 3)
-#define OMP_CLAUSE_SHARED (1U << 4)
-#define OMP_CLAUSE_COPYIN (1U << 5)
-#define OMP_CLAUSE_REDUCTION (1U << 6)
-#define OMP_CLAUSE_IF (1U << 7)
-#define OMP_CLAUSE_NUM_THREADS (1U << 8)
-#define OMP_CLAUSE_SCHEDULE (1U << 9)
-#define OMP_CLAUSE_DEFAULT (1U << 10)
-#define OMP_CLAUSE_ORDERED (1U << 11)
-#define OMP_CLAUSE_COLLAPSE (1U << 12)
-#define OMP_CLAUSE_UNTIED (1U << 13)
-#define OMP_CLAUSE_FINAL (1U << 14)
-#define OMP_CLAUSE_MERGEABLE (1U << 15)
-#define OMP_CLAUSE_ALIGNED (1U << 16)
-#define OMP_CLAUSE_DEPEND (1U << 17)
-#define OMP_CLAUSE_INBRANCH (1U << 18)
-#define OMP_CLAUSE_LINEAR (1U << 19)
-#define OMP_CLAUSE_NOTINBRANCH (1U << 20)
-#define OMP_CLAUSE_PROC_BIND (1U << 21)
-#define OMP_CLAUSE_SAFELEN (1U << 22)
-#define OMP_CLAUSE_SIMDLEN (1U << 23)
-#define OMP_CLAUSE_UNIFORM (1U << 24)
-#define OMP_CLAUSE_DEVICE (1U << 25)
-#define OMP_CLAUSE_MAP (1U << 26)
-#define OMP_CLAUSE_TO (1U << 27)
-#define OMP_CLAUSE_FROM (1U << 28)
-#define OMP_CLAUSE_NUM_TEAMS (1U << 29)
-#define OMP_CLAUSE_THREAD_LIMIT (1U << 30)
-#define OMP_CLAUSE_DIST_SCHEDULE (1U << 31)
-
-/* Match OpenMP directive clauses. MASK is a bitmask of
+static match
+match_oacc_expr_list (const char *str, gfc_expr_list **list,
+ bool allow_asterisk)
+{
+ gfc_expr_list *head, *tail, *p;
+ locus old_loc;
+ gfc_expr *expr;
+ match m;
+
+ head = tail = NULL;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (str);
+ if (m != MATCH_YES)
+ return m;
+
+ for (;;)
+ {
+ m = gfc_match_expr (&expr);
+ if (m == MATCH_YES || allow_asterisk)
+ {
+ p = gfc_get_expr_list ();
+ if (head == NULL)
+ head = tail = p;
+ else
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ if (m == MATCH_YES)
+ tail->expr = expr;
+ else if (gfc_match (" *") != MATCH_YES)
+ goto syntax;
+ goto next_item;
+ }
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ goto syntax;
+
+ next_item:
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ while (*list)
+ list = &(*list)->next;
+
+ *list = head;
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in OpenACC expression list at %C");
+
+cleanup:
+ gfc_free_expr_list (head);
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+static match
+match_oacc_clause_gang (gfc_omp_clauses *cp)
+{
+ if (gfc_match_char ('(') != MATCH_YES)
+ return MATCH_NO;
+ if (gfc_match (" num :") == MATCH_YES)
+ {
+ cp->gang_static = false;
+ return gfc_match (" %e )", &cp->gang_expr);
+ }
+ if (gfc_match (" static :") == MATCH_YES)
+ {
+ cp->gang_static = true;
+ if (gfc_match (" * )") != MATCH_YES)
+ return gfc_match (" %e )", &cp->gang_expr);
+ return MATCH_YES;
+ }
+ return gfc_match (" %e )", &cp->gang_expr);
+}
+
+#define OMP_CLAUSE_PRIVATE ((uint64_t) 1 << 0)
+#define OMP_CLAUSE_FIRSTPRIVATE ((uint64_t) 1 << 1)
+#define OMP_CLAUSE_LASTPRIVATE ((uint64_t) 1 << 2)
+#define OMP_CLAUSE_COPYPRIVATE ((uint64_t) 1 << 3)
+#define OMP_CLAUSE_SHARED ((uint64_t) 1 << 4)
+#define OMP_CLAUSE_COPYIN ((uint64_t) 1 << 5)
+#define OMP_CLAUSE_REDUCTION ((uint64_t) 1 << 6)
+#define OMP_CLAUSE_IF ((uint64_t) 1 << 7)
+#define OMP_CLAUSE_NUM_THREADS ((uint64_t) 1 << 8)
+#define OMP_CLAUSE_SCHEDULE ((uint64_t) 1 << 9)
+#define OMP_CLAUSE_DEFAULT ((uint64_t) 1 << 10)
+#define OMP_CLAUSE_ORDERED ((uint64_t) 1 << 11)
+#define OMP_CLAUSE_COLLAPSE ((uint64_t) 1 << 12)
+#define OMP_CLAUSE_UNTIED ((uint64_t) 1 << 13)
+#define OMP_CLAUSE_FINAL ((uint64_t) 1 << 14)
+#define OMP_CLAUSE_MERGEABLE ((uint64_t) 1 << 15)
+#define OMP_CLAUSE_ALIGNED ((uint64_t) 1 << 16)
+#define OMP_CLAUSE_DEPEND ((uint64_t) 1 << 17)
+#define OMP_CLAUSE_INBRANCH ((uint64_t) 1 << 18)
+#define OMP_CLAUSE_LINEAR ((uint64_t) 1 << 19)
+#define OMP_CLAUSE_NOTINBRANCH ((uint64_t) 1 << 20)
+#define OMP_CLAUSE_PROC_BIND ((uint64_t) 1 << 21)
+#define OMP_CLAUSE_SAFELEN ((uint64_t) 1 << 22)
+#define OMP_CLAUSE_SIMDLEN ((uint64_t) 1 << 23)
+#define OMP_CLAUSE_UNIFORM ((uint64_t) 1 << 24)
+#define OMP_CLAUSE_DEVICE ((uint64_t) 1 << 25)
+#define OMP_CLAUSE_MAP ((uint64_t) 1 << 26)
+#define OMP_CLAUSE_TO ((uint64_t) 1 << 27)
+#define OMP_CLAUSE_FROM ((uint64_t) 1 << 28)
+#define OMP_CLAUSE_NUM_TEAMS ((uint64_t) 1 << 29)
+#define OMP_CLAUSE_THREAD_LIMIT ((uint64_t) 1 << 30)
+#define OMP_CLAUSE_DIST_SCHEDULE ((uint64_t) 1 << 31)
+
+/* OpenACC 2.0 clauses. */
+#define OMP_CLAUSE_ASYNC ((uint64_t) 1 << 32)
+#define OMP_CLAUSE_NUM_GANGS ((uint64_t) 1 << 33)
+#define OMP_CLAUSE_NUM_WORKERS ((uint64_t) 1 << 34)
+#define OMP_CLAUSE_VECTOR_LENGTH ((uint64_t) 1 << 35)
+#define OMP_CLAUSE_COPY ((uint64_t) 1 << 36)
+#define OMP_CLAUSE_COPYOUT ((uint64_t) 1 << 37)
+#define OMP_CLAUSE_CREATE ((uint64_t) 1 << 38)
+#define OMP_CLAUSE_PRESENT ((uint64_t) 1 << 39)
+#define OMP_CLAUSE_PRESENT_OR_COPY ((uint64_t) 1 << 40)
+#define OMP_CLAUSE_PRESENT_OR_COPYIN ((uint64_t) 1 << 41)
+#define OMP_CLAUSE_PRESENT_OR_COPYOUT ((uint64_t) 1 << 42)
+#define OMP_CLAUSE_PRESENT_OR_CREATE ((uint64_t) 1 << 43)
+#define OMP_CLAUSE_DEVICEPTR ((uint64_t) 1 << 44)
+#define OMP_CLAUSE_GANG ((uint64_t) 1 << 45)
+#define OMP_CLAUSE_WORKER ((uint64_t) 1 << 46)
+#define OMP_CLAUSE_VECTOR ((uint64_t) 1 << 47)
+#define OMP_CLAUSE_SEQ ((uint64_t) 1 << 48)
+#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_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)
+
+/* 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_omp_namelist **head = NULL;
+ if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true)
+ == MATCH_YES)
+ {
+ gfc_omp_namelist *n;
+ for (n = *head; n; n = n->next)
+ n->u.map_op = map_op;
+ return true;
+ }
+
+ return false;
+}
+
+/* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
clauses that are allowed for a particular directive. */
static match
-gfc_match_omp_clauses (gfc_omp_clauses **cp, unsigned int mask,
- bool first = true, bool needs_space = true)
+gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask,
+ bool first = true, bool needs_space = true,
+ bool openacc = false)
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
locus old_loc;
needs_space = false;
first = false;
gfc_gobble_whitespace ();
+ if ((mask & OMP_CLAUSE_ASYNC) && !c->async)
+ if (gfc_match ("async") == MATCH_YES)
+ {
+ c->async = true;
+ needs_space = false;
+ if (gfc_match (" ( %e )", &c->async_expr) != MATCH_YES)
+ {
+ c->async_expr = gfc_get_constant_expr (BT_INTEGER,
+ gfc_default_integer_kind,
+ &gfc_current_locus);
+ mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
+ }
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_GANG) && !c->gang)
+ if (gfc_match ("gang") == MATCH_YES)
+ {
+ c->gang = true;
+ if (match_oacc_clause_gang(c) == MATCH_YES)
+ needs_space = false;
+ else
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_WORKER) && !c->worker)
+ if (gfc_match ("worker") == MATCH_YES)
+ {
+ c->worker = true;
+ if (gfc_match (" ( num : %e )", &c->worker_expr) == MATCH_YES
+ || gfc_match (" ( %e )", &c->worker_expr) == MATCH_YES)
+ needs_space = false;
+ else
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_VECTOR_LENGTH) && c->vector_length_expr == NULL
+ && gfc_match ("vector_length ( %e )", &c->vector_length_expr)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_VECTOR) && !c->vector)
+ if (gfc_match ("vector") == MATCH_YES)
+ {
+ c->vector = true;
+ if (gfc_match (" ( length : %e )", &c->vector_expr) == MATCH_YES
+ || gfc_match (" ( %e )", &c->vector_expr) == MATCH_YES)
+ needs_space = false;
+ else
+ needs_space = true;
+ continue;
+ }
if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
&& gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
continue;
&c->lists[OMP_LIST_SHARED], true)
== MATCH_YES)
continue;
- if ((mask & OMP_CLAUSE_COPYIN)
- && gfc_match_omp_variable_list ("copyin (",
- &c->lists[OMP_LIST_COPYIN], true)
+ if (mask & OMP_CLAUSE_COPYIN)
+ {
+ if (openacc)
+ {
+ if (gfc_match ("copyin ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_TO))
+ continue;
+ }
+ else if (gfc_match_omp_variable_list ("copyin (",
+ &c->lists[OMP_LIST_COPYIN],
+ true) == MATCH_YES)
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NUM_GANGS) && c->num_gangs_expr == NULL
+ && gfc_match ("num_gangs ( %e )", &c->num_gangs_expr) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_NUM_WORKERS) && c->num_workers_expr == NULL
+ && gfc_match ("num_workers ( %e )", &c->num_workers_expr)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_COPY)
+ && gfc_match ("copy ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_TOFROM))
+ continue;
+ if ((mask & OMP_CLAUSE_COPYOUT)
+ && gfc_match ("copyout ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_FROM))
+ continue;
+ if ((mask & OMP_CLAUSE_CREATE)
+ && gfc_match ("create ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_ALLOC))
+ continue;
+ if ((mask & OMP_CLAUSE_DELETE)
+ && gfc_match ("delete ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_DEALLOC))
+ continue;
+ if ((mask & OMP_CLAUSE_PRESENT)
+ && gfc_match ("present ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_PRESENT))
+ continue;
+ if ((mask & OMP_CLAUSE_PRESENT_OR_COPY)
+ && gfc_match ("present_or_copy ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_TOFROM))
+ continue;
+ if ((mask & OMP_CLAUSE_PRESENT_OR_COPY)
+ && gfc_match ("pcopy ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_TOFROM))
+ continue;
+ if ((mask & OMP_CLAUSE_PRESENT_OR_COPYIN)
+ && gfc_match ("present_or_copyin ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_TO))
+ continue;
+ if ((mask & OMP_CLAUSE_PRESENT_OR_COPYIN)
+ && gfc_match ("pcopyin ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_TO))
+ continue;
+ if ((mask & OMP_CLAUSE_PRESENT_OR_COPYOUT)
+ && gfc_match ("present_or_copyout ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FROM))
+ continue;
+ if ((mask & OMP_CLAUSE_PRESENT_OR_COPYOUT)
+ && gfc_match ("pcopyout ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FROM))
+ continue;
+ if ((mask & OMP_CLAUSE_PRESENT_OR_CREATE)
+ && gfc_match ("present_or_create ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_ALLOC))
+ continue;
+ if ((mask & OMP_CLAUSE_PRESENT_OR_CREATE)
+ && gfc_match ("pcreate ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_ALLOC))
+ continue;
+ if ((mask & OMP_CLAUSE_DEVICEPTR)
+ && gfc_match ("deviceptr ( ") == MATCH_YES)
+ {
+ gfc_omp_namelist **list = &c->lists[OMP_LIST_MAP];
+ gfc_omp_namelist **head = NULL;
+ if (gfc_match_omp_variable_list ("", list, true, NULL, &head, false)
+ == MATCH_YES)
+ {
+ gfc_omp_namelist *n;
+ for (n = *head; n; n = n->next)
+ n->u.map_op = OMP_MAP_FORCE_DEVICEPTR;
+ continue;
+ }
+ }
+ if ((mask & OMP_CLAUSE_USE_DEVICE)
+ && gfc_match_omp_variable_list ("use_device (",
+ &c->lists[OMP_LIST_USE_DEVICE], true)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
+ && gfc_match_omp_variable_list ("device_resident (",
+ &c->lists[OMP_LIST_DEVICE_RESIDENT],
+ true)
== MATCH_YES)
continue;
+ if ((mask & OMP_CLAUSE_OACC_DEVICE)
+ && gfc_match ("device ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_TO))
+ continue;
+ if ((mask & OMP_CLAUSE_HOST_SELF)
+ && (gfc_match ("host ( ") == MATCH_YES
+ || gfc_match ("self ( ") == MATCH_YES)
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_FORCE_FROM))
+ continue;
+ if ((mask & OMP_CLAUSE_TILE)
+ && match_oacc_expr_list ("tile (", &c->tile_list, true) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_SEQ) && !c->seq
+ && gfc_match ("seq") == MATCH_YES)
+ {
+ c->seq = true;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_INDEPENDENT) && !c->independent
+ && gfc_match ("independent") == MATCH_YES)
+ {
+ c->independent = true;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_AUTO) && !c->par_auto
+ && gfc_match ("auto") == MATCH_YES)
+ {
+ c->par_auto = true;
+ needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_WAIT) && !c->wait
+ && gfc_match ("wait") == MATCH_YES)
+ {
+ c->wait = true;
+ match_oacc_expr_list (" (", &c->wait_list, false);
+ continue;
+ }
old_loc = gfc_current_locus;
if ((mask & OMP_CLAUSE_REDUCTION)
&& gfc_match ("reduction ( ") == MATCH_YES)
return MATCH_YES;
}
+
+#define OACC_PARALLEL_CLAUSES \
+ (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
+ | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
+ | 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_DEVICEPTR | OMP_CLAUSE_PRIVATE \
+ | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
+#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)
+#define OACC_DATA_CLAUSES \
+ (OMP_CLAUSE_IF | 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)
+#define OACC_LOOP_CLAUSES \
+ (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)
+#define OACC_PARALLEL_LOOP_CLAUSES \
+ (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
+#define OACC_KERNELS_LOOP_CLAUSES \
+ (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
+#define OACC_HOST_DATA_CLAUSES OMP_CLAUSE_USE_DEVICE
+#define OACC_DECLARE_CLAUSES \
+ (OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
+ | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
+ | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
+ | 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)
+#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 \
+ | OMP_CLAUSE_PRESENT_OR_CREATE)
+#define OACC_EXIT_DATA_CLAUSES \
+ (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT | OMP_CLAUSE_COPYOUT \
+ | OMP_CLAUSE_DELETE)
+#define OACC_WAIT_CLAUSES \
+ (OMP_CLAUSE_ASYNC)
+
+
+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)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OACC_PARALLEL_LOOP;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_parallel (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OACC_PARALLEL_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OACC_PARALLEL;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+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)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OACC_KERNELS_LOOP;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_kernels (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OACC_KERNELS_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OACC_KERNELS;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_data (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OACC_DATA_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OACC_DATA;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_host_data (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OACC_HOST_DATA_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OACC_HOST_DATA;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_loop (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OACC_LOOP_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OACC_LOOP;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_declare (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ new_st.ext.omp_clauses = c;
+ new_st.ext.omp_clauses->loc = gfc_current_locus;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_update (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OACC_UPDATE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_enter_data (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OACC_ENTER_DATA_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OACC_ENTER_DATA;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_exit_data (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OACC_EXIT_DATA_CLAUSES, false, false, true)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_OACC_EXIT_DATA;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_wait (void)
+{
+ gfc_omp_clauses *c = gfc_get_omp_clauses ();
+ 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);
+
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk in !$ACC WAIT at %C");
+ return MATCH_ERROR;
+ }
+
+ if (wait_list)
+ for (el = wait_list; el; el = el->next)
+ {
+ if (el->expr == NULL)
+ {
+ gfc_error ("Invalid argument to $!ACC WAIT at %L",
+ &wait_list->expr->where);
+ return MATCH_ERROR;
+ }
+
+ if (!gfc_resolve_expr (el->expr)
+ || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0
+ || el->expr->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
+ &el->expr->where);
+
+ return MATCH_ERROR;
+ }
+ }
+ c->wait_list = wait_list;
+ new_st.op = EXEC_OACC_WAIT;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+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);
+ if (m != MATCH_YES)
+ {
+ gfc_free_omp_clauses(c);
+ return m;
+ }
+
+ if (gfc_current_state() != COMP_DO
+ && gfc_current_state() != COMP_DO_CONCURRENT)
+ {
+ gfc_error ("ACC CACHE directive must be inside of loop %C");
+ gfc_free_omp_clauses(c);
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_OACC_CACHE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_oacc_routine (void)
+{
+ locus old_loc;
+ gfc_symbol *sym;
+ match m;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (" (");
+
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
+ && m == MATCH_YES)
+ {
+ gfc_error ("Only the !$ACC ROUTINE form without "
+ "list is allowed in interface block at %C");
+ goto cleanup;
+ }
+
+ if (m == MATCH_NO
+ && gfc_current_ns->proc_name
+ && gfc_match_omp_eos () == MATCH_YES)
+ {
+ 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;
+ }
+
+ if (m != MATCH_YES)
+ return m;
+
+ /* Scan for a function name. */
+ m = gfc_match_symbol (&sym, 0);
+
+ 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 '%s'", 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 (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after !$ACC ROUTINE at %C");
+ goto cleanup;
+ }
+ return MATCH_YES;
+
+cleanup:
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+
#define OMP_PARALLEL_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
| OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
}
+static bool
+oacc_is_loop (gfc_code *code)
+{
+ return code->op == EXEC_OACC_PARALLEL_LOOP
+ || code->op == EXEC_OACC_KERNELS_LOOP
+ || code->op == EXEC_OACC_LOOP;
+}
+
+static void
+resolve_oacc_scalar_int_expr (gfc_expr *expr, const char *clause)
+{
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("%s clause at %L requires a scalar INTEGER expression",
+ clause, &expr->where);
+}
+
+
+static void
+resolve_oacc_positive_int_expr (gfc_expr *expr, const char *clause)
+{
+ resolve_oacc_scalar_int_expr (expr, clause);
+ if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_INTEGER
+ && mpz_sgn(expr->value.integer) <= 0)
+ gfc_warning ("INTEGER expression of %s clause at %L must be positive",
+ clause, &expr->where);
+}
+
+/* Emits error when symbol is pointer, cray pointer or cray pointee
+ of derived of polymorphic type. */
+
+static void
+check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
+{
+ if (sym->ts.type == BT_DERIVED && sym->attr.pointer)
+ gfc_error ("POINTER object '%s' of derived type in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
+ gfc_error ("Cray pointer object of derived type '%s' in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
+ gfc_error ("Cray pointee object of derived type '%s' in %s clause at %L",
+ sym->name, name, &loc);
+
+ if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.pointer))
+ gfc_error ("POINTER object '%s' of polymorphic type in %s clause at %L",
+ sym->name, name, &loc);
+ if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.cray_pointer))
+ gfc_error ("Cray pointer object of polymorphic type '%s' in %s clause at %L",
+ sym->name, name, &loc);
+ if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.cray_pointee))
+ gfc_error ("Cray pointee object of polymorphic type '%s' in %s clause at %L",
+ sym->name, name, &loc);
+}
+
+/* Emits error when symbol represents assumed size/rank array. */
+
+static void
+check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
+{
+ if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
+ gfc_error ("Assumed size array '%s' in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->as && sym->as->type == AS_ASSUMED_RANK)
+ gfc_error ("Assumed rank array '%s' 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 '%s' in %s clause at %L",
+ sym->name, name, &loc);
+}
+
+static void
+resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
+{
+ if (sym->ts.type == BT_DERIVED && sym->attr.allocatable)
+ gfc_error ("ALLOCATABLE object '%s' of derived type in %s clause at %L",
+ sym->name, name, &loc);
+ if ((sym->ts.type == BT_ASSUMED && sym->attr.allocatable)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.allocatable))
+ gfc_error ("ALLOCATABLE object '%s' of polymorphic type "
+ "in %s clause at %L", sym->name, name, &loc);
+ check_symbol_not_pointer (sym, loc, name);
+ check_array_not_assumed (sym, loc, name);
+}
+
+static void
+resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
+{
+ if (sym->attr.pointer
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.class_pointer))
+ gfc_error ("POINTER object '%s' in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->attr.cray_pointer
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.cray_pointer))
+ gfc_error ("Cray pointer object '%s' in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->attr.cray_pointee
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.cray_pointee))
+ gfc_error ("Cray pointee object '%s' in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (sym)->attr.allocatable))
+ gfc_error ("ALLOCATABLE object '%s' in %s clause at %L",
+ sym->name, name, &loc);
+ if (sym->attr.value)
+ gfc_error ("VALUE object '%s' in %s clause at %L",
+ sym->name, name, &loc);
+ check_array_not_assumed (sym, loc, name);
+}
+
+
struct resolve_omp_udr_callback_data
{
gfc_symbol *sym1, *sym2;
return copy;
}
+/* Returns true if clause in list 'list' is compatible with any of
+ of the clauses in lists [0..list-1]. E.g., a reduction variable may
+ appear in both reduction and private clauses, so this function
+ will return true in this case. */
+
+static bool
+oacc_compatible_clauses (gfc_omp_clauses *clauses, int list,
+ gfc_symbol *sym, bool openacc)
+{
+ gfc_omp_namelist *n;
+
+ if (!openacc)
+ return false;
+
+ if (list != OMP_LIST_REDUCTION)
+ return false;
+
+ for (n = clauses->lists[OMP_LIST_FIRST]; n; n = n->next)
+ if (n->sym == sym)
+ return true;
+
+ return false;
+}
/* OpenMP directive resolving routines. */
static void
resolve_omp_clauses (gfc_code *code, locus *where,
- gfc_omp_clauses *omp_clauses, gfc_namespace *ns)
+ gfc_omp_clauses *omp_clauses, gfc_namespace *ns,
+ bool openacc = false)
{
gfc_omp_namelist *n;
+ gfc_expr_list *el;
int list;
static const char *clause_names[]
= { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
"COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
- "TO", "FROM", "REDUCTION" };
+ "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "USE_DEVICE",
+ "CACHE" };
if (omp_clauses == NULL)
return;
&& list != OMP_LIST_LASTPRIVATE
&& list != OMP_LIST_ALIGNED
&& list != OMP_LIST_DEPEND
- && list != OMP_LIST_MAP
+ && (list != OMP_LIST_MAP || openacc)
&& list != OMP_LIST_FROM
&& list != OMP_LIST_TO)
for (n = omp_clauses->lists[list]; n; n = n->next)
{
- if (n->sym->mark)
+ if (n->sym->mark && !oacc_compatible_clauses (omp_clauses, list,
+ n->sym, openacc))
gfc_error ("Symbol %qs present on multiple clauses at %L",
n->sym->name, where);
else
case OMP_LIST_TO:
case OMP_LIST_FROM:
for (; n != NULL; n = n->next)
- if (n->expr)
- {
- if (!gfc_resolve_expr (n->expr)
- || n->expr->expr_type != EXPR_VARIABLE
- || n->expr->ref == NULL
- || n->expr->ref->next
- || n->expr->ref->type != REF_ARRAY)
- gfc_error ("%qs in %s clause at %L is not a proper "
- "array section", n->sym->name, name, where);
- else if (n->expr->ref->u.ar.codimen)
- gfc_error ("Coarrays not supported in %s clause at %L",
- name, where);
- else
- {
- int i;
- gfc_array_ref *ar = &n->expr->ref->u.ar;
- for (i = 0; i < ar->dimen; i++)
- if (ar->stride[i])
- {
- gfc_error ("Stride should not be specified for "
- "array section in %s clause at %L",
- name, where);
- break;
- }
- else if (ar->dimen_type[i] != DIMEN_ELEMENT
- && ar->dimen_type[i] != DIMEN_RANGE)
- {
- gfc_error ("%qs in %s clause at %L is not a "
- "proper array section",
- n->sym->name, name, where);
- break;
- }
- else if (list == OMP_LIST_DEPEND
- && ar->start[i]
- && ar->start[i]->expr_type == EXPR_CONSTANT
- && ar->end[i]
- && ar->end[i]->expr_type == EXPR_CONSTANT
- && mpz_cmp (ar->start[i]->value.integer,
- ar->end[i]->value.integer) > 0)
- {
- gfc_error ("%qs in DEPEND clause at %L is a zero "
- "size array section", n->sym->name,
- where);
- break;
- }
- }
- }
+ {
+ if (n->expr)
+ {
+ if (!gfc_resolve_expr (n->expr)
+ || n->expr->expr_type != EXPR_VARIABLE
+ || n->expr->ref == NULL
+ || n->expr->ref->next
+ || n->expr->ref->type != REF_ARRAY)
+ gfc_error ("%qs in %s clause at %L is not a proper "
+ "array section", n->sym->name, name, where);
+ else if (n->expr->ref->u.ar.codimen)
+ gfc_error ("Coarrays not supported in %s clause at %L",
+ name, where);
+ else
+ {
+ int i;
+ gfc_array_ref *ar = &n->expr->ref->u.ar;
+ for (i = 0; i < ar->dimen; i++)
+ if (ar->stride[i])
+ {
+ gfc_error ("Stride should not be specified for "
+ "array section in %s clause at %L",
+ name, where);
+ break;
+ }
+ else if (ar->dimen_type[i] != DIMEN_ELEMENT
+ && ar->dimen_type[i] != DIMEN_RANGE)
+ {
+ gfc_error ("%qs in %s clause at %L is not a "
+ "proper array section",
+ n->sym->name, name, where);
+ break;
+ }
+ else if (list == OMP_LIST_DEPEND
+ && ar->start[i]
+ && ar->start[i]->expr_type == EXPR_CONSTANT
+ && ar->end[i]
+ && ar->end[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (ar->start[i]->value.integer,
+ ar->end[i]->value.integer) > 0)
+ {
+ gfc_error ("%qs in DEPEND clause at %L is a "
+ "zero size array section",
+ n->sym->name, where);
+ break;
+ }
+ }
+ }
+ else if (openacc)
+ {
+ if (list == OMP_LIST_MAP
+ && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR)
+ resolve_oacc_deviceptr_clause (n->sym, *where, name);
+ else
+ resolve_oacc_data_clauses (n->sym, *where, name);
+ }
+ }
+
if (list != OMP_LIST_DEPEND)
for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
{
gfc_error ("Cray pointer %qs in %s clause at %L",
n->sym->name, name, where);
}
- if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
+ if (code
+ && (oacc_is_loop (code) || code->op == EXEC_OACC_PARALLEL))
+ check_array_not_assumed (n->sym, *where, name);
+ else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array %qs in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
default:
break;
}
+
switch (list)
{
case OMP_LIST_REDUCTION:
to be done here for OMP_LIST_PRIVATE. */
case OMP_LIST_PRIVATE:
gcc_assert (code && code->op != EXEC_NOP);
+ break;
+ case OMP_LIST_USE_DEVICE:
+ if (n->sym->attr.allocatable
+ || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
+ && CLASS_DATA (n->sym)->attr.allocatable))
+ gfc_error ("ALLOCATABLE object '%s' in %s clause at %L",
+ n->sym->name, name, where);
+ if (n->sym->attr.pointer
+ || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
+ && CLASS_DATA (n->sym)->attr.class_pointer))
+ gfc_error ("POINTER object '%s' in %s clause at %L",
+ n->sym->name, name, where);
+ if (n->sym->attr.cray_pointer)
+ gfc_error ("Cray pointer object '%s' in %s clause at %L",
+ n->sym->name, name, where);
+ if (n->sym->attr.cray_pointee)
+ gfc_error ("Cray pointee object '%s' in %s clause at %L",
+ n->sym->name, name, where);
+ /* FALLTHRU */
+ case OMP_LIST_DEVICE_RESIDENT:
+ case OMP_LIST_CACHE:
+ check_symbol_not_pointer (n->sym, *where, name);
+ check_array_not_assumed (n->sym, *where, name);
+ break;
default:
break;
}
gfc_error ("THREAD_LIMIT clause at %L requires a scalar "
"INTEGER expression", &expr->where);
}
+ if (omp_clauses->async)
+ if (omp_clauses->async_expr)
+ resolve_oacc_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
+ if (omp_clauses->num_gangs_expr)
+ resolve_oacc_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
+ if (omp_clauses->num_workers_expr)
+ resolve_oacc_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
+ if (omp_clauses->vector_length_expr)
+ resolve_oacc_positive_int_expr (omp_clauses->vector_length_expr, "VECTOR_LENGTH");
+ if (omp_clauses->gang_expr)
+ resolve_oacc_positive_int_expr (omp_clauses->gang_expr, "GANG");
+ if (omp_clauses->worker_expr)
+ resolve_oacc_positive_int_expr (omp_clauses->worker_expr, "WORKER");
+ if (omp_clauses->vector_expr)
+ resolve_oacc_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
+ if (omp_clauses->wait)
+ if (omp_clauses->wait_list)
+ for (el = omp_clauses->wait_list; el; el = el->next)
+ resolve_oacc_scalar_int_expr (el->expr, "WAIT");
}
hash_set<gfc_symbol *> *sharing_clauses;
hash_set<gfc_symbol *> *private_iterators;
struct fortran_omp_context *previous;
+ bool is_openmp;
} *omp_current_ctx;
static gfc_code *omp_current_do_code;
static int omp_current_do_collapse;
ctx.sharing_clauses = new hash_set<gfc_symbol *>;
ctx.private_iterators = new hash_set<gfc_symbol *>;
ctx.previous = omp_current_ctx;
+ ctx.is_openmp = true;
omp_current_ctx = &ctx;
for (list = 0; list < OMP_LIST_NUM; list++)
if (omp_current_ctx == NULL)
return;
- if (omp_current_ctx->sharing_clauses->contains (sym))
+ /* An openacc context may represent a data clause. Abort if so. */
+ if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
+ return;
+
+ if (omp_current_ctx->is_openmp
+ && omp_current_ctx->sharing_clauses->contains (sym))
return;
if (! omp_current_ctx->private_iterators->add (sym))
}
}
+static bool
+oacc_is_parallel (gfc_code *code)
+{
+ return code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_PARALLEL_LOOP;
+}
+
+static bool
+oacc_is_kernels (gfc_code *code)
+{
+ return code->op == EXEC_OACC_KERNELS || code->op == EXEC_OACC_KERNELS_LOOP;
+}
+
+static gfc_statement
+omp_code_to_statement (gfc_code *code)
+{
+ switch (code->op)
+ {
+ case EXEC_OMP_PARALLEL:
+ return ST_OMP_PARALLEL;
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ return ST_OMP_PARALLEL_SECTIONS;
+ case EXEC_OMP_SECTIONS:
+ return ST_OMP_SECTIONS;
+ case EXEC_OMP_ORDERED:
+ return ST_OMP_ORDERED;
+ case EXEC_OMP_CRITICAL:
+ return ST_OMP_CRITICAL;
+ case EXEC_OMP_MASTER:
+ return ST_OMP_MASTER;
+ case EXEC_OMP_SINGLE:
+ return ST_OMP_SINGLE;
+ case EXEC_OMP_TASK:
+ return ST_OMP_TASK;
+ case EXEC_OMP_WORKSHARE:
+ return ST_OMP_WORKSHARE;
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ return ST_OMP_PARALLEL_WORKSHARE;
+ case EXEC_OMP_DO:
+ return ST_OMP_DO;
+ default:
+ gcc_unreachable ();
+ }
+}
+
+static gfc_statement
+oacc_code_to_statement (gfc_code *code)
+{
+ switch (code->op)
+ {
+ case EXEC_OACC_PARALLEL:
+ return ST_OACC_PARALLEL;
+ case EXEC_OACC_KERNELS:
+ return ST_OACC_KERNELS;
+ case EXEC_OACC_DATA:
+ return ST_OACC_DATA;
+ case EXEC_OACC_HOST_DATA:
+ return ST_OACC_HOST_DATA;
+ case EXEC_OACC_PARALLEL_LOOP:
+ return ST_OACC_PARALLEL_LOOP;
+ case EXEC_OACC_KERNELS_LOOP:
+ return ST_OACC_KERNELS_LOOP;
+ case EXEC_OACC_LOOP:
+ return ST_OACC_LOOP;
+ default:
+ gcc_unreachable ();
+ }
+}
+
+static void
+resolve_oacc_directive_inside_omp_region (gfc_code *code)
+{
+ if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
+ {
+ gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
+ gfc_statement oacc_st = oacc_code_to_statement (code);
+ gfc_error ("The %s directive cannot be specified within "
+ "a %s region at %L", gfc_ascii_statement (oacc_st),
+ gfc_ascii_statement (st), &code->loc);
+ }
+}
+
+static void
+resolve_omp_directive_inside_oacc_region (gfc_code *code)
+{
+ if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
+ {
+ gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
+ gfc_statement omp_st = omp_code_to_statement (code);
+ gfc_error ("The %s directive cannot be specified within "
+ "a %s region at %L", gfc_ascii_statement (omp_st),
+ gfc_ascii_statement (st), &code->loc);
+ }
+}
+
+
+static void
+resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
+ const char *clause)
+{
+ gfc_symbol *dovar;
+ gfc_code *c;
+ int i;
+
+ for (i = 1; i <= collapse; i++)
+ {
+ if (do_code->op == EXEC_DO_WHILE)
+ {
+ gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
+ "at %L", &do_code->loc);
+ break;
+ }
+ gcc_assert (do_code->op == EXEC_DO || do_code->op == EXEC_DO_CONCURRENT);
+ if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
+ gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
+ &do_code->loc);
+ dovar = do_code->ext.iterator->var->symtree->n.sym;
+ if (i > 1)
+ {
+ gfc_code *do_code2 = code->block->next;
+ int j;
+
+ for (j = 1; j < i; j++)
+ {
+ gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
+ if (dovar == ivar
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
+ || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
+ {
+ gfc_error ("!$ACC LOOP %s loops don't form rectangular iteration space at %L",
+ clause, &do_code->loc);
+ break;
+ }
+ if (j < i)
+ break;
+ do_code2 = do_code2->block->next;
+ }
+ }
+ if (i == collapse)
+ break;
+ for (c = do_code->next; c; c = c->next)
+ if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
+ {
+ gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
+ clause, &c->loc);
+ break;
+ }
+ if (c)
+ break;
+ do_code = do_code->block;
+ if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
+ && do_code->op != EXEC_DO_CONCURRENT)
+ {
+ gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
+ clause, &code->loc);
+ break;
+ }
+ do_code = do_code->next;
+ if (do_code == NULL
+ || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
+ && do_code->op != EXEC_DO_CONCURRENT))
+ {
+ gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
+ clause, &code->loc);
+ break;
+ }
+ }
+}
+
+
+static void
+resolve_oacc_params_in_parallel (gfc_code *code, const char *clause)
+{
+ fortran_omp_context *c;
+
+ if (oacc_is_parallel (code))
+ gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
+ "non-static arguments at %L", clause, &code->loc);
+ for (c = omp_current_ctx; c; c = c->previous)
+ {
+ if (oacc_is_loop (c->code))
+ break;
+ if (oacc_is_parallel (c->code))
+ gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
+ "non-static arguments at %L", clause, &code->loc);
+ }
+}
+
+
+static void
+resolve_oacc_loop_blocks (gfc_code *code)
+{
+ fortran_omp_context *c;
+
+ if (!oacc_is_loop (code))
+ return;
+
+ if (code->op == EXEC_OACC_LOOP)
+ for (c = omp_current_ctx; c; c = c->previous)
+ {
+ if (oacc_is_loop (c->code))
+ {
+ if (code->ext.omp_clauses->gang)
+ {
+ if (c->code->ext.omp_clauses->gang)
+ gfc_error ("Loop parallelized across gangs is not allowed "
+ "inside another loop parallelized across gangs at %L",
+ &code->loc);
+ if (c->code->ext.omp_clauses->worker)
+ gfc_error ("Loop parallelized across gangs is not allowed "
+ "inside loop parallelized across workers at %L",
+ &code->loc);
+ if (c->code->ext.omp_clauses->vector)
+ gfc_error ("Loop parallelized across gangs is not allowed "
+ "inside loop parallelized across workers at %L",
+ &code->loc);
+ }
+ if (code->ext.omp_clauses->worker)
+ {
+ if (c->code->ext.omp_clauses->worker)
+ gfc_error ("Loop parallelized across workers is not allowed "
+ "inside another loop parallelized across workers at %L",
+ &code->loc);
+ if (c->code->ext.omp_clauses->vector)
+ gfc_error ("Loop parallelized across workers is not allowed "
+ "inside another loop parallelized across vectors at %L",
+ &code->loc);
+ }
+ if (code->ext.omp_clauses->vector)
+ if (c->code->ext.omp_clauses->vector)
+ gfc_error ("Loop parallelized across vectors is not allowed "
+ "inside another loop parallelized across vectors at %L",
+ &code->loc);
+ }
+
+ if (oacc_is_parallel (c->code) || oacc_is_kernels (c->code))
+ break;
+ }
+
+ if (code->ext.omp_clauses->seq)
+ {
+ if (code->ext.omp_clauses->independent)
+ gfc_error ("Clause SEQ conflicts with INDEPENDENT at %L", &code->loc);
+ if (code->ext.omp_clauses->gang)
+ gfc_error ("Clause SEQ conflicts with GANG at %L", &code->loc);
+ if (code->ext.omp_clauses->worker)
+ gfc_error ("Clause SEQ conflicts with WORKER at %L", &code->loc);
+ if (code->ext.omp_clauses->vector)
+ gfc_error ("Clause SEQ conflicts with VECTOR at %L", &code->loc);
+ if (code->ext.omp_clauses->par_auto)
+ gfc_error ("Clause SEQ conflicts with AUTO at %L", &code->loc);
+ }
+ if (code->ext.omp_clauses->par_auto)
+ {
+ if (code->ext.omp_clauses->gang)
+ gfc_error ("Clause AUTO conflicts with GANG at %L", &code->loc);
+ if (code->ext.omp_clauses->worker)
+ gfc_error ("Clause AUTO conflicts with WORKER at %L", &code->loc);
+ 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)
+ gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
+ "vectors at the same time at %L", &code->loc);
+
+ if (code->ext.omp_clauses->gang
+ && code->ext.omp_clauses->gang_expr
+ && !code->ext.omp_clauses->gang_static)
+ resolve_oacc_params_in_parallel (code, "GANG");
+
+ if (code->ext.omp_clauses->worker
+ && code->ext.omp_clauses->worker_expr)
+ resolve_oacc_params_in_parallel (code, "WORKER");
+
+ if (code->ext.omp_clauses->tile_list)
+ {
+ gfc_expr_list *el;
+ int num = 0;
+ for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
+ {
+ num++;
+ if (el->expr == NULL)
+ continue;
+ resolve_oacc_positive_int_expr (el->expr, "TILE");
+ if (el->expr->expr_type != EXPR_CONSTANT)
+ gfc_error ("TILE requires constant expression at %L", &code->loc);
+ }
+ resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
+ }
+}
+
+
+void
+gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
+{
+ fortran_omp_context ctx;
+
+ resolve_oacc_loop_blocks (code);
+
+ ctx.code = code;
+ ctx.sharing_clauses = NULL;
+ ctx.private_iterators = new hash_set<gfc_symbol *>;
+ ctx.previous = omp_current_ctx;
+ ctx.is_openmp = false;
+ omp_current_ctx = &ctx;
+
+ gfc_resolve_blocks (code->block, ns);
+
+ omp_current_ctx = ctx.previous;
+ delete ctx.private_iterators;
+}
+
+
+static void
+resolve_oacc_loop (gfc_code *code)
+{
+ gfc_code *do_code;
+ int collapse;
+
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL, true);
+
+ do_code = code->block->next;
+ collapse = code->ext.omp_clauses->collapse;
+
+ if (collapse <= 0)
+ collapse = 1;
+ resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
+}
+
+
+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;
+
+ if (ns->oacc_declare_clauses == NULL)
+ return;
+
+ loc = ns->oacc_declare_clauses->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)
+ {
+ n->sym->mark = 0;
+ if (n->sym->attr.flavor == FL_PARAMETER)
+ gfc_error ("PARAMETER object '%s' 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 '%s' 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");
+}
+
+
+void
+gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
+{
+ resolve_oacc_directive_inside_omp_region (code);
+
+ switch (code->op)
+ {
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_HOST_DATA:
+ case EXEC_OACC_UPDATE:
+ case EXEC_OACC_ENTER_DATA:
+ case EXEC_OACC_EXIT_DATA:
+ case EXEC_OACC_WAIT:
+ resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL,
+ true);
+ break;
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_KERNELS_LOOP:
+ case EXEC_OACC_LOOP:
+ resolve_oacc_loop (code);
+ break;
+ case EXEC_OACC_CACHE:
+ resolve_oacc_cache (code);
+ break;
+ default:
+ break;
+ }
+}
+
/* Resolve OpenMP directive clauses and check various requirements
of each directive. */
void
gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
{
+ resolve_omp_directive_inside_oacc_region (code);
+
if (code->op != EXEC_OMP_ATOMIC)
gfc_maybe_initialize_eh ();
projects / thirdparty / gcc.git / blobdiff