| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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 Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Util; use Sem_Util; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo; use Sinfo; |
| |
| 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 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. |
| |
| 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 No (Device_Entities) 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 No (Kernels) 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 => Specification (Kernel_Body), |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Make_Null_Statement (Loc)))); |
| |
| Set_Corresponding_Spec (Null_Body, |
| Corresponding_Spec (Kernel_Body)); |
| |
| 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))); |
| 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; |
| |
| --------------------------------- |
| -- 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 No (Device_Entities) 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 (No (Get_CUDA_Device_Entities (Pack_Id))); |
| 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 (No (Get_CUDA_Kernels (Pack_Id))); |
| CUDA_Kernels_Table.Set (Pack_Id, Kernels); |
| end Set_CUDA_Kernels; |
| |
| end GNAT_CUDA; |
