gcc/ada/gnat_cuda.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                 C U D A                                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2010-2023, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  This package defines CUDA-specific datastructures and functions.
  27
  28 with Atree;          use Atree;
  29 with Debug;          use Debug;
  30 with Einfo.Entities; use Einfo.Entities;
  31 with Einfo.Utils;    use Einfo.Utils;
  32 with Elists;         use Elists;
  33 with Errout;         use Errout;
  34 with Nlists;         use Nlists;
  35 with Nmake;          use Nmake;
  36 with Sem_Aux;        use Sem_Aux;
  37 with Sem_Util;       use Sem_Util;
  38 with Sinfo.Nodes;    use Sinfo.Nodes;
  39 with Sinfo;          use Sinfo;
  40
  41 with GNAT.HTable;
  42
  43 package body GNAT_CUDA is
  44
  45    --------------------------------------
  46    -- Hash Table for CUDA_Global nodes --
  47    --------------------------------------
  48
  49    type Hash_Range is range 0 .. 510;
  50    --  Size of hash table headers
  51
  52    function Hash (F : Entity_Id) return Hash_Range;
  53    --  Hash function for hash table
  54
  55    package CUDA_Device_Entities_Table is new
  56      GNAT.HTable.Simple_HTable
  57        (Header_Num => Hash_Range,
  58         Element    => Elist_Id,
  59         No_Element => No_Elist,
  60         Key        => Entity_Id,
  61         Hash       => Hash,
  62         Equal      => "=");
  63    --  The keys of this table are package entities whose bodies contain at
  64    --  least one procedure marked with aspect CUDA_Device. The values are
  65    --  Elists of the marked entities.
  66
  67    package CUDA_Kernels_Table is new
  68      GNAT.HTable.Simple_HTable
  69        (Header_Num => Hash_Range,
  70         Element    => Elist_Id,
  71         No_Element => No_Elist,
  72         Key        => Entity_Id,
  73         Hash       => Hash,
  74         Equal      => "=");
  75    --  The keys of this table are package entities whose bodies contain at
  76    --  least one procedure marked with aspect CUDA_Global. The values are
  77    --  Elists of the marked procedures.
  78
  79    procedure Empty_CUDA_Global_Subprograms (Pack_Id : Entity_Id);
  80    --  For all subprograms marked CUDA_Global in Pack_Id, remove declarations
  81    --  and replace statements with a single null statement.
  82    --  This is required because CUDA_Global subprograms could be referring to
  83    --  device-only symbols, which would result in unknown symbols at link time
  84    --  if kept around.
  85    --  We choose to empty CUDA_Global subprograms rather than completely
  86    --  removing them from the package because registering CUDA_Global
  87    --  subprograms with the CUDA runtime on the host requires knowing the
  88    --  subprogram's host-side address.
  89
  90    function Get_CUDA_Device_Entities (Pack_Id : Entity_Id) return Elist_Id;
  91    --  Returns an Elist of all entities marked with pragma CUDA_Device that
  92    --  are declared within package body Pack_Body. Returns No_Elist if Pack_Id
  93    --  does not contain such entities.
  94
  95    procedure Remove_CUDA_Device_Entities (Pack_Id : Entity_Id);
  96    --  Removes all entities marked with the CUDA_Device pragma from package
  97    --  Pack_Id. Must only be called when compiling for the host.
  98
  99    procedure Set_CUDA_Device_Entities
 100      (Pack_Id : Entity_Id;
 101       E       : Elist_Id);
 102    --  Stores E as the list of CUDA_Device entities belonging to the package
 103    --  entity Pack_Id. Pack_Id must not have a list of device entities.
 104
 105    procedure Set_CUDA_Kernels
 106      (Pack_Id : Entity_Id;
 107       Kernels : Elist_Id);
 108    --  Stores Kernels as the list of kernels belonging to the package entity
 109    --  Pack_Id. Pack_Id must not have a list of kernels.
 110
 111    ----------------------------
 112    -- Add_CUDA_Device_Entity --
 113    ----------------------------
 114
 115    procedure Add_CUDA_Device_Entity
 116      (Pack_Id : Entity_Id;
 117       E       : Entity_Id)
 118    is
 119       Device_Entities : Elist_Id := Get_CUDA_Device_Entities (Pack_Id);
 120    begin
 121       if No (Device_Entities) then
 122          Device_Entities := New_Elmt_List;
 123          Set_CUDA_Device_Entities (Pack_Id, Device_Entities);
 124       end if;
 125       Append_Elmt (E, Device_Entities);
 126    end Add_CUDA_Device_Entity;
 127
 128    ---------------------
 129    -- Add_CUDA_Kernel --
 130    ---------------------
 131
 132    procedure Add_CUDA_Kernel
 133      (Pack_Id : Entity_Id;
 134       Kernel  : Entity_Id)
 135    is
 136       Kernels : Elist_Id := Get_CUDA_Kernels (Pack_Id);
 137    begin
 138       if No (Kernels) then
 139          Kernels := New_Elmt_List;
 140          Set_CUDA_Kernels (Pack_Id, Kernels);
 141       end if;
 142       Append_Elmt (Kernel, Kernels);
 143    end Add_CUDA_Kernel;
 144
 145    -----------------------------------
 146    -- Empty_CUDA_Global_Subprograms --
 147    -----------------------------------
 148
 149    procedure Empty_CUDA_Global_Subprograms (Pack_Id : Entity_Id) is
 150       Spec_Id     : constant Node_Id := Corresponding_Spec (Pack_Id);
 151       Kernels     : constant Elist_Id := Get_CUDA_Kernels (Spec_Id);
 152       Kernel_Elm  : Elmt_Id;
 153       Kernel      : Entity_Id;
 154       Kernel_Body : Node_Id;
 155       Null_Body   : Entity_Id;
 156       Loc         : Source_Ptr;
 157    begin
 158       --  It is an error to empty CUDA_Global subprograms when not compiling
 159       --  for the host.
 160       pragma Assert (Debug_Flag_Underscore_C);
 161
 162       if No (Kernels) then
 163          return;
 164       end if;
 165
 166       Kernel_Elm := First_Elmt (Kernels);
 167       while Present (Kernel_Elm) loop
 168          Kernel      := Node (Kernel_Elm);
 169          Kernel_Body := Subprogram_Body (Kernel);
 170          Loc         := Sloc (Kernel_Body);
 171
 172          Null_Body := Make_Subprogram_Body (Loc,
 173            Specification              => Specification (Kernel_Body),
 174            Declarations               => New_List,
 175            Handled_Statement_Sequence =>
 176              Make_Handled_Sequence_Of_Statements (Loc,
 177                Statements => New_List (Make_Null_Statement (Loc))));
 178
 179          Set_Corresponding_Spec (Null_Body,
 180            Corresponding_Spec (Kernel_Body));
 181
 182          Rewrite (Kernel_Body, Null_Body);
 183
 184          Next_Elmt (Kernel_Elm);
 185       end loop;
 186    end Empty_CUDA_Global_Subprograms;
 187
 188    -------------------------
 189    -- Expand_CUDA_Package --
 190    -------------------------
 191
 192    procedure Expand_CUDA_Package (N : Node_Id) is
 193    begin
 194
 195       --  If not compiling for the host, do not do anything.
 196
 197       if not Debug_Flag_Underscore_C then
 198          return;
 199       end if;
 200
 201       --  Remove the content (both declarations and statements) of CUDA_Global
 202       --  procedures. This is required because CUDA_Global functions could be
 203       --  referencing entities available only on the device, which would result
 204       --  in unknown symbol errors at link time.
 205
 206       Empty_CUDA_Global_Subprograms (N);
 207
 208       --  Remove CUDA_Device entities (except if they are also CUDA_Host), as
 209       --  they can only be referenced from the device and might reference
 210       --  device-only symbols.
 211
 212       Remove_CUDA_Device_Entities
 213         (Package_Specification (Corresponding_Spec (N)));
 214    end Expand_CUDA_Package;
 215
 216    ----------
 217    -- Hash --
 218    ----------
 219
 220    function Hash (F : Entity_Id) return Hash_Range is
 221    begin
 222       return Hash_Range (F mod 511);
 223    end Hash;
 224
 225    ------------------------------
 226    -- Get_CUDA_Device_Entities --
 227    ------------------------------
 228
 229    function Get_CUDA_Device_Entities (Pack_Id : Entity_Id) return Elist_Id is
 230    begin
 231       return CUDA_Device_Entities_Table.Get (Pack_Id);
 232    end Get_CUDA_Device_Entities;
 233
 234    ----------------------
 235    -- Get_CUDA_Kernels --
 236    ----------------------
 237
 238    function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id is
 239    begin
 240       return CUDA_Kernels_Table.Get (Pack_Id);
 241    end Get_CUDA_Kernels;
 242
 243    ---------------------------------
 244    -- Remove_CUDA_Device_Entities --
 245    ---------------------------------
 246
 247    procedure Remove_CUDA_Device_Entities (Pack_Id : Entity_Id) is
 248       Device_Entities : constant Elist_Id :=
 249         Get_CUDA_Device_Entities (Pack_Id);
 250       Device_Elmt     : Elmt_Id;
 251       Device_Entity   : Entity_Id;
 252       Bod             : Node_Id;
 253    begin
 254       pragma Assert (Debug_Flag_Underscore_C);
 255
 256       if No (Device_Entities) then
 257          return;
 258       end if;
 259
 260       Device_Elmt := First_Elmt (Device_Entities);
 261       while Present (Device_Elmt) loop
 262          Device_Entity := Node (Device_Elmt);
 263          Next_Elmt (Device_Elmt);
 264
 265          case Ekind (Device_Entity) is
 266             when E_Function | E_Procedure =>
 267                Bod := Subprogram_Body (Device_Entity);
 268
 269                if Nkind (Parent (Bod)) = N_Subunit
 270                  and then Present (Corresponding_Stub (Parent (Bod)))
 271                then
 272                   Error_Msg_N
 273                     ("Cuda_Device not suported on separate subprograms",
 274                      Corresponding_Stub (Parent (Bod)));
 275                else
 276                   Remove (Bod);
 277                   Remove (Subprogram_Spec (Device_Entity));
 278                end if;
 279
 280             when E_Variable | E_Constant =>
 281                Remove (Declaration_Node (Device_Entity));
 282
 283             when others =>
 284                pragma Assert (False);
 285          end case;
 286
 287          Remove_Entity_And_Homonym (Device_Entity);
 288       end loop;
 289    end Remove_CUDA_Device_Entities;
 290
 291    ------------------------------
 292    -- Set_CUDA_Device_Entities --
 293    ------------------------------
 294
 295    procedure Set_CUDA_Device_Entities
 296      (Pack_Id : Entity_Id;
 297       E       : Elist_Id)
 298    is
 299    begin
 300       pragma Assert (No (Get_CUDA_Device_Entities (Pack_Id)));
 301       CUDA_Device_Entities_Table.Set (Pack_Id, E);
 302    end Set_CUDA_Device_Entities;
 303
 304    ----------------------
 305    -- Set_CUDA_Kernels --
 306    ----------------------
 307
 308    procedure Set_CUDA_Kernels
 309      (Pack_Id : Entity_Id;
 310       Kernels : Elist_Id)
 311    is
 312    begin
 313       pragma Assert (No (Get_CUDA_Kernels (Pack_Id)));
 314       CUDA_Kernels_Table.Set (Pack_Id, Kernels);
 315    end Set_CUDA_Kernels;
 316
 317 end GNAT_CUDA;