OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Stub CUDA_Execute and CUDA_Global pragmas 

This commit adds CUDA_Execute and CUDA_Global to the list of allowed
pragmas. It also implements basic validation of said pragmas.

gcc/ada/

	* aspects.ads: Declare CUDA_Global as aspect.
	* einfo.ads: Use Flag118 for the Is_CUDA_Kernel flag.
	(Set_Is_CUDA_Kernel): New function.
	(Is_CUDA_Kernel): New function.
	* einfo.adb (Set_Is_CUDA_Kernel): New function.
	(Is_CUDA_Kernel): New function.
	* par-prag.adb (Prag): Ignore Pragma_CUDA_Execute and
	Pragma_CUDA_global.
	* rtsfind.ads: Define CUDA.Driver_Types.Stream_T and
	CUDA.Vector_Types.Dim3 entities
	* rtsfind.adb: Define CUDA_Descendant subtype.
	(Get_Unit_Name): Handle CUDA_Descendant packages.
	* sem_prag.ads: Mark CUDA_Global as aspect-specifying pragma.
	* sem_prag.adb (Analyze_Pragma): Validate Pragma_CUDA_Execute and
	Pragma_CUDA_Global.
	* snames.ads-tmpl: Define Name_CUDA_Execute and Name_CUDA_Global.
This commit is contained in:
Arnaud Charlet 2020-07-23 09:54:45 -04:00
parent 3968b02a4b
commit ad1bea3a4b
9 changed files with 221 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/aspects.ads
View File

@ -189,6 +189,7 @@ package Aspects is
Aspect_Atomic_Components,
Aspect_Disable_Controlled, -- GNAT
Aspect_Discard_Names,
Aspect_CUDA_Global, -- GNAT
Aspect_Export,
Aspect_Favor_Top_Level, -- GNAT
Aspect_Independent,
@ -458,6 +459,7 @@ package Aspects is
Aspect_Contract_Cases => False,
Aspect_Convention => True,
Aspect_CPU => False,
Aspect_CUDA_Global => False,
Aspect_Default_Component_Value => True,
Aspect_Default_Initial_Condition => False,
Aspect_Default_Iterator => False,
@ -601,6 +603,7 @@ package Aspects is
Aspect_Contract_Cases => Name_Contract_Cases,
Aspect_Convention => Name_Convention,
Aspect_CPU => Name_CPU,
Aspect_CUDA_Global => Name_CUDA_Global,
Aspect_Default_Component_Value => Name_Default_Component_Value,
Aspect_Default_Initial_Condition => Name_Default_Initial_Condition,
Aspect_Default_Iterator => Name_Default_Iterator,
@ -839,6 +842,7 @@ package Aspects is
Aspect_Attach_Handler => Always_Delay,
Aspect_Constant_Indexing => Always_Delay,
Aspect_CPU => Always_Delay,
Aspect_CUDA_Global => Always_Delay,
Aspect_Default_Iterator => Always_Delay,
Aspect_Default_Storage_Pool => Always_Delay,
Aspect_Default_Value => Always_Delay,

14
gcc/ada/einfo.adb
View File

