| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- C U D A -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2010-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- This package defines CUDA-specific datastructures and functions. |
| |
| with Atree; use Atree; |
| with Debug; use Debug; |
| with Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Elists; use Elists; |
| with Errout; use Errout; |
| with Namet; use Namet; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Util; use Sem_Util; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo; use Sinfo; |
| with Snames; use Snames; |
| with Stringt; use Stringt; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| |
| with GNAT.HTable; |
| |
| package body GNAT_CUDA is |
| |
| -------------------------------------- |
| -- Hash Table for CUDA_Global nodes -- |
| -------------------------------------- |
| |
| type Hash_Range is range 0 .. 510; |
| -- Size of hash table headers |
| |
| function Hash (F : Entity_Id) return Hash_Range; |
| -- Hash function for hash table |
| |
| package CUDA_Device_Entities_Table is new |
| GNAT.HTable.Simple_HTable |
| (Header_Num => Hash_Range, |
| Element => Elist_Id, |
| No_Element => No_Elist, |
| Key => Entity_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- The keys of this table are package entities whose bodies contain at |
| -- least one procedure marked with aspect CUDA_Device. The values are |
| -- Elists of the marked entities. |
| |
| package CUDA_Kernels_Table is new |
| GNAT.HTable.Simple_HTable |
| (Header_Num => Hash_Range, |
| Element => Elist_Id, |
| No_Element => No_Elist, |
| Key => Entity_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- The keys of this table are package entities whose bodies contain at |
| -- least one procedure marked with aspect CUDA_Global. The values are |
| -- Elists of the marked procedures. |
| |
| procedure Build_And_Insert_CUDA_Initialization (N : Node_Id); |
| -- Builds declarations necessary for CUDA initialization and inserts them |
| -- in N, the package body that contains CUDA_Global nodes. These |
| -- declarations are: |
| -- |
| -- * A symbol to hold the pointer P to the CUDA fat binary. |
| -- |
| -- * A type definition T for a wrapper that contains the pointer to the |
| -- CUDA fat binary. |
| -- |
| -- * An object of the aforementioned type to hold the aforementioned |
| -- pointer. |
| -- |
| -- * For each CUDA_Global procedure in the package, a declaration of a C |
| -- string containing the function's name. |
| -- |
| -- * A procedure that takes care of calling CUDA functions that register |
| -- CUDA_Global procedures with the runtime. |
| |
| procedure Empty_CUDA_Global_Subprograms (Pack_Id : Entity_Id); |
| -- For all subprograms marked CUDA_Global in Pack_Id, remove declarations |
| -- and replace statements with a single null statement. |
| -- This is required because CUDA_Global subprograms could be referring to |
| -- device-only symbols, which would result in unknown symbols at link time |
| -- if kept around. |
| -- We choose to empty CUDA_Global subprograms rather than completely |
| -- removing them from the package because registering CUDA_Global |
| -- subprograms with the CUDA runtime on the host requires knowing the |
| -- subprogram's host-side address. |
| |
| function Get_CUDA_Device_Entities (Pack_Id : Entity_Id) return Elist_Id; |
| -- Returns an Elist of all entities marked with pragma CUDA_Device that |
| -- are declared within package body Pack_Body. Returns No_Elist if Pack_Id |
| -- does not contain such entities. |
| |
| function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id; |
| -- Returns an Elist of all procedures marked with pragma CUDA_Global that |
| -- are declared within package body Pack_Body. Returns No_Elist if Pack_Id |
| -- does not contain such procedures. |
| |
| procedure Remove_CUDA_Device_Entities (Pack_Id : Entity_Id); |
| -- Removes all entities marked with the CUDA_Device pragma from package |
| -- Pack_Id. Must only be called when compiling for the host. |
| |
| procedure Set_CUDA_Device_Entities |
| (Pack_Id : Entity_Id; |
| E : Elist_Id); |
| -- Stores E as the list of CUDA_Device entities belonging to the package |
| -- entity Pack_Id. Pack_Id must not have a list of device entities. |
| |
| procedure Set_CUDA_Kernels |
| (Pack_Id : Entity_Id; |
| Kernels : Elist_Id); |
| -- Stores Kernels as the list of kernels belonging to the package entity |
| -- Pack_Id. Pack_Id must not have a list of kernels. |
| |
| ---------------------------- |
| -- Add_CUDA_Device_Entity -- |
| ---------------------------- |
| |
| procedure Add_CUDA_Device_Entity |
| (Pack_Id : Entity_Id; |
| E : Entity_Id) |
| is |
| Device_Entities : Elist_Id := Get_CUDA_Device_Entities (Pack_Id); |
| begin |
| if Device_Entities = No_Elist then |
| Device_Entities := New_Elmt_List; |
| Set_CUDA_Device_Entities (Pack_Id, Device_Entities); |
| end if; |
| Append_Elmt (E, Device_Entities); |
| end Add_CUDA_Device_Entity; |
| |
| --------------------- |
| -- Add_CUDA_Kernel -- |
| --------------------- |
| |
| procedure Add_CUDA_Kernel |
| (Pack_Id : Entity_Id; |
| Kernel : Entity_Id) |
| is |
| Kernels : Elist_Id := Get_CUDA_Kernels (Pack_Id); |
| begin |
| if Kernels = No_Elist then |
| Kernels := New_Elmt_List; |
| Set_CUDA_Kernels (Pack_Id, Kernels); |
| end if; |
| Append_Elmt (Kernel, Kernels); |
| end Add_CUDA_Kernel; |
| |
| ----------------------------------- |
| -- Empty_CUDA_Global_Subprograms -- |
| ----------------------------------- |
| |
| procedure Empty_CUDA_Global_Subprograms (Pack_Id : Entity_Id) is |
| Spec_Id : constant Node_Id := Corresponding_Spec (Pack_Id); |
| Kernels : constant Elist_Id := Get_CUDA_Kernels (Spec_Id); |
| Kernel_Elm : Elmt_Id; |
| Kernel : Entity_Id; |
| Kernel_Body : Node_Id; |
| Null_Body : Entity_Id; |
| Loc : Source_Ptr; |
| begin |
| -- It is an error to empty CUDA_Global subprograms when not compiling |
| -- for the host. |
| pragma Assert (Debug_Flag_Underscore_C); |
| |
| if No (Kernels) then |
| return; |
| end if; |
| |
| Kernel_Elm := First_Elmt (Kernels); |
| while Present (Kernel_Elm) loop |
| Kernel := Node (Kernel_Elm); |
| Kernel_Body := Subprogram_Body (Kernel); |
| Loc := Sloc (Kernel_Body); |
| |
| Null_Body := Make_Subprogram_Body (Loc, |
| Specification => Subprogram_Specification (Kernel), |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Make_Null_Statement (Loc)))); |
| |
| Rewrite (Kernel_Body, Null_Body); |
| |
| Next_Elmt (Kernel_Elm); |
| end loop; |
| end Empty_CUDA_Global_Subprograms; |
| |
| ------------------------- |
| -- Expand_CUDA_Package -- |
| ------------------------- |
| |
| procedure Expand_CUDA_Package (N : Node_Id) is |
| begin |
| |
| -- If not compiling for the host, do not do anything. |
| |
| if not Debug_Flag_Underscore_C then |
| return; |
| end if; |
| |
| -- Remove the content (both declarations and statements) of CUDA_Global |
| -- procedures. This is required because CUDA_Global functions could be |
| -- referencing entities available only on the device, which would result |
| -- in unknown symbol errors at link time. |
| |
| Empty_CUDA_Global_Subprograms (N); |
| |
| -- Remove CUDA_Device entities (except if they are also CUDA_Host), as |
| -- they can only be referenced from the device and might reference |
| -- device-only symbols. |
| |
| Remove_CUDA_Device_Entities |
| (Package_Specification (Corresponding_Spec (N))); |
| |
| -- If procedures marked with CUDA_Global have been defined within N, |
| -- we need to register them with the CUDA runtime at program startup. |
| -- This requires multiple declarations and function calls which need |
| -- to be appended to N's declarations. |
| |
| Build_And_Insert_CUDA_Initialization (N); |
| end Expand_CUDA_Package; |
| |
| ---------- |
| -- Hash -- |
| ---------- |
| |
| function Hash (F : Entity_Id) return Hash_Range is |
| begin |
| return Hash_Range (F mod 511); |
| end Hash; |
| |
| ------------------------------ |
| -- Get_CUDA_Device_Entities -- |
| ------------------------------ |
| |
| function Get_CUDA_Device_Entities (Pack_Id : Entity_Id) return Elist_Id is |
| begin |
| return CUDA_Device_Entities_Table.Get (Pack_Id); |
| end Get_CUDA_Device_Entities; |
| |
| ---------------------- |
| -- Get_CUDA_Kernels -- |
| ---------------------- |
| |
| function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id is |
| begin |
| return CUDA_Kernels_Table.Get (Pack_Id); |
| end Get_CUDA_Kernels; |
| |
| ------------------------------------------ |
| -- Build_And_Insert_CUDA_Initialization -- |
| ------------------------------------------ |
| |
| procedure Build_And_Insert_CUDA_Initialization (N : Node_Id) is |
| |
| -- For the following kernel declaration: |
| -- |
| -- package body <Package_Name> is |
| -- procedure <Proc_Name> (X : Integer) with CUDA_Global; |
| -- end package; |
| -- |
| -- Insert the following declarations: |
| -- |
| -- Fat_Binary : System.Address; |
| -- pragma Import |
| -- (Convention => C, |
| -- Entity => Fat_Binary, |
| -- External_Name => "_binary_<Package_Name>_fatbin_start"); |
| -- |
| -- Wrapper : Fatbin_Wrapper := |
| -- (16#466243b1#, 1, Fat_Binary'Address, System.Null_Address); |
| -- |
| -- Proc_Symbol_Name : Interfaces.C.Strings.Chars_Ptr := |
| -- Interfaces.C.Strings.New_Char_Array("<Proc_Name>"); |
| -- |
| -- Fat_Binary_Handle : System.Address := |
| -- CUDA.Internal.Register_Fat_Binary (Wrapper'Address); |
| -- |
| -- procedure Initialize_CUDA_Kernel is |
| -- begin |
| -- CUDA.Internal.Register_Function |
| -- (Fat_Binary_Handle, |
| -- <Proc_Name>'Address, |
| -- Proc_Symbol_Name, |
| -- Proc_Symbol_Name, |
| -- -1, |
| -- System.Null_Address, |
| -- System.Null_Address, |
| -- System.Null_Address, |
| -- System.Null_Address, |
| -- System.Null_Address); |
| -- CUDA.Internal.Register_Fat_Binary_End (Fat_Binary_Handle); |
| -- end Initialize_CUDA_Kernel; |
| -- |
| -- Proc_Symbol_Name is the name of the procedure marked with |
| -- CUDA_Global. The CUDA runtime uses this in order to be able to find |
| -- kernels in the fat binary, so it has to match the name of the |
| -- procedure symbol compiled by GNAT_LLVM. When looking at the code |
| -- generated by NVCC, it seems that the CUDA runtime also needs the name |
| -- of the procedure symbol of the host. Fortuantely, the procedures are |
| -- named the same way whether they are compiled for the host or the |
| -- device, so we use Vector_Add_Name to specify the name of the symbol |
| -- for both the host and the device. The meaning of the rest of the |
| -- arguments is unknown. |
| |
| function Build_CUDA_Init_Proc |
| (Init_Id : Entity_Id; |
| CUDA_Kernels : Elist_Id; |
| Handle_Id : Entity_Id; |
| Pack_Decls : List_Id) return Node_Id; |
| -- Create the declaration of Init_Id, the function that binds each |
| -- kernel present in CUDA_Kernels with the fat binary Handle_Id and then |
| -- tells the CUDA runtime that no new function will be bound to the fat |
| -- binary. |
| |
| function Build_Fat_Binary_Declaration |
| (Bin_Id : Entity_Id) return Node_Id; |
| -- Create a declaration for Bin_Id, the entity that represents the fat |
| -- binary, i.e.: |
| -- |
| -- Bin_Id : System.Address; |
| |
| function Build_Fat_Binary_Handle_Declaration |
| (Handle_Id : Entity_Id; |
| Wrapper_Id : Entity_Id) return Node_Id; |
| -- Create the declaration of Handle_Id, a System.Address that will |
| -- receive the results of passing the address of Wrapper_Id to |
| -- CUDA.Register_Fat_Binary, i.e.: |
| -- |
| -- Handle_Id : System.Address := |
| -- CUDA.Register_Fat_Binary (Wrapper_Id'Address) |
| |
| function Build_Fat_Binary_Wrapper_Declaration |
| (Wrapper_Id : Entity_Id; |
| Bin_Id : Entity_Id) return Node_Id; |
| -- Create the declaration of the fat binary wrapper Wrapper_Id, which |
| -- holds magic numbers and Bin_Id'Address, i.e.: |
| -- |
| -- Wrapper_Id : System.Address := |
| -- (16#466243b1#, 1, Bin_Id'Address, System.Null_Address); |
| |
| function Build_Import_Pragma |
| (Bin_Id : Entity_Id; |
| Pack_Body : Node_Id) return Node_Id; |
| -- Create a pragma that will bind the fat binary Bin_Id to its external |
| -- symbol. N is the package body Bin_Id belongs to, i.e.: |
| -- |
| -- pragma Import |
| -- (Convention => C, |
| -- Entity => Bin_Id, |
| -- External_Name => "_binary_<Pack_Body's name>_fatbin_start"); |
| |
| function Build_Kernel_Name_Declaration |
| (Kernel : Entity_Id) return Node_Id; |
| -- Create the declaration of a C string that contains the name of |
| -- Kernel's symbol, i.e.: |
| -- |
| -- Kernel : Interfaces.C.Strings.Chars_Ptr := |
| -- Interfaces.C.Strings.New_Char_Array("<Kernel's name>"); |
| |
| function Build_Register_Procedure_Call |
| (Loc : Source_Ptr; |
| Bin : Entity_Id; |
| Kernel : Entity_Id; |
| Kernel_Name : Entity_Id) return Node_Id; |
| -- Return a call to CUDA.Internal.Register_Function that binds Kernel |
| -- (the entity of a procedure) to the symbol described by the C string |
| -- Kernel_Name in the fat binary Bin, using Loc as location. |
| |
| -------------------------- |
| -- Build_CUDA_Init_Proc -- |
| -------------------------- |
| |
| function Build_CUDA_Init_Proc |
| (Init_Id : Entity_Id; |
| CUDA_Kernels : Elist_Id; |
| Handle_Id : Entity_Id; |
| Pack_Decls : List_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Init_Id); |
| |
| Stmts : constant List_Id := New_List; |
| -- List of statements that will be used by the cuda initialization |
| -- function. |
| |
| New_Stmt : Node_Id; |
| -- Temporary variable to hold the various newly-created nodes |
| |
| Kernel_Elmt : Elmt_Id; |
| Kernel_Id : Entity_Id; |
| |
| begin |
| -- For each CUDA_Global function, declare a C string that holds |
| -- its symbol's name (i.e. packagename __ functionname). |
| |
| -- Also create a function call to CUDA.Internal.Register_Function |
| -- that takes the declared C string, a pointer to the function and |
| -- the fat binary handle. |
| |
| Kernel_Elmt := First_Elmt (CUDA_Kernels); |
| while Present (Kernel_Elmt) loop |
| Kernel_Id := Node (Kernel_Elmt); |
| |
| New_Stmt := Build_Kernel_Name_Declaration (Kernel_Id); |
| Append (New_Stmt, Pack_Decls); |
| Analyze (New_Stmt); |
| |
| Append_To (Stmts, |
| Build_Register_Procedure_Call (Loc, |
| Bin => Handle_Id, |
| Kernel => Kernel_Id, |
| Kernel_Name => Defining_Entity (New_Stmt))); |
| |
| Next_Elmt (Kernel_Elmt); |
| end loop; |
| |
| -- Finish the CUDA initialization function: add a call to |
| -- register_fat_binary_end, to let the CUDA runtime know that we |
| -- won't be registering any other symbol with the current fat binary. |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Register_Fat_Binary_End), Loc), |
| Parameter_Associations => |
| New_List (New_Occurrence_Of (Handle_Id, Loc)))); |
| |
| -- Now that we have all the declarations and calls we need, we can |
| -- build and and return the initialization procedure. |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, Init_Id), |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
| end Build_CUDA_Init_Proc; |
| |
| ---------------------------------- |
| -- Build_Fat_Binary_Declaration -- |
| ---------------------------------- |
| |
| function Build_Fat_Binary_Declaration |
| (Bin_Id : Entity_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Object_Declaration (Sloc (Bin_Id), |
| Defining_Identifier => Bin_Id, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Address), Sloc (Bin_Id))); |
| end Build_Fat_Binary_Declaration; |
| |
| ----------------------------------------- |
| -- Build_Fat_Binary_Handle_Declaration -- |
| ----------------------------------------- |
| |
| function Build_Fat_Binary_Handle_Declaration |
| (Handle_Id : Entity_Id; |
| Wrapper_Id : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Handle_Id); |
| begin |
| -- Generate: |
| -- Handle_Id : System.Address := |
| -- CUDA.Register_Fat_Binary (Wrapper_Id'Address); |
| |
| return |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Handle_Id, |
| Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Register_Fat_Binary), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Wrapper_Id, Loc), |
| Attribute_Name => Name_Address)))); |
| end Build_Fat_Binary_Handle_Declaration; |
| |
| ------------------------------------------ |
| -- Build_Fat_Binary_Wrapper_Declaration -- |
| ------------------------------------------ |
| |
| function Build_Fat_Binary_Wrapper_Declaration |
| (Wrapper_Id : Entity_Id; |
| Bin_Id : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Wrapper_Id); |
| begin |
| return |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Wrapper_Id, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Fatbin_Wrapper), Loc), |
| Expression => |
| Make_Aggregate (Loc, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, UI_From_Int (16#466243b1#)), |
| Make_Integer_Literal (Loc, Uint_1), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Bin_Id, Loc), |
| Attribute_Name => Name_Address), |
| New_Occurrence_Of (RTE (RE_Null_Address), Loc)))); |
| end Build_Fat_Binary_Wrapper_Declaration; |
| |
| ------------------------- |
| -- Build_Import_Pragma -- |
| ------------------------- |
| |
| function Build_Import_Pragma |
| (Bin_Id : Entity_Id; |
| Pack_Body : Node_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Bin_Id); |
| External_Symbol : String_Id; |
| begin |
| Start_String; |
| Store_String_Chars |
| ("_binary_" |
| & Get_Name_String (Chars (Defining_Unit_Name (Pack_Body))) |
| & "_fatbin_start"); |
| External_Symbol := End_String; |
| |
| return |
| Make_Pragma (Loc, |
| Pragma_Identifier => |
| Make_Identifier (Loc, Name_Import), |
| Pragma_Argument_Associations => New_List ( |
| Make_Pragma_Argument_Association (Loc, |
| Chars => Name_Convention, |
| Expression => Make_Identifier (Loc, Name_C)), |
| Make_Pragma_Argument_Association (Loc, |
| Chars => Name_Entity, |
| Expression => New_Occurrence_Of (Bin_Id, Loc)), |
| Make_Pragma_Argument_Association (Loc, |
| Chars => Name_External_Name, |
| Expression => Make_String_Literal (Loc, External_Symbol)))); |
| end Build_Import_Pragma; |
| |
| ------------------------------------- |
| -- Build_Kernel_Name_Declaration -- |
| ------------------------------------- |
| |
| function Build_Kernel_Name_Declaration |
| (Kernel : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Kernel); |
| |
| Package_Name : constant String := |
| Get_Name_String (Chars (Scope (Kernel))); |
| |
| Symbol_Name : constant String := Get_Name_String (Chars (Kernel)); |
| |
| Kernel_Name : String_Id; |
| begin |
| Start_String; |
| Store_String_Chars (Package_Name & "__" & Symbol_Name); |
| Kernel_Name := End_String; |
| |
| return |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Make_Temporary (Loc, 'C'), |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Chars_Ptr), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_New_Char_Array), Loc), |
| Parameter_Associations => New_List ( |
| Make_String_Literal (Loc, Kernel_Name)))); |
| end Build_Kernel_Name_Declaration; |
| |
| ----------------------------------- |
| -- Build_Register_Procedure_Call -- |
| ----------------------------------- |
| |
| function Build_Register_Procedure_Call |
| (Loc : Source_Ptr; |
| Bin : Entity_Id; |
| Kernel : Entity_Id; |
| Kernel_Name : Entity_Id) return Node_Id |
| is |
| Args : constant List_Id := New_List; |
| begin |
| -- First argument: the handle of the fat binary |
| |
| Append (New_Occurrence_Of (Bin, Loc), Args); |
| |
| -- Second argument: the host address of the function that is marked |
| -- with CUDA_Global. |
| |
| Append_To (Args, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Kernel, Loc), |
| Attribute_Name => Name_Address)); |
| |
| -- Third argument, the name of the function on the host |
| |
| Append (New_Occurrence_Of (Kernel_Name, Loc), Args); |
| |
| -- Fourth argument, the name of the function on the device |
| |
| Append (New_Occurrence_Of (Kernel_Name, Loc), Args); |
| |
| -- Fith argument: -1. Meaning unknown - this has been copied from |
| -- LLVM. |
| |
| Append (Make_Integer_Literal (Loc, Uint_Minus_1), Args); |
| |
| -- Args 6, 7, 8, 9, 10: Null pointers. Again, meaning unknown |
| |
| for Arg_Count in 6 .. 10 loop |
| Append_To (Args, New_Occurrence_Of (RTE (RE_Null_Address), Loc)); |
| end loop; |
| |
| -- Build the call to CUDARegisterFunction, passing the argument list |
| -- we just built. |
| |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Register_Function), Loc), |
| Parameter_Associations => Args); |
| end Build_Register_Procedure_Call; |
| |
| -- Local declarations |
| |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Spec_Id : constant Node_Id := Corresponding_Spec (N); |
| -- The specification of the package we're adding a cuda init func to |
| |
| Pack_Decls : constant List_Id := Declarations (N); |
| |
| CUDA_Node_List : constant Elist_Id := Get_CUDA_Kernels (Spec_Id); |
| -- CUDA nodes that belong to the package |
| |
| CUDA_Init_Func : Entity_Id; |
| -- Entity of the cuda init func |
| |
| Fat_Binary : Entity_Id; |
| -- Entity of the fat binary of N. Bound to said fat binary by a pragma |
| |
| Fat_Binary_Handle : Entity_Id; |
| -- Entity of the result of passing the fat binary wrapper to |
| -- CUDA.Register_Fat_Binary. |
| |
| Fat_Binary_Wrapper : Entity_Id; |
| -- Entity of a record that holds a bunch of magic numbers and a |
| -- reference to Fat_Binary. |
| |
| New_Stmt : Node_Id; |
| -- Node to store newly-created declarations |
| |
| -- Start of processing for Build_And_Insert_CUDA_Initialization |
| |
| begin |
| if CUDA_Node_List = No_Elist then |
| return; |
| end if; |
| |
| Fat_Binary := Make_Temporary (Loc, 'C'); |
| New_Stmt := Build_Fat_Binary_Declaration (Fat_Binary); |
| Append_To (Pack_Decls, New_Stmt); |
| Analyze (New_Stmt); |
| |
| New_Stmt := Build_Import_Pragma (Fat_Binary, N); |
| Append_To (Pack_Decls, New_Stmt); |
| Analyze (New_Stmt); |
| |
| Fat_Binary_Wrapper := Make_Temporary (Loc, 'C'); |
| New_Stmt := |
| Build_Fat_Binary_Wrapper_Declaration |
| (Wrapper_Id => Fat_Binary_Wrapper, |
| Bin_Id => Fat_Binary); |
| Append_To (Pack_Decls, New_Stmt); |
| Analyze (New_Stmt); |
| |
| Fat_Binary_Handle := Make_Temporary (Loc, 'C'); |
| New_Stmt := |
| Build_Fat_Binary_Handle_Declaration |
| (Fat_Binary_Handle, Fat_Binary_Wrapper); |
| Append_To (Pack_Decls, New_Stmt); |
| Analyze (New_Stmt); |
| |
| CUDA_Init_Func := Make_Temporary (Loc, 'C'); |
| New_Stmt := |
| Build_CUDA_Init_Proc |
| (Init_Id => CUDA_Init_Func, |
| CUDA_Kernels => CUDA_Node_List, |
| Handle_Id => Fat_Binary_Handle, |
| Pack_Decls => Pack_Decls); |
| Append_To (Pack_Decls, New_Stmt); |
| Analyze (New_Stmt); |
| |
| New_Stmt := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (CUDA_Init_Func, Loc)); |
| Append_To (Pack_Decls, New_Stmt); |
| Analyze (New_Stmt); |
| end Build_And_Insert_CUDA_Initialization; |
| |
| --------------------------------- |
| -- Remove_CUDA_Device_Entities -- |
| --------------------------------- |
| |
| procedure Remove_CUDA_Device_Entities (Pack_Id : Entity_Id) is |
| Device_Entities : constant Elist_Id := |
| Get_CUDA_Device_Entities (Pack_Id); |
| Device_Elmt : Elmt_Id; |
| Device_Entity : Entity_Id; |
| Bod : Node_Id; |
| begin |
| pragma Assert (Debug_Flag_Underscore_C); |
| |
| if Device_Entities = No_Elist then |
| return; |
| end if; |
| |
| Device_Elmt := First_Elmt (Device_Entities); |
| while Present (Device_Elmt) loop |
| Device_Entity := Node (Device_Elmt); |
| Next_Elmt (Device_Elmt); |
| |
| case Ekind (Device_Entity) is |
| when E_Function | E_Procedure => |
| Bod := Subprogram_Body (Device_Entity); |
| |
| if Nkind (Parent (Bod)) = N_Subunit |
| and then Present (Corresponding_Stub (Parent (Bod))) |
| then |
| Error_Msg_N |
| ("Cuda_Device not suported on separate subprograms", |
| Corresponding_Stub (Parent (Bod))); |
| else |
| Remove (Bod); |
| Remove (Subprogram_Spec (Device_Entity)); |
| end if; |
| |
| when E_Variable | E_Constant => |
| Remove (Declaration_Node (Device_Entity)); |
| |
| when others => |
| pragma Assert (False); |
| end case; |
| |
| Remove_Entity_And_Homonym (Device_Entity); |
| end loop; |
| end Remove_CUDA_Device_Entities; |
| |
| ------------------------------ |
| -- Set_CUDA_Device_Entities -- |
| ------------------------------ |
| |
| procedure Set_CUDA_Device_Entities |
| (Pack_Id : Entity_Id; |
| E : Elist_Id) |
| is |
| begin |
| pragma Assert (Get_CUDA_Device_Entities (Pack_Id) = No_Elist); |
| CUDA_Device_Entities_Table.Set (Pack_Id, E); |
| end Set_CUDA_Device_Entities; |
| |
| ---------------------- |
| -- Set_CUDA_Kernels -- |
| ---------------------- |
| |
| procedure Set_CUDA_Kernels |
| (Pack_Id : Entity_Id; |
| Kernels : Elist_Id) |
| is |
| begin |
| pragma Assert (Get_CUDA_Kernels (Pack_Id) = No_Elist); |
| CUDA_Kernels_Table.Set (Pack_Id, Kernels); |
| end Set_CUDA_Kernels; |
| |
| end GNAT_CUDA; |
