[gcc r12-4029] [Ada] Empty CUDA_Global procedures when compiling for host

[gcc r12-4029] [Ada] Empty CUDA_Global procedures when compiling for host

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:29ada0e5a2ec9545a94fafeac21ac074d306376d

commit r12-4029-g29ada0e5a2ec9545a94fafeac21ac074d306376d
Author: Ghjuvan Lacambre <lacambre@adacore.com>
Date:   Mon Aug 16 15:28:09 2021 +0200

    [Ada] Empty CUDA_Global procedures when compiling for host
    
    gcc/ada/
    
            * gnat_cuda.adb (Empty_CUDA_Global_Subprograms): New procedure.
            (Expand_CUDA_Package): Call Empty_CUDA_Global_Subprograms.

Diff:
---
 gcc/ada/gnat_cuda.adb | 92 +++++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 78 insertions(+), 14 deletions(-)

diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb
index 9d4caa698bc..fe080aeaf45 100644
--- a/gcc/ada/gnat_cuda.adb
+++ b/gcc/ada/gnat_cuda.adb
@@ -25,20 +25,22 @@
 
 --  This package defines CUDA-specific datastructures and functions.
 
-with Debug;          use Debug;
-with Elists;         use Elists;
-with Namet;          use Namet;
-with Nlists;         use Nlists;
-with Nmake;          use Nmake;
-with Rtsfind;        use Rtsfind;
-with Sinfo;          use Sinfo;
-with Sinfo.Nodes;    use Sinfo.Nodes;
-with Stringt;        use Stringt;
-with Tbuild;         use Tbuild;
-with Uintp;          use Uintp;
-with Sem;            use Sem;
-with Sem_Util;       use Sem_Util;
-with Snames;         use Snames;
+with Atree;       use Atree;
+with Debug;       use Debug;
+with Elists;      use Elists;
+with Namet;       use Namet;
+with Nlists;      use Nlists;
+with Nmake;       use Nmake;
+with Rtsfind;     use Rtsfind;
+with Sinfo;       use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Stringt;     use Stringt;
+with Tbuild;      use Tbuild;
+with Uintp;       use Uintp;
+with Sem;         use Sem;
+with Sem_Aux;     use Sem_Aux;
+with Sem_Util;    use Sem_Util;
+with Snames;      use Snames;
 
 with GNAT.HTable;
 
@@ -97,6 +99,17 @@ package body GNAT_CUDA is
    --    * 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
@@ -153,6 +166,50 @@ package body GNAT_CUDA is
       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
 
@@ -162,6 +219,13 @@ package body GNAT_CUDA is
          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);
+
       --  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