@ -423,6 +423,7 @@ package body Einfo is
-- Never_Set_In_Source Flag115
-- Is_Visible_Lib_Unit Flag116
-- Is_Unchecked_Union Flag117
-- Is_CUDA_Kernel Flag118
-- Has_Convention_Pragma Flag119
-- Has_Primitive_Operations Flag120
@ -2235,6 +2236,12 @@ package body Einfo is
return Flag74 (Id);
end Is_CPP_Class;
function Is_CUDA_Kernel (Id : E) return B is
begin
pragma Assert (Ekind (Id) in E_Function | E_Procedure);
return Flag118 (Id);
end Is_CUDA_Kernel;
function Is_DIC_Procedure (Id : E) return B is
begin
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
@ -5477,6 +5484,12 @@ package body Einfo is
Set_Flag74 (Id, V);
end Set_Is_CPP_Class;
procedure Set_Is_CUDA_Kernel (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) in E_Function | E_Procedure);
Set_Flag118 (Id, V);
end Set_Is_CUDA_Kernel;
procedure Set_Is_DIC_Procedure (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
@ -9848,6 +9861,7 @@ package body Einfo is
W ("Is_Atomic", Flag85 (Id));
W ("Is_Bit_Packed_Array", Flag122 (Id));
W ("Is_CPP_Class", Flag74 (Id));
W ("Is_CUDA_Kernel", Flag118 (Id));
W ("Is_Called", Flag102 (Id));
W ("Is_Character_Type", Flag63 (Id));
W ("Is_Checked_Ghost_Entity", Flag277 (Id));

10
gcc/ada/einfo.ads
View File

@ -2508,6 +2508,10 @@ package Einfo is
-- Defined in all type entities, set only for tagged types to which a
-- valid pragma Import (CPP, ...) or pragma CPP_Class has been applied.
-- Is_CUDA_Kernel (Flag118)
-- Defined in function and procedure entities. Set if the subprogram is a
-- CUDA kernel.
-- Is_Decimal_Fixed_Point_Type (synthesized)
-- Applies to all type entities, true for decimal fixed point
-- types and subtypes.
@ -6239,6 +6243,7 @@ package Einfo is
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
-- Is_CUDA_Kernel (Flag118) (non-generic case only)
-- Is_DIC_Procedure (Flag132) (non-generic case only)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Discriminant_Check_Function (Flag264)
@ -6566,6 +6571,7 @@ package Einfo is
-- Is_Asynchronous (Flag81)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
-- Is_CUDA_Kernel (Flag118)
-- Is_DIC_Procedure (Flag132) (non-generic case only)
-- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Elaboration_Warnings_OK_Id (Flag304)
@ -7345,6 +7351,7 @@ package Einfo is
function Is_Controlled_Active (Id : E) return B;
function Is_Controlling_Formal (Id : E) return B;
function Is_CPP_Class (Id : E) return B;
function Is_CUDA_Kernel (Id : E) return B;
function Is_Descendant_Of_Address (Id : E) return B;
function Is_DIC_Procedure (Id : E) return B;
function Is_Discrim_SO_Function (Id : E) return B;
@ -8060,6 +8067,7 @@ package Einfo is
procedure Set_Is_Controlled_Active (Id : E; V : B := True);
procedure Set_Is_Controlling_Formal (Id : E; V : B := True);
procedure Set_Is_CPP_Class (Id : E; V : B := True);
procedure Set_Is_CUDA_Kernel (Id : E; V : B := True);
procedure Set_Is_Descendant_Of_Address (Id : E; V : B := True);
procedure Set_Is_DIC_Procedure (Id : E; V : B := True);
procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True);
@ -8904,6 +8912,7 @@ package Einfo is
pragma Inline (Is_Controlled_Active);
pragma Inline (Is_Controlling_Formal);
pragma Inline (Is_CPP_Class);
pragma Inline (Is_CUDA_Kernel);
pragma Inline (Is_Decimal_Fixed_Point_Type);
pragma Inline (Is_Descendant_Of_Address);
pragma Inline (Is_DIC_Procedure);
@ -9506,6 +9515,7 @@ package Einfo is
pragma Inline (Set_Is_Controlled_Active);
pragma Inline (Set_Is_Controlling_Formal);
pragma Inline (Set_Is_CPP_Class);
pragma Inline (Set_Is_CUDA_Kernel);
pragma Inline (Set_Is_Descendant_Of_Address);
pragma Inline (Set_Is_DIC_Procedure);
pragma Inline (Set_Is_Discrim_SO_Function);

42
gcc/ada/par-prag.adb
View File

