diff options
Diffstat (limited to 'gcc/fortran/openmp.c')
| -rw-r--r-- | gcc/fortran/openmp.c | 1521 |
1 files changed, 1429 insertions, 92 deletions
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 65659c0..005739b 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -27,6 +27,8 @@ along with GCC; see the file COPYING3. If not see #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 '!'. */ @@ -76,11 +78,33 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) 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 @@ -287,45 +311,175 @@ cleanup: 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; @@ -339,6 +493,56 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, unsigned int mask, 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; @@ -376,11 +580,159 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, unsigned int mask, &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) @@ -785,6 +1137,352 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, unsigned int mask, 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 \ @@ -1916,6 +2614,129 @@ gfc_match_omp_end_single (void) } +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; @@ -2013,19 +2834,45 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, 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; @@ -2115,12 +2962,13 @@ resolve_omp_clauses (gfc_code *code, locus *where, && 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 @@ -2262,53 +3110,64 @@ resolve_omp_clauses (gfc_code *code, locus *where, 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) { @@ -2346,7 +3205,10 @@ resolve_omp_clauses (gfc_code *code, locus *where, 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) @@ -2366,6 +3228,7 @@ resolve_omp_clauses (gfc_code *code, locus *where, default: break; } + switch (list) { case OMP_LIST_REDUCTION: @@ -2499,6 +3362,30 @@ resolve_omp_clauses (gfc_code *code, locus *where, 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; } @@ -2554,6 +3441,25 @@ resolve_omp_clauses (gfc_code *code, locus *where, 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"); } @@ -3021,6 +3927,7 @@ struct fortran_omp_context 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; @@ -3065,6 +3972,7 @@ gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) 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++) @@ -3159,7 +4067,12 @@ gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym) 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)) @@ -3340,6 +4253,428 @@ resolve_omp_do (gfc_code *code) } } +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. */ @@ -3347,6 +4682,8 @@ resolve_omp_do (gfc_code *code) 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 (); |