@@ -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,
@@ -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));
@@ -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);
@@ -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
@@ -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) := '.';
@@ -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,
@@ -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,
@@ -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,
@@ -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,
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. Tested on x86_64-pc-linux-gnu, committed on master