This commit removes entities marked with the CUDA_Device pragma from the
packages specs and bodies they exist in.
Tested on x86_64-pc-linux-gnu, committed on trunk
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
--- 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
--- 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
--- 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",