@ -1311,43 +1311,45 @@ begin
when Pragma_Abort_Defer
| Pragma_Abstract_State
| Pragma_Aggregate_Individually_Assign
| Pragma_Async_Readers
| Pragma_Async_Writers
| Pragma_Assertion_Policy
| Pragma_Assume
| Pragma_Assume_No_Invalid_Values
| Pragma_All_Calls_Remote
| Pragma_Allow_Integer_Address
| Pragma_Annotate
| Pragma_Assert
| Pragma_Assert_And_Cut
| Pragma_Assertion_Policy
| Pragma_Assume
| Pragma_Assume_No_Invalid_Values
| Pragma_Async_Readers
| Pragma_Async_Writers
| Pragma_Asynchronous
| Pragma_Atomic
| Pragma_Atomic_Components
| Pragma_Attach_Handler
| Pragma_Attribute_Definition
| Pragma_Check
| Pragma_Check_Float_Overflow
| Pragma_Check_Name
| Pragma_Check_Policy
| Pragma_Compile_Time_Error
| Pragma_Compile_Time_Warning
| Pragma_Constant_After_Elaboration
| Pragma_Contract_Cases
| Pragma_Convention_Identifier
| Pragma_CPP_Class
| Pragma_CPP_Constructor
| Pragma_CPP_Virtual
| Pragma_CPP_Vtable
| Pragma_CPU
| Pragma_CUDA_Execute
| Pragma_CUDA_Global
| Pragma_C_Pass_By_Copy
| Pragma_Check
| Pragma_Check_Float_Overflow
| Pragma_Check_Name
| Pragma_Check_Policy
| Pragma_Comment
| Pragma_Common_Object
| Pragma_Compile_Time_Error
| Pragma_Compile_Time_Warning
| Pragma_Complete_Representation
| Pragma_Complex_Representation
| Pragma_Component_Alignment
| Pragma_Constant_After_Elaboration
| Pragma_Contract_Cases
| Pragma_Controlled
| Pragma_Convention
| Pragma_Convention_Identifier
| Pragma_Deadline_Floor
| Pragma_Debug_Policy
| Pragma_Default_Initial_Condition
@ -1446,19 +1448,19 @@ begin
| Pragma_Part_Of
| Pragma_Partition_Elaboration_Policy
| Pragma_Passive
| Pragma_Preelaborable_Initialization
| Pragma_Polling
| Pragma_Prefix_Exception_Messages
| Pragma_Persistent_BSS
| Pragma_Polling
| Pragma_Post
| Pragma_Postcondition
| Pragma_Post_Class
| Pragma_Postcondition
| Pragma_Pre
| Pragma_Pre_Class
| Pragma_Precondition
| Pragma_Predicate
| Pragma_Predicate_Failure
| Pragma_Preelaborable_Initialization
| Pragma_Preelaborate
| Pragma_Pre_Class
| Pragma_Prefix_Exception_Messages
| Pragma_Priority
| Pragma_Priority_Specific_Dispatching
| Pragma_Profile
@ -1482,6 +1484,7 @@ begin
| Pragma_Rename_Pragma
| Pragma_Restricted_Run_Time
| Pragma_Reviewable
| Pragma_SPARK_Mode
| Pragma_Secondary_Stack_Size
| Pragma_Share_Generic
| Pragma_Shared
@ -1489,7 +1492,6 @@ begin
| Pragma_Short_Circuit_And_Or
| Pragma_Short_Descriptors
| Pragma_Simple_Storage_Pool_Type
| Pragma_SPARK_Mode
| Pragma_Static_Elaboration_Desired
| Pragma_Storage_Size
| Pragma_Storage_Unit

6
gcc/ada/rtsfind.adb
View File

@ -585,6 +585,9 @@ package body Rtsfind is
range Ada_Wide_Wide_Text_IO_Decimal_IO ..
Ada_Wide_Wide_Text_IO_Modular_IO;
subtype CUDA_Descendant is RTU_Id
range CUDA_Driver_Types .. CUDA_Vector_Types;
subtype Interfaces_Descendant is RTU_Id
range Interfaces_Packed_Decimal .. Interfaces_Packed_Decimal;
@ -665,6 +668,9 @@ package body Rtsfind is
Name_Buffer (22) := '.';
end if;
elsif U_Id in CUDA_Descendant then
Name_Buffer (5) := '.';
elsif U_Id in Interfaces_Descendant then
Name_Buffer (11) := '.';

