The CUDA_Device aspect allows specifying an entity as being device
(GPU)-only. This commit implements the basic machinery to detect the
aspect/pragma, but does not implement any functionality (a warning is
issued instead).
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* aspects.ads: Add CUDA_Device aspect.
* gnat_cuda.ads (Add_CUDA_Device_Entity): New subprogram.
* gnat_cuda.adb:
(Add_CUDA_Device_Entity): New subprogram.
(CUDA_Device_Entities_Table): New hashmap for CUDA_Device
entities.
(Get_CUDA_Device_Entities): New internal subprogram.
(Set_CUDA_Device_Entities): New internal subprogram.
* par-prag.adb (Prag): Handle pragma id Pragma_CUDA_Device.
* sem_prag.ads (Aspect_Specifying_Pragma): Mark CUDA_Device as
being both aspect and pragma.
* sem_prag.adb (Analyze_Pragma): Add CUDA_Device entities to
list of CUDA_Entities belonging to package N.
(Sig_Flags): Signal CUDA_Device entities as referenced.
* snames.ads-tmpl: Create CUDA_Device names and pragmas.
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -187,6 +187,7 @@ package Aspects is
Aspect_Atomic_Components,
Aspect_Disable_Controlled, -- GNAT
Aspect_Discard_Names,
+ Aspect_CUDA_Device, -- GNAT
Aspect_CUDA_Global, -- GNAT
Aspect_Exclusive_Functions,
Aspect_Export,
@@ -476,6 +477,7 @@ package Aspects is
Aspect_Contract_Cases => False,
Aspect_Convention => True,
Aspect_CPU => False,
+ Aspect_CUDA_Device => False,
Aspect_CUDA_Global => False,
Aspect_Default_Component_Value => True,
Aspect_Default_Initial_Condition => False,
@@ -627,6 +629,7 @@ package Aspects is
Aspect_Contract_Cases => Name_Contract_Cases,
Aspect_Convention => Name_Convention,
Aspect_CPU => Name_CPU,
+ Aspect_CUDA_Device => Name_CUDA_Device,
Aspect_CUDA_Global => Name_CUDA_Global,
Aspect_Default_Component_Value => Name_Default_Component_Value,
Aspect_Default_Initial_Condition => Name_Default_Initial_Condition,
@@ -872,6 +875,7 @@ package Aspects is
Aspect_Attach_Handler => Always_Delay,
Aspect_Constant_Indexing => Always_Delay,
Aspect_CPU => Always_Delay,
+ Aspect_CUDA_Device => Always_Delay,
Aspect_CUDA_Global => Always_Delay,
Aspect_Default_Iterator => Always_Delay,
Aspect_Default_Storage_Pool => Always_Delay,
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
@@ -54,6 +54,18 @@ package body GNAT_CUDA is
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,
@@ -85,17 +97,45 @@ package body GNAT_CUDA is
-- * A procedure that takes care of calling CUDA functions that register
-- CUDA_Global procedures with the runtime.
+ 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.
+
function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id;
-- Returns an Elist of all procedures marked with pragma CUDA_Global that
-- are declared within package body Pack_Body. Returns No_Elist if Pack_Id
-- does not contain such procedures.
+ 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 Device_Entities = No_Elist 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 --
---------------------
@@ -139,6 +179,15 @@ package body GNAT_CUDA is
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 --
----------------------
@@ -605,9 +654,22 @@ package body GNAT_CUDA is
Analyze (New_Stmt);
end Build_And_Insert_CUDA_Initialization;
- --------------------
- -- Set_CUDA_Nodes --
- --------------------
+ ------------------------------
+ -- Set_CUDA_Device_Entities --
+ ------------------------------
+
+ procedure Set_CUDA_Device_Entities
+ (Pack_Id : Entity_Id;
+ E : Elist_Id)
+ is
+ begin
+ pragma Assert (Get_CUDA_Device_Entities (Pack_Id) = No_Elist);
+ CUDA_Device_Entities_Table.Set (Pack_Id, E);
+ end Set_CUDA_Device_Entities;
+
+ ----------------------
+ -- Set_CUDA_Kernels --
+ ----------------------
procedure Set_CUDA_Kernels
(Pack_Id : Entity_Id;
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
@@ -77,6 +77,9 @@ with Types; use Types;
package GNAT_CUDA is
+ procedure Add_CUDA_Device_Entity (Pack_Id : Entity_Id; E : Entity_Id);
+ -- And E to the list of CUDA_Device entities that belong to Pack_Id
+
procedure Add_CUDA_Kernel (Pack_Id : Entity_Id; Kernel : Entity_Id);
-- Add Kernel to the list of CUDA_Global nodes that belong to Pack_Id.
-- Kernel is a procedure entity marked with CUDA_Global, Pack_Id is the
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -1338,6 +1338,7 @@ begin
| Pragma_CPP_Virtual
| Pragma_CPP_Vtable
| Pragma_CPU
+ | Pragma_CUDA_Device
| Pragma_CUDA_Execute
| Pragma_CUDA_Global
| Pragma_C_Pass_By_Copy
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
@@ -14839,9 +14839,40 @@ package body Sem_Prag is
& "effect?j?", N);
end if;
- --------------------
+ -----------------
+ -- CUDA_Device --
+ -----------------
+
+ when Pragma_CUDA_Device => CUDA_Device : declare
+ Arg_Node : Node_Id;
+ Device_Entity : Entity_Id;
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Arg_Node := Get_Pragma_Arg (Arg1);
+
+ Check_Arg_Is_Library_Level_Local_Name (Arg_Node);
+ Device_Entity := Entity (Arg_Node);
+
+ if Ekind (Device_Entity) in E_Variable
+ | E_Constant
+ | E_Procedure
+ | E_Function
+ then
+ Add_CUDA_Device_Entity (Scope (Device_Entity), Device_Entity);
+ Error_Msg_N ("??& not implemented yet", N);
+
+ else
+ Error_Msg_NE ("& must be constant, variable or subprogram",
+ N,
+ Device_Entity);
+ end if;
+
+ end CUDA_Device;
+
+ ------------------
-- CUDA_Execute --
- --------------------
+ ------------------
-- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
-- EXPRESSION,
@@ -31248,6 +31279,7 @@ package body Sem_Prag is
Pragma_C_Pass_By_Copy => 0,
Pragma_Comment => -1,
Pragma_Common_Object => 0,
+ Pragma_CUDA_Device => -1,
Pragma_CUDA_Execute => -1,
Pragma_CUDA_Global => -1,
Pragma_Compile_Time_Error => -1,
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -49,6 +49,7 @@ package Sem_Prag is
Pragma_Contract_Cases => True,
Pragma_Convention => True,
Pragma_CPU => True,
+ Pragma_CUDA_Device => True,
Pragma_CUDA_Global => True,
Pragma_Default_Initial_Condition => True,
Pragma_Default_Storage_Pool => True,
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -526,6 +526,7 @@ package Snames is
Name_CPP_Constructor : constant Name_Id := N + $; -- GNAT
Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
+ Name_CUDA_Device : constant Name_Id := N + $; -- GNAT
Name_CUDA_Execute : constant Name_Id := N + $; -- GNAT
Name_CUDA_Global : constant Name_Id := N + $; -- GNAT
@@ -1862,6 +1863,7 @@ package Snames is
Pragma_CPP_Constructor,
Pragma_CPP_Virtual,
Pragma_CPP_Vtable,
+ Pragma_CUDA_Device,
Pragma_CUDA_Execute,
Pragma_CUDA_Global,
Pragma_Deadline_Floor,