From 7beb2b9dd2cb4adfab630231badae2517c138461 Mon Sep 17 00:00:00 2001 From: Olivier Hainque Date: Mon, 3 Dec 2018 15:47:57 +0000 Subject: [PATCH] [Ada] Gigi support for OpenACC pragmas Matching front-end bits to support Acc_Kernels, Acc_Parallel, Acc_Loop and Acc_Data. 2018-12-03 Olivier Hainque gcc/ada/ * gcc-interface/lang.opt (fopenacc): New option for Ada. * gcc-interface/misc.c (gnat_handle_option): Handle it. * gcc-interface/trans.c (struct loop_info_d): Add OMP attributes. (Iterate_Acc_Clause_Arg, Acc_gnat_to_gnu): New functions, helpers for OpenACC pragmas processing in Pragma_to_gnu. (Acc_Var_to_gnu, Acc_Reduc_Var_to_gnu, Acc_Reduc_to_gnu): Likewise. (Acc_Size_Expr_to_gnu, Acc_Size_List_to_gnu): Likewise. (Pragma_Acc_Data_to_gnu): Likewise. (Pragma_to_gnu): Handle Pragma_Acc_Loop, Pragma_Acc_Data, Pragma_Acc_Kernels and Pragma_Acc_Parallel. (Acc_Loop_to_gnu, Regular_Loop_to_gnu): New functions. Helpers for ... (Loop_Statement_to_gnu): Rework to handle OpenACC loops. From-SVN: r266748 --- gcc/ada/ChangeLog | 18 + gcc/ada/gcc-interface/lang.opt | 4 + gcc/ada/gcc-interface/misc.c | 1 + gcc/ada/gcc-interface/trans.c | 736 ++++++++++++++++++++++++++++++++- 4 files changed, 739 insertions(+), 20 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d66c7bd66fd..a036eb1322b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2018-12-03 Olivier Hainque + + * gcc-interface/lang.opt (fopenacc): New option for Ada. + * gcc-interface/misc.c (gnat_handle_option): Handle it. + * gcc-interface/trans.c (struct loop_info_d): Add OMP + attributes. + (Iterate_Acc_Clause_Arg, Acc_gnat_to_gnu): New functions, + helpers for OpenACC pragmas processing in Pragma_to_gnu. + (Acc_Var_to_gnu, Acc_Reduc_Var_to_gnu, Acc_Reduc_to_gnu): + Likewise. + (Acc_Size_Expr_to_gnu, Acc_Size_List_to_gnu): Likewise. + (Pragma_Acc_Data_to_gnu): Likewise. + (Pragma_to_gnu): Handle Pragma_Acc_Loop, Pragma_Acc_Data, + Pragma_Acc_Kernels and Pragma_Acc_Parallel. + (Acc_Loop_to_gnu, Regular_Loop_to_gnu): New functions. Helpers + for ... + (Loop_Statement_to_gnu): Rework to handle OpenACC loops. + 2018-12-03 Olivier Hainque * gcc-interface/targtyps.c (MALLOC_OBSERVABLE_ALIGNMENT): Set to diff --git a/gcc/ada/gcc-interface/lang.opt b/gcc/ada/gcc-interface/lang.opt index 18ff6b0d1bd..cc9fa497933 100644 --- a/gcc/ada/gcc-interface/lang.opt +++ b/gcc/ada/gcc-interface/lang.opt @@ -100,4 +100,8 @@ fbuiltin-printf Ada Undocumented Ignored. +fopenacc +Ada LTO +; Documented in C but it should be: Enable OpenACC support + ; This comment is to ensure we retain the blank line above. diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 00b73705f32..29323b0560f 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -166,6 +166,7 @@ gnat_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value, /* These are handled by the front-end. */ break; + case OPT_fopenacc: case OPT_fshort_enums: case OPT_fsigned_char: case OPT_funsigned_char: diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 2cd710247a4..4c066c02421 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -47,6 +47,7 @@ #include "gimplify.h" #include "opts.h" #include "common/common-target.h" +#include "gomp-constants.h" #include "stringpool.h" #include "attribs.h" @@ -196,6 +197,9 @@ struct GTY(()) loop_info_d { tree loop_var; tree low_bound; tree high_bound; + tree omp_loop_clauses; + tree omp_construct_clauses; + enum tree_code omp_code; vec *checks; bool artificial; }; @@ -1249,6 +1253,226 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) return gnu_result; } + +/* If GNAT_EXPR is an N_Identifier, N_Integer_Literal or N_Operator_Symbol, + call FN on it. If GNAT_EXPR is an aggregate, call FN on each of its + elements. In both cases, pass GNU_EXPR and DATA as additional arguments. + + This function is used everywhere OpenAcc pragmas are processed if these + pragmas can accept aggregates. */ + +static tree +Iterate_Acc_Clause_Arg (Node_Id gnat_expr, tree gnu_expr, + tree (*fn)(Node_Id, tree, void*), + void* data) +{ + switch (Nkind (gnat_expr)) + { + case N_Aggregate: + if (Present (Expressions (gnat_expr))) + { + for (Node_Id gnat_list_expr = First (Expressions (gnat_expr)); + Present (gnat_list_expr); + gnat_list_expr = Next (gnat_list_expr)) + gnu_expr = fn (gnat_list_expr, gnu_expr, data); + } + else if (Present (Component_Associations (gnat_expr))) + { + for (Node_Id gnat_list_expr = First (Component_Associations + (gnat_expr)); + Present (gnat_list_expr); + gnat_list_expr = Next (gnat_list_expr)) + gnu_expr = fn (Expression (gnat_list_expr), gnu_expr, data); + } + else + gcc_unreachable(); + break; + case N_Identifier: + case N_Integer_Literal: + case N_Operator_Symbol: + gnu_expr = fn (gnat_expr, gnu_expr, data); + break; + default: + gcc_unreachable(); + } + return gnu_expr; +} + +/* Same as gnat_to_gnu for a GNAT_NODE referenced within an OpenAcc directive, + undoing transformations that are inappropriate for such context. */ + +tree +Acc_gnat_to_gnu (Node_Id gnat_node) +{ + tree gnu_result = gnat_to_gnu (gnat_node); + + /* If gnat_node is an identifier for a boolean, gnat_to_gnu might have + turned it into `identifier != 0`. Since arguments to OpenAcc pragmas + need to be writable, we need to return the identifier residing in such + expressions rather than the expression itself. */ + if (Nkind (gnat_node) == N_Identifier + && TREE_CODE (gnu_result) == NE_EXPR + && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_result, 0))) == BOOLEAN_TYPE + && integer_zerop (TREE_OPERAND (gnu_result, 1))) + gnu_result = TREE_OPERAND (gnu_result, 0); + + return gnu_result; +} + +/* Turn GNAT_EXPR into a tree node representing an OMP data clause and chain + it to GNU_CLAUSES, a list of pre-existing OMP clauses. GNAT_EXPR should be + a N_Identifier, this is enforced by the frontend. + + This function is called every time translation of an argument for an OpenAcc + clause (e.g. Acc_Parallel(Copy => My_Identifier)) is needed. */ + +static tree +Acc_Data_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void* data) +{ + tree gnu_clause; + enum gomp_map_kind kind = *((enum gomp_map_kind*) data); + gnu_clause = build_omp_clause (EXPR_LOCATION(gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_MAP); + + gcc_assert (Nkind (gnat_expr) == N_Identifier); + OMP_CLAUSE_DECL (gnu_clause) = + gnat_to_gnu_entity (Entity (gnat_expr), NULL_TREE, false); + + TREE_ADDRESSABLE (OMP_CLAUSE_DECL (gnu_clause)) = 1; + OMP_CLAUSE_SET_MAP_KIND (gnu_clause, kind); + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + return gnu_clause; +} + +/* Turn GNAT_EXPR into a tree node representing an OMP clause and chain it to + GNU_CLAUSES, a list of existing OMP clauses. + + This function is used for parsing arguments of non-data clauses (e.g. + Acc_Parallel(Wait => gnatexpr)). */ + +static tree +Acc_Var_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void* data) +{ + tree gnu_clause; + enum omp_clause_code kind = *((enum omp_clause_code*) data); + gnu_clause = + build_omp_clause (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), kind); + + OMP_CLAUSE_DECL (gnu_clause) = Acc_gnat_to_gnu (gnat_expr); + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + return gnu_clause; +} + +/* Turn GNAT_EXPR into a tree OMP clause representing a reduction clause. + GNAT_EXPR has to be a N_Identifier, this is enforced by the frontend. + + For example, GNAT_EXPR could be My_Identifier in the following pragma: + Acc_Parallel(Reduction => ("+" => My_Identifier)). */ + +static tree +Acc_Reduc_Var_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void* data) +{ + tree gnu_clause; + tree_code code = *((tree_code*) data); + gnu_clause = build_omp_clause (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_REDUCTION); + OMP_CLAUSE_DECL (gnu_clause) = Acc_gnat_to_gnu (gnat_expr); + OMP_CLAUSE_REDUCTION_CODE (gnu_clause) = code; + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + return gnu_clause; +} + +/* Turn GNAT_EXPR into a list of OMP reduction clauses. GNAT_EXPR has to + follow the structure of a reduction clause, e.g. ("+" => Identifier). */ + +static tree +Acc_Reduc_to_gnu (Node_Id gnat_expr) +{ + tree gnu_clauses = NULL_TREE; + for (Node_Id gnat_op = First (Component_Associations (gnat_expr)); + Present (gnat_op); + gnat_op = Next (gnat_op)) + { + tree_code code = ERROR_MARK; + String_Id str = Strval (First (Choices (gnat_op))); + switch (Get_String_Char (str, 1)) + { + case '+': + code = PLUS_EXPR; + break; + case '*': + code = MULT_EXPR; + break; + case 'm': + if (Get_String_Char (str, 2) == 'i' + && Get_String_Char (str, 3) == 'n') + code = MIN_EXPR; + else if (Get_String_Char (str, 2) == 'a' + && Get_String_Char (str, 3) == 'x') + code = MAX_EXPR; + break; + case 'a': + if (Get_String_Char (str, 2) == 'n' + && Get_String_Char (str, 3) == 'd') + code = TRUTH_ANDIF_EXPR; + break; + case 'o': + if (Get_String_Char (str, 2) == 'r') + code = TRUTH_ORIF_EXPR; + break; + default: + gcc_unreachable(); + } + /* Unsupported reduction operation. This should have been + caught in sem_prag.adb. */ + gcc_assert (code != ERROR_MARK); + + gnu_clauses = Iterate_Acc_Clause_Arg (Expression (gnat_op), + gnu_clauses, + Acc_Reduc_Var_to_gnu, + &code); + } + return gnu_clauses; +} + +/* Turn GNAT_EXPR, either '*' or an integer literal, into a tree_cons. This is + only used by Acc_Size_List_to_gnu. */ + +static tree +Acc_Size_Expr_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void *) +{ + tree gnu_expr; + + if (Nkind (gnat_expr) == N_Operator_Symbol + && Get_String_Char (Strval (gnat_expr), 1) == '*') + gnu_expr = integer_zero_node; + else + gnu_expr = Acc_gnat_to_gnu (gnat_expr); + + return tree_cons (NULL_TREE, gnu_expr, gnu_clauses); +} + +/* Turn GNAT_EXPR, an aggregate of either '*' or integer literals, into an OMP + clause node. + + This function is used for the Tile clause of the Loop directive. This is + what GNAT_EXPR might look like: (1, 1, '*'). */ + +static tree +Acc_Size_List_to_gnu (Node_Id gnat_expr) +{ + tree gnu_clause; + tree gnu_list; + + gnu_clause = build_omp_clause (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_TILE); + gnu_list = Iterate_Acc_Clause_Arg (gnat_expr, NULL_TREE, + Acc_Size_Expr_to_gnu, + NULL); + OMP_CLAUSE_TILE_LIST (gnu_clause) = nreverse (gnu_list); + return gnu_clause; +} + /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return any statements we generate. */ @@ -1309,6 +1533,274 @@ Pragma_to_gnu (Node_Id gnat_node) } break; + case Pragma_Acc_Loop: + { + tree gnu_clauses = gnu_loop_stack->last ()->omp_loop_clauses; + if (!flag_openacc) + break; + if (!Present (Pragma_Argument_Associations (gnat_node))) + break; + for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) + { + Node_Id gnat_expr = Expression (gnat_temp); + tree gnu_clause = NULL_TREE; + enum omp_clause_code kind; + + if (Chars (gnat_temp) == No_Name) + { + /* The clause is an identifier without a parameter. */ + switch (Chars (gnat_expr)) + { + case Name_Auto: + kind = OMP_CLAUSE_AUTO; + break; + case Name_Gang: + kind = OMP_CLAUSE_GANG; + break; + case Name_Independent: + kind = OMP_CLAUSE_INDEPENDENT; + break; + case Name_Seq: + kind = OMP_CLAUSE_SEQ; + break; + case Name_Vector: + kind = OMP_CLAUSE_VECTOR; + break; + case Name_Worker: + kind = OMP_CLAUSE_WORKER; + break; + default: + gcc_unreachable(); + } + gnu_clause = build_omp_clause (EXPR_LOCATION + (gnu_loop_stack->last ()->stmt), + kind); + } + else + { + /* The clause is an identifier parameter(s). */ + switch (Chars (gnat_temp)) + { + case Name_Collapse: + gnu_clause = build_omp_clause + (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_COLLAPSE); + OMP_CLAUSE_COLLAPSE_EXPR (gnu_clause) = + Acc_gnat_to_gnu (gnat_expr); + break; + case Name_Device_Type: + /* Unimplemented by GCC yet. */ + gcc_unreachable(); + break; + case Name_Independent: + gnu_clause = build_omp_clause + (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_INDEPENDENT); + break; + case Name_Acc_Private: + kind = OMP_CLAUSE_PRIVATE; + gnu_clause = Iterate_Acc_Clause_Arg (gnat_expr, 0, + Acc_Var_to_gnu, + &kind); + break; + case Name_Reduction: + gnu_clause = Acc_Reduc_to_gnu (gnat_expr); + break; + case Name_Tile: + gnu_clause = Acc_Size_List_to_gnu (gnat_expr); + break; + case Name_Gang: + case Name_Vector: + case Name_Worker: + /* These are for the Loop+Kernel combination, which is + unimplemented by the frontend for now. */ + default: + gcc_unreachable(); + } + } + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + gnu_clauses = gnu_clause; + } + gnu_loop_stack->last ()->omp_loop_clauses = gnu_clauses; + } + break; + /* Grouping the transformation of these pragmas together makes sense + because they are mutually exclusive, share most of their clauses and + the verification that each clause can legally appear for the pragma has + been done in the frontend. */ + case Pragma_Acc_Data: + case Pragma_Acc_Kernels: + case Pragma_Acc_Parallel: + { + if (!flag_openacc) + break; + + tree gnu_clauses = gnu_loop_stack->last ()->omp_construct_clauses; + if (pragma_id == Pragma_Acc_Data) + gnu_loop_stack->last ()->omp_code = OACC_DATA; + else if (pragma_id == Pragma_Acc_Kernels) + gnu_loop_stack->last ()->omp_code = OACC_KERNELS; + else if (pragma_id == Pragma_Acc_Parallel) + gnu_loop_stack->last ()->omp_code = OACC_PARALLEL; + else + gcc_unreachable (); + + if (!Present (Pragma_Argument_Associations (gnat_node))) + break; + + for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) + { + Node_Id gnat_expr = Expression (gnat_temp); + tree gnu_clause; + enum omp_clause_code clause_code; + enum gomp_map_kind map_kind; + + switch (Chars (gnat_temp)) + { + case Name_Async: + gnu_clause = build_omp_clause + (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_ASYNC); + OMP_CLAUSE_ASYNC_EXPR (gnu_clause) = + Acc_gnat_to_gnu (gnat_expr); + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + gnu_clauses = gnu_clause; + break; + + case Name_Num_Gangs: + gnu_clause = build_omp_clause + (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_NUM_GANGS); + OMP_CLAUSE_NUM_GANGS_EXPR (gnu_clause) = + Acc_gnat_to_gnu (gnat_expr); + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + gnu_clauses = gnu_clause; + break; + + case Name_Num_Workers: + gnu_clause = build_omp_clause + (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_NUM_WORKERS); + OMP_CLAUSE_NUM_WORKERS_EXPR (gnu_clause) = + Acc_gnat_to_gnu (gnat_expr); + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + gnu_clauses = gnu_clause; + break; + + case Name_Vector_Length: + gnu_clause = build_omp_clause + (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_VECTOR_LENGTH); + OMP_CLAUSE_VECTOR_LENGTH_EXPR (gnu_clause) = + Acc_gnat_to_gnu (gnat_expr); + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + gnu_clauses = gnu_clause; + break; + + case Name_Wait: + clause_code = OMP_CLAUSE_WAIT; + gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses, + Acc_Var_to_gnu, + &clause_code); + break; + + case Name_Acc_If: + gnu_clause = build_omp_clause (EXPR_LOCATION + (gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_IF); + OMP_CLAUSE_IF_MODIFIER (gnu_clause) = ERROR_MARK; + OMP_CLAUSE_IF_EXPR (gnu_clause) = Acc_gnat_to_gnu (gnat_expr); + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + gnu_clauses = gnu_clause; + break; + + case Name_Copy: + map_kind = GOMP_MAP_FORCE_TOFROM; + gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses, + Acc_Data_to_gnu, + &map_kind); + break; + + case Name_Copy_In: + map_kind = GOMP_MAP_FORCE_TO; + gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses, + Acc_Data_to_gnu, + &map_kind); + break; + + case Name_Copy_Out: + map_kind = GOMP_MAP_FORCE_FROM; + gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses, + Acc_Data_to_gnu, + &map_kind); + break; + + case Name_Present: + map_kind = GOMP_MAP_FORCE_PRESENT; + gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses, + Acc_Data_to_gnu, + &map_kind); + break; + + case Name_Create: + map_kind = GOMP_MAP_FORCE_ALLOC; + gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses, + Acc_Data_to_gnu, + &map_kind); + break; + + case Name_Device_Ptr: + map_kind = GOMP_MAP_FORCE_DEVICEPTR; + gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses, + Acc_Data_to_gnu, + &map_kind); + break; + + case Name_Acc_Private: + clause_code = OMP_CLAUSE_PRIVATE; + gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses, + Acc_Var_to_gnu, + &clause_code); + break; + + case Name_First_Private: + clause_code = OMP_CLAUSE_FIRSTPRIVATE; + gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses, + Acc_Var_to_gnu, + &clause_code); break; + + case Name_Default: + gnu_clause = build_omp_clause (EXPR_LOCATION + (gnu_loop_stack->last ()->stmt), + OMP_CLAUSE_DEFAULT); + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + /* The standard also accepts "present" but this isn't + implemented in GCC yet. */ + OMP_CLAUSE_DEFAULT_KIND (gnu_clause) = OMP_CLAUSE_DEFAULT_NONE; + OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses; + gnu_clauses = gnu_clause; + break; + + case Name_Reduction: + gnu_clauses = Acc_Reduc_to_gnu(gnat_expr); + break; + + case Name_Detach: + case Name_Attach: + case Name_Device_Type: + /* Unimplemented by GCC. */ + default: + gcc_unreachable (); + } + } + gnu_loop_stack->last ()->omp_construct_clauses = gnu_clauses; + } + break; + case Pragma_Loop_Optimize: for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); Present (gnat_temp); @@ -2838,32 +3330,174 @@ independent_iterations_p (tree stmt_list) return true; } -/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, - to a GCC tree, which is returned. */ +/* Helper for Loop_Statement_to_gnu to translate the body of a loop, + designated by GNAT_LOOP, to which an Acc_Loop pragma applies. The pragma + arguments might instruct us to collapse a nest of loops, where computation + statements are expected only within the innermost loop, as in: + + for I in 1 .. 5 loop + pragma Acc_Parallel; + pragma Acc_Loop(Collapse => 3); + for J in 1 .. 8 loop + for K in 1 .. 4 loop + X (I, J, K) := Y (I, J, K) + 2; + end loop; + end loop; + end loop; + + We expect the top of gnu_loop_stack to hold a pointer to the loop info + setup for the translation of GNAT_LOOP, which holds a pointer to the + initial gnu loop stmt node. We return the new gnu loop statement to + use. */ static tree -Loop_Statement_to_gnu (Node_Id gnat_node) +Acc_Loop_to_gnu (Node_Id gnat_loop) { + const struct loop_info_d * const gnu_loop_info = gnu_loop_stack->last (); + tree gnu_loop_stmt = gnu_loop_info->stmt; + + tree acc_loop = make_node (OACC_LOOP); + tree acc_bind_expr = NULL_TREE; + Node_Id cur_loop = gnat_loop; + int collapse_count = 1; + tree initv; + tree condv; + tree incrv; + + /* Parse the pragmas, adding clauses to the current gnu_loop_stack through + side effects. */ + for (Node_Id tmp = First (Statements (gnat_loop)); + Present (tmp) && Nkind (tmp) == N_Pragma; + tmp = Next (tmp)) + Pragma_to_gnu(tmp); + + /* Find the number of loops that should be collapsed. */ + for (tree tmp = gnu_loop_stack->last ()->omp_loop_clauses; tmp ; + tmp = OMP_CLAUSE_CHAIN (tmp)) + if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_COLLAPSE) + collapse_count = tree_to_shwi (OMP_CLAUSE_COLLAPSE_EXPR (tmp)); + else if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_TILE) + collapse_count = list_length (OMP_CLAUSE_TILE_LIST (tmp)); + + initv = make_tree_vec (collapse_count); + condv = make_tree_vec (collapse_count); + incrv = make_tree_vec (collapse_count); + + start_stmt_group (); + gnat_pushlevel (); + + /* For each nested loop that should be collapsed ... */ + for (int count = 0; count < collapse_count; ++count) + { + Node_Id lps = + Loop_Parameter_Specification (Iteration_Scheme (cur_loop)); + tree low = + Acc_gnat_to_gnu (Low_Bound (Discrete_Subtype_Definition (lps))); + tree high = + Acc_gnat_to_gnu (High_Bound (Discrete_Subtype_Definition (lps))); + tree variable = + gnat_to_gnu_entity (Defining_Identifier (lps), NULL_TREE, true); + + /* Build the initial value of the variable of the invariant. */ + TREE_VEC_ELT (initv, count) = build2 (MODIFY_EXPR, + TREE_TYPE (variable), + variable, + low); + add_stmt (TREE_VEC_ELT (initv, count)); + + /* Build the invariant of the loop. */ + TREE_VEC_ELT (condv, count) = build2 (LE_EXPR, + boolean_type_node, + variable, + high); + + /* Build the incrementation expression of the loop. */ + TREE_VEC_ELT (incrv, count) = + build2 (MODIFY_EXPR, + TREE_TYPE (variable), + variable, + build2 (PLUS_EXPR, + TREE_TYPE (variable), + variable, + build_int_cst (TREE_TYPE (variable), 1))); + + /* Don't process the innermost loop because its statements belong to + another statement group. */ + if (count < collapse_count - 1) + /* Process the current loop's body. */ + for (Node_Id stmt = First (Statements (cur_loop)); + Present (stmt); stmt = Next (stmt)) + { + /* If we are processsing the outermost loop, it is ok for it to + contain pragmas. */ + if (Nkind (stmt) == N_Pragma && count == 0) + ; + /* The frontend might have inserted a N_Object_Declaration in the + loop's body to declare the iteration variable of the next loop. + It will need to be hoisted before the collapsed loops. */ + else if (Nkind (stmt) == N_Object_Declaration) + Acc_gnat_to_gnu (stmt); + else if (Nkind (stmt) == N_Loop_Statement) + cur_loop = stmt; + /* Every other kind of statement is prohibited in collapsed + loops. */ + else if (count < collapse_count - 1) + gcc_unreachable(); + } + } + gnat_poplevel (); + acc_bind_expr = end_stmt_group (); + + /* Parse the innermost loop. */ + start_stmt_group(); + for (Node_Id stmt = First (Statements (cur_loop)); + Present (stmt); + stmt = Next (stmt)) + { + /* When the innermost loop is the only loop, do not parse the pragmas + again. */ + if (Nkind (stmt) == N_Pragma && collapse_count == 1) + continue; + add_stmt (Acc_gnat_to_gnu (stmt)); + } + + TREE_TYPE (acc_loop) = void_type_node; + OMP_FOR_INIT (acc_loop) = initv; + OMP_FOR_COND (acc_loop) = condv; + OMP_FOR_INCR (acc_loop) = incrv; + OMP_FOR_BODY (acc_loop) = end_stmt_group (); + OMP_FOR_PRE_BODY (acc_loop) = NULL; + OMP_FOR_ORIG_DECLS (acc_loop) = NULL; + OMP_FOR_CLAUSES (acc_loop) = gnu_loop_stack->last ()->omp_loop_clauses; + + BIND_EXPR_BODY (acc_bind_expr) = acc_loop; + + return gnu_loop_stmt; +} + +/* Helper for Loop_Statement_to_gnu, to translate the body of a loop not + subject to any sort of parallelization directive or restriction, designated + by GNAT_NODE. + + We expect the top of gnu_loop_stack to hold a pointer to the loop info + setup for the translation, which holds a pointer to the initial gnu loop + stmt node. We return the new gnu loop statement to use. + + We might also set *GNU_COND_EXPR_P to request a variant of the translation + scheme in Loop_Statement_to_gnu. */ + +static tree +Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p) +{ + struct loop_info_d * const gnu_loop_info = gnu_loop_stack->last (); + tree gnu_loop_stmt = gnu_loop_info->stmt; + const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); - struct loop_info_d *gnu_loop_info = ggc_cleared_alloc (); - tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE, - NULL_TREE, NULL_TREE, NULL_TREE); - tree gnu_loop_label = create_artificial_label (input_location); - tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE; - tree gnu_result; + tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; - /* Push the loop_info structure associated with the LOOP_STMT. */ - vec_safe_push (gnu_loop_stack, gnu_loop_info); + tree gnu_cond_expr = *gnu_cond_expr_p; - /* Set location information for statement and end label. */ - set_expr_location_from_node (gnu_loop_stmt, gnat_node); - Sloc_to_locus (Sloc (End_Label (gnat_node)), - &DECL_SOURCE_LOCATION (gnu_loop_label)); - LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label; - - /* Save the statement for later reuse. */ - gnu_loop_info->stmt = gnu_loop_stmt; - gnu_loop_info->artificial = !Comes_From_Source (gnat_node); + tree gnu_loop_label = LOOP_STMT_LABEL (gnu_loop_stmt); /* Set the condition under which the loop must keep going. For the case "LOOP .... END LOOP;" the condition is always true. */ @@ -3203,6 +3837,68 @@ Loop_Statement_to_gnu (Node_Id gnat_node) gnu_loop_stmt = end_stmt_group (); } + *gnu_cond_expr_p = gnu_cond_expr; + + return gnu_loop_stmt; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, + to a GCC tree, which is returned. */ + +static tree +Loop_Statement_to_gnu (Node_Id gnat_node) +{ + struct loop_info_d *gnu_loop_info = ggc_cleared_alloc (); + + tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE); + tree gnu_cond_expr = NULL_TREE; + tree gnu_loop_label = create_artificial_label (input_location); + tree gnu_result; + + /* Push the loop_info structure associated with the LOOP_STMT. */ + vec_safe_push (gnu_loop_stack, gnu_loop_info); + + /* Set location information for statement and end label. */ + set_expr_location_from_node (gnu_loop_stmt, gnat_node); + Sloc_to_locus (Sloc (End_Label (gnat_node)), + &DECL_SOURCE_LOCATION (gnu_loop_label)); + LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label; + + /* Save the statement for later reuse. */ + gnu_loop_info->stmt = gnu_loop_stmt; + gnu_loop_info->artificial = !Comes_From_Source (gnat_node); + + /* Perform the core loop body translation. */ + if (Is_OpenAcc_Loop (gnat_node)) + gnu_loop_stmt = Acc_Loop_to_gnu (gnat_node); + else + gnu_loop_stmt = Regular_Loop_to_gnu (gnat_node, &gnu_cond_expr); + + /* A gnat_node that has its OpenAcc_Environment flag set needs to be + offloaded. Note that the OpenAcc_Loop flag is not necessarily set. */ + if (Is_OpenAcc_Environment (gnat_node)) + { + tree_code code = gnu_loop_stack->last ()->omp_code; + tree tmp = make_node (code); + TREE_TYPE (tmp) = void_type_node; + if (code == OACC_PARALLEL || code == OACC_KERNELS) + { + OMP_BODY (tmp) = gnu_loop_stmt; + OMP_CLAUSES (tmp) = gnu_loop_stack->last ()->omp_construct_clauses; + } + else if (code == OACC_DATA) + { + OACC_DATA_BODY (tmp) = gnu_loop_stmt; + OACC_DATA_CLAUSES (tmp) = + gnu_loop_stack->last ()->omp_construct_clauses; + } + else + gcc_unreachable(); + set_expr_location_from_node (tmp, gnat_node); + gnu_loop_stmt = tmp; + } + /* If we have an outer COND_EXPR, that's our result and this loop is its "true" statement. Otherwise, the result is the LOOP_STMT. */ if (gnu_cond_expr)