[Ada] Implement CUDA_Device

gcc/ada/

	* gnat_cuda.adb (Remove_CUDA_Device_Entities): New function.
	(Expand_CUDA_Package): Call Remove_CUDA_Device_Entities.
	* gnat_cuda.ads (Expand_CUDA_Package): Expand documentation.
	* sem_prag.adb (Analyze_Pragma): Remove warning about
	CUDA_Device not being implemented.

diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb
index fe080aeaf4577cec735da3d0eada458f567b753d..a1739be5031847c0f6bd915eff255dde81a3aa3d 100644 (file)
--- a/gcc/ada/gnat_cuda.adb
+++ b/gcc/ada/gnat_cuda.adb
@@ -25,22 +25,25 @@
 
 --  This package defines CUDA-specific datastructures and functions.
 
-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 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;
 
@@ -120,6 +123,10 @@ package body GNAT_CUDA is
    --  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);
@@ -226,6 +233,13 @@ package body GNAT_CUDA is
 
       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
@@ -718,6 +732,54 @@ package body GNAT_CUDA is
       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 --
    ------------------------------

diff --git a/gcc/ada/gnat_cuda.ads b/gcc/ada/gnat_cuda.ads
index fc84bda3e8ce6a7fa6f0f037e80702d34b208ab1..390f5de846b8367daea45eb42dbf2135ae50073d 100644 (file)
--- a/gcc/ada/gnat_cuda.ads
+++ b/gcc/ada/gnat_cuda.ads
@@ -86,7 +86,10 @@ package GNAT_CUDA is
    --  entity of its parent package body.
 
    procedure Expand_CUDA_Package (N : Node_Id);
-   --  When compiling for the host, generate code to register kernels with the
-   --  CUDA runtime and post-process kernels.
+   --  When compiling for the host:
+   --  - Generate code to register kernels with the CUDA runtime and
+   --    post-process kernels.
+   --  - Empty content of CUDA_Global procedures.
+   --  - Remove declarations of CUDA_Device entities.
 
 end GNAT_CUDA;

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index c985e36d92904ee2eb9a65c609a1640317e573b8..43bf577e1a5df8c84b5e9d3fecb18bb0e14b2931 100644 (file)
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -14849,9 +14849,9 @@ package body Sem_Prag is
          begin
             GNAT_Pragma;
             Check_Arg_Count (1);
-            Arg_Node := Get_Pragma_Arg (Arg1);
+            Check_Arg_Is_Library_Level_Local_Name (Arg1);
 
-            Check_Arg_Is_Library_Level_Local_Name (Arg_Node);
+            Arg_Node := Get_Pragma_Arg (Arg1);
             Device_Entity := Entity (Arg_Node);
 
             if Ekind (Device_Entity) in E_Variable
@@ -14859,8 +14859,9 @@ package body Sem_Prag is
                                       | E_Procedure
                                       | E_Function
             then
-               Add_CUDA_Device_Entity (Scope (Device_Entity), Device_Entity);
-               Error_Msg_N ("??& not implemented yet", N);
+               Add_CUDA_Device_Entity
+                 (Package_Specification_Of_Scope (Scope (Device_Entity)),
+                  Device_Entity);
 
             else
                Error_Msg_NE ("& must be constant, variable or subprogram",