-----------------------
function Acc_First (N : Node_Id) return Node_Id;
- -- Helper function to iterate over arguments given to OpenAcc pragmas.
+ -- Helper function to iterate over arguments given to OpenAcc pragmas
function Acc_Next (N : Node_Id) return Node_Id;
- -- Helper function to iterate over arguments given to OpenAcc pragmas.
+ -- Helper function to iterate over arguments given to OpenAcc pragmas
procedure Acquire_Warning_Match_String (Arg : Node_Id);
-- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
-- profile.
procedure Validate_Acc_Condition_Clause (Clause : Node_Id);
- -- Make sure the argument of a given Acc_If clause is a boolean.
+ -- Make sure the argument of a given Acc_If clause is a Boolean
procedure Validate_Acc_Data_Clause (Clause : Node_Id);
-- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin,
-- Copyout...) is an identifier or an aggregate of identifiers.
procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id);
- -- Make sure the argument of an OpenAcc clause is an Integer expression.
+ -- Make sure the argument of an OpenAcc clause is an Integer expression
procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id);
-- Make sure the argument of an OpenAcc clause is an Integer expression
procedure Validate_Acc_Loop_Vector (Clause : Node_Id);
-- When this procedure is called in a construct offloaded by an
-- Acc_Kernels pragma, makes sure that a Vector_Length clause does
- -- not exist on said pragma.
- -- In all cases, make sure the argument is an integer expression.
+ -- not exist on said pragma. In all cases, make sure the argument
+ -- is an Integer expression.
procedure Validate_Acc_Loop_Worker (Clause : Node_Id);
-- When this procedure is called in a construct offloaded by an
if Nkind (N) = N_Aggregate then
if Present (Expressions (N)) then
return First (Expressions (N));
+
elsif Present (Component_Associations (N)) then
return Expression (First (Component_Associations (N)));
end if;
end if;
+
return N;
end Acc_First;
begin
if Nkind (Parent (N)) = N_Component_Association then
return Expression (Next (Parent (N)));
+
elsif Nkind (Parent (N)) = N_Aggregate then
return Next (N);
+
else
return Empty;
end if;
procedure Validate_Acc_Condition_Clause (Clause : Node_Id) is
begin
Analyze_And_Resolve (Clause);
+
if not Is_Boolean_Type (Etype (Clause)) then
- Error_Pragma ("Expected a boolean");
+ Error_Pragma ("expected a boolean");
end if;
end Validate_Acc_Condition_Clause;
procedure Validate_Acc_Data_Clause (Clause : Node_Id) is
Expr : Node_Id;
+
begin
Expr := Acc_First (Clause);
while Present (Expr) loop
if Nkind (Expr) /= N_Identifier then
- Error_Pragma ("Expected an Identifer");
+ Error_Pragma ("expected an identifer");
end if;
+
Analyze_And_Resolve (Expr);
+
Expr := Acc_Next (Expr);
end loop;
end Validate_Acc_Data_Clause;
procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id) is
begin
Analyze_And_Resolve (Clause);
+
if not Is_Integer_Type (Etype (Clause)) then
- Error_Pragma_Arg ("Expected an integer", Clause);
+ Error_Pragma_Arg ("expected an integer", Clause);
end if;
end Validate_Acc_Int_Expr_Clause;
procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id) is
Expr : Node_Id;
+
begin
Expr := Acc_First (Clause);
while Present (Expr) loop
Analyze_And_Resolve (Expr);
+
if not Is_Integer_Type (Etype (Expr)) then
- Error_Pragma ("Expected an Integer");
+ Error_Pragma ("expected an integer");
end if;
+
Expr := Acc_Next (Expr);
end loop;
end Validate_Acc_Int_Expr_List_Clause;
--------------------------------
procedure Validate_Acc_Loop_Collapse (Clause : Node_Id) is
- Count : Uint;
- Parent_Loop : Node_Id;
- Current_Statement : Node_Id;
+ Count : Uint;
+ Par_Loop : Node_Id;
+ Stmt : Node_Id;
+
begin
- -- Make sure the argument is a positive integer.
+ -- Make sure the argument is a positive integer
+
Analyze_And_Resolve (Clause);
+
Count := Static_Integer (Clause);
if Count = No_Uint or else Count < 1 then
- Error_Pragma_Arg ("Expected a positive integer", Clause);
+ Error_Pragma_Arg ("expected a positive integer", Clause);
end if;
-- Then, make sure we have at least Count-1 tightly-nested loops
-- (i.e. loops with no statements in between).
- Parent_Loop := Parent (Parent (Parent (Clause)));
- Current_Statement := First (Statements (Parent_Loop));
+ Par_Loop := Parent (Parent (Parent (Clause)));
+ Stmt := First (Statements (Par_Loop));
+
-- Skip first pragmas in the parent loop
- while Present (Current_Statement)
- and then Nkind (Current_Statement) = N_Pragma loop
- Current_Statement := Next (Current_Statement);
+
+ while Present (Stmt) and then Nkind (Stmt) = N_Pragma loop
+ Next (Stmt);
end loop;
- if not Present (Next (Current_Statement)) then
- While_Loop :
- while Nkind (Current_Statement) = N_Loop_Statement
- and Count > 1 loop
- Current_Statement := First (Statements (Current_Statement));
- exit While_Loop when Present (Next (Current_Statement));
+ if not Present (Next (Stmt)) then
+ while Nkind (Stmt) = N_Loop_Statement and Count > 1 loop
+ Stmt := First (Statements (Stmt));
+ exit when Present (Next (Stmt));
+
Count := Count - 1;
- end loop While_Loop;
+ end loop;
end if;
if Count > 1 then
- Error_Pragma_Arg ("Collapse argument too high or loops not " &
- "tightly nested.", Clause);
+ Error_Pragma_Arg
+ ("Collapse argument too high or loops not tightly nested",
+ Clause);
end if;
end Validate_Acc_Loop_Collapse;
---------------------------------
procedure Validate_Acc_Name_Reduction (Clause : Node_Id) is
+
-- ??? On top of the following operations, the OpenAcc spec adds the
-- "bitwise and", "bitwise or" and modulo for C and ".eqv" and
-- ".neqv" for Fortran. Can we, should we and how do we support them
-- in Ada?
- type Reduction_Op is (Add_Op, Mul_Op, Max_Op,
- Min_Op, And_Op, Or_Op);
+
+ type Reduction_Op is (Add_Op, Mul_Op, Max_Op, Min_Op, And_Op, Or_Op);
+
function To_Reduction_Op (Op : String) return Reduction_Op;
+ -- Convert operator Op described by a String into its corresponding
+ -- enumeration value.
+
+ ---------------------
+ -- To_Reduction_Op --
+ ---------------------
+
function To_Reduction_Op (Op : String) return Reduction_Op is
begin
if Op = "+" then
return Add_Op;
+
elsif Op = "*" then
return Mul_Op;
+
elsif Op = "max" then
return Max_Op;
+
elsif Op = "min" then
return Min_Op;
+
elsif Op = "and" then
return And_Op;
+
elsif Op = "or" then
return Or_Op;
+
else
- Error_Pragma ("Unsuported reduction operation");
+ Error_Pragma ("unsuported reduction operation");
end if;
end To_Reduction_Op;
- Expr : Node_Id;
- Reduc_Op : Node_Id;
+
+ -- Local variables
+
+ Seen : constant Elist_Id := New_Elmt_List;
+
+ Expr : Node_Id;
+ Reduc_Op : Node_Id;
Reduc_Var : Node_Id;
- Seen_Entities : Elist_Id;
+
+ -- Start of processing for Validate_Acc_Name_Reduction
+
begin
- -- Reduction operations look like this:
- -- ("+" => (a, b), "*" => c)
- Seen_Entities := New_Elmt_List;
+ -- Reduction operations appear in the following form:
+ -- ("+" => (a, b), "*" => c)
+
Expr := First (Component_Associations (Clause));
while Present (Expr) loop
Reduc_Op := First (Choices (Expr));
String_To_Name_Buffer (Strval (Reduc_Op));
- case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is
- when Add_Op | Mul_Op | Max_Op | Min_Op =>
+ case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is
+ when Add_Op
+ | Mul_Op
+ | Max_Op
+ | Min_Op
+ =>
Reduc_Var := Acc_First (Expression (Expr));
while Present (Reduc_Var) loop
Analyze_And_Resolve (Reduc_Var);
- if Contains (Seen_Entities, Entity (Reduc_Var)) then
- Error_Pragma ("Variable used in multiple reductions");
+
+ if Contains (Seen, Entity (Reduc_Var)) then
+ Error_Pragma ("variable used in multiple reductions");
+
else
- if (Nkind (Reduc_Var) /= N_Identifier)
- or not Is_Numeric_Type (Etype (Reduc_Var))
+ if Nkind (Reduc_Var) /= N_Identifier
+ or not Is_Numeric_Type (Etype (Reduc_Var))
then
Error_Pragma
- ("Expected an identifier for a Numeric");
+ ("expected an identifier for a Numeric");
end if;
- Append_Elmt (Entity (Reduc_Var), Seen_Entities);
+
+ Append_Elmt (Entity (Reduc_Var), Seen);
end if;
+
Reduc_Var := Acc_Next (Reduc_Var);
end loop;
- when And_Op | Or_Op =>
+ when And_Op
+ | Or_Op
+ =>
Reduc_Var := Acc_First (Expression (Expr));
while Present (Reduc_Var) loop
Analyze_And_Resolve (Reduc_Var);
- if Contains (Seen_Entities, Entity (Reduc_Var)) then
- Error_Pragma ("Variable used in multiple " &
- "reductions");
+
+ if Contains (Seen, Entity (Reduc_Var)) then
+ Error_Pragma ("variable used in multiple reductions");
+
else
- if Nkind (Reduc_Var) /= N_Identifier or not
- Is_Boolean_Type (Etype (Reduc_Var))
+ if Nkind (Reduc_Var) /= N_Identifier
+ or not Is_Boolean_Type (Etype (Reduc_Var))
then
- Error_Pragma ("Expected a variable of type " &
- "Boolean");
+ Error_Pragma
+ ("expected a variable of type boolean");
end if;
- Append_Elmt (Entity (Reduc_Var), Seen_Entities);
+
+ Append_Elmt (Entity (Reduc_Var), Seen);
end if;
+
Reduc_Var := Acc_Next (Reduc_Var);
end loop;
end case;
- Expr := Next (Expr);
+
+ Next (Expr);
end loop;
end Validate_Acc_Name_Reduction;
-----------------------------------
procedure Validate_Acc_Size_Expressions (Clause : Node_Id) is
-
- -- A size expr is either an integer expression or "*"
function Validate_Size_Expr (Expr : Node_Id) return Boolean;
+ -- A size expr is either an integer expression or "*"
+
+ ------------------------
+ -- Validate_Size_Expr --
+ ------------------------
+
function Validate_Size_Expr (Expr : Node_Id) return Boolean is
begin
if Nkind (Expr) = N_Operator_Symbol then
return Get_String_Char (Strval (Expr), 1) = Get_Char_Code ('*');
end if;
+
Analyze_And_Resolve (Expr);
+
return Is_Integer_Type (Etype (Expr));
end Validate_Size_Expr;
+ -- Local variables
+
Expr : Node_Id;
+
+ -- Start of processing for Validate_Acc_Size_Expressions
+
begin
Expr := Acc_First (Clause);
while Present (Expr) loop
if not Validate_Size_Expr (Expr) then
- Error_Pragma ("Size expressions should be either integers " &
- "or '*'");
+ Error_Pragma
+ ("Size expressions should be either integers or '*'");
end if;
+
Expr := Acc_Next (Expr);
end loop;
end Validate_Acc_Size_Expressions;
--------------
when Pragma_Acc_Data => Acc_Data : declare
- Clause_Names : constant Name_List := (
- Name_Attach,
+ Clause_Names : constant Name_List :=
+ (Name_Attach,
Name_Copy,
Name_Copy_In,
Name_Copy_Out,
Name_Detach,
Name_Device_Ptr,
Name_No_Create,
- Name_Present
- );
+ Name_Present);
+
+ Clause : Node_Id;
Clauses : Args_List (Clause_Names'Range);
- Clause : Node_Id;
begin
if not OpenAcc_Enabled then
return;
end if;
+
GNAT_Pragma;
- if Nkind (Parent (N)) /= N_Loop_Statement
- then
- Error_Pragma ("Acc_Data pragma should be placed in loop or "
- & "block statements.");
+
+ if Nkind (Parent (N)) /= N_Loop_Statement then
+ Error_Pragma
+ ("Acc_Data pragma should be placed in loop or block "
+ & "statements");
end if;
+
Gather_Associations (Clause_Names, Clauses);
+
for Id in Clause_Names'First .. Clause_Names'Last loop
Clause := Clauses (Id);
+
if Present (Clause) then
case Clause_Names (Id) is
when Name_Copy
| Name_Copy_Out
| Name_Create
| Name_Device_Ptr
- | Name_Present =>
+ | Name_Present
+ =>
Validate_Acc_Data_Clause (Clause);
+
when Name_Attach
| Name_Detach
| Name_Delete
- | Name_No_Create =>
- Error_Pragma ("Unsupported pragma clause.");
- when others => raise Program_Error;
+ | Name_No_Create
+ =>
+ Error_Pragma ("unsupported pragma clause");
+
+ when others =>
+ raise Program_Error;
end case;
end if;
end loop;
Set_Is_OpenAcc_Environment (Parent (N));
-
end Acc_Data;
--------------
--------------
when Pragma_Acc_Loop => Acc_Loop : declare
-
- Clause_Names : constant Name_List := (
- Name_Auto,
+ Clause_Names : constant Name_List :=
+ (Name_Auto,
Name_Collapse,
Name_Gang,
Name_Independent,
Name_Seq,
Name_Tile,
Name_Vector,
- Name_Worker
- );
+ Name_Worker);
+
+ Clause : Node_Id;
Clauses : Args_List (Clause_Names'Range);
- Clause : Node_Id;
- Parent_Node : Node_Id;
+ Par : Node_Id;
begin
if not OpenAcc_Enabled then
return;
end if;
+
GNAT_Pragma;
-- Make sure the pragma is in an openacc construct
+
Check_Loop_Pragma_Placement;
- Parent_Node := Parent (N);
- while Present (Parent_Node) and then
- (Nkind (Parent_Node) /= N_Loop_Statement or else
- not Is_OpenAcc_Environment (Parent_Node)) loop
- Parent_Node := Parent (Parent_Node);
+
+ Par := Parent (N);
+ while Present (Par)
+ and then (Nkind (Par) /= N_Loop_Statement
+ or else not Is_OpenAcc_Environment (Par))
+ loop
+ Par := Parent (Par);
end loop;
- if not Is_OpenAcc_Environment (Parent_Node) then
- Error_Pragma ("Acc_Loop directive must be associated with an " &
- "OpenAcc construct region");
+
+ if not Is_OpenAcc_Environment (Par) then
+ Error_Pragma
+ ("Acc_Loop directive must be associated with an OpenAcc "
+ & "construct region");
end if;
Gather_Associations (Clause_Names, Clauses);
+
for Id in Clause_Names'First .. Clause_Names'Last loop
Clause := Clauses (Id);
+
if Present (Clause) then
case Clause_Names (Id) is
- when Name_Auto | Name_Independent | Name_Seq => null;
+ when Name_Auto
+ | Name_Independent
+ | Name_Seq
+ =>
+ null;
+
when Name_Collapse =>
Validate_Acc_Loop_Collapse (Clause);
- when Name_Gang => Validate_Acc_Loop_Gang (Clause);
+
+ when Name_Gang =>
+ Validate_Acc_Loop_Gang (Clause);
+
when Name_Acc_Private =>
Validate_Acc_Data_Clause (Clause);
+
when Name_Reduction =>
Validate_Acc_Name_Reduction (Clause);
- when Name_Tile => Validate_Acc_Size_Expressions (Clause);
- when Name_Vector => Validate_Acc_Loop_Vector (Clause);
- when Name_Worker => Validate_Acc_Loop_Worker (Clause);
- when others => raise Program_Error;
+
+ when Name_Tile =>
+ Validate_Acc_Size_Expressions (Clause);
+
+ when Name_Vector =>
+ Validate_Acc_Loop_Vector (Clause);
+
+ when Name_Worker =>
+ Validate_Acc_Loop_Worker (Clause);
+
+ when others =>
+ raise Program_Error;
end case;
end if;
end loop;
+
Set_Is_OpenAcc_Loop (Parent (N));
end Acc_Loop;
-- Acc_Parallel and Acc_Kernels --
----------------------------------
- when Pragma_Acc_Parallel | Pragma_Acc_Kernels =>
- Acc_Kernels_Or_Parallel :
- declare
-
- Clause_Names : constant Name_List := (
- Name_Acc_If,
+ when Pragma_Acc_Parallel
+ | Pragma_Acc_Kernels
+ =>
+ Acc_Kernels_Or_Parallel : declare
+ Clause_Names : constant Name_List :=
+ (Name_Acc_If,
Name_Async,
Name_Copy,
Name_Copy_In,
Name_Present,
Name_Vector_Length,
Name_Wait,
+
-- Parallel only
+
Name_Acc_Private,
Name_First_Private,
Name_Reduction,
+
-- Kernels only
+
Name_Attach,
- Name_No_Create
- );
+ Name_No_Create);
+
+ Clause : Node_Id;
Clauses : Args_List (Clause_Names'Range);
- Clause : Node_Id;
begin
if not OpenAcc_Enabled then
return;
end if;
+
GNAT_Pragma;
Check_Loop_Pragma_Placement;
if Nkind (Parent (N)) /= N_Loop_Statement then
- Error_Pragma ("Pragma should be placed in loop or block "
- & "statements.");
+ Error_Pragma
+ ("pragma should be placed in loop or block statements");
end if;
Gather_Associations (Clause_Names, Clauses);
+
for Id in Clause_Names'First .. Clause_Names'Last loop
Clause := Clauses (Id);
+
if Present (Clause) then
if Chars (Parent (Clause)) = No_Name then
- Error_Pragma ("All arguments should be associations");
+ Error_Pragma ("all arguments should be associations");
else
case Clause_Names (Id) is
- -- Note: According to the OpenAcc Standard v2.6,
- -- Async's argument should be optional. Because
- -- this complicates parsing the clause, the
- -- argument is made mandatory. The standard defines
- -- two negative values, acc_async_noval and
- -- acc_async_sync. When given acc_async_noval as
- -- value, the clause should behave as if no
- -- argument was given. According to the standard,
- -- acc_async_noval is defined in header files for C
- -- and Fortran, thus this value should probably be
- -- defined in the OpenAcc Ada library once it is
- -- implemented.
+
+ -- Note: According to the OpenAcc Standard v2.6,
+ -- Async's argument should be optional. Because this
+ -- complicates parsing the clause, the argument is
+ -- made mandatory. The standard defines two negative
+ -- values, acc_async_noval and acc_async_sync. When
+ -- given acc_async_noval as value, the clause should
+ -- behave as if no argument was given. According to
+ -- the standard, acc_async_noval is defined in header
+ -- files for C and Fortran, thus this value should
+ -- probably be defined in the OpenAcc Ada library once
+ -- it is implemented.
+
when Name_Async
| Name_Num_Gangs
| Name_Num_Workers
- | Name_Vector_Length =>
+ | Name_Vector_Length
+ =>
Validate_Acc_Int_Expr_Clause (Clause);
when Name_Acc_If =>
Validate_Acc_Condition_Clause (Clause);
- -- Unsupported by GCC
+ -- Unsupported by GCC
+
when Name_Attach
- | Name_No_Create =>
- Error_Pragma ("Unsupported clause.");
+ | Name_No_Create
+ =>
+ Error_Pragma ("unsupported clause");
- when Name_First_Private
- | Name_Acc_Private =>
+ when Name_Acc_Private
+ | Name_First_Private
+ =>
if Prag_Id /= Pragma_Acc_Parallel then
- Error_Pragma ("Argument is only available for" &
- " 'Parallel' construct.");
+ Error_Pragma
+ ("argument is only available for 'Parallel' "
+ & "construct");
else
Validate_Acc_Data_Clause (Clause);
end if;
when Name_Copy
| Name_Copy_In
| Name_Copy_Out
- | Name_Present
| Name_Create
- | Name_Device_Ptr =>
+ | Name_Device_Ptr
+ | Name_Present
+ =>
Validate_Acc_Data_Clause (Clause);
when Name_Reduction =>
if Prag_Id /= Pragma_Acc_Parallel then
- Error_Pragma ("Argument is only available for" &
- " 'Parallel' construct.");
+ Error_Pragma
+ ("argument is only available for 'Parallel' "
+ & "construct");
else
Validate_Acc_Name_Reduction (Clause);
end if;
when Name_Default =>
if Chars (Clause) /= Name_None then
- Error_Pragma ("Expected None");
+ Error_Pragma ("expected none");
end if;
when Name_Device_Type =>
- Error_Pragma ("Unsupported pragma clause");
+ Error_Pragma ("unsupported pragma clause");
+
+ -- Similar to Name_Async, Name_Wait's arguments should
+ -- be optional. However, this can be simulated using
+ -- acc_async_noval, hence, we do not bother making the
+ -- argument optional for now.
- -- Same as for Name_Async, Name_Wait's arguments
- -- should be optional. However, this can be
- -- simulated using acc_async_noval, hence, we do
- -- not bother making the argument optional for now.
when Name_Wait =>
Validate_Acc_Int_Expr_List_Clause (Clause);
- when others => raise Program_Error;
+ when others =>
+ raise Program_Error;
end case;
end if;
end if;
end loop;
Set_Is_OpenAcc_Environment (Parent (N));
-
end Acc_Kernels_Or_Parallel;
------------
projects / gcc.git / commitdiff