Mercurial > hg > CbC > CbC_gcc
diff gcc/fortran/openmp.c @ 145:1830386684a0
gcc-9.2.0
| author | anatofuz |
|---|---|
| date | Thu, 13 Feb 2020 11:34:05 +0900 |
| parents | 84e7813d76e9 |
| children |
line wrap: on
line diff
--- a/gcc/fortran/openmp.c Thu Oct 25 07:37:49 2018 +0900 +++ b/gcc/fortran/openmp.c Thu Feb 13 11:34:05 2020 +0900 @@ -1,5 +1,5 @@ /* OpenMP directive matching and resolving. - Copyright (C) 2005-2018 Free Software Foundation, Inc. + Copyright (C) 2005-2020 Free Software Foundation, Inc. Contributed by Jakub Jelinek This file is part of GCC. @@ -31,7 +31,7 @@ /* Match an end of OpenMP directive. End of OpenMP directive is optional whitespace, followed by '\n' or comment '!'. */ -match +static match gfc_match_omp_eos (void) { locus old_loc; @@ -57,6 +57,17 @@ return MATCH_NO; } +match +gfc_match_omp_eos_error (void) +{ + if (gfc_match_omp_eos() == MATCH_YES) + return MATCH_YES; + + gfc_error ("Unexpected junk at %C"); + return MATCH_ERROR; +} + + /* Free an omp_clauses structure. */ void @@ -222,7 +233,8 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, bool allow_common, bool *end_colon = NULL, gfc_omp_namelist ***headp = NULL, - bool allow_sections = false) + bool allow_sections = false, + bool allow_derived = false) { gfc_omp_namelist *head, *tail, *p; locus old_loc, cur_loc; @@ -248,7 +260,8 @@ case MATCH_YES: gfc_expr *expr; expr = NULL; - if (allow_sections && gfc_peek_ascii_char () == '(') + if ((allow_sections && gfc_peek_ascii_char () == '(') + || (allow_derived && gfc_peek_ascii_char () == '%')) { gfc_current_locus = cur_loc; m = gfc_match_variable (&expr, 0); @@ -261,6 +274,11 @@ default: break; } + if (gfc_is_coindexed (expr)) + { + gfc_error ("List item shall not be coindexed at %C"); + goto cleanup; + } } gfc_set_sym_referenced (sym); p = gfc_get_omp_namelist (); @@ -780,12 +798,13 @@ OMP_CLAUSE_SIMD, OMP_CLAUSE_THREADS, OMP_CLAUSE_USE_DEVICE_PTR, + OMP_CLAUSE_USE_DEVICE_ADDR, /* Actually, OpenMP 5.0. */ OMP_CLAUSE_NOWAIT, /* This must come last. */ OMP_MASK1_LAST }; -/* OpenACC 2.0 specific clauses. */ +/* OpenACC 2.0+ specific clauses. */ enum omp_mask2 { OMP_CLAUSE_ASYNC, @@ -795,6 +814,7 @@ OMP_CLAUSE_COPY, OMP_CLAUSE_COPYOUT, OMP_CLAUSE_CREATE, + OMP_CLAUSE_NO_CREATE, OMP_CLAUSE_PRESENT, OMP_CLAUSE_DEVICEPTR, OMP_CLAUSE_GANG, @@ -811,6 +831,8 @@ OMP_CLAUSE_TILE, OMP_CLAUSE_IF_PRESENT, OMP_CLAUSE_FINALIZE, + OMP_CLAUSE_ATTACH, + OMP_CLAUSE_DETACH, /* This must come last. */ OMP_MASK2_LAST }; @@ -914,10 +936,12 @@ mapping. */ static bool -gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op) +gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, + bool allow_common, bool allow_derived) { gfc_omp_namelist **head = NULL; - if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true) + if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true, + allow_derived) == MATCH_YES) { gfc_omp_namelist *n; @@ -939,6 +963,14 @@ { gfc_omp_clauses *c = gfc_get_omp_clauses (); locus old_loc; + /* Determine whether we're dealing with an OpenACC directive that permits + derived type member accesses. This in particular disallows + "!$acc declare" from using such accesses, because it's not clear if/how + that should work. */ + bool allow_derived = (openacc + && ((mask & OMP_CLAUSE_ATTACH) + || (mask & OMP_CLAUSE_DETACH) + || (mask & OMP_CLAUSE_HOST_SELF))); gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64); *cp = NULL; @@ -1012,6 +1044,12 @@ needs_space = true; continue; } + if ((mask & OMP_CLAUSE_ATTACH) + && gfc_match ("attach ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_ATTACH, false, + allow_derived)) + continue; break; case 'c': if ((mask & OMP_CLAUSE_COLLAPSE) @@ -1039,7 +1077,8 @@ if ((mask & OMP_CLAUSE_COPY) && gfc_match ("copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM)) + OMP_MAP_TOFROM, true, + allow_derived)) continue; if (mask & OMP_CLAUSE_COPYIN) { @@ -1047,7 +1086,8 @@ { if (gfc_match ("copyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO)) + OMP_MAP_TO, true, + allow_derived)) continue; } else if (gfc_match_omp_variable_list ("copyin (", @@ -1058,7 +1098,7 @@ if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("copyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM)) + OMP_MAP_FROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYPRIVATE) && gfc_match_omp_variable_list ("copyprivate (", @@ -1068,7 +1108,7 @@ if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC)) + OMP_MAP_ALLOC, true, allow_derived)) continue; break; case 'd': @@ -1104,7 +1144,8 @@ if ((mask & OMP_CLAUSE_DELETE) && gfc_match ("delete ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_RELEASE)) + OMP_MAP_RELEASE, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_DEPEND) && gfc_match ("depend ( ") == MATCH_YES) @@ -1147,6 +1188,12 @@ else gfc_current_locus = old_loc; } + if ((mask & OMP_CLAUSE_DETACH) + && gfc_match ("detach ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_DETACH, false, + allow_derived)) + continue; if ((mask & OMP_CLAUSE_DEVICE) && !openacc && c->device == NULL @@ -1156,12 +1203,14 @@ && openacc && gfc_match ("device ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_TO)) + OMP_MAP_FORCE_TO, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_DEVICEPTR) && gfc_match ("deviceptr ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_DEVICEPTR)) + OMP_MAP_FORCE_DEVICEPTR, false, + allow_derived)) continue; if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) && gfc_match_omp_variable_list @@ -1239,7 +1288,8 @@ if ((mask & OMP_CLAUSE_HOST_SELF) && gfc_match ("host ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM)) + OMP_MAP_FORCE_FROM, true, + allow_derived)) continue; break; case 'i': @@ -1432,6 +1482,12 @@ } break; case 'n': + if ((mask & OMP_CLAUSE_NO_CREATE) + && gfc_match ("no_create ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_IF_PRESENT, true, + allow_derived)) + continue; if ((mask & OMP_CLAUSE_NOGROUP) && !c->nogroup && gfc_match ("nogroup") == MATCH_YES) @@ -1511,47 +1567,49 @@ if ((mask & OMP_CLAUSE_COPY) && gfc_match ("pcopy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM)) + OMP_MAP_TOFROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match ("pcopyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO)) + OMP_MAP_TO, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("pcopyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM)) + OMP_MAP_FROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("pcreate ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC)) + OMP_MAP_ALLOC, true, allow_derived)) 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)) + OMP_MAP_FORCE_PRESENT, false, + allow_derived)) continue; if ((mask & OMP_CLAUSE_COPY) && gfc_match ("present_or_copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM)) + OMP_MAP_TOFROM, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match ("present_or_copyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO)) + OMP_MAP_TO, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("present_or_copyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM)) + OMP_MAP_FROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("present_or_create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC)) + OMP_MAP_ALLOC, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRIORITY) && c->priority == NULL @@ -1669,8 +1727,8 @@ if (gfc_match_omp_variable_list (" :", &c->lists[OMP_LIST_REDUCTION], - false, NULL, &head, - openacc) == MATCH_YES) + false, NULL, &head, openacc, + allow_derived) == MATCH_YES) { gfc_omp_namelist *n; if (rop == OMP_REDUCTION_NONE) @@ -1710,22 +1768,17 @@ locus old_loc2 = gfc_current_locus; do { - if (!c->sched_simd - && gfc_match ("simd") == MATCH_YES) + if (gfc_match ("simd") == MATCH_YES) { c->sched_simd = true; nmodifiers++; } - else if (!c->sched_monotonic - && !c->sched_nonmonotonic - && gfc_match ("monotonic") == MATCH_YES) + else if (gfc_match ("monotonic") == MATCH_YES) { c->sched_monotonic = true; nmodifiers++; } - else if (!c->sched_monotonic - && !c->sched_nonmonotonic - && gfc_match ("nonmonotonic") == MATCH_YES) + else if (gfc_match ("nonmonotonic") == MATCH_YES) { c->sched_nonmonotonic = true; nmodifiers++; @@ -1736,7 +1789,7 @@ gfc_current_locus = old_loc2; break; } - if (nmodifiers == 0 + if (nmodifiers == 1 && gfc_match (" , ") == MATCH_YES) continue; else if (gfc_match (" : ") == MATCH_YES) @@ -1774,7 +1827,8 @@ if ((mask & OMP_CLAUSE_HOST_SELF) && gfc_match ("self ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM)) + OMP_MAP_FORCE_FROM, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_SEQ) && !c->seq @@ -1854,6 +1908,11 @@ ("use_device_ptr (", &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES) continue; + if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR) + && gfc_match_omp_variable_list + ("use_device_addr (", + &c->lists[OMP_LIST_USE_DEVICE_ADDR], false) == MATCH_YES) + continue; break; case 'v': /* VECTOR_LENGTH must be matched before VECTOR, because the latter @@ -1881,10 +1940,8 @@ break; case 'w': if ((mask & OMP_CLAUSE_WAIT) - && !c->wait && gfc_match ("wait") == MATCH_YES) { - c->wait = true; match m = match_oacc_expr_list (" (", &c->wait_list, false); if (m == MATCH_ERROR) { @@ -1892,7 +1949,19 @@ break; } else if (m == MATCH_NO) - needs_space = true; + { + gfc_expr *expr + = gfc_get_constant_expr (BT_INTEGER, + gfc_default_integer_kind, + &gfc_current_locus); + mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL); + gfc_expr_list **expr_list = &c->wait_list; + while (*expr_list) + expr_list = &(*expr_list)->next; + *expr_list = gfc_get_expr_list (); + (*expr_list)->expr = expr; + needs_space = true; + } continue; } if ((mask & OMP_CLAUSE_WORKER) @@ -1917,6 +1986,8 @@ if (gfc_match_omp_eos () != MATCH_YES) { + if (!gfc_error_flag_test ()) + gfc_error ("Failed to match clause at %C"); gfc_free_omp_clauses (c); return MATCH_ERROR; } @@ -1930,19 +2001,25 @@ (omp_mask (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_DEVICEPTR \ - | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT \ - | OMP_CLAUSE_WAIT) + | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ + | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) #define OACC_KERNELS_CLAUSES \ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \ | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ - | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_DEFAULT \ - | OMP_CLAUSE_WAIT) + | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) +#define OACC_SERIAL_CLAUSES \ + (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \ + | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ + | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ + | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) #define OACC_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \ | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \ - | OMP_CLAUSE_PRESENT) + | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH) #define OACC_LOOP_CLAUSES \ (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \ | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \ @@ -1952,7 +2029,12 @@ (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES) #define OACC_KERNELS_LOOP_CLAUSES \ (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES) -#define OACC_HOST_DATA_CLAUSES omp_mask (OMP_CLAUSE_USE_DEVICE) +#define OACC_SERIAL_LOOP_CLAUSES \ + (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES) +#define OACC_HOST_DATA_CLAUSES \ + (omp_mask (OMP_CLAUSE_USE_DEVICE) \ + | OMP_CLAUSE_IF \ + | OMP_CLAUSE_IF_PRESENT) #define OACC_DECLARE_CLAUSES \ (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \ @@ -1963,10 +2045,11 @@ | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT) #define OACC_ENTER_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ - | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE) + | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH) #define OACC_EXIT_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ - | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE) + | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \ + | OMP_CLAUSE_DETACH) #define OACC_WAIT_CLAUSES \ omp_mask (OMP_CLAUSE_ASYNC) #define OACC_ROUTINE_CLAUSES \ @@ -2014,6 +2097,20 @@ match +gfc_match_oacc_serial_loop (void) +{ + return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES); +} + + +match +gfc_match_oacc_serial (void) +{ + return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES); +} + + +match gfc_match_oacc_data (void) { return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES); @@ -2070,13 +2167,6 @@ module_var = true; } - if (ns->proc_name->attr.oacc_function) - { - gfc_error ("Invalid declare in routine with $!ACC DECLARE at %L", - &where); - return MATCH_ERROR; - } - if (s->attr.use_assoc) { gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L", @@ -2234,44 +2324,55 @@ return MATCH_YES; } -/* Determine the loop level for a routine. */ - -static int -gfc_oacc_routine_dims (gfc_omp_clauses *clauses) -{ - int level = -1; +/* Determine the OpenACC 'routine' directive's level of parallelism. */ + +static oacc_routine_lop +gfc_oacc_routine_lop (gfc_omp_clauses *clauses) +{ + oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ; if (clauses) { - unsigned mask = 0; + unsigned n_lop_clauses = 0; if (clauses->gang) - level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level); + { + ++n_lop_clauses; + ret = OACC_ROUTINE_LOP_GANG; + } if (clauses->worker) - level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level); + { + ++n_lop_clauses; + ret = OACC_ROUTINE_LOP_WORKER; + } if (clauses->vector) - level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level); + { + ++n_lop_clauses; + ret = OACC_ROUTINE_LOP_VECTOR; + } if (clauses->seq) - level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level); - - if (mask != (mask & -mask)) - gfc_error ("Multiple loop axes specified for routine"); + { + ++n_lop_clauses; + ret = OACC_ROUTINE_LOP_SEQ; + } + + if (n_lop_clauses > 1) + ret = OACC_ROUTINE_LOP_ERROR; } - if (level < 0) - level = GOMP_DIM_MAX; - - return level; + return ret; } match gfc_match_oacc_routine (void) { locus old_loc; + match m; + gfc_intrinsic_sym *isym = NULL; gfc_symbol *sym = NULL; - match m; gfc_omp_clauses *c = NULL; gfc_oacc_routine_name *n = NULL; + oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE; old_loc = gfc_current_locus; @@ -2289,29 +2390,34 @@ if (m == MATCH_YES) { char buffer[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symtree *st; m = gfc_match_name (buffer); if (m == MATCH_YES) { - st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); + gfc_symtree *st = NULL; + + /* First look for an intrinsic symbol. */ + isym = gfc_find_function (buffer); + if (!isym) + isym = gfc_find_subroutine (buffer); + /* If no intrinsic symbol found, search the current namespace. */ + if (!isym) + st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); if (st) { sym = st->n.sym; + /* If the name in a 'routine' directive refers to the containing + subroutine or function, then make sure that we'll later handle + this accordingly. */ if (gfc_current_ns->proc_name != NULL && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0) sym = NULL; } - if (st == NULL - || (sym - && !sym->attr.external - && !sym->attr.function - && !sym->attr.subroutine)) + if (isym == NULL && st == NULL) { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, " - "invalid function name %s", - (sym) ? sym->name : buffer); + gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C", + buffer); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -2337,26 +2443,77 @@ != MATCH_YES)) return MATCH_ERROR; - if (sym != NULL) + lop = gfc_oacc_routine_lop (c); + if (lop == OACC_ROUTINE_LOP_ERROR) + { + gfc_error ("Multiple loop axes specified for routine at %C"); + goto cleanup; + } + + if (isym != NULL) + { + /* Diagnose any OpenACC 'routine' directive that doesn't match the + (implicit) one with a 'seq' clause. */ + if (c && (c->gang || c->worker || c->vector)) + { + gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )" + " at %C marked with incompatible GANG, WORKER, or VECTOR" + " clause"); + goto cleanup; + } + } + else if (sym != NULL) { - n = gfc_get_oacc_routine_name (); - n->sym = sym; - n->clauses = NULL; - n->next = NULL; - if (gfc_current_ns->oacc_routine_names != NULL) - n->next = gfc_current_ns->oacc_routine_names; - - gfc_current_ns->oacc_routine_names = n; + bool add = true; + + /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't + match the first one. */ + for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names; + n_p; + n_p = n_p->next) + if (n_p->sym == sym) + { + add = false; + if (lop != gfc_oacc_routine_lop (n_p->clauses)) + { + gfc_error ("!$ACC ROUTINE already applied at %C"); + goto cleanup; + } + } + + if (add) + { + sym->attr.oacc_routine_lop = lop; + + n = gfc_get_oacc_routine_name (); + n->sym = sym; + n->clauses = c; + n->next = gfc_current_ns->oacc_routine_names; + n->loc = old_loc; + gfc_current_ns->oacc_routine_names = n; + } } else if (gfc_current_ns->proc_name) { + /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't + match the first one. */ + oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop; + if (lop_p != OACC_ROUTINE_LOP_NONE + && lop != lop_p) + { + gfc_error ("!$ACC ROUTINE already applied at %C"); + goto cleanup; + } + if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, gfc_current_ns->proc_name->name, &old_loc)) goto cleanup; - gfc_current_ns->proc_name->attr.oacc_function - = gfc_oacc_routine_dims (c) + 1; + gfc_current_ns->proc_name->attr.oacc_routine_lop = lop; } + else + /* Something has gone wrong, possibly a syntax error. */ + goto cleanup; if (n) n->clauses = c; @@ -2402,7 +2559,7 @@ #define OMP_TASKLOOP_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \ - | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \ + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \ | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \ | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP) #define OMP_TARGET_CLAUSES \ @@ -2412,7 +2569,7 @@ | OMP_CLAUSE_IS_DEVICE_PTR) #define OMP_TARGET_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ - | OMP_CLAUSE_USE_DEVICE_PTR) + | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) #define OMP_TARGET_ENTER_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) @@ -2424,7 +2581,7 @@ | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) #define OMP_TEAMS_CLAUSES \ (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \ - | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION) #define OMP_DISTRIBUTE_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ @@ -3698,6 +3855,7 @@ { return code->op == EXEC_OACC_PARALLEL_LOOP || code->op == EXEC_OACC_KERNELS_LOOP + || code->op == EXEC_OACC_SERIAL_LOOP || code->op == EXEC_OACC_LOOP; } @@ -3739,9 +3897,6 @@ 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 %qs 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 %qs of derived type in %s clause at %L", sym->name, name, &loc); @@ -3777,24 +3932,11 @@ if (sym->as && sym->as->type == AS_ASSUMED_RANK) gfc_error ("Assumed rank array %qs in %s clause at %L", sym->name, name, &loc); - if (sym->as && sym->as->type == AS_DEFERRED && sym->attr.pointer - && !sym->attr.contiguous) - gfc_error ("Noncontiguous deferred shape array %qs in %s clause at %L", - sym->name, name, &loc); } static void 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 %qs 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 %qs 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); } @@ -3941,7 +4083,7 @@ = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP", "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE", - "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR" }; + "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR" }; if (omp_clauses == NULL) return; @@ -4075,6 +4217,30 @@ gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size " "at %L must be positive", &expr->where); } + if (omp_clauses->sched_kind != OMP_SCHED_NONE + && omp_clauses->sched_nonmonotonic) + { + if (omp_clauses->sched_kind != OMP_SCHED_DYNAMIC + && omp_clauses->sched_kind != OMP_SCHED_GUIDED) + { + const char *p; + switch (omp_clauses->sched_kind) + { + case OMP_SCHED_STATIC: p = "STATIC"; break; + case OMP_SCHED_RUNTIME: p = "RUNTIME"; break; + case OMP_SCHED_AUTO: p = "AUTO"; break; + default: gcc_unreachable (); + } + gfc_error ("NONMONOTONIC modifier specified for %s schedule kind " + "at %L", p, &code->loc); + } + else if (omp_clauses->sched_monotonic) + gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers " + "specified at %L", &code->loc); + else if (omp_clauses->ordered) + gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED " + "clause at %L", &code->loc); + } /* Check that no symbol appears on multiple clauses, except that a symbol can appear on both firstprivate and lastprivate. */ @@ -4082,6 +4248,7 @@ for (n = omp_clauses->lists[list]; n; n = n->next) { n->sym->mark = 0; + n->sym->comp_mark = 0; if (n->sym->attr.flavor == FL_VARIABLE || n->sym->attr.proc_pointer || (!code && (!n->sym->attr.dummy || n->sym->ns != ns))) @@ -4119,8 +4286,21 @@ continue; } } - gfc_error ("Object %qs is not a variable at %L", n->sym->name, - &n->where); + if (list == OMP_LIST_MAP + && n->sym->attr.flavor == FL_PARAMETER) + { + if (openacc) + gfc_error ("Object %qs is not a variable at %L; parameters" + " cannot be and need not be copied", n->sym->name, + &n->where); + else + gfc_error ("Object %qs is not a variable at %L; parameters" + " cannot be and need not be mapped", n->sym->name, + &n->where); + } + else + gfc_error ("Object %qs is not a variable at %L", n->sym->name, + &n->where); } for (list = 0; list < OMP_LIST_NUM; list++) @@ -4134,11 +4314,28 @@ && (list != OMP_LIST_REDUCTION || !openacc)) for (n = omp_clauses->lists[list]; n; n = n->next) { - if (n->sym->mark) + bool component_ref_p = false; + + /* Allow multiple components of the same (e.g. derived-type) + variable here. Duplicate components are detected elsewhere. */ + if (n->expr && n->expr->expr_type == EXPR_VARIABLE) + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + component_ref_p = true; + if ((!component_ref_p && n->sym->comp_mark) + || (component_ref_p && n->sym->mark)) + gfc_error ("Symbol %qs has mixed component and non-component " + "accesses at %L", n->sym->name, &n->where); + else if (n->sym->mark) gfc_error ("Symbol %qs present on multiple clauses at %L", n->sym->name, &n->where); else - n->sym->mark = 1; + { + if (component_ref_p) + n->sym->comp_mark = 1; + else + n->sym->mark = 1; + } } gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); @@ -4329,23 +4526,54 @@ "are allowed on ORDERED directive at %L", &n->where); } + gfc_ref *array_ref = NULL; + bool resolved = false; if (n->expr) { - if (!gfc_resolve_expr (n->expr) + array_ref = n->expr->ref; + resolved = gfc_resolve_expr (n->expr); + + /* Look through component refs to find last array + reference. */ + if (openacc && resolved) + { + /* The "!$acc cache" directive allows rectangular + subarrays to be specified, with some restrictions + on the form of bounds (not implemented). + Only raise an error here if we're really sure the + array isn't contiguous. An expression such as + arr(-n:n,-n:n) could be contiguous even if it looks + like it may not be. */ + if (list != OMP_LIST_CACHE + && !gfc_is_simply_contiguous (n->expr, false, true) + && gfc_is_not_contiguous (n->expr)) + gfc_error ("Array is not contiguous at %L", + &n->where); + + while (array_ref + && (array_ref->type == REF_COMPONENT + || (array_ref->type == REF_ARRAY + && array_ref->next + && (array_ref->next->type + == REF_COMPONENT)))) + array_ref = array_ref->next; + } + } + if (array_ref + || (n->expr + && (!resolved || n->expr->expr_type != EXPR_VARIABLE))) + { + if (!resolved || n->expr->expr_type != EXPR_VARIABLE - || n->expr->ref == NULL - || n->expr->ref->next - || n->expr->ref->type != REF_ARRAY) + || array_ref->next + || array_ref->type != REF_ARRAY) gfc_error ("%qs in %s clause at %L is not a proper " "array section", n->sym->name, name, &n->where); - else if (n->expr->ref->u.ar.codimen) - gfc_error ("Coarrays not supported in %s clause at %L", - name, &n->where); else { int i; - gfc_array_ref *ar = &n->expr->ref->u.ar; + gfc_array_ref *ar = &array_ref->u.ar; for (i = 0; i < ar->dimen; i++) if (ar->stride[i]) { @@ -4461,8 +4689,26 @@ } break; case OMP_LIST_IS_DEVICE_PTR: + if (!n->sym->attr.dummy) + gfc_error ("Non-dummy object %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.allocatable + || (n->sym->ts.type == BT_CLASS + && CLASS_DATA (n->sym)->attr.allocatable)) + gfc_error ("ALLOCATABLE object %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.pointer + || (n->sym->ts.type == BT_CLASS + && CLASS_DATA (n->sym)->attr.pointer)) + gfc_error ("POINTER object %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.value) + gfc_error ("VALUE object %qs in %s clause at %L", + n->sym->name, name, &n->where); + break; case OMP_LIST_USE_DEVICE_PTR: - /* FIXME: Handle these. */ + case OMP_LIST_USE_DEVICE_ADDR: + /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */ break; default: for (; n != NULL; n = n->next) @@ -4490,7 +4736,9 @@ n->sym->name, name, &n->where); } if (code - && (oacc_is_loop (code) || code->op == EXEC_OACC_PARALLEL)) + && (oacc_is_loop (code) + || code->op == EXEC_OACC_PARALLEL + || code->op == EXEC_OACC_SERIAL)) check_array_not_assumed (n->sym, n->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", @@ -4761,10 +5009,8 @@ resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER"); if (omp_clauses->vector_expr) resolve_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_scalar_int_expr (el->expr, "WAIT"); + for (el = omp_clauses->wait_list; el; el = el->next) + resolve_scalar_int_expr (el->expr, "WAIT"); if (omp_clauses->collapse && omp_clauses->tile_list) gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc); if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED) @@ -5423,8 +5669,7 @@ 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)) + if (omp_current_ctx->sharing_clauses->contains (sym)) return; if (! omp_current_ctx->private_iterators->add (sym) && add_clause) @@ -5644,12 +5889,6 @@ 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) { @@ -5677,6 +5916,81 @@ return ST_OMP_PARALLEL_WORKSHARE; case EXEC_OMP_DO: return ST_OMP_DO; + case EXEC_OMP_ATOMIC: + return ST_OMP_ATOMIC; + case EXEC_OMP_BARRIER: + return ST_OMP_BARRIER; + case EXEC_OMP_CANCEL: + return ST_OMP_CANCEL; + case EXEC_OMP_CANCELLATION_POINT: + return ST_OMP_CANCELLATION_POINT; + case EXEC_OMP_FLUSH: + return ST_OMP_FLUSH; + case EXEC_OMP_DISTRIBUTE: + return ST_OMP_DISTRIBUTE; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_DISTRIBUTE_PARALLEL_DO; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD; + case EXEC_OMP_DISTRIBUTE_SIMD: + return ST_OMP_DISTRIBUTE_SIMD; + case EXEC_OMP_DO_SIMD: + return ST_OMP_DO_SIMD; + case EXEC_OMP_SIMD: + return ST_OMP_SIMD; + case EXEC_OMP_TARGET: + return ST_OMP_TARGET; + case EXEC_OMP_TARGET_DATA: + return ST_OMP_TARGET_DATA; + case EXEC_OMP_TARGET_ENTER_DATA: + return ST_OMP_TARGET_ENTER_DATA; + case EXEC_OMP_TARGET_EXIT_DATA: + return ST_OMP_TARGET_EXIT_DATA; + case EXEC_OMP_TARGET_PARALLEL: + return ST_OMP_TARGET_PARALLEL; + case EXEC_OMP_TARGET_PARALLEL_DO: + return ST_OMP_TARGET_PARALLEL_DO; + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + return ST_OMP_TARGET_PARALLEL_DO_SIMD; + case EXEC_OMP_TARGET_SIMD: + return ST_OMP_TARGET_SIMD; + case EXEC_OMP_TARGET_TEAMS: + return ST_OMP_TARGET_TEAMS; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + return ST_OMP_TARGET_TEAMS_DISTRIBUTE; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD; + case EXEC_OMP_TARGET_UPDATE: + return ST_OMP_TARGET_UPDATE; + case EXEC_OMP_TASKGROUP: + return ST_OMP_TASKGROUP; + case EXEC_OMP_TASKLOOP: + return ST_OMP_TASKLOOP; + case EXEC_OMP_TASKLOOP_SIMD: + return ST_OMP_TASKLOOP_SIMD; + case EXEC_OMP_TASKWAIT: + return ST_OMP_TASKWAIT; + case EXEC_OMP_TASKYIELD: + return ST_OMP_TASKYIELD; + case EXEC_OMP_TEAMS: + return ST_OMP_TEAMS; + case EXEC_OMP_TEAMS_DISTRIBUTE: + return ST_OMP_TEAMS_DISTRIBUTE; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + return ST_OMP_TEAMS_DISTRIBUTE_SIMD; + case EXEC_OMP_PARALLEL_DO: + return ST_OMP_PARALLEL_DO; + case EXEC_OMP_PARALLEL_DO_SIMD: + return ST_OMP_PARALLEL_DO_SIMD; + default: gcc_unreachable (); } @@ -5691,6 +6005,8 @@ return ST_OACC_PARALLEL; case EXEC_OACC_KERNELS: return ST_OACC_KERNELS; + case EXEC_OACC_SERIAL: + return ST_OACC_SERIAL; case EXEC_OACC_DATA: return ST_OACC_DATA; case EXEC_OACC_HOST_DATA: @@ -5699,10 +6015,26 @@ return ST_OACC_PARALLEL_LOOP; case EXEC_OACC_KERNELS_LOOP: return ST_OACC_KERNELS_LOOP; + case EXEC_OACC_SERIAL_LOOP: + return ST_OACC_SERIAL_LOOP; case EXEC_OACC_LOOP: return ST_OACC_LOOP; case EXEC_OACC_ATOMIC: return ST_OACC_ATOMIC; + case EXEC_OACC_ROUTINE: + return ST_OACC_ROUTINE; + case EXEC_OACC_UPDATE: + return ST_OACC_UPDATE; + case EXEC_OACC_WAIT: + return ST_OACC_WAIT; + case EXEC_OACC_CACHE: + return ST_OACC_CACHE; + case EXEC_OACC_ENTER_DATA: + return ST_OACC_ENTER_DATA; + case EXEC_OACC_EXIT_DATA: + return ST_OACC_EXIT_DATA; + case EXEC_OACC_DECLARE: + return ST_OACC_DECLARE; default: gcc_unreachable (); } @@ -5751,7 +6083,13 @@ "at %L", &do_code->loc); break; } - gcc_assert (do_code->op == EXEC_DO || do_code->op == EXEC_DO_CONCURRENT); + if (do_code->op == EXEC_DO_CONCURRENT) + { + gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L", + &do_code->loc); + break; + } + gcc_assert (do_code->op == EXEC_DO); 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); @@ -5831,75 +6169,9 @@ 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 vectors 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 && 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 " @@ -5950,19 +6222,34 @@ gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) { fortran_omp_context ctx; + gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; + gfc_omp_namelist *n; + int list; resolve_oacc_loop_blocks (code); ctx.code = code; - ctx.sharing_clauses = NULL; + ctx.sharing_clauses = new hash_set<gfc_symbol *>; ctx.private_iterators = new hash_set<gfc_symbol *>; ctx.previous = omp_current_ctx; ctx.is_openmp = false; omp_current_ctx = &ctx; + for (list = 0; list < OMP_LIST_NUM; list++) + switch (list) + { + case OMP_LIST_PRIVATE: + for (n = omp_clauses->lists[list]; n; n = n->next) + ctx.sharing_clauses->add (n->sym); + break; + default: + break; + } + gfc_resolve_blocks (code->block, ns); omp_current_ctx = ctx.previous; + delete ctx.sharing_clauses; delete ctx.private_iterators; } @@ -6000,18 +6287,14 @@ for (n = oc->clauses->lists[list]; n; n = n->next) { n->sym->mark = 0; - if (n->sym->attr.function || n->sym->attr.subroutine) + if (n->sym->attr.flavor != FL_VARIABLE + && (n->sym->attr.flavor != FL_PROCEDURE + || n->sym->result != n->sym)) { gfc_error ("Object %qs is not a variable at %L", n->sym->name, &oc->loc); continue; } - if (n->sym->attr.flavor == FL_PARAMETER) - { - gfc_error ("PARAMETER object %qs is not allowed at %L", - n->sym->name, &oc->loc); - continue; - } if (n->expr && n->expr->ref->type == REF_ARRAY) { @@ -6049,6 +6332,33 @@ } } + +void +gfc_resolve_oacc_routines (gfc_namespace *ns) +{ + for (gfc_oacc_routine_name *orn = ns->oacc_routine_names; + orn; + orn = orn->next) + { + gfc_symbol *sym = orn->sym; + if (!sym->attr.external + && !sym->attr.function + && !sym->attr.subroutine) + { + gfc_error ("NAME %qs does not refer to a subroutine or function" + " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc); + continue; + } + if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc)) + { + gfc_error ("NAME %qs invalid" + " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc); + continue; + } + } +} + + void gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) { @@ -6058,6 +6368,7 @@ { case EXEC_OACC_PARALLEL: case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL: case EXEC_OACC_DATA: case EXEC_OACC_HOST_DATA: case EXEC_OACC_UPDATE: @@ -6069,6 +6380,7 @@ break; case EXEC_OACC_PARALLEL_LOOP: case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_SERIAL_LOOP: case EXEC_OACC_LOOP: resolve_oacc_loop (code); break;