17
gcc/ada/rtsfind.ads
View File

@ -159,6 +159,15 @@ package Rtsfind is
Ada_Wide_Wide_Text_IO_Integer_IO,
Ada_Wide_Wide_Text_IO_Modular_IO,
-- CUDA
CUDA,
-- Children of CUDA
CUDA_Driver_Types,
CUDA_Vector_Types,
-- Interfaces
Interfaces,
@ -614,6 +623,10 @@ package Rtsfind is
RO_WW_Decimal_IO, -- Ada.Wide_Wide_Text_IO
RO_WW_Fixed_IO, -- Ada.Wide_Wide_Text_IO
RE_Stream_T, -- CUDA.Driver_Types
RE_Dim3, -- CUDA.Vector_Types
RE_Integer_8, -- Interfaces
RE_Integer_16, -- Interfaces
RE_Integer_32, -- Interfaces
@ -1901,6 +1914,10 @@ package Rtsfind is
RO_WW_Decimal_IO => Ada_Wide_Wide_Text_IO,
RO_WW_Fixed_IO => Ada_Wide_Wide_Text_IO,
RE_Stream_T => CUDA_Driver_Types,
RE_Dim3 => CUDA_Vector_Types,
RE_Integer_8 => Interfaces,
RE_Integer_16 => Interfaces,
RE_Integer_32 => Interfaces,

144
gcc/ada/sem_prag.adb
View File

