[Ada] Stub CUDA_Device aspect

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.

7 files changed, 110 insertions, 5 deletions

diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 7d0c703..11e0aeb 100644
--- 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
index 6273a5d..9d4caa6 100644
--- 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
index d35bc8a..fc84bda 100644
--- 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
index 06c7d87..e1258e0 100644
--- 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
index 7386ecc..c985e36 100644
--- 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
index 3d7b00c..fed24fd 100644
--- 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
index a6cf5a0..400adb0 100644
--- 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,