From 524301457dd42c12bb76dc4ff47d8e270e39ef65 Mon Sep 17 00:00:00 2001 From: Ghjuvan Lacambre Date: Wed, 24 Jun 2020 17:12:19 +0200 Subject: [PATCH] [Ada] Implement expansion of CUDA_Execute pragma gcc/ada/ * elists.ads (New_Elmt_List): New functions. * elists.adb (New_Elmt_List): New functions. * exp_prag.adb: Add dependency on Elists. (Expand_Pragma_CUDA_Execute): New function. (Expand_N_Pragma): Add call to Expand_Pragma_CUDA_Execute. * rtsfind.ads: Add CUDA.Internal, CUDA.Runtime, System.C packages and RE_Push_Call_Configuration, RE_Pop_Call_Configuration, RE_Launch_Kernel, RO_IC_Unsigned, RO_IC_Unsigned_Long_Long entities. * rtsfind.adb: Extend Interfaces_Descendant to include Interfaces_C. --- gcc/ada/elists.adb | 58 ++++++ gcc/ada/elists.ads | 15 ++ gcc/ada/exp_prag.adb | 473 +++++++++++++++++++++++++++++++++++++++++++ gcc/ada/rtsfind.adb | 2 +- gcc/ada/rtsfind.ads | 21 +- 5 files changed, 567 insertions(+), 2 deletions(-) diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index 90bcd2ee225..44998bcd28b 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.adb @@ -373,6 +373,64 @@ package body Elists is return Elists.Last; end New_Elmt_List; + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List (Elmt1 : Node_Or_Entity_Id) + return Elist_Id + is + L : constant Elist_Id := New_Elmt_List; + begin + Append_Elmt (Elmt1, L); + return L; + end New_Elmt_List; + + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id) return Elist_Id + is + L : constant Elist_Id := New_Elmt_List (Elmt1); + begin + Append_Elmt (Elmt2, L); + return L; + end New_Elmt_List; + + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id; + Elmt3 : Node_Or_Entity_Id) return Elist_Id + is + L : constant Elist_Id := New_Elmt_List (Elmt1, Elmt2); + begin + Append_Elmt (Elmt3, L); + return L; + end New_Elmt_List; + + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id; + Elmt3 : Node_Or_Entity_Id; + Elmt4 : Node_Or_Entity_Id) return Elist_Id + is + L : constant Elist_Id := New_Elmt_List (Elmt1, Elmt2, Elmt3); + begin + Append_Elmt (Elmt4, L); + return L; + end New_Elmt_List; + --------------- -- Next_Elmt -- --------------- diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads index 12672a69385..825b87f5bcd 100644 --- a/gcc/ada/elists.ads +++ b/gcc/ada/elists.ads @@ -90,6 +90,21 @@ package Elists is -- a field in some other node which points to an element list where the -- list is then subsequently filled in using Append calls. + function New_Elmt_List (Elmt1 : Node_Or_Entity_Id) return Elist_Id; + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id) return Elist_Id; + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id; + Elmt3 : Node_Or_Entity_Id) return Elist_Id; + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id; + Elmt3 : Node_Or_Entity_Id; + Elmt4 : Node_Or_Entity_Id) return Elist_Id; + -- Create a new element list containing the given arguments. + function First_Elmt (List : Elist_Id) return Elmt_Id; pragma Inline (First_Elmt); -- Obtains the first element of the given element list or, if the list has diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index e978595d403..b0ee2337ef8 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -28,6 +28,7 @@ with Casing; use Casing; with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; @@ -67,6 +68,7 @@ package body Exp_Prag is procedure Expand_Pragma_Abort_Defer (N : Node_Id); procedure Expand_Pragma_Check (N : Node_Id); procedure Expand_Pragma_Common_Object (N : Node_Id); + procedure Expand_Pragma_CUDA_Execute (N : Node_Id); procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); @@ -156,6 +158,9 @@ package body Exp_Prag is when Pragma_Common_Object => Expand_Pragma_Common_Object (N); + when Pragma_CUDA_Execute => + Expand_Pragma_CUDA_Execute (N); + when Pragma_Import => Expand_Pragma_Import_Or_Interface (N); @@ -614,6 +619,474 @@ package body Exp_Prag is Expression => New_Copy_Tree (Psect))))); end Expand_Pragma_Common_Object; + -------------------------------- + -- Expand_Pragma_CUDA_Execute -- + -------------------------------- + + -- Pragma CUDA_Execute is expanded in the following manner: + + -- Original Code + + -- pragma CUDA_Execute (My_Proc (X, Y), Blocks, Grids, Mem, Stream) + + -- Expanded Code + + -- declare + -- Blocks_Id : CUDA.Vector_Types.Dim3 := Blocks; + -- Grids_Id : CUDA.Vector_Types.Dim3 := Grids; + -- Mem_Id : Integer := ; + -- Stream_Id : CUDA.Driver_Types.Stream_T := ; + -- X_Id : := X; + -- Y_Id : := Y; + -- Arg_Id : Array (1..2) of System.Address := + -- (X'Address,_Id Y'Address);_Id + -- begin + -- CUDA.Internal.Push_Call_Configuration ( + -- Grids_Id, + -- Blocks_Id, + -- Mem_Id, + -- Stream_Id); + -- CUDA.Internal.Pop_Call_Configuration ( + -- Grids_Id'address, + -- Blocks_Id'address, + -- Mem_Id'address, + -- Stream_Id'address), + -- CUDA.Runtime_Api.Launch_Kernel ( + -- My_Proc'Address, + -- Blocks_Id, + -- Grids_Id, + -- Arg_Id'Address, + -- Mem_Id, + -- Stream_Id); + -- end; + + procedure Expand_Pragma_CUDA_Execute (N : Node_Id) is + + Loc : constant Source_Ptr := Sloc (N); + + procedure Append_Copies + (Params : List_Id; + Decls : List_Id; + Copies : Elist_Id); + -- For each parameter in list Params, create an object declaration of + -- the followinng form: + -- + -- Copy_Id : Param_Typ := Param_Val; + -- + -- Param_Typ is the type of the parameter. Param_Val is the initial + -- value of the parameter. The declarations are stored in Decls, the + -- entities of the new objects are collected in list Copies. + + function Build_Dim3_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id; + -- Build an object declaration of the form + -- + -- Decl_Id : CUDA.Vectory_Types.Dim3 := Val; + -- + -- Val depends on the nature of Init_Val, as follows: + -- + -- * If Init_Val is already of type CUDA.Vector_Types.Dim3, then + -- Init_Val is used. + -- + -- * If Init_Val is a single Integer, Val has the following form: + -- + -- (Interfaces.C.Unsigned (Init_Val), + -- Interfaces.C.Unsigned (1), + -- Interfaces.C.Unsigned (1)) + -- + -- * If Init_Val is an aggregate of three values, Val has the + -- following form: + -- + -- (Interfaces.C.Unsigned (Val_1), + -- Interfaces.C.Unsigned (Val_2), + -- Interfaces.C.Unsigned (Val_3)) + + function Build_Kernel_Args_Declaration + (Kernel_Arg : Entity_Id; + Var_Ids : Elist_Id) return Node_Id; + -- Given a list of variables, return an object declaration of the + -- following form: + -- + -- Kernel_Arg : ... := (Var_1'Address, ..., Var_N'Address); + + function Build_Launch_Kernel_Call + (Proc : Entity_Id; + Grid_Dims : Entity_Id; + Block_Dims : Entity_Id; + Kernel_Arg : Entity_Id; + Memory : Entity_Id; + Stream : Entity_Id) return Node_Id; + -- Builds and returns a call to CUDA.Launch_Kernel using the given + -- arguments. Proc is the entity of the procedure passed to the + -- CUDA_Execute pragma. Grid_Dims and Block_Dims are entities of the + -- generated declarations that hold the kernel's dimensions. Args is the + -- entity of the temporary array that holds the arguments of the kernel. + -- Memory and Stream are the entities of the temporaries that hold the + -- fourth and fith arguments of CUDA_Execute or their default values. + + function Build_Shared_Memory_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id; + -- Builds a declaration the Defining_Identifier of which is Decl_Id, the + -- type of which is CUDA.Driver_Types.Stream_T and the value of which is + -- Init_Val if present or null if not. + + function Build_Simple_Declaration_With_Default + (Decl_Id : Entity_Id; + Init_Val : Entity_Id; + Typ : Entity_Id; + Default_Val : Entity_Id) return Node_Id; + -- Build a declaration the Defining_Identifier of which is Decl_Id, the + -- Object_Definition of which is Typ, the value of which is Init_Val if + -- present or Default otherwise. + + function Build_Stream_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id; + -- Build a declaration the Defining_Identifier of which is Decl_Id, the + -- type of which is Integer, the value of which is Init_Val if present + -- and 0 otherwise. + + function To_Addresses (Elmts : Elist_Id) return List_Id; + -- Returns a new list containing each element of Elmts wrapped in an + -- 'address attribute reference. When passed No_Elist, returns an empty + -- list. + + ------------------- + -- Append_Copies -- + ------------------- + + procedure Append_Copies + (Params : List_Id; + Decls : List_Id; + Copies : Elist_Id) + is + Copy : Entity_Id; + Param : Node_Id; + begin + Param := First (Params); + while Present (Param) loop + Copy := Make_Temporary (Loc, 'C'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Copy, + Object_Definition => New_Occurrence_Of (Etype (Param), Loc), + Expression => New_Copy_Tree (Param))); + + Append_Elmt (Copy, Copies); + Next (Param); + end loop; + end Append_Copies; + + ---------------------------- + -- Build_Dim3_Declaration -- + ---------------------------- + + function Build_Dim3_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id + is + Grid_Dim_X : Node_Id; + Grid_Dim_Y : Node_Id; + Grid_Dim_Z : Node_Id; + Init_Value : Node_Id; + begin + if Etype (Init_Val) = RTE (RE_Dim3) then + Init_Value := Init_Val; + else + -- If Init_Val is an aggregate, use each of its arguments + + if Nkind (Init_Val) = N_Aggregate then + Grid_Dim_X := First (Expressions (Init_Val)); + Grid_Dim_Y := Next (Grid_Dim_X); + Grid_Dim_Z := Next (Grid_Dim_Y); + + -- Otherwise, we know it is an integer and the rest defaults to 1. + + else + Grid_Dim_X := Init_Val; + Grid_Dim_Y := Make_Integer_Literal (Loc, 1); + Grid_Dim_Z := Make_Integer_Literal (Loc, 1); + end if; + + -- Then cast every value to Interfaces.C.Unsigned and build an + -- aggregate we can use to initialize the Dim3. + + Init_Value := + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RO_IC_Unsigned), Loc), + Expression => New_Copy_Tree (Grid_Dim_X)), + + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RO_IC_Unsigned), Loc), + Expression => New_Copy_Tree (Grid_Dim_Y)), + + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RO_IC_Unsigned), Loc), + Expression => New_Copy_Tree (Grid_Dim_Z)))); + end if; + + -- Finally return the declaration + + return Make_Object_Declaration (Loc, + Defining_Identifier => Decl_Id, + Object_Definition => New_Occurrence_Of (RTE (RE_Dim3), Loc), + Expression => Init_Value); + end Build_Dim3_Declaration; + + ----------------------------------- + -- Build_Kernel_Args_Declaration -- + ----------------------------------- + + function Build_Kernel_Args_Declaration + (Kernel_Arg : Entity_Id; + Var_Ids : Elist_Id) return Node_Id + is + Vals : constant List_Id := To_Addresses (Var_Ids); + begin + return + Make_Object_Declaration (Loc, + Defining_Identifier => Kernel_Arg, + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Integer_Literal (Loc, List_Length (Vals)))), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Etype (RTE (RE_Address)), Loc))), + Expression => Make_Aggregate (Loc, Vals)); + end Build_Kernel_Args_Declaration; + + ------------------------------- + -- Build_Launch_Kernel_Call -- + ------------------------------- + + function Build_Launch_Kernel_Call + (Proc : Entity_Id; + Grid_Dims : Entity_Id; + Block_Dims : Entity_Id; + Kernel_Arg : Entity_Id; + Memory : Entity_Id; + Stream : Entity_Id) return Node_Id is + begin + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Launch_Kernel), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Proc, Loc), + Attribute_Name => Name_Address), + New_Occurrence_Of (Grid_Dims, Loc), + New_Occurrence_Of (Block_Dims, Loc), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Kernel_Arg, Loc), + Attribute_Name => Name_Address), + New_Occurrence_Of (Memory, Loc), + New_Occurrence_Of (Stream, Loc))); + end Build_Launch_Kernel_Call; + + ------------------------------------- + -- Build_Shared_Memory_Declaration -- + ------------------------------------- + + function Build_Shared_Memory_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id + is + begin + return Build_Simple_Declaration_With_Default + (Decl_Id => Decl_Id, + Init_Val => Init_Val, + Typ => + New_Occurrence_Of (RTE (RO_IC_Unsigned_Long_Long), Loc), + Default_Val => Make_Integer_Literal (Loc, 0)); + end Build_Shared_Memory_Declaration; + + ------------------------------------------- + -- Build_Simple_Declaration_With_Default -- + ------------------------------------------- + + function Build_Simple_Declaration_With_Default + (Decl_Id : Entity_Id; + Init_Val : Node_Id; + Typ : Entity_Id; + Default_Val : Node_Id) return Node_Id + is + Value : Node_Id := Init_Val; + begin + if No (Value) then + Value := Default_Val; + end if; + + return Make_Object_Declaration (Loc, + Defining_Identifier => Decl_Id, + Object_Definition => Typ, + Expression => Value); + end Build_Simple_Declaration_With_Default; + + ------------------------------ + -- Build_Stream_Declaration -- + ------------------------------ + + function Build_Stream_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id + is + begin + return Build_Simple_Declaration_With_Default + (Decl_Id => Decl_Id, + Init_Val => Init_Val, + Typ => New_Occurrence_Of (RTE (RE_Stream_T), Loc), + Default_Val => Make_Null (Loc)); + end Build_Stream_Declaration; + + ------------------ + -- To_Addresses -- + ------------------ + + function To_Addresses (Elmts : Elist_Id) return List_Id is + Result : constant List_Id := New_List; + Elmt : Elmt_Id; + begin + if Elmts = No_Elist then + return Result; + end if; + + Elmt := First_Elmt (Elmts); + while Present (Elmt) loop + Append_To (Result, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Node (Elmt), Loc), + Attribute_Name => Name_Address)); + Next_Elmt (Elmt); + end loop; + + return Result; + end To_Addresses; + + -- Local variables + + -- Pragma arguments + + Procedure_Call : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 1)); + Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 2)); + Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 3)); + Shared_Memory : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 4)); + CUDA_Stream : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 5)); + + -- Entities of objects that capture the value of pragma arguments + + Grids_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); + Blocks_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); + Memory_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); + Stream_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); + + -- List holding the entities of the copies of Procedure_Call's + -- arguments. + + Kernel_Arg_Copies : constant Elist_Id := New_Elmt_List; + + -- Entity of the array that contains the address of each of the kernel's + -- arguments. + + Kernel_Args_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); + + -- Calls to the CUDA runtime API. + + Launch_Kernel_Call : Node_Id; + Pop_Call : Node_Id; + Push_Call : Node_Id; + + -- Declaration of all temporaries required for CUDA API Calls. + + Blk_Decls : constant List_Id := New_List; + + -- Start of processing for CUDA_Execute + + begin + -- Build parameter declarations for CUDA API calls + + Append_To + (Blk_Decls, Build_Dim3_Declaration (Grids_Id, Grid_Dimensions)); + + Append_To + (Blk_Decls, + Build_Dim3_Declaration (Blocks_Id, Block_Dimensions)); + + Append_To + (Blk_Decls, + Build_Shared_Memory_Declaration (Memory_Id, Shared_Memory)); + + Append_To + (Blk_Decls, Build_Stream_Declaration (Stream_Id, CUDA_Stream)); + + Append_Copies + (Parameter_Associations (Procedure_Call), + Blk_Decls, + Kernel_Arg_Copies); + + Append_To + (Blk_Decls, + Build_Kernel_Args_Declaration + (Kernel_Args_Id, Kernel_Arg_Copies)); + + -- Build calls to the CUDA API + + Push_Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Push_Call_Configuration), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Grids_Id, Loc), + New_Occurrence_Of (Blocks_Id, Loc), + New_Occurrence_Of (Memory_Id, Loc), + New_Occurrence_Of (Stream_Id, Loc))); + + Pop_Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Pop_Call_Configuration), Loc), + Parameter_Associations => To_Addresses + (New_Elmt_List + (Grids_Id, + Blocks_Id, + Memory_Id, + Stream_Id))); + + Launch_Kernel_Call := Build_Launch_Kernel_Call + (Proc => Entity (Name (Procedure_Call)), + Grid_Dims => Grids_Id, + Block_Dims => Blocks_Id, + Kernel_Arg => Kernel_Args_Id, + Memory => Memory_Id, + Stream => Stream_Id); + + -- Finally make the block that holds declarations and calls + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => Blk_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Push_Call, + Pop_Call, + Launch_Kernel_Call)))); + Analyze (N); + end Expand_Pragma_CUDA_Execute; + ---------------------------------- -- Expand_Pragma_Contract_Cases -- ---------------------------------- diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 76893753df0..83220ef0cbb 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -589,7 +589,7 @@ package body Rtsfind is range CUDA_Driver_Types .. CUDA_Vector_Types; subtype Interfaces_Descendant is RTU_Id - range Interfaces_Packed_Decimal .. Interfaces_Packed_Decimal; + range Interfaces_C .. Interfaces_Packed_Decimal; subtype System_Descendant is RTU_Id range System_Address_Image .. System_Tasking_Stages; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index ff9eb0aa83b..ed6b671ef80 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -159,13 +159,15 @@ package Rtsfind is Ada_Wide_Wide_Text_IO_Integer_IO, Ada_Wide_Wide_Text_IO_Modular_IO, - -- CUDA + -- Package CUDA CUDA, -- Children of CUDA CUDA_Driver_Types, + CUDA_Internal, + CUDA_Runtime_Api, CUDA_Vector_Types, -- Interfaces @@ -174,6 +176,7 @@ package Rtsfind is -- Children of Interfaces + Interfaces_C, Interfaces_Packed_Decimal, -- Package System @@ -625,6 +628,11 @@ package Rtsfind is RE_Stream_T, -- CUDA.Driver_Types + RE_Push_Call_Configuration, -- CUDA.Internal + RE_Pop_Call_Configuration, -- CUDA.Internal + + RE_Launch_Kernel, -- CUDA.Runtime_Api + RE_Dim3, -- CUDA.Vector_Types RE_Integer_8, -- Interfaces @@ -636,6 +644,9 @@ package Rtsfind is RE_Unsigned_32, -- Interfaces RE_Unsigned_64, -- Interfaces + RO_IC_Unsigned, -- Interfaces.C + RO_IC_Unsigned_Long_Long, -- Interfaces.C + RE_Address, -- System RE_Any_Priority, -- System RE_Bit_Order, -- System @@ -1916,6 +1927,11 @@ package Rtsfind is RE_Stream_T => CUDA_Driver_Types, + RE_Push_Call_Configuration => CUDA_Internal, + RE_Pop_Call_Configuration => CUDA_Internal, + + RE_Launch_Kernel => CUDA_Runtime_Api, + RE_Dim3 => CUDA_Vector_Types, RE_Integer_8 => Interfaces, @@ -1927,6 +1943,9 @@ package Rtsfind is RE_Unsigned_32 => Interfaces, RE_Unsigned_64 => Interfaces, + RO_IC_Unsigned => Interfaces_C, + RO_IC_Unsigned_Long_Long => Interfaces_C, + RE_Address => System, RE_Any_Priority => System, RE_Bit_Order => System, -- 2.30.2