@ -3789,7 +3789,8 @@ package body Sem_Prag is
Arg2 : Node_Id;
Arg3 : Node_Id;
Arg4 : Node_Id;
-- First four pragma arguments (pragma argument association nodes, or
Arg5 : Node_Id;
-- First five pragma arguments (pragma argument association nodes, or
-- Empty if the corresponding argument does not exist).
type Name_List is array (Natural range <>) of Name_Id;
@ -11535,6 +11536,7 @@ package body Sem_Prag is
Arg2 := Empty;
Arg3 := Empty;
Arg4 := Empty;
Arg5 := Empty;
if Present (Pragma_Argument_Associations (N)) then
Arg_Count := List_Length (Pragma_Argument_Associations (N));
@ -11548,6 +11550,10 @@ package body Sem_Prag is
if Present (Arg3) then
Arg4 := Next (Arg3);
if Present (Arg4) then
Arg5 := Next (Arg4);
end if;
end if;
end if;
end if;
@ -14765,6 +14771,140 @@ package body Sem_Prag is
& "effect?j?", N);
end if;
--------------------
-- CUDA_Execute --
--------------------
-- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
-- EXPRESSION,
-- EXPRESSION,
-- [, EXPRESSION
-- [, EXPRESSION]]);
when Pragma_CUDA_Execute => CUDA_Execute : declare
function Is_Acceptable_Dim3 (N : Node_Id) return Boolean;
-- Returns True if N is an acceptable argument for CUDA_Execute,
-- false otherwise.
------------------------
-- Is_Acceptable_Dim3 --
------------------------
function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is
Tmp : Node_Id;
begin
if Etype (N) = RTE (RE_Dim3) or else Is_Integer_Type (Etype (N))
then
return True;
end if;
if Nkind (N) = N_Aggregate
and then List_Length (Expressions (N)) = 3
then
Tmp := First (Expressions (N));
while Present (Tmp) loop
Analyze_And_Resolve (Tmp, Any_Integer);
Tmp := Next (Tmp);
end loop;
return True;
end if;
return False;
end Is_Acceptable_Dim3;
-- Local variables
Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg3);
Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg2);
Kernel_Call : constant Node_Id := Get_Pragma_Arg (Arg1);
Shared_Memory : Node_Id;
Stream : Node_Id;
-- Start of processing for CUDA_Execute
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (3);
Check_At_Most_N_Arguments (5);
Analyze_And_Resolve (Kernel_Call);
if Nkind (Kernel_Call) /= N_Function_Call
or else Etype (Kernel_Call) /= Standard_Void_Type
then
-- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
-- GNAT sees Kernel_Call as an N_Function_Call since
-- Kernel_Call "looks" like an expression. However, only
-- procedures can be kernels, so to make things easier for the
-- user the error message complains about Kernel_Call not being
-- a procedure call.
Error_Msg_N ("first argument of & must be a procedure call", N);
end if;
Analyze (Grid_Dimensions);
if not Is_Acceptable_Dim3 (Grid_Dimensions) then
Error_Msg_N
("second argument of & must be an Integer, Dim3 or aggregate "
& "containing 3 Integers", N);
end if;
Analyze (Block_Dimensions);
if not Is_Acceptable_Dim3 (Block_Dimensions) then
Error_Msg_N
("third argument of & must be an Integer, Dim3 or aggregate "
& "containing 3 Integers", N);
end if;
if Present (Arg4) then
Shared_Memory := Get_Pragma_Arg (Arg4);
Analyze_And_Resolve (Shared_Memory, Any_Integer);
if Present (Arg5) then
Stream := Get_Pragma_Arg (Arg5);
Analyze_And_Resolve (Stream, RTE (RE_Stream_T));
end if;
end if;
end CUDA_Execute;
-----------------
-- CUDA_Global --
-----------------
-- pragma CUDA_Global (IDENTIFIER);
when Pragma_CUDA_Global => CUDA_Global : declare
Arg_Node : Node_Id;
Kernel_Proc : Entity_Id;
Pack_Id : Entity_Id;
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
Arg_Node := Get_Pragma_Arg (Arg1);
Analyze (Arg_Node);
Kernel_Proc := Entity (Arg_Node);
Pack_Id := Scope (Kernel_Proc);
if Ekind (Kernel_Proc) /= E_Procedure then
Error_Msg_NE ("& must be a procedure", N, Kernel_Proc);
elsif Ekind (Pack_Id) /= E_Package
or else not Is_Library_Level_Entity (Pack_Id)
then
Error_Msg_NE
("& must reside in a library-level package", N, Kernel_Proc);
else
Set_Is_CUDA_Kernel (Kernel_Proc);
end if;
end CUDA_Global;
----------------
-- CPP_Vtable --
----------------
@ -30690,6 +30830,8 @@ package body Sem_Prag is
Pragma_C_Pass_By_Copy => 0,
Pragma_Comment => -1,
Pragma_Common_Object => 0,
Pragma_CUDA_Execute => -1,
Pragma_CUDA_Global => -1,
Pragma_Compile_Time_Error => -1,
Pragma_Compile_Time_Warning => -1,
Pragma_Compiler_Unit => -1,

1
gcc/ada/sem_prag.ads
View File

@ -49,6 +49,7 @@ package Sem_Prag is
Pragma_Contract_Cases => True,
Pragma_Convention => True,
Pragma_CPU => True,
Pragma_CUDA_Global => True,
Pragma_Default_Initial_Condition => True,
Pragma_Default_Storage_Pool => True,
Pragma_Depends => True,

4
gcc/ada/snames.ads-tmpl
View File

@ -514,6 +514,8 @@ package Snames is
Name_CPP_Constructor : constant Name_Id := N + $; -- GNAT
Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
Name_CUDA_Execute : constant Name_Id := N + $; -- GNAT
Name_CUDA_Global : constant Name_Id := N + $; -- GNAT
-- Note: CPU is not in this list because its name matches the name of
-- the corresponding attribute. However, it is included in the definition
@ -1998,6 +2000,8 @@ package Snames is
Pragma_CPP_Constructor,
Pragma_CPP_Virtual,
Pragma_CPP_Vtable,
Pragma_CUDA_Execute,
Pragma_CUDA_Global,
Pragma_Deadline_Floor,
Pragma_Debug,
Pragma_Default_Initial_Condition,