From: Arnaud Charlet Date: Thu, 23 Jul 2020 13:54:45 +0000 (-0400) Subject: [Ada] Stub CUDA_Execute and CUDA_Global pragmas X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ad1bea3a4b30482686be9245af78f994722f2fec;p=gcc.git [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. --- diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 4e517d1fb5b..03941065b80 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -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, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index eab06eefe49..6cdea4801a6 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 758aef56576..7932c9270b4 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 1f25ec8fbf0..259d15fb0cb 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -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 diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 7e617b6a705..5cf3b91ecb9 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -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) := '.'; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 6a1738b635c..ff9eb0aa83b 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -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, diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index eb8f2a0494f..f7019caebea 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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, diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index bdc449502c7..460fc9ce477 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -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, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index c4486ff3a71..6310442f9e8 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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,