This patch adds support for OpenACC 2.0a, with some omissions, to the
fortran front end. It only contains the fortran changes from
gomp-4_0-branch, therefore the middle end and runtime changes are a
necessary prerequisite for this patch. I'll post a separate patch with
the fortran tests later. If anyone wants to test this patch, please use
gomp-4_0-branch instead. You don't need a CUDA accelerator to use
OpenACC, and some of the runtime tests will fail because that branch
doesn't include the nvptx backend.
Notable OpenACC omissions include support for the device_type clause and
the atomic directive. Hopefully we can get those in before 5.0 is released.
All of theses changes have been approved for gomp-4_0-branch. Is this
patch OK for mainline trunk (after the runtime and middle end go in)?
Ilmir, I know that you contributed most of OpenACC support to the
fortran front end. Am I missing any other authors in the ChangeLog?
Thanks,
Cesar
2014-11-06 Cesar Philippidis <ce...@codesourcery.com>
Thomas Schwinge <tho...@codesourcery.com>
Ilmir Usmanov <i.usma...@samsung.com>
gcc/fortran/
* cpp.c (cpp_define_builtins): Conditionally define _OPENACC.
* dump-parse-tree.c
(show_omp_node): Dump also OpenACC executable statements.
(show_code_node): Call it.
(show_namespace): Dump !$ACC DECLARE directive.
* f95-lang.c (gfc_init_builtin_functions): Handle openacc builtins.
* gfortran.h (gfc_statement): Add ST_OACC_PARALLEL_LOOP,
ST_OACC_END_PARALLEL_LOOP, ST_OACC_PARALLEL, ST_OACC_END_PARALLEL,
ST_OACC_KERNELS, ST_OACC_END_KERNELS, ST_OACC_DATA, ST_OACC_END_DATA,
ST_OACC_HOST_DATA, ST_OACC_END_HOST_DATA, ST_OACC_LOOP,
ST_OACC_END_LOOP, ST_OACC_DECLARE, ST_OACC_UPDATE, ST_OACC_WAIT,
ST_OACC_CACHE, ST_OACC_KERNELS_LOOP, ST_OACC_END_KERNELS_LOOP,
ST_OACC_ENTER_DATA, ST_OACC_EXIT_DATA, ST_OACC_ROUTINE.
(gfc_expr_list): New struct.
(gfc_omp_map_op): Add OMP_MAP_FORCE_ALLOC, OMP_MAP_FORCE_DEALLOC,
OMP_MAP_FORCE_TO, OMP_MAP_FORCE_FROM, OMP_MAP_FORCE_TOFROM,
OMP_MAP_FORCE_PRESENT.
(enum): Add OMP_LIST_COPY, OMP_LIST_DATA_CLAUSE_FIRST,
OMP_LIST_DEVICEPTR, OMP_LIST_DATA_CLAUSE_LAST,
OMP_LIST_DEVICE_RESIDENT, OMP_LIST_USE_DEVICE, OMP_LIST_CACHE,
OMP_LIST_NUM, OMP_LIST_LAST = OMP_LIST_NUM.
(struct gfc_omp_classes): Add async_expr, gang_expr, worker_expr,
vector_expr, num_gangs_expr, num_workers_expr, vector_length_expr,
wait_list, tile_list, async, gang, worker, vector, seq, independent,
wait, par_auto, gang_static and union locus loc.
(struct gfc_namespace): Add oacc_declare_clauses.
(gfc_exec_op): Add EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP,
EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS, EXEC_OACC_DATA,
EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT,
EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA.
(gfc_option_t): Add gfc_flag_openacc.
(gfc_free_expr_list): Declare.
(gfc_resolve_oacc_directive): Declare.
(gfc_resolve_oacc_declare): Declare.
(gfc_resolve_oacc_parallel_loop_blocks): Declare.
(gfc_resolve_oacc_blocks): Declare.
* gfortran.texi: Add notes regarding OpenACC.
* intrinsic.texi: Likewise.
* invoke.texi: Likewise.
* lang.opt (fopenacc): New option.
* match.c (match_exit_cycle): Handle EXEC_OACC_LOOP and
EXEC_OACC_PARALLEL_LOOP.
* match.h (gfc_match_oacc_cache, gfc_match_oacc_wait,
gfc_match_oacc_update, gfc_match_oacc_declare, gfc_match_oacc_loop,
gfc_match_oacc_host_data, gfc_match_oacc_data, gfc_match_oacc_kernels,
gfc_match_oacc_kernels_loop, gfc_match_oacc_parallel,
gfc_match_oacc_parallel, gfc_match_oacc_parallel_loop,
gfc_match_oacc_enter_data, gfc_match_oacc_exit_data,
gfc_match_oacc_routine): Declare.
* openmp.c (gfc_free_omp_clauses): Free various OpenACC exprs and
lists.
(gfc_free_expr_list): New function.
(match_oacc_expr_list): New function.
(match_oacc_clause_gang): New function.
(OMP_CLAUSE_ASYNC, OMP_CLAUSE_NUM_GANGS, OMP_CLAUSE_NUM_WORKERS,
OMP_CLAUSE_VECTOR_LENGTH, OMP_CLAUSE_COPY, 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_GANG, OMP_CLAUSE_WORKER, OMP_CLAUSE_VECTOR,
OMP_CLAUSE_SEQ, OMP_CLAUSE_INDEPENDENT, OMP_CLAUSE_USE_DEVICE,
OMP_CLAUSE_DEVICE_RESIDENT, OMP_CLAUSE_HOST_SELF,
OMP_CLAUSE_OACC_DEVICE, OMP_CLAUSE_WAIT, OMP_CLAUSE_DELETE,
OMP_CLAUSE_AUTO, OMP_CLAUSE_TILE): New defines.
(gfc_match_omp_map_clause): New function.
(gfc_match_omp_clauses): Handle OpenACC clauses.
(OACC_PARALLEL_CLAUSES, define OACC_KERNELS_CLAUSES,
OACC_DATA_CLAUSES, define OACC_LOOP_CLAUSES,
OACC_PARALLEL_LOOP_CLAUSES, OACC_KERNELS_LOOP_CLAUSES,
OACC_HOST_DATA_CLAUSES, OACC_DECLARE_CLAUSES, OACC_UPDATE_CLAUSES,
OACC_ENTER_DATA_CLAUSES, OACC_EXIT_DATA_CLAUSES,
OACC_WAIT_CLAUSES): New defines.
(gfc_match_oacc_parallel_loop): New function.
(gfc_match_oacc_parallel): New function.
(gfc_match_oacc_kernels_loop): New function.
(gfc_match_oacc_kernels): New function.
(gfc_match_oacc_data): New function.
(gfc_match_oacc_host_data): New function.
(gfc_match_oacc_loop): New function.
(gfc_match_oacc_declare): New function.
(gfc_match_oacc_update): New function.
(gfc_match_oacc_enter_data): New function.
(gfc_match_oacc_exit_data): New function.
(gfc_match_oacc_wait): New function.
(gfc_match_oacc_cache): New function
(gfc_match_oacc_routine): New function.
(gfc_match_omp_end_nowait): New function.
(oacc_is_loop): New funcion.
(resolve_oacc_scalar_int_expr): New function.
(resolve_oacc_positive_int_expr): New function.
(check_symbol_not_pointer): New function.
(check_array_not_assumed): New function.
(resolve_oacc_data_clauses): New function.
(resolve_oacc_deviceptr_clause): New function.
(oacc_compatible_clauses): New function.
(resolve_omp_clauses): Handle openacc clauses.
(struct fortran_omp_context): Add an is_openmp member.
(gfc_resolve_omp_parallel_blocks): Set it.
(gfc_resolve_do_iterator): Check it.
(oacc_is_parallel): New function.
(oacc_is_kernels): New function.
(omp_code_to_statement): New function.
(oacc_code_to_statement): New function.
(resolve_oacc_directive_inside_omp_region): New function.
(resolve_omp_directive_inside_oacc_region): New function.
(resolve_oacc_nested_loops): New function.
(resolve_oacc_params_in_parallel): New function.
(resolve_oacc_loop_blocks): New function.
(gfc_resolve_oacc_blocks): New function.
(resolve_oacc_loop): New function.
(resolve_oacc_cache): New function.
(gfc_resolve_oacc_declare): New function.
(gfc_resolve_oacc_directive): New function.
(gfc_resolve_omp_directive): Handle openacc regions.
* options.c (gfc_init_options): Initialize gfc_flag_openacc.
(gfc_handle_option): Handle OPT_fopenacc.
* parse.c (decode_oacc_directive): New function.
(verify_token_free): New function.
(next_free): Handle OpenACC directives.
(verify_token_fixed): New function.
(next_fixed): Handle OpenACC directives.
(next_statement): Handle ST_OACC_UPDATE, ST_OACC_WAIT, ST_OACC_CACHE,
ST_OACC_ENTER_DATA, ST_OACC_EXIT_DATA, ST_OACC_PARALLEL_LOOP,
ST_OACC_PARALLEL, ST_OACC_KERNELS, ST_OACC_DATA, ST_OACC_HOST_DATA,
ST_OACC_LOOP, ST_OACC_KERNELS_LOOP, and ST_OACC_ROUTINE.
(push_state): Handle oacc_declare_clauses.
(gfc_ascii_statement): Handle OpenACC statements.
(verify_st_order): Handle ST_OACC_DECLARE.
(parse_critical_block): Handle OpenACC directives.
(parse_oacc_structured_block): New function.
(parse_oacc_loop): New function.
(parse_executable): Handle ST_OACC_PARALLEL_LOOP, ST_OACC_KERNELS_LOOP,
ST_OACC_LOOP, ST_OACC_PARALLEL, ST_OACC_KERNELS, ST_OACC_DATA,
ST_OACC_HOST_DATA statements.
* parse.h (struct gfc_state_data): Add oacc_declare_clauses to
union ext.
* resolve.c (gfc_resolve_blocks): Handle EXEC_OACC_PARALLEL_LOOP,
EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS_LOOP, EXEC_OACC_KERNELS,
EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE,
EXEC_OACC_WAIT, EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA,
EXEC_OACC_EXIT_DATA.
(gfc_resolve_code): Likewise.
(resolve_codes): Handle OpenACC execs.
* scanner.c (openacc_flag, openacc_locus): New static global variables.
(skip_oacc_attribute): New function.
(skip_omp_attribute): New function.
(skip_free_comments): Handle -fopenacc.
(skip_fixed_comments): Likewise.
(gfc_next_char_literal): Likewise.
* st.c (gfc_free_statement): Handle EXEC_OACC_PARALLEL_LOOP,
EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS_LOOP, EXEC_OACC_KERNELS,
EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE,
EXEC_OACC_WAIT, EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA,
EXEC_OACC_EXIT_DATA.
* trans-decl.c (gfc_generate_function_code): Handle openacc declare
clauses.
* trans-openmp.c (gfc_trans_omp_map_clause_list): New function.
(gfc_convert_expr_to_tree): New function.
(gfc_trans_omp_clauses): Handle OpenACC clauses.
(gfc_trans_oacc_construct): New function.
(gfc_trans_oacc_executable_directive): New function.
(gfc_trans_oacc_wait_directive): New function.
(gfc_trans_omp_do): Handle EXEC_OACC_LOOP.
(gfc_trans_oacc_combined_directive): New function.
(gfc_trans_oacc_declare): New function.
(gfc_trans_oacc_directive): New function.
* trans-stmt.c (gfc_trans_block_construct): Handle OpenACC declare
statements.
* trans-stmt.h (gfc_trans_oacc_directive): Declare.
(gfc_trans_oacc_declare): Declare.
* trans.c (trans_code): Handle EXEC_OACC_PARALLEL_LOOP,
EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS_LOOP, EXEC_OACC_KERNELS,
EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE,
EXEC_OACC_WAIT, EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA,
EXEC_OACC_EXIT_DATA.
* types.def (BT_FN_INT_INT, BT_FN_VOID_INT_PTR_INT,
BT_FN_VOID_INT_INT_VAR,
BT_FN_VOID_INT_PTR_SIZE_PTR_PTR_PTR_INT_INT_VAR,
BT_FN_VOID_INT_OMPFN_PTR_SIZE_PTR_PTR_PTR_INT_INT_INT_INT_INT_VAR): New
types.
diff --git a/gcc/fortran/cpp.c b/gcc/fortran/cpp.c
index 7fb8d16..c7c8769 100644
--- a/gcc/fortran/cpp.c
+++ b/gcc/fortran/cpp.c
@@ -170,6 +170,9 @@ cpp_define_builtins (cpp_reader *pfile)
cpp_define (pfile, "__GFORTRAN__=1");
cpp_define (pfile, "_LANGUAGE_FORTRAN=1");
+ if (gfc_option.gfc_flag_openacc)
+ cpp_define (pfile, "_OPENACC=201306");
+
if (gfc_option.gfc_flag_openmp)
cpp_define (pfile, "_OPENMP=201307");
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 19f83a9..57af730 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1072,7 +1072,267 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
}
}
-/* Show a single OpenMP directive node and everything underneath it
+
+/* Show OpenMP or OpenACC clauses. */
+
+static void
+show_omp_clauses (gfc_omp_clauses *omp_clauses)
+{
+ int list_type;
+
+ switch (omp_clauses->cancel)
+ {
+ case OMP_CANCEL_UNKNOWN:
+ break;
+ case OMP_CANCEL_PARALLEL:
+ fputs (" PARALLEL", dumpfile);
+ break;
+ case OMP_CANCEL_SECTIONS:
+ fputs (" SECTIONS", dumpfile);
+ break;
+ case OMP_CANCEL_DO:
+ fputs (" DO", dumpfile);
+ break;
+ case OMP_CANCEL_TASKGROUP:
+ fputs (" TASKGROUP", dumpfile);
+ break;
+ }
+ if (omp_clauses->if_expr)
+ {
+ fputs (" IF(", dumpfile);
+ show_expr (omp_clauses->if_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->final_expr)
+ {
+ fputs (" FINAL(", dumpfile);
+ show_expr (omp_clauses->final_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->num_threads)
+ {
+ fputs (" NUM_THREADS(", dumpfile);
+ show_expr (omp_clauses->num_threads);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->async)
+ {
+ fputs (" ASYNC", dumpfile);
+ if (omp_clauses->async_expr)
+ {
+ fputc ('(', dumpfile);
+ show_expr (omp_clauses->async_expr);
+ fputc (')', dumpfile);
+ }
+ }
+ if (omp_clauses->num_gangs_expr)
+ {
+ fputs (" NUM_GANGS(", dumpfile);
+ show_expr (omp_clauses->num_gangs_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->num_workers_expr)
+ {
+ fputs (" NUM_WORKERS(", dumpfile);
+ show_expr (omp_clauses->num_workers_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->vector_length_expr)
+ {
+ fputs (" VECTOR_LENGTH(", dumpfile);
+ show_expr (omp_clauses->vector_length_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->gang)
+ {
+ fputs (" GANG", dumpfile);
+ if (omp_clauses->gang_expr)
+ {
+ fputc ('(', dumpfile);
+ show_expr (omp_clauses->gang_expr);
+ fputc (')', dumpfile);
+ }
+ }
+ if (omp_clauses->worker)
+ {
+ fputs (" WORKER", dumpfile);
+ if (omp_clauses->worker_expr)
+ {
+ fputc ('(', dumpfile);
+ show_expr (omp_clauses->worker_expr);
+ fputc (')', dumpfile);
+ }
+ }
+ if (omp_clauses->vector)
+ {
+ fputs (" VECTOR", dumpfile);
+ if (omp_clauses->vector_expr)
+ {
+ fputc ('(', dumpfile);
+ show_expr (omp_clauses->vector_expr);
+ fputc (')', dumpfile);
+ }
+ }
+ if (omp_clauses->sched_kind != OMP_SCHED_NONE)
+ {
+ const char *type;
+ switch (omp_clauses->sched_kind)
+ {
+ case OMP_SCHED_STATIC: type = "STATIC"; break;
+ case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
+ case OMP_SCHED_GUIDED: type = "GUIDED"; break;
+ case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
+ case OMP_SCHED_AUTO: type = "AUTO"; break;
+ default:
+ gcc_unreachable ();
+ }
+ fprintf (dumpfile, " SCHEDULE (%s", type);
+ if (omp_clauses->chunk_size)
+ {
+ fputc (',', dumpfile);
+ show_expr (omp_clauses->chunk_size);
+ }
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
+ {
+ const char *type;
+ switch (omp_clauses->default_sharing)
+ {
+ case OMP_DEFAULT_NONE: type = "NONE"; break;
+ case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
+ case OMP_DEFAULT_SHARED: type = "SHARED"; break;
+ case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
+ default:
+ gcc_unreachable ();
+ }
+ fprintf (dumpfile, " DEFAULT(%s)", type);
+ }
+ if (omp_clauses->tile_list)
+ {
+ gfc_expr_list *list;
+ fputs (" TILE(", dumpfile);
+ for (list = omp_clauses->tile_list; list; list = list->next)
+ {
+ show_expr (list->expr);
+ if (list->next)
+ fputs (", ", dumpfile);
+ }
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->wait_list)
+ {
+ gfc_expr_list *list;
+ fputs (" WAIT(", dumpfile);
+ for (list = omp_clauses->wait_list; list; list = list->next)
+ {
+ show_expr (list->expr);
+ if (list->next)
+ fputs (", ", dumpfile);
+ }
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->seq)
+ fputs (" SEQ", dumpfile);
+ if (omp_clauses->independent)
+ fputs (" INDEPENDENT", dumpfile);
+ if (omp_clauses->ordered)
+ fputs (" ORDERED", dumpfile);
+ if (omp_clauses->untied)
+ fputs (" UNTIED", dumpfile);
+ if (omp_clauses->mergeable)
+ fputs (" MERGEABLE", dumpfile);
+ if (omp_clauses->collapse)
+ fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
+ for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
+ if (omp_clauses->lists[list_type] != NULL
+ && list_type != OMP_LIST_COPYPRIVATE)
+ {
+ const char *type = NULL;
+ switch (list_type)
+ {
+ case OMP_LIST_COPY: type = "COPY"; break;
+ case OMP_LIST_DEVICEPTR: type = "DEVICEPTR"; break;
+ case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break;
+ case OMP_LIST_DEVICE_RESIDENT: type = "USE_DEVICE"; break;
+ case OMP_LIST_CACHE: type = ""; break;
+ case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
+ case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
+ case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
+ case OMP_LIST_SHARED: type = "SHARED"; break;
+ case OMP_LIST_COPYIN: type = "COPYIN"; break;
+ case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
+ case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
+ case OMP_LIST_LINEAR: type = "LINEAR"; break;
+ case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
+ case OMP_LIST_DEPEND: type = "DEPEND"; break;
+ default:
+ gcc_unreachable ();
+ }
+ fprintf (dumpfile, " %s(", type);
+ show_omp_namelist (list_type, omp_clauses->lists[list_type]);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->safelen_expr)
+ {
+ fputs (" SAFELEN(", dumpfile);
+ show_expr (omp_clauses->safelen_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->simdlen_expr)
+ {
+ fputs (" SIMDLEN(", dumpfile);
+ show_expr (omp_clauses->simdlen_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->inbranch)
+ fputs (" INBRANCH", dumpfile);
+ if (omp_clauses->notinbranch)
+ fputs (" NOTINBRANCH", dumpfile);
+ if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
+ {
+ const char *type;
+ switch (omp_clauses->proc_bind)
+ {
+ case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
+ case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
+ case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
+ default:
+ gcc_unreachable ();
+ }
+ fprintf (dumpfile, " PROC_BIND(%s)", type);
+ }
+ if (omp_clauses->num_teams)
+ {
+ fputs (" NUM_TEAMS(", dumpfile);
+ show_expr (omp_clauses->num_teams);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->device)
+ {
+ fputs (" DEVICE(", dumpfile);
+ show_expr (omp_clauses->device);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->thread_limit)
+ {
+ fputs (" THREAD_LIMIT(", dumpfile);
+ show_expr (omp_clauses->thread_limit);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE)
+ {
+ fprintf (dumpfile, " DIST_SCHEDULE (static");
+ if (omp_clauses->dist_chunk_size)
+ {
+ fputc (',', dumpfile);
+ show_expr (omp_clauses->dist_chunk_size);
+ }
+ fputc (')', dumpfile);
+ }
+}
+
+/* Show a single OpenMP or OpenACC directive node and everything underneath it
if necessary. */
static void
@@ -1080,9 +1340,22 @@ show_omp_node (int level, gfc_code *c)
{
gfc_omp_clauses *omp_clauses = NULL;
const char *name = NULL;
+ bool is_oacc = false;
switch (c->op)
{
+ case EXEC_OACC_PARALLEL_LOOP: name = "PARALLEL LOOP"; is_oacc = true; break;
+ case EXEC_OACC_PARALLEL: name = "PARALLEL"; is_oacc = true; break;
+ case EXEC_OACC_KERNELS_LOOP: name = "KERNELS LOOP"; is_oacc = true; break;
+ case EXEC_OACC_KERNELS: name = "KERNELS"; is_oacc = true; break;
+ case EXEC_OACC_DATA: name = "DATA"; is_oacc = true; break;
+ case EXEC_OACC_HOST_DATA: name = "HOST_DATA"; is_oacc = true; break;
+ case EXEC_OACC_LOOP: name = "LOOP"; is_oacc = true; break;
+ case EXEC_OACC_UPDATE: name = "UPDATE"; is_oacc = true; break;
+ case EXEC_OACC_WAIT: name = "WAIT"; is_oacc = true; break;
+ case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
+ case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
+ case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
case EXEC_OMP_CANCEL: name = "CANCEL"; break;
@@ -1109,9 +1382,21 @@ show_omp_node (int level, gfc_code *c)
default:
gcc_unreachable ();
}
- fprintf (dumpfile, "!$OMP %s", name);
+ fprintf (dumpfile, "!$%s %s", is_oacc ? "ACC" : "OMP", name);
switch (c->op)
{
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_KERNELS_LOOP:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_HOST_DATA:
+ case EXEC_OACC_LOOP:
+ case EXEC_OACC_UPDATE:
+ case EXEC_OACC_WAIT:
+ case EXEC_OACC_CACHE:
+ case EXEC_OACC_ENTER_DATA:
+ case EXEC_OACC_EXIT_DATA:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_DO:
@@ -1148,170 +1433,13 @@ show_omp_node (int level, gfc_code *c)
break;
}
if (omp_clauses)
- {
- int list_type;
-
- switch (omp_clauses->cancel)
- {
- case OMP_CANCEL_UNKNOWN:
- break;
- case OMP_CANCEL_PARALLEL:
- fputs (" PARALLEL", dumpfile);
- break;
- case OMP_CANCEL_SECTIONS:
- fputs (" SECTIONS", dumpfile);
- break;
- case OMP_CANCEL_DO:
- fputs (" DO", dumpfile);
- break;
- case OMP_CANCEL_TASKGROUP:
- fputs (" TASKGROUP", dumpfile);
- break;
- }
- if (omp_clauses->if_expr)
- {
- fputs (" IF(", dumpfile);
- show_expr (omp_clauses->if_expr);
- fputc (')', dumpfile);
- }
- if (omp_clauses->final_expr)
- {
- fputs (" FINAL(", dumpfile);
- show_expr (omp_clauses->final_expr);
- fputc (')', dumpfile);
- }
- if (omp_clauses->num_threads)
- {
- fputs (" NUM_THREADS(", dumpfile);
- show_expr (omp_clauses->num_threads);
- fputc (')', dumpfile);
- }
- if (omp_clauses->sched_kind != OMP_SCHED_NONE)
- {
- const char *type;
- switch (omp_clauses->sched_kind)
- {
- case OMP_SCHED_STATIC: type = "STATIC"; break;
- case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
- case OMP_SCHED_GUIDED: type = "GUIDED"; break;
- case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
- case OMP_SCHED_AUTO: type = "AUTO"; break;
- default:
- gcc_unreachable ();
- }
- fprintf (dumpfile, " SCHEDULE (%s", type);
- if (omp_clauses->chunk_size)
- {
- fputc (',', dumpfile);
- show_expr (omp_clauses->chunk_size);
- }
- fputc (')', dumpfile);
- }
- if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
- {
- const char *type;
- switch (omp_clauses->default_sharing)
- {
- case OMP_DEFAULT_NONE: type = "NONE"; break;
- case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
- case OMP_DEFAULT_SHARED: type = "SHARED"; break;
- case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
- default:
- gcc_unreachable ();
- }
- fprintf (dumpfile, " DEFAULT(%s)", type);
- }
- if (omp_clauses->ordered)
- fputs (" ORDERED", dumpfile);
- if (omp_clauses->untied)
- fputs (" UNTIED", dumpfile);
- if (omp_clauses->mergeable)
- fputs (" MERGEABLE", dumpfile);
- if (omp_clauses->collapse)
- fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
- for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
- if (omp_clauses->lists[list_type] != NULL
- && list_type != OMP_LIST_COPYPRIVATE)
- {
- const char *type = NULL;
- switch (list_type)
- {
- case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
- case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
- case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
- case OMP_LIST_SHARED: type = "SHARED"; break;
- case OMP_LIST_COPYIN: type = "COPYIN"; break;
- case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
- case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
- case OMP_LIST_LINEAR: type = "LINEAR"; break;
- case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
- case OMP_LIST_DEPEND: type = "DEPEND"; break;
- default:
- gcc_unreachable ();
- }
- fprintf (dumpfile, " %s(", type);
- show_omp_namelist (list_type, omp_clauses->lists[list_type]);
- fputc (')', dumpfile);
- }
- if (omp_clauses->safelen_expr)
- {
- fputs (" SAFELEN(", dumpfile);
- show_expr (omp_clauses->safelen_expr);
- fputc (')', dumpfile);
- }
- if (omp_clauses->simdlen_expr)
- {
- fputs (" SIMDLEN(", dumpfile);
- show_expr (omp_clauses->simdlen_expr);
- fputc (')', dumpfile);
- }
- if (omp_clauses->inbranch)
- fputs (" INBRANCH", dumpfile);
- if (omp_clauses->notinbranch)
- fputs (" NOTINBRANCH", dumpfile);
- if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
- {
- const char *type;
- switch (omp_clauses->proc_bind)
- {
- case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
- case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
- case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
- default:
- gcc_unreachable ();
- }
- fprintf (dumpfile, " PROC_BIND(%s)", type);
- }
- if (omp_clauses->num_teams)
- {
- fputs (" NUM_TEAMS(", dumpfile);
- show_expr (omp_clauses->num_teams);
- fputc (')', dumpfile);
- }
- if (omp_clauses->device)
- {
- fputs (" DEVICE(", dumpfile);
- show_expr (omp_clauses->device);
- fputc (')', dumpfile);
- }
- if (omp_clauses->thread_limit)
- {
- fputs (" THREAD_LIMIT(", dumpfile);
- show_expr (omp_clauses->thread_limit);
- fputc (')', dumpfile);
- }
- if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE)
- {
- fprintf (dumpfile, " DIST_SCHEDULE (static");
- if (omp_clauses->dist_chunk_size)
- {
- fputc (',', dumpfile);
- show_expr (omp_clauses->dist_chunk_size);
- }
- fputc (')', dumpfile);
- }
- }
+ show_omp_clauses (omp_clauses);
fputc ('\n', dumpfile);
+
+ /* OpenACC executable directives don't have associated blocks. */
+ if (c->op == EXEC_OACC_CACHE || c->op == EXEC_OACC_UPDATE
+ || c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA)
+ return;
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
{
gfc_code *d = c->block;
@@ -1331,7 +1459,7 @@ show_omp_node (int level, gfc_code *c)
return;
fputc ('\n', dumpfile);
code_indent (level, 0);
- fprintf (dumpfile, "!$OMP END %s", name);
+ fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name);
if (omp_clauses != NULL)
{
if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
@@ -2311,6 +2439,18 @@ show_code_node (int level, gfc_code *c)
fprintf (dumpfile, " EOR=%d", dt->eor->value);
break;
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_KERNELS_LOOP:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_HOST_DATA:
+ case EXEC_OACC_LOOP:
+ case EXEC_OACC_UPDATE:
+ case EXEC_OACC_WAIT:
+ case EXEC_OACC_CACHE:
+ case EXEC_OACC_ENTER_DATA:
+ case EXEC_OACC_EXIT_DATA:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
@@ -2432,6 +2572,14 @@ show_namespace (gfc_namespace *ns)
for (eq = ns->equiv; eq; eq = eq->next)
show_equiv (eq);
+ if (ns->oacc_declare_clauses)
+ {
+ /* Dump !$ACC DECLARE clauses. */
+ show_indent ();
+ fprintf (dumpfile, "!$ACC DECLARE");
+ show_omp_clauses (ns->oacc_declare_clauses);
+ }
+
fputc ('\n', dumpfile);
show_indent ();
fputs ("code:", dumpfile);
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c
index c313606..d660bf7 100644
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -662,6 +662,11 @@ gfc_init_builtin_functions (void)
#define DEF_FUNCTION_TYPE_8(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
ARG6, ARG7, ARG8) NAME,
#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
+#define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME,
+#define DEF_FUNCTION_TYPE_VAR_8(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
+ ARG6, ARG7, ARG8) NAME,
+#define DEF_FUNCTION_TYPE_VAR_12(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
+ ARG6, ARG7, ARG8, ARG9, ARG10, ARG11, ARG12) NAME,
#define DEF_POINTER_TYPE(NAME, TYPE) NAME,
#include "types.def"
#undef DEF_PRIMITIVE_TYPE
@@ -675,6 +680,9 @@ gfc_init_builtin_functions (void)
#undef DEF_FUNCTION_TYPE_7
#undef DEF_FUNCTION_TYPE_8
#undef DEF_FUNCTION_TYPE_VAR_0
+#undef DEF_FUNCTION_TYPE_VAR_2
+#undef DEF_FUNCTION_TYPE_VAR_8
+#undef DEF_FUNCTION_TYPE_VAR_12
#undef DEF_POINTER_TYPE
BT_LAST
};
@@ -1109,6 +1117,42 @@ gfc_init_builtin_functions (void)
builtin_types[(int) ENUM] \
= build_varargs_function_type_list (builtin_types[(int) RETURN], \
NULL_TREE);
+#define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \
+ builtin_types[(int) ENUM] \
+ = build_varargs_function_type_list (builtin_types[(int) RETURN], \
+ builtin_types[(int) ARG1], \
+ builtin_types[(int) ARG2], \
+ NULL_TREE);
+#define DEF_FUNCTION_TYPE_VAR_8(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
+ ARG6, ARG7, ARG8) \
+ builtin_types[(int) ENUM] \
+ = build_varargs_function_type_list (builtin_types[(int) RETURN], \
+ builtin_types[(int) ARG1], \
+ builtin_types[(int) ARG2], \
+ builtin_types[(int) ARG3], \
+ builtin_types[(int) ARG4], \
+ builtin_types[(int) ARG5], \
+ builtin_types[(int) ARG6], \
+ builtin_types[(int) ARG7], \
+ builtin_types[(int) ARG8], \
+ NULL_TREE);
+#define DEF_FUNCTION_TYPE_VAR_12(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
+ ARG6, ARG7, ARG8, ARG9, ARG10, ARG11, ARG12) \
+ builtin_types[(int) ENUM] \
+ = build_varargs_function_type_list (builtin_types[(int) RETURN], \
+ builtin_types[(int) ARG1], \
+ builtin_types[(int) ARG2], \
+ builtin_types[(int) ARG3], \
+ builtin_types[(int) ARG4], \
+ builtin_types[(int) ARG5], \
+ builtin_types[(int) ARG6], \
+ builtin_types[(int) ARG7], \
+ builtin_types[(int) ARG8], \
+ builtin_types[(int) ARG9], \
+ builtin_types[(int) ARG10], \
+ builtin_types[(int) ARG11], \
+ builtin_types[(int) ARG12], \
+ NULL_TREE);
#define DEF_POINTER_TYPE(ENUM, TYPE) \
builtin_types[(int) ENUM] \
= build_pointer_type (builtin_types[(int) TYPE]);
@@ -1124,6 +1168,9 @@ gfc_init_builtin_functions (void)
#undef DEF_FUNCTION_TYPE_7
#undef DEF_FUNCTION_TYPE_8
#undef DEF_FUNCTION_TYPE_VAR_0
+#undef DEF_FUNCTION_TYPE_VAR_2
+#undef DEF_FUNCTION_TYPE_VAR_8
+#undef DEF_FUNCTION_TYPE_VAR_12
#undef DEF_POINTER_TYPE
builtin_types[(int) BT_LAST] = NULL_TREE;
@@ -1135,6 +1182,21 @@ gfc_init_builtin_functions (void)
#include "../sync-builtins.def"
#undef DEF_SYNC_BUILTIN
+ if (gfc_option.gfc_flag_openacc)
+ {
+#undef DEF_GOACC_BUILTIN
+#define DEF_GOACC_BUILTIN(code, name, type, attr) \
+ gfc_define_builtin ("__builtin_" name, builtin_types[type], \
+ code, name, attr);
+#undef DEF_GOACC_BUILTIN_COMPILER
+ /* TODO: this is not doing the right thing. */
+#define DEF_GOACC_BUILTIN_COMPILER(code, name, type, attr) \
+ gfc_define_builtin (name, builtin_types[type], code, name, attr);
+#include "../oacc-builtins.def"
+#undef DEF_GOACC_BUILTIN_COMPILER
+#undef DEF_GOACC_BUILTIN
+ }
+
if (gfc_option.gfc_flag_openmp
|| gfc_option.gfc_flag_openmp_simd
|| flag_tree_parallelize_loops)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 00bc840..6bd131c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -216,6 +216,12 @@ typedef enum
ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE,
ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT,
ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS,
+ ST_OACC_PARALLEL_LOOP, ST_OACC_END_PARALLEL_LOOP, ST_OACC_PARALLEL,
+ ST_OACC_END_PARALLEL, ST_OACC_KERNELS, ST_OACC_END_KERNELS, ST_OACC_DATA,
+ ST_OACC_END_DATA, ST_OACC_HOST_DATA, ST_OACC_END_HOST_DATA, ST_OACC_LOOP,
+ ST_OACC_END_LOOP, ST_OACC_DECLARE, ST_OACC_UPDATE, ST_OACC_WAIT,
+ ST_OACC_CACHE, ST_OACC_KERNELS_LOOP, ST_OACC_END_KERNELS_LOOP,
+ ST_OACC_ENTER_DATA, ST_OACC_EXIT_DATA, ST_OACC_ROUTINE,
ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_ATOMIC,
ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED,
ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS,
@@ -1087,6 +1093,16 @@ gfc_namelist;
#define gfc_get_namelist() XCNEW (gfc_namelist)
+/* Likewise to gfc_namelist, but contains expressions. */
+typedef struct gfc_expr_list
+{
+ struct gfc_expr *expr;
+ struct gfc_expr_list *next;
+}
+gfc_expr_list;
+
+#define gfc_get_expr_list() XCNEW (gfc_expr_list)
+
typedef enum
{
OMP_REDUCTION_NONE = -1,
@@ -1119,7 +1135,13 @@ typedef enum
OMP_MAP_ALLOC,
OMP_MAP_TO,
OMP_MAP_FROM,
- OMP_MAP_TOFROM
+ OMP_MAP_TOFROM,
+ OMP_MAP_FORCE_ALLOC,
+ OMP_MAP_FORCE_DEALLOC,
+ OMP_MAP_FORCE_TO,
+ OMP_MAP_FORCE_FROM,
+ OMP_MAP_FORCE_TOFROM,
+ OMP_MAP_FORCE_PRESENT
}
gfc_omp_map_op;
@@ -1145,7 +1167,8 @@ gfc_omp_namelist;
enum
{
- OMP_LIST_PRIVATE,
+ OMP_LIST_FIRST,
+ OMP_LIST_PRIVATE = OMP_LIST_FIRST,
OMP_LIST_FIRSTPRIVATE,
OMP_LIST_LASTPRIVATE,
OMP_LIST_COPYPRIVATE,
@@ -1159,7 +1182,15 @@ enum
OMP_LIST_TO,
OMP_LIST_FROM,
OMP_LIST_REDUCTION,
- OMP_LIST_NUM
+ OMP_LIST_COPY,
+ OMP_LIST_DATA_CLAUSE_FIRST = OMP_LIST_COPY,
+ OMP_LIST_DEVICEPTR,
+ OMP_LIST_DATA_CLAUSE_LAST = OMP_LIST_DEVICEPTR,
+ OMP_LIST_DEVICE_RESIDENT,
+ OMP_LIST_USE_DEVICE,
+ OMP_LIST_CACHE,
+ OMP_LIST_NUM,
+ OMP_LIST_LAST = OMP_LIST_NUM
};
/* Because a symbol can belong to multiple namelists, they must be
@@ -1222,6 +1253,27 @@ typedef struct gfc_omp_clauses
struct gfc_expr *thread_limit;
enum gfc_omp_sched_kind dist_sched_kind;
struct gfc_expr *dist_chunk_size;
+
+ /* OpenACC. */
+ struct gfc_expr *async_expr;
+ struct gfc_expr *gang_expr;
+ struct gfc_expr *worker_expr;
+ struct gfc_expr *vector_expr;
+ struct gfc_expr *num_gangs_expr;
+ struct gfc_expr *num_workers_expr;
+ struct gfc_expr *vector_length_expr;
+ gfc_expr_list *wait_list;
+ gfc_expr_list *tile_list;
+ unsigned async:1, gang:1, worker:1, vector:1, seq:1, independent:1;
+ unsigned wait:1, par_auto:1, gang_static:1;
+
+ /* Directive specific data. */
+ union
+ {
+ /* !$ACC DECLARE locus. */
+ locus loc;
+ }
+ ext;
}
gfc_omp_clauses;
@@ -1629,6 +1681,9 @@ typedef struct gfc_namespace
this namespace. */
struct gfc_data *data;
+ /* !$ACC DECLARE clauses. */
+ gfc_omp_clauses *oacc_declare_clauses;
+
gfc_charlen *cl_list, *old_cl_list;
gfc_dt_list *derived_types;
@@ -2296,6 +2351,10 @@ typedef enum
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
EXEC_LOCK, EXEC_UNLOCK,
+ EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP,
+ EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS, EXEC_OACC_DATA, EXEC_OACC_HOST_DATA,
+ EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE,
+ EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA,
EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
@@ -2495,6 +2554,7 @@ typedef struct
int blas_matmul_limit;
int flag_cray_pointer;
int flag_d_lines;
+ int gfc_flag_openacc;
int gfc_flag_openmp;
int gfc_flag_openmp_simd;
int flag_sign_zero;
@@ -2968,6 +3028,11 @@ void gfc_resolve_omp_declare_simd (gfc_namespace *);
void gfc_resolve_omp_udrs (gfc_symtree *);
void gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *);
void gfc_omp_restore_state (struct gfc_omp_saved_state *);
+void gfc_free_expr_list (gfc_expr_list *);
+void gfc_resolve_oacc_directive (gfc_code *, gfc_namespace *);
+void gfc_resolve_oacc_declare (gfc_namespace *);
+void gfc_resolve_oacc_parallel_loop_blocks (gfc_code *, gfc_namespace *);
+void gfc_resolve_oacc_blocks (gfc_code *, gfc_namespace *);
/* expr.c */
void gfc_free_actual_arglist (gfc_actual_arglist *);
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 41d6559..c3e7518 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -474,7 +474,8 @@ The GNU Fortran compiler is able to compile nearly all
standard-compliant Fortran 95, Fortran 90, and Fortran 77 programs,
including a number of standard and non-standard extensions, and can be
used on real-world programs. In particular, the supported extensions
-include OpenMP, Cray-style pointers, and several Fortran 2003 and Fortran
+include OpenACC, OpenMP, Cray-style pointers, and several Fortran 2003
+and Fortran
2008 features, including TR 15581. However, it is still under
development and has a few remaining rough edges.
@@ -531,7 +532,8 @@ The current status of the support is can be found in the
@ref{Fortran 2003 status}, @ref{Fortran 2008 status} and
@ref{TS 29113 status} sections of the documentation.
-Additionally, the GNU Fortran compilers supports the OpenMP specification
+Additionally, the GNU Fortran compilers supports the OpenACC specification
+(version 2.0, @url{http://www.openacc.org/}), and OpenMP specification
(version 4.0, @url{http://openmp.org/@/wp/@/openmp-specifications/}).
@node Varying Length Character Strings
@@ -963,7 +965,8 @@ module.
@cindex statement, @code{ISO_FORTRAN_ENV}
@code{USE} statement with @code{INTRINSIC} and @code{NON_INTRINSIC}
attribute; supported intrinsic modules: @code{ISO_FORTRAN_ENV},
-@code{ISO_C_BINDING}, @code{OMP_LIB} and @code{OMP_LIB_KINDS}.
+@code{ISO_C_BINDING}, @code{OMP_LIB} and @code{OMP_LIB_KINDS},
+and @code{OPENACC}.
@item
Renaming of operators in the @code{USE} statement.
@@ -1358,6 +1361,7 @@ without warning.
* Hollerith constants support::
* Cray pointers::
* CONVERT specifier::
+* OpenACC::
* OpenMP::
* Argument list functions::
@end menu
@@ -1873,6 +1877,32 @@ carries a significant speed overhead. If speed in this area matters
to you, it is best if you use this only for data that needs to be
portable.
+@node OpenACC
+@subsection OpenACC
+@cindex OpenACC
+
+OpenACC is an application programming interface (API) that supports
+offloading of code to accelerator devices. It consists of a set of
+compiler directives, library routines, and environment variables that
+influence run-time behavior.
+
+GNU Fortran strives to be compatible to the
+@uref{http://www.openacc.org/, OpenACC Application Programming
+Interface v2.0}.
+
+To enable the processing of the OpenACC directive @code{!$acc} in
+free-form source code; the @code{c$acc}, @code{*$acc} and @code{!$acc}
+directives in fixed form; the @code{!$} conditional compilation
+sentinels in free form; and the @code{c$}, @code{*$} and @code{!$}
+sentinels in fixed form, @command{gfortran} needs to be invoked with
+the @option{-fopenacc}. This also arranges for automatic linking of
+the GNU OpenACC runtime library @ref{Top,,libgomp,libgomp,GNU OpenACC
+and OpenMP runtime library}.
+
+The OpenACC Fortran runtime library routines are provided both in a
+form of a Fortran 90 module named @code{openacc} and in a form of a
+Fortran @code{include} file named @file{openacc_lib.h}.
+
@node OpenMP
@subsection OpenMP
@cindex OpenMP
@@ -1894,7 +1924,7 @@ directives in fixed form; the @code{!$} conditional compilation sentinels
in free form; and the @code{c$}, @code{*$} and @code{!$} sentinels
in fixed form, @command{gfortran} needs to be invoked with the
@option{-fopenmp}. This also arranges for automatic linking of the
-GNU OpenMP runtime library @ref{Top,,libgomp,libgomp,GNU OpenMP
+GNU OpenMP runtime library @ref{Top,,libgomp,libgomp,GNU OpenACC and OpenMP
runtime library}.
The OpenMP Fortran runtime library routines are provided both in a
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 90c9a3a..fdaf044 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -13773,6 +13773,7 @@ Fortran 95 elemental function: @ref{IEOR}
* ISO_FORTRAN_ENV::
* ISO_C_BINDING::
* IEEE modules::
+* OpenACC Module OPENACC::
* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
@end menu
@@ -14018,6 +14019,33 @@ with the following options: @code{-fno-unsafe-math-optimizations
-frounding-math -fsignaling-nans}.
+
+@node OpenACC Module OPENACC
+@section OpenACC Module @code{OPENACC}
+@table @asis
+@item @emph{Standard}:
+OpenACC Application Programming Interface v2.0
+@end table
+
+
+The OpenACC Fortran runtime library routines are provided both in a
+form of a Fortran 90 module, named @code{OPENACC}, and in form of a
+Fortran @code{include} file named @file{openacc_lib.h}. The
+procedures provided by @code{OPENACC} can be found in the
+@ref{Top,,Introduction,libgomp,GNU OpenACC and OpenMP runtime library}
+manual, the named constants defined in the modules are listed below.
+
+For details refer to the actual
+@uref{http://www.openacc.org/,
+OpenACC Application Programming Interface v2.0}.
+
+@code{OPENACC} provides the scalar default-integer
+named constant @code{openacc_version} with a value of the form
+@var{yyyymm}, where @code{yyyy} is the year and @var{mm} the month
+of the OpenACC version; for OpenACC v2.0 the value is @code{201306}.
+
+
+
@node OpenMP Modules OMP_LIB and OMP_LIB_KINDS
@section OpenMP Modules @code{OMP_LIB} and @code{OMP_LIB_KINDS}
@table @asis
@@ -14030,7 +14058,8 @@ The OpenMP Fortran runtime library routines are provided both in
a form of two Fortran 90 modules, named @code{OMP_LIB} and
@code{OMP_LIB_KINDS}, and in a form of a Fortran @code{include} file named
@file{omp_lib.h}. The procedures provided by @code{OMP_LIB} can be found
-in the @ref{Top,,Introduction,libgomp,GNU OpenMP runtime library} manual,
+in the @ref{Top,,Introduction,libgomp,GNU OpenACC and OpenMP runtime
+library} manual,
the named constants defined in the modules are listed
below.
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 18d0c9e..2a1d1ad 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -120,7 +120,7 @@ by type. Explanations are in the following sections.
-ffixed-line-length-none -ffree-form -ffree-line-length-@var{n} @gol
-ffree-line-length-none -fimplicit-none -finteger-4-integer-8 @gol
-fmax-identifier-length -fmodule-private -fno-fixed-form -fno-range-check @gol
--fopenmp -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 @gol
+-fopenacc -fopenmp -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 @gol
-freal-8-real-10 -freal-8-real-16 -freal-8-real-4 -std=@var{std}
}
@@ -302,6 +302,16 @@ Specify that no implicit typing is allowed, unless overridden by explicit
Enable the Cray pointer extension, which provides C-like pointer
functionality.
+@item -fopenacc
+@opindex @code{fopenacc}
+@cindex OpenACC
+Enable the OpenACC extensions. This includes OpenACC @code{!$acc}
+directives in free form and @code{c$acc}, @code{*$acc} and
+@code{!$acc} directives in fixed form, @code{!$} conditional
+compilation sentinels in free form and @code{c$}, @code{*$} and
+@code{!$} sentinels in fixed form, and when linking arranges for the
+OpenACC runtime library to be linked in.
+
@item -fopenmp
@opindex @code{fopenmp}
@cindex OpenMP
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index b66e892..bbea334 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -529,6 +529,10 @@ fmodule-private
Fortran
Set default accessibility of module entities to PRIVATE.
+fopenacc
+Fortran
+; Documented in C
+
fopenmp
Fortran
; Documented in C
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 84e2764..ba5f8ad 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2491,7 +2491,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
if (o != NULL)
{
- gfc_error ("%s statement at %C leaving OpenMP structured block",
+ gfc_error ("%s statement at %C leaving OpenMP or OpenACC structured block",
gfc_ascii_statement (st));
return MATCH_ERROR;
}
@@ -2501,6 +2501,33 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
if (cnt > 0
&& o != NULL
&& o->state == COMP_OMP_STRUCTURED_BLOCK
+ && (o->head->op == EXEC_OACC_LOOP
+ || o->head->op == EXEC_OACC_PARALLEL_LOOP))
+ {
+ int collapse = 1;
+ gcc_assert (o->head->next != NULL
+ && (o->head->next->op == EXEC_DO
+ || o->head->next->op == EXEC_DO_WHILE)
+ && o->previous != NULL
+ && o->previous->tail->op == o->head->op);
+ if (o->previous->tail->ext.omp_clauses != NULL
+ && o->previous->tail->ext.omp_clauses->collapse > 1)
+ collapse = o->previous->tail->ext.omp_clauses->collapse;
+ if (st == ST_EXIT && cnt <= collapse)
+ {
+ gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
+ return MATCH_ERROR;
+ }
+ if (st == ST_CYCLE && cnt < collapse)
+ {
+ gfc_error ("CYCLE statement at %C to non-innermost collapsed"
+ " !$ACC LOOP loop");
+ return MATCH_ERROR;
+ }
+ }
+ if (cnt > 0
+ && o != NULL
+ && (o->state == COMP_OMP_STRUCTURED_BLOCK)
&& (o->head->op == EXEC_OMP_DO
|| o->head->op == EXEC_OMP_PARALLEL_DO
|| o->head->op == EXEC_OMP_SIMD
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index d07db11..11e199d 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -122,6 +122,22 @@ gfc_common_head *gfc_get_common (const char *, int);
/* openmp.c. */
+/* OpenACC directive matchers. */
+match gfc_match_oacc_cache (void);
+match gfc_match_oacc_wait (void);
+match gfc_match_oacc_update (void);
+match gfc_match_oacc_declare (void);
+match gfc_match_oacc_loop (void);
+match gfc_match_oacc_host_data (void);
+match gfc_match_oacc_data (void);
+match gfc_match_oacc_kernels (void);
+match gfc_match_oacc_kernels_loop (void);
+match gfc_match_oacc_parallel (void);
+match gfc_match_oacc_parallel_loop (void);
+match gfc_match_oacc_enter_data (void);
+match gfc_match_oacc_exit_data (void);
+match gfc_match_oacc_routine (void);
+
/* OpenMP directive matchers. */
match gfc_match_omp_eos (void);
match gfc_match_omp_atomic (void);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 3ee0f92..959798a 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -76,11 +76,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,6 +309,88 @@ cleanup:
return MATCH_ERROR;
}
+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 (1U << 0)
#define OMP_CLAUSE_FIRSTPRIVATE (1U << 1)
#define OMP_CLAUSE_LASTPRIVATE (1U << 2)
@@ -320,12 +424,60 @@ cleanup:
#define OMP_CLAUSE_THREAD_LIMIT (1U << 30)
#define OMP_CLAUSE_DIST_SCHEDULE (1U << 31)
-/* Match OpenMP directive clauses. MASK is a bitmask of
+/* OpenACC 2.0 clauses. */
+#define OMP_CLAUSE_ASYNC (1ULL << 32)
+#define OMP_CLAUSE_NUM_GANGS (1ULL << 33)
+#define OMP_CLAUSE_NUM_WORKERS (1ULL << 34)
+#define OMP_CLAUSE_VECTOR_LENGTH (1ULL << 35)
+#define OMP_CLAUSE_COPY (1ULL << 36)
+#define OMP_CLAUSE_COPYOUT (1ULL << 37)
+#define OMP_CLAUSE_CREATE (1ULL << 38)
+#define OMP_CLAUSE_PRESENT (1ULL << 39)
+#define OMP_CLAUSE_PRESENT_OR_COPY (1ULL << 40)
+#define OMP_CLAUSE_PRESENT_OR_COPYIN (1ULL << 41)
+#define OMP_CLAUSE_PRESENT_OR_COPYOUT (1ULL << 42)
+#define OMP_CLAUSE_PRESENT_OR_CREATE (1ULL << 43)
+#define OMP_CLAUSE_DEVICEPTR (1ULL << 44)
+#define OMP_CLAUSE_GANG (1ULL << 45)
+#define OMP_CLAUSE_WORKER (1ULL << 46)
+#define OMP_CLAUSE_VECTOR (1ULL << 47)
+#define OMP_CLAUSE_SEQ (1ULL << 48)
+#define OMP_CLAUSE_INDEPENDENT (1ULL << 49)
+#define OMP_CLAUSE_USE_DEVICE (1ULL << 50)
+#define OMP_CLAUSE_DEVICE_RESIDENT (1ULL << 51)
+#define OMP_CLAUSE_HOST_SELF (1ULL << 52)
+#define OMP_CLAUSE_OACC_DEVICE (1ULL << 53)
+#define OMP_CLAUSE_WAIT (1ULL << 54)
+#define OMP_CLAUSE_DELETE (1ULL << 55)
+#define OMP_CLAUSE_AUTO (1ULL << 56)
+#define OMP_CLAUSE_TILE (1ULL << 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, unsigned long long mask,
+ bool first = true, bool needs_space = true,
+ bool openacc = false)
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
locus old_loc;
@@ -339,6 +491,57 @@ 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);
+ /* TODO XXX: FIX -1 (acc_async_noval). */
+ mpz_set_si (c->async_expr->value.integer, -1);
+ }
+ 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 +579,150 @@ 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_omp_variable_list ("deviceptr (",
+ &c->lists[OMP_LIST_DEVICEPTR], true)
+ == MATCH_YES)
+ 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 +1127,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->ext.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 \
@@ -1898,21 +2586,144 @@ gfc_match_omp_end_nowait (void)
}
-match
-gfc_match_omp_end_single (void)
+match
+gfc_match_omp_end_single (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match ("% nowait") == MATCH_YES)
+ {
+ new_st.op = EXEC_OMP_END_NOWAIT;
+ new_st.ext.omp_bool = true;
+ return MATCH_YES;
+ }
+ if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_END_SINGLE;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+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)
{
- gfc_omp_clauses *c;
- if (gfc_match ("% nowait") == MATCH_YES)
- {
- new_st.op = EXEC_OMP_END_NOWAIT;
- new_st.ext.omp_bool = true;
- return MATCH_YES;
- }
- if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
- return MATCH_ERROR;
- new_st.op = EXEC_OMP_END_SINGLE;
- new_st.ext.omp_clauses = c;
- return MATCH_YES;
+ 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);
}
@@ -2013,19 +2824,48 @@ 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",
+ "COPY", "COPYIN", "COPYOUT", "CREATE", "DELETE", "PRESENT",
+ "PRESENT_OR_COPY", "PRESENT_OR_COPYIN", "PRESENT_OR_COPYOUT",
+ "PRESENT_OR_CREATE", "DEVICEPTR", "DEVICE_RESIDENT", "USE_DEVICE",
+ "HOST", "DEVICE", "CACHE" };
if (omp_clauses == NULL)
return;
@@ -2115,12 +2955,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 '%s' present on multiple clauses at %L",
n->sym->name, where);
else
@@ -2262,53 +3103,59 @@ 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 ("'%s' 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 ("'%s' 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 ("'%s' 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 ("'%s' 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 ("'%s' 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 ("'%s' in DEPEND clause at %L is a "
+ "zero size array section",
+ n->sym->name, where);
+ break;
+ }
+ }
+ }
+ else if (openacc)
+ resolve_oacc_data_clauses (n->sym, *where,
+ clause_names[list]);
+ }
+
if (list != OMP_LIST_DEPEND)
for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
{
@@ -2346,7 +3193,10 @@ resolve_omp_clauses (gfc_code *code, locus *where,
gfc_error ("Cray pointer '%s' 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 '%s' in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
@@ -2366,6 +3216,16 @@ resolve_omp_clauses (gfc_code *code, locus *where,
default:
break;
}
+
+ if (list >= OMP_LIST_DATA_CLAUSE_FIRST
+ && list < OMP_LIST_DATA_CLAUSE_LAST)
+ resolve_oacc_data_clauses (n->sym, *where, name);
+
+ if (list > OMP_LIST_DATA_CLAUSE_LAST)
+ {
+ check_symbol_not_pointer (n->sym, *where, name);
+ check_array_not_assumed (n->sym, *where, name);
+ }
switch (list)
{
case OMP_LIST_REDUCTION:
@@ -2499,6 +3359,28 @@ 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_DEVICEPTR:
+ resolve_oacc_deviceptr_clause (n->sym, *where, name);
+ 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);
+ break;
default:
break;
}
@@ -2554,6 +3436,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 +3922,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 +3967,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 +4062,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 +4248,449 @@ 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)
+{
+ gfc_error ("Sorry, !$ACC cache unimplemented yet at %L", &code->loc);
+}
+
+
+void
+gfc_resolve_oacc_declare (gfc_namespace *ns)
+{
+ int list;
+ gfc_omp_namelist *n;
+ locus loc;
+ static const char *clause_names[] = {"COPY", "COPYIN", "COPYOUT", "CREATE",
+ "DELETE", "PRESENT", "PRESENT_OR_COPY", "PRESENT_OR_COPYIN",
+ "PRESENT_OR_COPYOUT", "PRESENT_OR_CREATE", "DEVICEPTR",
+ "DEVICE_RESIDENT"};
+
+ if (ns->oacc_declare_clauses == NULL)
+ return;
+
+ loc = ns->oacc_declare_clauses->ext.loc;
+
+ /* FIXME: handle omp_list_map. */
+ for (list = OMP_LIST_DATA_CLAUSE_FIRST;
+ 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_DATA_CLAUSE_FIRST;
+ 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 (list = OMP_LIST_DATA_CLAUSE_FIRST;
+ list < OMP_LIST_DATA_CLAUSE_LAST; /* Skip deviceptr clause. */
+ list++)
+ {
+ const char *name = clause_names[list - OMP_LIST_DATA_CLAUSE_FIRST];
+ for (n = ns->oacc_declare_clauses->lists[list]; n; n = n->next)
+ resolve_oacc_data_clauses (n->sym, loc, name);
+ }
+
+ for (n = ns->oacc_declare_clauses->lists[OMP_LIST_DEVICEPTR]; n; n = n->next)
+ resolve_oacc_deviceptr_clause (n->sym, loc,
+ clause_names[OMP_LIST_DEVICEPTR -
+ OMP_LIST_DATA_CLAUSE_FIRST]);
+
+ for (n = ns->oacc_declare_clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n;
+ n = n->next)
+ check_array_not_assumed (n->sym, loc,
+ clause_names[OMP_LIST_DEVICE_RESIDENT -
+ OMP_LIST_DATA_CLAUSE_FIRST]);
+}
+
+
+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 +4698,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 ();
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 8bc8f94..9e04066 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -149,6 +149,7 @@ gfc_init_options (unsigned int decoded_options_count,
gfc_option.blas_matmul_limit = 30;
gfc_option.flag_cray_pointer = 0;
gfc_option.flag_d_lines = -1;
+ gfc_option.gfc_flag_openacc = 0;
gfc_option.gfc_flag_openmp = 0;
gfc_option.flag_sign_zero = 1;
gfc_option.flag_recursive = 0;
@@ -836,6 +837,10 @@ gfc_handle_option (size_t scode, const char *arg, int value,
gfc_option.source_form = FORM_FREE;
break;
+ case OPT_fopenacc:
+ gfc_option.gfc_flag_openacc = value;
+ break;
+
case OPT_fopenmp:
gfc_option.gfc_flag_openmp = value;
break;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 4539beb..33b10cd 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -582,6 +582,93 @@ decode_statement (void)
} while (0);
static gfc_statement
+decode_oacc_directive (void)
+{
+ locus old_locus;
+ char c;
+
+ gfc_enforce_clean_symbol_state ();
+
+ gfc_clear_error (); /* Clear any pending errors. */
+ gfc_clear_warning (); /* Clear any pending warnings. */
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error_now ("OpenACC directives at %C may not appear in PURE "
+ "procedures");
+ gfc_error_recovery ();
+ return ST_NONE;
+ }
+
+ gfc_unset_implicit_pure (NULL);
+
+ old_locus = gfc_current_locus;
+
+ /* General OpenACC directive matching: Instead of testing every possible
+ statement, we eliminate most possibilities by peeking at the
+ first character. */
+
+ c = gfc_peek_ascii_char ();
+
+ switch (c)
+ {
+ case 'c':
+ match ("cache", gfc_match_oacc_cache, ST_OACC_CACHE);
+ break;
+ case 'd':
+ match ("data", gfc_match_oacc_data, ST_OACC_DATA);
+ match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE);
+ break;
+ case 'e':
+ match ("end data", gfc_match_omp_eos, ST_OACC_END_DATA);
+ match ("end host_data", gfc_match_omp_eos, ST_OACC_END_HOST_DATA);
+ match ("end kernels loop", gfc_match_omp_eos, ST_OACC_END_KERNELS_LOOP);
+ match ("end kernels", gfc_match_omp_eos, ST_OACC_END_KERNELS);
+ match ("end loop", gfc_match_omp_eos, ST_OACC_END_LOOP);
+ match ("end parallel loop", gfc_match_omp_eos, ST_OACC_END_PARALLEL_LOOP);
+ match ("end parallel", gfc_match_omp_eos, ST_OACC_END_PARALLEL);
+ match ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA);
+ match ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA);
+ break;
+ case 'h':
+ match ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA);
+ break;
+ case 'p':
+ match ("parallel loop", gfc_match_oacc_parallel_loop, ST_OACC_PARALLEL_LOOP);
+ match ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL);
+ break;
+ case 'k':
+ match ("kernels loop", gfc_match_oacc_kernels_loop, ST_OACC_KERNELS_LOOP);
+ match ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS);
+ break;
+ case 'l':
+ match ("loop", gfc_match_oacc_loop, ST_OACC_LOOP);
+ break;
+ case 'r':
+ match ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE);
+ break;
+ case 'u':
+ match ("update", gfc_match_oacc_update, ST_OACC_UPDATE);
+ break;
+ case 'w':
+ match ("wait", gfc_match_oacc_wait, ST_OACC_WAIT);
+ break;
+ }
+
+ /* Directive not found or stored an error message.
+ Check and give up. */
+
+ if (gfc_error_check () == 0)
+ gfc_error_now ("Unclassifiable OpenACC directive at %C");
+
+ reject_statement ();
+
+ gfc_error_recovery ();
+
+ return ST_NONE;
+}
+
+static gfc_statement
decode_omp_directive (void)
{
locus old_locus;
@@ -808,6 +895,23 @@ decode_gcc_attribute (void)
#undef match
+/* Assert next length characters to be equal to token in free form. */
+
+static void
+verify_token_free (const char* token, int length, bool last_was_use_stmt)
+{
+ int i;
+ char c;
+
+ c = gfc_next_ascii_char ();
+ for (i = 0; i < length; i++, c = gfc_next_ascii_char ())
+ gcc_assert (c == token[i]);
+
+ gcc_assert (gfc_is_whitespace(c));
+ gfc_gobble_whitespace ();
+ if (last_was_use_stmt)
+ use_modules ();
+}
/* Get the next statement in free form source. */
@@ -877,7 +981,7 @@ next_free (void)
else if (c == '!')
{
/* Comments have already been skipped by the time we get here,
- except for GCC attributes and OpenMP directives. */
+ except for GCC attributes and OpenMP/OpenACC directives. */
gfc_next_ascii_char (); /* Eat up the exclamation sign. */
c = gfc_peek_ascii_char ();
@@ -894,23 +998,41 @@ next_free (void)
return decode_gcc_attribute ();
}
- else if (c == '$'
- && (gfc_option.gfc_flag_openmp
- || gfc_option.gfc_flag_openmp_simd))
+ else if (c == '$')
{
- int i;
-
- c = gfc_next_ascii_char ();
- for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
- gcc_assert (c == "$omp"[i]);
+ /* Since both OpenMP and OpenACC directives starts with
+ !$ character sequence, we must check all flags combinations */
+ if ((gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd)
+ && !gfc_option.gfc_flag_openacc)
+ {
+ verify_token_free ("$omp", 4, last_was_use_stmt);
+ return decode_omp_directive ();
+ }
+ else if ((gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd)
+ && gfc_option.gfc_flag_openacc)
+ {
+ gfc_next_ascii_char (); /* Eat up dollar character */
+ c = gfc_peek_ascii_char ();
- gcc_assert (c == ' ' || c == '\t');
- gfc_gobble_whitespace ();
- if (last_was_use_stmt)
- use_modules ();
- return decode_omp_directive ();
+ if (c == 'o')
+ {
+ verify_token_free ("omp", 3, last_was_use_stmt);
+ return decode_omp_directive ();
+ }
+ else if (c == 'a')
+ {
+ verify_token_free ("acc", 3, last_was_use_stmt);
+ return decode_oacc_directive ();
+ }
+ }
+ else if (gfc_option.gfc_flag_openacc)
+ {
+ verify_token_free ("$acc", 4, last_was_use_stmt);
+ return decode_oacc_directive ();
+ }
}
-
gcc_unreachable ();
}
@@ -926,6 +1048,28 @@ next_free (void)
return decode_statement ();
}
+/* Assert next length characters to be equal to token in fixed form. */
+
+static bool
+verify_token_fixed (const char *token, int length, bool last_was_use_stmt)
+{
+ int i;
+ char c = gfc_next_char_literal (NONSTRING);
+
+ for (i = 0; i < length; i++, c = gfc_next_char_literal (NONSTRING))
+ gcc_assert ((char) gfc_wide_tolower (c) == token[i]);
+
+ if (c != ' ' && c != '0')
+ {
+ gfc_buffer_error (0);
+ gfc_error ("Bad continuation line at %C");
+ return false;
+ }
+ if (last_was_use_stmt)
+ use_modules ();
+
+ return true;
+}
/* Get the next statement in fixed-form source. */
@@ -985,22 +1129,40 @@ next_fixed (void)
return decode_gcc_attribute ();
}
- else if (c == '$'
- && (gfc_option.gfc_flag_openmp
- || gfc_option.gfc_flag_openmp_simd))
+ else if (c == '$')
{
- for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
- gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
-
- if (c != ' ' && c != '0')
+ if ((gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd)
+ && !gfc_option.gfc_flag_openacc)
{
- gfc_buffer_error (0);
- gfc_error ("Bad continuation line at %C");
- return ST_NONE;
+ if (!verify_token_fixed ("omp", 3, last_was_use_stmt))
+ return ST_NONE;
+ return decode_omp_directive ();
+ }
+ else if ((gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd)
+ && gfc_option.gfc_flag_openacc)
+ {
+ c = gfc_next_char_literal(NONSTRING);
+ if (c == 'o' || c == 'O')
+ {
+ if (!verify_token_fixed ("mp", 2, last_was_use_stmt))
+ return ST_NONE;
+ return decode_omp_directive ();
+ }
+ else if (c == 'a' || c == 'A')
+ {
+ if (!verify_token_fixed ("cc", 2, last_was_use_stmt))
+ return ST_NONE;
+ return decode_oacc_directive ();
+ }
+ }
+ else if (gfc_option.gfc_flag_openacc)
+ {
+ if (!verify_token_fixed ("acc", 3, last_was_use_stmt))
+ return ST_NONE;
+ return decode_oacc_directive ();
}
- if (last_was_use_stmt)
- use_modules ();
- return decode_omp_directive ();
}
/* FALLTHROUGH */
@@ -1160,7 +1322,9 @@ next_statement (void)
case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
- case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK
+ case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
+ case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
+ case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
/* Statements that mark other executable statements. */
@@ -1185,7 +1349,9 @@ next_statement (void)
case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
- case ST_CRITICAL
+ case ST_CRITICAL: \
+ case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
+ case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: case ST_OACC_KERNELS_LOOP
/* Declaration statements */
@@ -1193,7 +1359,7 @@ next_statement (void)
case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \
- case ST_OMP_DECLARE_TARGET
+ case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
@@ -1213,6 +1379,8 @@ push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
p->sym = sym;
p->head = p->tail = NULL;
p->do_variable = NULL;
+ if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT)
+ p->ext.oacc_declare_clauses = NULL;
/* If this the state of a construct like BLOCK, DO or IF, the corresponding
construct statement was accepted right before pushing the state. Thus,
@@ -1678,6 +1846,69 @@ gfc_ascii_statement (gfc_statement st)
case ST_END_ENUM:
p = "END ENUM";
break;
+ case ST_OACC_PARALLEL_LOOP:
+ p = "!$ACC PARALLEL LOOP";
+ break;
+ case ST_OACC_END_PARALLEL_LOOP:
+ p = "!$ACC END PARALLEL LOOP";
+ break;
+ case ST_OACC_PARALLEL:
+ p = "!$ACC PARALLEL";
+ break;
+ case ST_OACC_END_PARALLEL:
+ p = "!$ACC END PARALLEL";
+ break;
+ case ST_OACC_KERNELS:
+ p = "!$ACC KERNELS";
+ break;
+ case ST_OACC_END_KERNELS:
+ p = "!$ACC END KERNELS";
+ break;
+ case ST_OACC_KERNELS_LOOP:
+ p = "!$ACC KERNELS LOOP";
+ break;
+ case ST_OACC_END_KERNELS_LOOP:
+ p = "!$ACC END KERNELS LOOP";
+ break;
+ case ST_OACC_DATA:
+ p = "!$ACC DATA";
+ break;
+ case ST_OACC_END_DATA:
+ p = "!$ACC END DATA";
+ break;
+ case ST_OACC_HOST_DATA:
+ p = "!$ACC HOST_DATA";
+ break;
+ case ST_OACC_END_HOST_DATA:
+ p = "!$ACC END HOST_DATA";
+ break;
+ case ST_OACC_LOOP:
+ p = "!$ACC LOOP";
+ break;
+ case ST_OACC_END_LOOP:
+ p = "!$ACC END LOOP";
+ break;
+ case ST_OACC_DECLARE:
+ p = "!$ACC DECLARE";
+ break;
+ case ST_OACC_UPDATE:
+ p = "!$ACC UPDATE";
+ break;
+ case ST_OACC_WAIT:
+ p = "!$ACC WAIT";
+ break;
+ case ST_OACC_CACHE:
+ p = "!$ACC CACHE";
+ break;
+ case ST_OACC_ENTER_DATA:
+ p = "!$ACC ENTER DATA";
+ break;
+ case ST_OACC_EXIT_DATA:
+ p = "!$ACC EXIT DATA";
+ break;
+ case ST_OACC_ROUTINE:
+ p = "!$ACC ROUTINE";
+ break;
case ST_OMP_ATOMIC:
p = "!$OMP ATOMIC";
break;
@@ -2177,6 +2408,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
case ST_PUBLIC:
case ST_PRIVATE:
case ST_DERIVED_DECL:
+ case ST_OACC_DECLARE:
case_decl:
if (p->state >= ORDER_EXEC)
goto order;
@@ -3078,6 +3310,19 @@ declSt:
st = next_statement ();
goto loop;
+ case ST_OACC_DECLARE:
+ if (!verify_st_order(&ss, st, false))
+ {
+ reject_statement ();
+ st = next_statement ();
+ goto loop;
+ }
+ if (gfc_state_stack->ext.oacc_declare_clauses == NULL)
+ gfc_state_stack->ext.oacc_declare_clauses = new_st.ext.omp_clauses;
+ accept_statement (st);
+ st = next_statement ();
+ goto loop;
+
default:
break;
}
@@ -3568,9 +3813,13 @@ static void
parse_critical_block (void)
{
gfc_code *top, *d;
- gfc_state_data s;
+ gfc_state_data s, *sd;
gfc_statement st;
+ for (sd = gfc_state_stack; sd; sd = sd->previous)
+ if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
+ gfc_error_now ("CRITICAL block inside of OpenMP or OpenACC region at %C");
+
s.ext.end_do_label = new_st.label1;
accept_statement (ST_CRITICAL);
@@ -3985,6 +4234,128 @@ parse_omp_atomic (void)
}
+/* Parse the statements of an OpenACC structured block. */
+
+static void
+parse_oacc_structured_block (gfc_statement acc_st)
+{
+ gfc_statement st, acc_end_st;
+ gfc_code *cp, *np;
+ gfc_state_data s, *sd;
+
+ for (sd = gfc_state_stack; sd; sd = sd->previous)
+ if (sd->state == COMP_CRITICAL)
+ gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
+
+ accept_statement (acc_st);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+ switch (acc_st)
+ {
+ case ST_OACC_PARALLEL:
+ acc_end_st = ST_OACC_END_PARALLEL;
+ break;
+ case ST_OACC_KERNELS:
+ acc_end_st = ST_OACC_END_KERNELS;
+ break;
+ case ST_OACC_DATA:
+ acc_end_st = ST_OACC_END_DATA;
+ break;
+ case ST_OACC_HOST_DATA:
+ acc_end_st = ST_OACC_END_HOST_DATA;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ do
+ {
+ st = parse_executable (ST_NONE);
+ if (st == ST_NONE)
+ unexpected_eof ();
+ else if (st != acc_end_st)
+ gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st));
+ reject_statement ();
+ }
+ while (st != acc_end_st);
+
+ gcc_assert (new_st.op == EXEC_NOP);
+
+ gfc_clear_new_st ();
+ gfc_commit_symbols ();
+ gfc_warning_check ();
+ pop_state ();
+}
+
+/* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
+
+static gfc_statement
+parse_oacc_loop (gfc_statement acc_st)
+{
+ gfc_statement st;
+ gfc_code *cp, *np;
+ gfc_state_data s, *sd;
+
+ for (sd = gfc_state_stack; sd; sd = sd->previous)
+ if (sd->state == COMP_CRITICAL)
+ gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
+
+ accept_statement (acc_st);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ for (;;)
+ {
+ st = next_statement ();
+ if (st == ST_NONE)
+ unexpected_eof ();
+ else if (st == ST_DO)
+ break;
+ else
+ {
+ gfc_error ("Expected DO loop at %C");
+ reject_statement ();
+ }
+ }
+
+ parse_do_block ();
+ if (gfc_statement_label != NULL
+ && gfc_state_stack->previous != NULL
+ && gfc_state_stack->previous->state == COMP_DO
+ && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
+ {
+ pop_state ();
+ return ST_IMPLIED_ENDDO;
+ }
+
+ check_do_closure ();
+ pop_state ();
+
+ st = next_statement ();
+ if (st == ST_OACC_END_LOOP)
+ gfc_warning ("Redundant !$ACC END LOOP at %C");
+ if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) ||
+ (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) ||
+ (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP))
+ {
+ gcc_assert (new_st.op == EXEC_NOP);
+ gfc_clear_new_st ();
+ gfc_commit_symbols ();
+ gfc_warning_check ();
+ st = next_statement ();
+ }
+ return st;
+}
+
+
/* Parse the statements of an OpenMP structured block. */
static void
@@ -4304,6 +4675,21 @@ parse_executable (gfc_statement st)
parse_forall_block ();
break;
+ case ST_OACC_PARALLEL_LOOP:
+ case ST_OACC_KERNELS_LOOP:
+ case ST_OACC_LOOP:
+ st = parse_oacc_loop (st);
+ if (st == ST_IMPLIED_ENDDO)
+ return st;
+ continue;
+
+ case ST_OACC_PARALLEL:
+ case ST_OACC_KERNELS:
+ case ST_OACC_DATA:
+ case ST_OACC_HOST_DATA:
+ parse_oacc_structured_block (st);
+ break;
+
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_SECTIONS:
case ST_OMP_SECTIONS:
@@ -4634,6 +5020,13 @@ contains:
done:
gfc_current_ns->code = gfc_state_stack->head;
+ if (gfc_state_stack->state == COMP_PROGRAM
+ || gfc_state_stack->state == COMP_MODULE
+ || gfc_state_stack->state == COMP_SUBROUTINE
+ || gfc_state_stack->state == COMP_FUNCTION
+ || gfc_state_stack->state == COMP_BLOCK)
+ gfc_current_ns->oacc_declare_clauses
+ = gfc_state_stack->ext.oacc_declare_clauses;
}
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 44b8f8b..be09a97 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -49,6 +49,7 @@ typedef struct gfc_state_data
union
{
gfc_st_label *end_do_label;
+ gfc_omp_clauses *oacc_declare_clauses;
}
ext;
}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4acebd0..ac72f64 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9073,6 +9073,18 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_WAIT:
break;
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_KERNELS_LOOP:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_HOST_DATA:
+ case EXEC_OACC_LOOP:
+ case EXEC_OACC_UPDATE:
+ case EXEC_OACC_WAIT:
+ case EXEC_OACC_CACHE:
+ case EXEC_OACC_ENTER_DATA:
+ case EXEC_OACC_EXIT_DATA:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DISTRIBUTE:
@@ -9886,6 +9898,15 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
omp_workshare_save = -1;
switch (code->op)
{
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_KERNELS_LOOP:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_HOST_DATA:
+ case EXEC_OACC_LOOP:
+ gfc_resolve_oacc_blocks (code, ns);
+ break;
case EXEC_OMP_PARALLEL_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 1;
@@ -10238,6 +10259,21 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
"expression", &code->expr1->where);
break;
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_KERNELS_LOOP:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_HOST_DATA:
+ case EXEC_OACC_LOOP:
+ case EXEC_OACC_UPDATE:
+ case EXEC_OACC_WAIT:
+ case EXEC_OACC_CACHE:
+ case EXEC_OACC_ENTER_DATA:
+ case EXEC_OACC_EXIT_DATA:
+ gfc_resolve_oacc_directive (code, ns);
+ break;
+
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CANCEL:
@@ -14847,6 +14883,7 @@ resolve_codes (gfc_namespace *ns)
old_obstack = labels_obstack;
bitmap_obstack_initialize (&labels_obstack);
+ gfc_resolve_oacc_declare (ns);
gfc_resolve_code (ns->code, ns);
bitmap_obstack_release (&labels_obstack);
diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c
index 2c0d4c3..85ce3f8 100644
--- a/gcc/fortran/scanner.c
+++ b/gcc/fortran/scanner.c
@@ -55,9 +55,11 @@ gfc_directorylist *include_dirs, *intrinsic_modules_dirs;
static gfc_file *file_head, *current_file;
-static int continue_flag, end_flag, openmp_flag, gcc_attribute_flag;
+static int continue_flag, end_flag, gcc_attribute_flag;
+static int openmp_flag, openacc_flag; /* If !$omp/!$acc occurred in current comment line */
static int continue_count, continue_line;
static locus openmp_locus;
+static locus openacc_locus;
static locus gcc_attribute_locus;
gfc_source_form gfc_current_form;
@@ -707,11 +709,89 @@ skip_gcc_attribute (locus start)
return r;
}
+/* Return true if CC was matched. */
+static bool
+skip_oacc_attribute (locus start, locus old_loc, bool continue_flag)
+{
+ bool r = false;
+ char c;
+
+ if ((c = next_char ()) == 'c' || c == 'C')
+ if ((c = next_char ()) == 'c' || c == 'C')
+ r = true;
+ if (r)
+ {
+ if ((c = next_char ()) == ' ' || c == '\t'
+ || continue_flag)
+ {
+ while (gfc_is_whitespace (c))
+ c = next_char ();
+ if (c != '\n' && c != '!')
+ {
+ openacc_flag = 1;
+ openacc_locus = old_loc;
+ gfc_current_locus = start;
+ }
+ else
+ r = false;
+ }
+ else
+ {
+ gfc_warning_now ("!$ACC at %C starts a commented "
+ "line as it neither is followed "
+ "by a space nor is a "
+ "continuation line");
+ r = false;
+ }
+ }
+
+ return r;
+}
+
+/* Return true if MP was matched. */
+static bool
+skip_omp_attribute (locus start, locus old_loc, bool continue_flag)
+{
+ bool r = false;
+ char c;
+
+ if ((c = next_char ()) == 'm' || c == 'M')
+ if ((c = next_char ()) == 'p' || c == 'P')
+ r = true;
+
+ if (r)
+ {
+ if ((c = next_char ()) == ' ' || c == '\t'
+ || continue_flag)
+ {
+ while (gfc_is_whitespace (c))
+ c = next_char ();
+ if (c != '\n' && c != '!')
+ {
+ openmp_flag = 1;
+ openmp_locus = old_loc;
+ gfc_current_locus = start;
+ }
+ else
+ r = false;
+ }
+ else
+ {
+ gfc_warning_now ("!$OMP at %C starts a commented "
+ "line as it neither is followed "
+ "by a space nor is a "
+ "continuation line");
+ r = false;
+ }
+ }
+
+ return r;
+}
/* Comment lines are null lines, lines containing only blanks or lines
on which the first nonblank line is a '!'.
- Return true if !$ openmp conditional compilation sentinel was
+ Return true if !$ openmp or openacc conditional compilation sentinel was
seen. */
static bool
@@ -744,56 +824,101 @@ skip_free_comments (void)
if (at_bol && skip_gcc_attribute (start))
return false;
- /* If -fopenmp, we need to handle here 2 things:
- 1) don't treat !$omp as comments, but directives
- 2) handle OpenMP conditional compilation, where
+ /* If -fopenmp/-fopenacc, we need to handle here 2 things:
+ 1) don't treat !$omp/!$acc as comments, but directives
+ 2) handle OpenMP/OpenACC conditional compilation, where
!$ should be treated as 2 spaces (for initial lines
only if followed by space). */
- if ((gfc_option.gfc_flag_openmp
- || gfc_option.gfc_flag_openmp_simd) && at_bol)
- {
- locus old_loc = gfc_current_locus;
- if (next_char () == '$')
- {
- c = next_char ();
- if (c == 'o' || c == 'O')
- {
- if (((c = next_char ()) == 'm' || c == 'M')
- && ((c = next_char ()) == 'p' || c == 'P'))
+ if (at_bol)
+ {
+ if ((gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd)
+ && gfc_option.gfc_flag_openacc)
+ {
+ locus old_loc = gfc_current_locus;
+ if (next_char () == '$')
+ {
+ c = next_char ();
+ if (c == 'o' || c == 'O')
+ {
+ if (skip_omp_attribute (start, old_loc, continue_flag))
+ return false;
+ gfc_current_locus = old_loc;
+ next_char ();
+ c = next_char ();
+ }
+ else if (c == 'a' || c == 'A')
+ {
+ if (skip_oacc_attribute (start, old_loc, continue_flag))
+ return false;
+ gfc_current_locus = old_loc;
+ next_char ();
+ c = next_char ();
+ }
+ if (continue_flag || c == ' ' || c == '\t')
+ {
+ gfc_current_locus = old_loc;
+ next_char ();
+ openmp_flag = openacc_flag = 0;
+ return true;
+ }
+ }
+ gfc_current_locus = old_loc;
+ }
+ else if ((gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd)
+ && !gfc_option.gfc_flag_openacc)
+ {
+ locus old_loc = gfc_current_locus;
+ if (next_char () == '$')
+ {
+ c = next_char ();
+ if (c == 'o' || c == 'O')
+ {
+ if (skip_omp_attribute (start, old_loc, continue_flag))
+ return false;
+ gfc_current_locus = old_loc;
+ next_char ();
+ c = next_char ();
+ }
+ if (continue_flag || c == ' ' || c == '\t')
+ {
+ gfc_current_locus = old_loc;
+ next_char ();
+ openmp_flag = 0;
+ return true;
+ }
+ }
+ gfc_current_locus = old_loc;
+ }
+ else if (gfc_option.gfc_flag_openacc
+ && !(gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd))
+ {
+ locus old_loc = gfc_current_locus;
+ if (next_char () == '$')
+ {
+ c = next_char ();
+ if (c == 'a' || c == 'A')
{
- if ((c = next_char ()) == ' ' || c == '\t'
- || continue_flag)
- {
- while (gfc_is_whitespace (c))
- c = next_char ();
- if (c != '\n' && c != '!')
- {
- openmp_flag = 1;
- openmp_locus = old_loc;
- gfc_current_locus = start;
- return false;
- }
- }
- else
- gfc_warning_now ("!$OMP at %C starts a commented "
- "line as it neither is followed "
- "by a space nor is a "
- "continuation line");
+ if (skip_oacc_attribute (start, old_loc,
+ continue_flag))
+ return false;
+ gfc_current_locus = old_loc;
+ next_char();
+ c = next_char();
}
- gfc_current_locus = old_loc;
- next_char ();
- c = next_char ();
- }
- if (continue_flag || c == ' ' || c == '\t')
- {
- gfc_current_locus = old_loc;
- next_char ();
- openmp_flag = 0;
- return true;
- }
- }
- gfc_current_locus = old_loc;
- }
+ if (continue_flag || c == ' ' || c == '\t')
+ {
+ gfc_current_locus = old_loc;
+ next_char();
+ openacc_flag = 0;
+ return true;
+ }
+ }
+ gfc_current_locus = old_loc;
+ }
+ }
skip_comment_line ();
continue;
}
@@ -804,6 +929,9 @@ skip_free_comments (void)
if (openmp_flag && at_bol)
openmp_flag = 0;
+ if (openacc_flag && at_bol)
+ openacc_flag = 0;
+
gcc_attribute_flag = 0;
gfc_current_locus = start;
return false;
@@ -866,9 +994,10 @@ skip_fixed_comments (void)
return;
}
- /* If -fopenmp, we need to handle here 2 things:
- 1) don't treat !$omp|c$omp|*$omp as comments, but directives
- 2) handle OpenMP conditional compilation, where
+ /* If -fopenmp/-fopenacc, we need to handle here 2 things:
+ 1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments,
+ but directives
+ 2) handle OpenMP/OpenACC conditional compilation, where
!$|c$|*$ should be treated as 2 spaces if the characters
in columns 3 to 6 are valid fixed form label columns
characters. */
@@ -935,6 +1064,67 @@ skip_fixed_comments (void)
}
gfc_current_locus = start;
}
+
+ if (gfc_option.gfc_flag_openacc)
+ {
+ if (next_char () == '$')
+ {
+ c = next_char ();
+ if (c == 'a' || c == 'A')
+ {
+ if (((c = next_char ()) == 'c' || c == 'C')
+ && ((c = next_char ()) == 'c' || c == 'C'))
+ {
+ c = next_char ();
+ if (c != '\n'
+ && ((openacc_flag && continue_flag)
+ || c == ' ' || c == '\t' || c == '0'))
+ {
+ do
+ c = next_char ();
+ while (gfc_is_whitespace (c));
+ if (c != '\n' && c != '!')
+ {
+ /* Canonicalize to *$acc. */
+ *start.nextc = '*';
+ openacc_flag = 1;
+ gfc_current_locus = start;
+ return;
+ }
+ }
+ }
+ }
+ else
+ {
+ int digit_seen = 0;
+
+ for (col = 3; col < 6; col++, c = next_char ())
+ if (c == ' ')
+ continue;
+ else if (c == '\t')
+ {
+ col = 6;
+ break;
+ }
+ else if (c < '0' || c > '9')
+ break;
+ else
+ digit_seen = 1;
+
+ if (col == 6 && c != '\n'
+ && ((continue_flag && !digit_seen)
+ || c == ' ' || c == '\t' || c == '0'))
+ {
+ gfc_current_locus = start;
+ start.nextc[0] = ' ';
+ start.nextc[1] = ' ';
+ continue;
+ }
+ }
+ }
+ gfc_current_locus = start;
+ }
+
skip_comment_line ();
continue;
}
@@ -977,6 +1167,7 @@ skip_fixed_comments (void)
}
openmp_flag = 0;
+ openacc_flag = 0;
gcc_attribute_flag = 0;
gfc_current_locus = start;
}
@@ -1005,10 +1196,11 @@ gfc_char_t
gfc_next_char_literal (gfc_instring in_string)
{
locus old_loc;
- int i, prev_openmp_flag;
+ int i, prev_openmp_flag, prev_openacc_flag;
gfc_char_t c;
continue_flag = 0;
+ prev_openacc_flag = prev_openmp_flag = 0;
restart:
c = next_char ();
@@ -1034,6 +1226,11 @@ restart:
sizeof (gfc_current_locus)) == 0)
goto done;
+ if (openacc_flag
+ && memcmp (&gfc_current_locus, &openacc_locus,
+ sizeof (gfc_current_locus)) == 0)
+ goto done;
+
/* This line can't be continued */
do
{
@@ -1088,7 +1285,11 @@ restart:
goto done;
}
- prev_openmp_flag = openmp_flag;
+ if (gfc_option.gfc_flag_openmp)
+ prev_openmp_flag = openmp_flag;
+ if (gfc_option.gfc_flag_openacc)
+ prev_openacc_flag = openacc_flag;
+
continue_flag = 1;
if (c == '!')
skip_comment_line ();
@@ -1118,13 +1319,23 @@ restart:
&& continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
- if (prev_openmp_flag != openmp_flag)
- {
- gfc_current_locus = old_loc;
- openmp_flag = prev_openmp_flag;
- c = '&';
- goto done;
- }
+ if (gfc_option.gfc_flag_openmp)
+ if (prev_openmp_flag != openmp_flag)
+ {
+ gfc_current_locus = old_loc;
+ openmp_flag = prev_openmp_flag;
+ c = '&';
+ goto done;
+ }
+
+ if (gfc_option.gfc_flag_openacc)
+ if (prev_openacc_flag != openacc_flag)
+ {
+ gfc_current_locus = old_loc;
+ openacc_flag = prev_openacc_flag;
+ c = '&';
+ goto done;
+ }
/* Now that we have a non-comment line, probe ahead for the
first non-whitespace character. If it is another '&', then
@@ -1148,6 +1359,17 @@ restart:
while (gfc_is_whitespace (c))
c = next_char ();
}
+ if (openacc_flag)
+ {
+ for (i = 0; i < 5; i++, c = next_char ())
+ {
+ gcc_assert(gfc_wide_tolower (c) == (unsigned char) "!$acc"[i]);
+ if (i == 4)
+ old_loc = gfc_current_locus;
+ }
+ while (gfc_is_whitespace (c))
+ c = next_char ();
+ }
if (c != '&')
{
@@ -1160,7 +1382,7 @@ restart:
}
/* Both !$omp and !$ -fopenmp continuation lines have & on the
continuation line only optionally. */
- else if (openmp_flag || openmp_cond_flag)
+ else if (openmp_flag || openacc_flag || openmp_cond_flag)
gfc_current_locus.nextc--;
else
{
@@ -1197,7 +1419,11 @@ restart:
gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
}
- prev_openmp_flag = openmp_flag;
+ if (gfc_option.gfc_flag_openmp)
+ prev_openmp_flag = openmp_flag;
+ if (gfc_option.gfc_flag_openacc)
+ prev_openacc_flag = openacc_flag;
+
continue_flag = 1;
old_loc = gfc_current_locus;
@@ -1205,26 +1431,40 @@ restart:
skip_fixed_comments ();
/* See if this line is a continuation line. */
- if (openmp_flag != prev_openmp_flag)
- {
- openmp_flag = prev_openmp_flag;
- goto not_continuation;
- }
+ if (gfc_option.gfc_flag_openmp)
+ if (openmp_flag != prev_openmp_flag)
+ {
+ openmp_flag = prev_openmp_flag;
+ goto not_continuation;
+ }
+ if (gfc_option.gfc_flag_openacc)
+ if (openacc_flag != prev_openacc_flag)
+ {
+ openacc_flag = prev_openacc_flag;
+ goto not_continuation;
+ }
- if (!openmp_flag)
+ if (!openmp_flag && !openacc_flag)
for (i = 0; i < 5; i++)
{
c = next_char ();
if (c != ' ')
goto not_continuation;
}
- else
+ else if (openmp_flag)
for (i = 0; i < 5; i++)
{
c = next_char ();
if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
goto not_continuation;
}
+ else if (openacc_flag)
+ for (i = 0; i < 5; i++)
+ {
+ c = next_char ();
+ if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i])
+ goto not_continuation;
+ }
c = next_char ();
if (c == '0' || c == ' ' || c == '\n')
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 0f18f78..27636bc 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -185,6 +185,18 @@ gfc_free_statement (gfc_code *p)
gfc_free_forall_iterator (p->ext.forall_iterator);
break;
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_KERNELS_LOOP:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_HOST_DATA:
+ case EXEC_OACC_LOOP:
+ case EXEC_OACC_UPDATE:
+ case EXEC_OACC_WAIT:
+ case EXEC_OACC_CACHE:
+ case EXEC_OACC_ENTER_DATA:
+ case EXEC_OACC_EXIT_DATA:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_DISTRIBUTE:
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 07fefd9..82df027 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5764,6 +5764,13 @@ gfc_generate_function_code (gfc_namespace * ns)
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
add_argument_checking (&body, sym);
+ /* Generate !$ACC DECLARE directive. */
+ if (ns->oacc_declare_clauses)
+ {
+ tree tmp = gfc_trans_oacc_declare (&body, ns);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 038c3e9..7dd4498 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -1708,6 +1708,40 @@ gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list,
}
static tree
+gfc_trans_omp_map_clause_list (enum omp_clause_map_kind kind,
+ gfc_omp_namelist *namelist, tree list)
+{
+ for (; namelist != NULL; namelist = namelist->next)
+ if (namelist->sym->attr.referenced)
+ {
+ tree t = gfc_trans_omp_variable (namelist->sym, false);
+ if (t != error_mark_node)
+ {
+ tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ OMP_CLAUSE_DECL (node) = t;
+ OMP_CLAUSE_MAP_KIND (node) = kind;
+ list = gfc_trans_add_clause (node, list);
+ }
+ }
+ return list;
+}
+
+static inline tree
+gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
+{
+ gfc_se se;
+ tree result;
+
+ gfc_init_se (&se, NULL );
+ gfc_conv_expr (&se, expr);
+ gfc_add_block_to_block (block, &se.pre);
+ result = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+
+ return result;
+}
+
+static tree
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
locus where, bool declare_simd = false)
{
@@ -1725,6 +1759,21 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
if (n == NULL)
continue;
+ if (list >= OMP_LIST_DATA_CLAUSE_FIRST
+ && list <= OMP_LIST_DATA_CLAUSE_LAST)
+ {
+ enum omp_clause_map_kind kind;
+ switch (list)
+ {
+ case OMP_LIST_DEVICEPTR:
+ kind = OMP_CLAUSE_MAP_FORCE_DEVICEPTR;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ omp_clauses = gfc_trans_omp_map_clause_list (kind, n, omp_clauses);
+ continue;
+ }
switch (list)
{
case OMP_LIST_REDUCTION:
@@ -1750,7 +1799,17 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
goto add_clause;
case OMP_LIST_UNIFORM:
clause_code = OMP_CLAUSE_UNIFORM;
- /* FALLTHROUGH */
+ goto add_clause;
+ case OMP_LIST_USE_DEVICE:
+ clause_code = OMP_CLAUSE_USE_DEVICE;
+ goto add_clause;
+ case OMP_LIST_DEVICE_RESIDENT:
+ clause_code = OMP_CLAUSE_DEVICE_RESIDENT;
+ goto add_clause;
+ case OMP_LIST_CACHE:
+ clause_code = OMP_CLAUSE__CACHE_;
+ goto add_clause;
+
add_clause:
omp_clauses
= gfc_trans_omp_variable_list (clause_code, n, omp_clauses,
@@ -2087,6 +2146,24 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
case OMP_MAP_TOFROM:
OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_TOFROM;
break;
+ case OMP_MAP_FORCE_ALLOC:
+ OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_ALLOC;
+ break;
+ case OMP_MAP_FORCE_DEALLOC:
+ OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_DEALLOC;
+ break;
+ case OMP_MAP_FORCE_TO:
+ OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_TO;
+ break;
+ case OMP_MAP_FORCE_FROM:
+ OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_FROM;
+ break;
+ case OMP_MAP_FORCE_TOFROM:
+ OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_TOFROM;
+ break;
+ case OMP_MAP_FORCE_PRESENT:
+ OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FORCE_PRESENT;
+ break;
default:
gcc_unreachable ();
}
@@ -2452,6 +2529,111 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
+ if (clauses->async)
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_ASYNC);
+ if (clauses->async_expr)
+ OMP_CLAUSE_ASYNC_EXPR (c) =
+ gfc_convert_expr_to_tree (block, clauses->async_expr);
+ else
+ OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ if (clauses->seq)
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ if (clauses->independent)
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_INDEPENDENT);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ if (clauses->wait_list)
+ {
+ gfc_expr_list *el;
+
+ for (el = clauses->wait_list; el; el = el->next)
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_WAIT);
+ OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr);
+ OMP_CLAUSE_CHAIN (c) = omp_clauses;
+ omp_clauses = c;
+ }
+ }
+ if (clauses->num_gangs_expr)
+ {
+ tree num_gangs_var =
+ gfc_convert_expr_to_tree (block, clauses->num_gangs_expr);
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_GANGS);
+ OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ if (clauses->num_workers_expr)
+ {
+ tree num_workers_var =
+ gfc_convert_expr_to_tree (block, clauses->num_workers_expr);
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_WORKERS);
+ OMP_CLAUSE_NUM_WORKERS_EXPR (c)= num_workers_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ if (clauses->vector_length_expr)
+ {
+ tree vector_length_var =
+ gfc_convert_expr_to_tree (block, clauses->vector_length_expr);
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR_LENGTH);
+ OMP_CLAUSE_VECTOR_LENGTH_EXPR (c)= vector_length_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ if (clauses->vector)
+ {
+ if (clauses->vector_expr)
+ {
+ tree vector_var =
+ gfc_convert_expr_to_tree (block, clauses->vector_expr);
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR);
+ OMP_CLAUSE_VECTOR_EXPR (c)= vector_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ else
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ }
+ if (clauses->worker)
+ {
+ if (clauses->worker_expr)
+ {
+ tree worker_var =
+ gfc_convert_expr_to_tree (block, clauses->worker_expr);
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER);
+ OMP_CLAUSE_WORKER_EXPR (c)= worker_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ else
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ }
+ if (clauses->gang)
+ {
+ if (clauses->gang_expr)
+ {
+ tree gang_var =
+ gfc_convert_expr_to_tree (block, clauses->gang_expr);
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_GANG);
+ OMP_CLAUSE_GANG_EXPR (c)= gang_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ else
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_GANG);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+ }
+
return nreverse (omp_clauses);
}
@@ -2479,6 +2661,115 @@ gfc_trans_omp_code (gfc_code *code, bool force_empty)
return stmt;
}
+/* Trans OpenACC directives. */
+/* parallel, kernels, data and host_data. */
+static tree
+gfc_trans_oacc_construct (gfc_code *code)
+{
+ stmtblock_t block;
+ tree stmt, oacc_clauses;
+ enum tree_code construct_code;
+
+ switch (code->op)
+ {
+ case EXEC_OACC_PARALLEL:
+ construct_code = OACC_PARALLEL;
+ break;
+ case EXEC_OACC_KERNELS:
+ construct_code = OACC_KERNELS;
+ break;
+ case EXEC_OACC_DATA:
+ construct_code = OACC_DATA;
+ break;
+ case EXEC_OACC_HOST_DATA:
+ construct_code = OACC_HOST_DATA;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ gfc_start_block (&block);
+ oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+ code->loc);
+ stmt = gfc_trans_omp_code (code->block->next, true);
+ stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
+ oacc_clauses);
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
+/* update, enter_data, exit_data, cache. */
+static tree
+gfc_trans_oacc_executable_directive (gfc_code *code)
+{
+ stmtblock_t block;
+ tree stmt, oacc_clauses;
+ enum tree_code construct_code;
+
+ switch (code->op)
+ {
+ case EXEC_OACC_UPDATE:
+ construct_code = OACC_UPDATE;
+ break;
+ case EXEC_OACC_ENTER_DATA:
+ construct_code = OACC_ENTER_DATA;
+ break;
+ case EXEC_OACC_EXIT_DATA:
+ construct_code = OACC_EXIT_DATA;
+ break;
+ case EXEC_OACC_CACHE:
+ construct_code = OACC_CACHE;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ gfc_start_block (&block);
+ oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
+ code->loc);
+ stmt = build1_loc (input_location, construct_code, void_type_node,
+ oacc_clauses);
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_oacc_wait_directive (gfc_code *code)
+{
+ stmtblock_t block;
+ tree stmt, t;
+ vec<tree, va_gc> *args;
+ int nparms = 0;
+ gfc_expr_list *el;
+ gfc_omp_clauses *clauses = code->ext.omp_clauses;
+ location_t loc = input_location;
+
+ for (el = clauses->wait_list; el; el = el->next)
+ nparms++;
+
+ vec_alloc (args, nparms + 2);
+ stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT);
+
+ gfc_start_block (&block);
+
+ if (clauses->async_expr)
+ t = gfc_convert_expr_to_tree (&block, clauses->async_expr);
+ else
+ t = build_int_cst (integer_type_node, -2);
+
+ args->quick_push (t);
+ args->quick_push (build_int_cst (integer_type_node, nparms));
+
+ for (el = clauses->wait_list; el; el = el->next)
+ args->quick_push (gfc_convert_expr_to_tree (&block, el->expr));
+
+ stmt = build_call_expr_loc_vec (loc, stmt, args);
+ gfc_add_expr_to_block (&block, stmt);
+
+ vec_free (args);
+
+ return gfc_finish_block (&block);
+}
static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
@@ -3092,6 +3383,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break;
case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break;
case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break;
+ case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
default: gcc_unreachable ();
}
@@ -3106,6 +3398,68 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
return gfc_finish_block (&block);
}
+/* parallel loop and kernels loop. */
+static tree
+gfc_trans_oacc_combined_directive (gfc_code *code)
+{
+ stmtblock_t block, *pblock = NULL;
+ gfc_omp_clauses construct_clauses, loop_clauses;
+ tree stmt, oacc_clauses = NULL_TREE;
+ enum tree_code construct_code;
+
+ switch (code->op)
+ {
+ case EXEC_OACC_PARALLEL_LOOP:
+ construct_code = OACC_PARALLEL;
+ break;
+ case EXEC_OACC_KERNELS_LOOP:
+ construct_code = OACC_KERNELS;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ gfc_start_block (&block);
+
+ memset (&loop_clauses, 0, sizeof (loop_clauses));
+ if (code->ext.omp_clauses != NULL)
+ {
+ memcpy (&construct_clauses, code->ext.omp_clauses,
+ sizeof (construct_clauses));
+ loop_clauses.collapse = construct_clauses.collapse;
+ loop_clauses.gang = construct_clauses.gang;
+ loop_clauses.vector = construct_clauses.vector;
+ loop_clauses.worker = construct_clauses.worker;
+ loop_clauses.seq = construct_clauses.seq;
+ loop_clauses.independent = construct_clauses.independent;
+ construct_clauses.collapse = 0;
+ construct_clauses.gang = false;
+ construct_clauses.vector = false;
+ construct_clauses.worker = false;
+ construct_clauses.seq = false;
+ construct_clauses.independent = false;
+ oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
+ code->loc);
+ }
+ if (!loop_clauses.seq)
+ pblock = █
+ else
+ pushlevel ();
+ stmt = gfc_trans_omp_do (code, code->op, pblock, &loop_clauses, NULL);
+ if (TREE_CODE (stmt) != BIND_EXPR)
+ stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
+ else
+ poplevel (0, 0);
+ stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
+ oacc_clauses);
+ if (code->op == EXEC_OACC_KERNELS_LOOP)
+ OACC_KERNELS_COMBINED (stmt) = 1;
+ else
+ OACC_PARALLEL_COMBINED (stmt) = 1;
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
static tree
gfc_trans_omp_flush (void)
{
@@ -3996,6 +4350,44 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
}
tree
+gfc_trans_oacc_declare (stmtblock_t *block, gfc_namespace *ns)
+{
+ tree oacc_clauses;
+ oacc_clauses = gfc_trans_omp_clauses (block, ns->oacc_declare_clauses,
+ ns->oacc_declare_clauses->ext.loc);
+ return build1_loc (ns->oacc_declare_clauses->ext.loc.lb->location,
+ OACC_DECLARE, void_type_node, oacc_clauses);
+}
+
+tree
+gfc_trans_oacc_directive (gfc_code *code)
+{
+ switch (code->op)
+ {
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_KERNELS_LOOP:
+ return gfc_trans_oacc_combined_directive (code);
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_HOST_DATA:
+ return gfc_trans_oacc_construct (code);
+ case EXEC_OACC_LOOP:
+ return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
+ NULL);
+ case EXEC_OACC_UPDATE:
+ case EXEC_OACC_CACHE:
+ case EXEC_OACC_ENTER_DATA:
+ case EXEC_OACC_EXIT_DATA:
+ return gfc_trans_oacc_executable_directive (code);
+ case EXEC_OACC_WAIT:
+ return gfc_trans_oacc_wait_directive (code);
+ default:
+ gcc_unreachable ();
+ }
+}
+
+tree
gfc_trans_omp_directive (gfc_code *code)
{
switch (code->op)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index d17b075..485bbc9 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1367,6 +1367,14 @@ gfc_trans_block_construct (gfc_code* code)
gfc_init_block (&body);
exit_label = gfc_build_label_decl (NULL_TREE);
code->exit_label = exit_label;
+
+ /* Generate !$ACC DECLARE directive. */
+ if (ns->oacc_declare_clauses)
+ {
+ tree tmp = gfc_trans_oacc_declare (&body, ns);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 087bafe..1a2543b 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -65,6 +65,10 @@ tree gfc_trans_deallocate_array (tree);
tree gfc_trans_omp_directive (gfc_code *);
void gfc_trans_omp_declare_simd (gfc_namespace *);
+/* trans-openacc.c */
+tree gfc_trans_oacc_directive (gfc_code *);
+tree gfc_trans_oacc_declare (stmtblock_t *block, gfc_namespace *);
+
/* trans-io.c */
tree gfc_trans_open (gfc_code *);
tree gfc_trans_close (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index b707023..61812a0 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1889,6 +1889,21 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_omp_directive (code);
break;
+ case EXEC_OACC_CACHE:
+ case EXEC_OACC_WAIT:
+ case EXEC_OACC_UPDATE:
+ case EXEC_OACC_LOOP:
+ case EXEC_OACC_HOST_DATA:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_KERNELS_LOOP:
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_ENTER_DATA:
+ case EXEC_OACC_EXIT_DATA:
+ res = gfc_trans_oacc_directive (code);
+ break;
+
default:
internal_error ("gfc_trans_code(): Bad statement code");
}
diff --git a/gcc/fortran/types.def b/gcc/fortran/types.def
index 99198e9..c7a3f63 100644
--- a/gcc/fortran/types.def
+++ b/gcc/fortran/types.def
@@ -82,6 +82,7 @@ DEF_FUNCTION_TYPE_0 (BT_FN_VOID, BT_VOID)
DEF_FUNCTION_TYPE_1 (BT_FN_VOID_PTR, BT_VOID, BT_PTR)
DEF_FUNCTION_TYPE_1 (BT_FN_VOID_PTRPTR, BT_VOID, BT_PTR_PTR)
DEF_FUNCTION_TYPE_1 (BT_FN_VOID_VPTR, BT_VOID, BT_VOLATILE_PTR)
+DEF_FUNCTION_TYPE_1 (BT_FN_INT_INT, BT_INT, BT_INT)
DEF_FUNCTION_TYPE_1 (BT_FN_UINT_UINT, BT_UINT, BT_UINT)
DEF_FUNCTION_TYPE_1 (BT_FN_PTR_PTR, BT_PTR, BT_PTR)
DEF_FUNCTION_TYPE_1 (BT_FN_VOID_INT, BT_VOID, BT_INT)
@@ -144,6 +145,7 @@ DEF_FUNCTION_TYPE_3 (BT_FN_VOID_VPTR_I2_INT, BT_VOID, BT_VOLATILE_PTR, BT_I2, BT
DEF_FUNCTION_TYPE_3 (BT_FN_VOID_VPTR_I4_INT, BT_VOID, BT_VOLATILE_PTR, BT_I4, BT_INT)
DEF_FUNCTION_TYPE_3 (BT_FN_VOID_VPTR_I8_INT, BT_VOID, BT_VOLATILE_PTR, BT_I8, BT_INT)
DEF_FUNCTION_TYPE_3 (BT_FN_VOID_VPTR_I16_INT, BT_VOID, BT_VOLATILE_PTR, BT_I16, BT_INT)
+DEF_FUNCTION_TYPE_3 (BT_FN_VOID_INT_PTR_INT, BT_VOID, BT_INT, BT_PTR, BT_INT)
DEF_FUNCTION_TYPE_4 (BT_FN_VOID_OMPFN_PTR_UINT_UINT,
BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT, BT_UINT)
@@ -209,3 +211,13 @@ DEF_FUNCTION_TYPE_8 (BT_FN_VOID_OMPFN_PTR_OMPCPYFN_LONG_LONG_BOOL_UINT_PTR,
BT_BOOL, BT_UINT, BT_PTR)
DEF_FUNCTION_TYPE_VAR_0 (BT_FN_VOID_VAR, BT_VOID)
+
+DEF_FUNCTION_TYPE_VAR_2 (BT_FN_VOID_INT_INT_VAR, BT_VOID, BT_INT, BT_INT)
+
+DEF_FUNCTION_TYPE_VAR_8 (BT_FN_VOID_INT_PTR_SIZE_PTR_PTR_PTR_INT_INT_VAR,
+ BT_VOID, BT_INT, BT_PTR, BT_SIZE, BT_PTR, BT_PTR,
+ BT_PTR, BT_INT, BT_INT)
+
+DEF_FUNCTION_TYPE_VAR_12 (BT_FN_VOID_INT_OMPFN_PTR_SIZE_PTR_PTR_PTR_INT_INT_INT_INT_INT_VAR,
+ BT_VOID, BT_INT, BT_PTR_FN_VOID_PTR, BT_PTR, BT_SIZE, BT_PTR, BT_PTR,
+ BT_PTR, BT_INT, BT_INT, BT_INT, BT_INT, BT_INT)
