[Ada] Stub CUDA_Execute and CUDA_Global pragmas
authorArnaud Charlet <charlet@adacore.com>
Thu, 23 Jul 2020 13:54:45 +0000 (09:54 -0400)
committerArnaud Charlet <charlet@adacore.com>
Thu, 23 Jul 2020 13:56:56 +0000 (09:56 -0400)
This commit adds CUDA_Execute and CUDA_Global to the list of allowed
pragmas. It also implements basic validation of said pragmas.

gcc/ada/

* aspects.ads: Declare CUDA_Global as aspect.
* einfo.ads: Use Flag118 for the Is_CUDA_Kernel flag.
(Set_Is_CUDA_Kernel): New function.
(Is_CUDA_Kernel): New function.
* einfo.adb (Set_Is_CUDA_Kernel): New function.
(Is_CUDA_Kernel): New function.
* par-prag.adb (Prag): Ignore Pragma_CUDA_Execute and
Pragma_CUDA_global.
* rtsfind.ads: Define CUDA.Driver_Types.Stream_T and
CUDA.Vector_Types.Dim3 entities
* rtsfind.adb: Define CUDA_Descendant subtype.
(Get_Unit_Name): Handle CUDA_Descendant packages.
* sem_prag.ads: Mark CUDA_Global as aspect-specifying pragma.
* sem_prag.adb (Analyze_Pragma): Validate Pragma_CUDA_Execute and
Pragma_CUDA_Global.
* snames.ads-tmpl: Define Name_CUDA_Execute and Name_CUDA_Global.

gcc/ada/aspects.ads
gcc/ada/einfo.adb
gcc/ada/einfo.ads
gcc/ada/par-prag.adb
gcc/ada/rtsfind.adb
gcc/ada/rtsfind.ads
gcc/ada/sem_prag.adb
gcc/ada/sem_prag.ads
gcc/ada/snames.ads-tmpl

index 4e517d1fb5b2a31cbbab25bb3ddf971f1de4b659..03941065b8007bb834e15dcc6dd44953e125d25e 100644 (file)
@@ -189,6 +189,7 @@ package Aspects is
       Aspect_Atomic_Components,
       Aspect_Disable_Controlled,            -- GNAT
       Aspect_Discard_Names,
+      Aspect_CUDA_Global,                   -- GNAT
       Aspect_Export,
       Aspect_Favor_Top_Level,               -- GNAT
       Aspect_Independent,
@@ -458,6 +459,7 @@ package Aspects is
       Aspect_Contract_Cases               => False,
       Aspect_Convention                   => True,
       Aspect_CPU                          => False,
+      Aspect_CUDA_Global                  => False,
       Aspect_Default_Component_Value      => True,
       Aspect_Default_Initial_Condition    => False,
       Aspect_Default_Iterator             => False,
@@ -601,6 +603,7 @@ package Aspects is
       Aspect_Contract_Cases               => Name_Contract_Cases,
       Aspect_Convention                   => Name_Convention,
       Aspect_CPU                          => Name_CPU,
+      Aspect_CUDA_Global                  => Name_CUDA_Global,
       Aspect_Default_Component_Value      => Name_Default_Component_Value,
       Aspect_Default_Initial_Condition    => Name_Default_Initial_Condition,
       Aspect_Default_Iterator             => Name_Default_Iterator,
@@ -839,6 +842,7 @@ package Aspects is
       Aspect_Attach_Handler               => Always_Delay,
       Aspect_Constant_Indexing            => Always_Delay,
       Aspect_CPU                          => Always_Delay,
+      Aspect_CUDA_Global                  => Always_Delay,
       Aspect_Default_Iterator             => Always_Delay,
       Aspect_Default_Storage_Pool         => Always_Delay,
       Aspect_Default_Value                => Always_Delay,
index eab06eefe498319a28e413427e169ff2d62534f5..6cdea4801a604c1b74812c8b7d27b0baa02c9ddd 100644 (file)
@@ -423,6 +423,7 @@ package body Einfo is
    --    Never_Set_In_Source             Flag115
    --    Is_Visible_Lib_Unit             Flag116
    --    Is_Unchecked_Union              Flag117
+   --    Is_CUDA_Kernel                  Flag118
    --    Has_Convention_Pragma           Flag119
    --    Has_Primitive_Operations        Flag120
 
@@ -2235,6 +2236,12 @@ package body Einfo is
       return Flag74 (Id);
    end Is_CPP_Class;
 
+   function Is_CUDA_Kernel (Id : E) return B is
+   begin
+      pragma Assert (Ekind (Id) in E_Function | E_Procedure);
+      return Flag118 (Id);
+   end Is_CUDA_Kernel;
+
    function Is_DIC_Procedure (Id : E) return B is
    begin
       pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
@@ -5477,6 +5484,12 @@ package body Einfo is
       Set_Flag74 (Id, V);
    end Set_Is_CPP_Class;
 
+   procedure Set_Is_CUDA_Kernel (Id : E; V : B := True) is
+   begin
+      pragma Assert (Ekind (Id) in E_Function | E_Procedure);
+      Set_Flag118 (Id, V);
+   end Set_Is_CUDA_Kernel;
+
    procedure Set_Is_DIC_Procedure (Id : E; V : B := True) is
    begin
       pragma Assert (Ekind (Id) = E_Procedure);
@@ -9848,6 +9861,7 @@ package body Einfo is
       W ("Is_Atomic",                       Flag85  (Id));
       W ("Is_Bit_Packed_Array",             Flag122 (Id));
       W ("Is_CPP_Class",                    Flag74  (Id));
+      W ("Is_CUDA_Kernel",                  Flag118  (Id));
       W ("Is_Called",                       Flag102 (Id));
       W ("Is_Character_Type",               Flag63  (Id));
       W ("Is_Checked_Ghost_Entity",         Flag277 (Id));
index 758aef56576d407359ca9fdc317914b145875555..7932c9270b4a274e91148e9ad1a7576e8f5eb9f6 100644 (file)
@@ -2508,6 +2508,10 @@ package Einfo is
 --       Defined in all type entities, set only for tagged types to which a
 --       valid pragma Import (CPP, ...) or pragma CPP_Class has been applied.
 
+--    Is_CUDA_Kernel (Flag118)
+--       Defined in function and procedure entities. Set if the subprogram is a
+--       CUDA kernel.
+
 --    Is_Decimal_Fixed_Point_Type (synthesized)
 --       Applies to all type entities, true for decimal fixed point
 --       types and subtypes.
@@ -6239,6 +6243,7 @@ package Einfo is
    --    Is_Abstract_Subprogram              (Flag19)   (non-generic case only)
    --    Is_Called                           (Flag102)  (non-generic case only)
    --    Is_Constructor                      (Flag76)
+   --    Is_CUDA_Kernel                      (Flag118)  (non-generic case only)
    --    Is_DIC_Procedure                    (Flag132)  (non-generic case only)
    --    Is_Discrim_SO_Function              (Flag176)
    --    Is_Discriminant_Check_Function      (Flag264)
@@ -6566,6 +6571,7 @@ package Einfo is
    --    Is_Asynchronous                     (Flag81)
    --    Is_Called                           (Flag102)  (non-generic case only)
    --    Is_Constructor                      (Flag76)
+   --    Is_CUDA_Kernel                      (Flag118)
    --    Is_DIC_Procedure                    (Flag132)  (non-generic case only)
    --    Is_Elaboration_Checks_OK_Id         (Flag148)
    --    Is_Elaboration_Warnings_OK_Id       (Flag304)
@@ -7345,6 +7351,7 @@ package Einfo is
    function Is_Controlled_Active                (Id : E) return B;
    function Is_Controlling_Formal               (Id : E) return B;
    function Is_CPP_Class                        (Id : E) return B;
+   function Is_CUDA_Kernel                      (Id : E) return B;
    function Is_Descendant_Of_Address            (Id : E) return B;
    function Is_DIC_Procedure                    (Id : E) return B;
    function Is_Discrim_SO_Function              (Id : E) return B;
@@ -8060,6 +8067,7 @@ package Einfo is
    procedure Set_Is_Controlled_Active            (Id : E; V : B := True);
    procedure Set_Is_Controlling_Formal           (Id : E; V : B := True);
    procedure Set_Is_CPP_Class                    (Id : E; V : B := True);
+   procedure Set_Is_CUDA_Kernel                  (Id : E; V : B := True);
    procedure Set_Is_Descendant_Of_Address        (Id : E; V : B := True);
    procedure Set_Is_DIC_Procedure                (Id : E; V : B := True);
    procedure Set_Is_Discrim_SO_Function          (Id : E; V : B := True);
@@ -8904,6 +8912,7 @@ package Einfo is
    pragma Inline (Is_Controlled_Active);
    pragma Inline (Is_Controlling_Formal);
    pragma Inline (Is_CPP_Class);
+   pragma Inline (Is_CUDA_Kernel);
    pragma Inline (Is_Decimal_Fixed_Point_Type);
    pragma Inline (Is_Descendant_Of_Address);
    pragma Inline (Is_DIC_Procedure);
@@ -9506,6 +9515,7 @@ package Einfo is
    pragma Inline (Set_Is_Controlled_Active);
    pragma Inline (Set_Is_Controlling_Formal);
    pragma Inline (Set_Is_CPP_Class);
+   pragma Inline (Set_Is_CUDA_Kernel);
    pragma Inline (Set_Is_Descendant_Of_Address);
    pragma Inline (Set_Is_DIC_Procedure);
    pragma Inline (Set_Is_Discrim_SO_Function);
index 1f25ec8fbf03eb5e56302b7a140ced29be45f00b..259d15fb0cbf505b31520bd5bd83fc021048b032 100644 (file)
@@ -1311,43 +1311,45 @@ begin
       when Pragma_Abort_Defer
          | Pragma_Abstract_State
          | Pragma_Aggregate_Individually_Assign
-         | Pragma_Async_Readers
-         | Pragma_Async_Writers
-         | Pragma_Assertion_Policy
-         | Pragma_Assume
-         | Pragma_Assume_No_Invalid_Values
          | Pragma_All_Calls_Remote
          | Pragma_Allow_Integer_Address
          | Pragma_Annotate
          | Pragma_Assert
          | Pragma_Assert_And_Cut
+         | Pragma_Assertion_Policy
+         | Pragma_Assume
+         | Pragma_Assume_No_Invalid_Values
+         | Pragma_Async_Readers
+         | Pragma_Async_Writers
          | Pragma_Asynchronous
          | Pragma_Atomic
          | Pragma_Atomic_Components
          | Pragma_Attach_Handler
          | Pragma_Attribute_Definition
-         | Pragma_Check
-         | Pragma_Check_Float_Overflow
-         | Pragma_Check_Name
-         | Pragma_Check_Policy
-         | Pragma_Compile_Time_Error
-         | Pragma_Compile_Time_Warning
-         | Pragma_Constant_After_Elaboration
-         | Pragma_Contract_Cases
-         | Pragma_Convention_Identifier
          | Pragma_CPP_Class
          | Pragma_CPP_Constructor
          | Pragma_CPP_Virtual
          | Pragma_CPP_Vtable
          | Pragma_CPU
+         | Pragma_CUDA_Execute
+         | Pragma_CUDA_Global
          | Pragma_C_Pass_By_Copy
+         | Pragma_Check
+         | Pragma_Check_Float_Overflow
+         | Pragma_Check_Name
+         | Pragma_Check_Policy
          | Pragma_Comment
          | Pragma_Common_Object
+         | Pragma_Compile_Time_Error
+         | Pragma_Compile_Time_Warning
          | Pragma_Complete_Representation
          | Pragma_Complex_Representation
          | Pragma_Component_Alignment
+         | Pragma_Constant_After_Elaboration
+         | Pragma_Contract_Cases
          | Pragma_Controlled
          | Pragma_Convention
+         | Pragma_Convention_Identifier
          | Pragma_Deadline_Floor
          | Pragma_Debug_Policy
          | Pragma_Default_Initial_Condition
@@ -1446,19 +1448,19 @@ begin
          | Pragma_Part_Of
          | Pragma_Partition_Elaboration_Policy
          | Pragma_Passive
-         | Pragma_Preelaborable_Initialization
-         | Pragma_Polling
-         | Pragma_Prefix_Exception_Messages
          | Pragma_Persistent_BSS
+         | Pragma_Polling
          | Pragma_Post
-         | Pragma_Postcondition
          | Pragma_Post_Class
+         | Pragma_Postcondition
          | Pragma_Pre
+         | Pragma_Pre_Class
          | Pragma_Precondition
          | Pragma_Predicate
          | Pragma_Predicate_Failure
+         | Pragma_Preelaborable_Initialization
          | Pragma_Preelaborate
-         | Pragma_Pre_Class
+         | Pragma_Prefix_Exception_Messages
          | Pragma_Priority
          | Pragma_Priority_Specific_Dispatching
          | Pragma_Profile
@@ -1482,6 +1484,7 @@ begin
          | Pragma_Rename_Pragma
          | Pragma_Restricted_Run_Time
          | Pragma_Reviewable
+         | Pragma_SPARK_Mode
          | Pragma_Secondary_Stack_Size
          | Pragma_Share_Generic
          | Pragma_Shared
@@ -1489,7 +1492,6 @@ begin
          | Pragma_Short_Circuit_And_Or
          | Pragma_Short_Descriptors
          | Pragma_Simple_Storage_Pool_Type
-         | Pragma_SPARK_Mode
          | Pragma_Static_Elaboration_Desired
          | Pragma_Storage_Size
          | Pragma_Storage_Unit
index 7e617b6a705240f36369190e1133551feb4bc775..5cf3b91ecb92b6a0c873decaac3d35b061c64772 100644 (file)
@@ -585,6 +585,9 @@ package body Rtsfind is
      range Ada_Wide_Wide_Text_IO_Decimal_IO ..
            Ada_Wide_Wide_Text_IO_Modular_IO;
 
+   subtype CUDA_Descendant is RTU_Id
+     range CUDA_Driver_Types .. CUDA_Vector_Types;
+
    subtype Interfaces_Descendant is RTU_Id
      range Interfaces_Packed_Decimal .. Interfaces_Packed_Decimal;
 
@@ -665,6 +668,9 @@ package body Rtsfind is
             Name_Buffer (22) := '.';
          end if;
 
+      elsif U_Id in CUDA_Descendant then
+         Name_Buffer (5) := '.';
+
       elsif U_Id in Interfaces_Descendant then
          Name_Buffer (11) := '.';
 
index 6a1738b635c06f1225974d1b49eda6bc18050683..ff9eb0aa83bfe6b445d4e30527bfcc476814a9f6 100644 (file)
@@ -159,6 +159,15 @@ package Rtsfind is
       Ada_Wide_Wide_Text_IO_Integer_IO,
       Ada_Wide_Wide_Text_IO_Modular_IO,
 
+      --  CUDA
+
+      CUDA,
+
+      --  Children of CUDA
+
+      CUDA_Driver_Types,
+      CUDA_Vector_Types,
+
       --  Interfaces
 
       Interfaces,
@@ -614,6 +623,10 @@ package Rtsfind is
      RO_WW_Decimal_IO,                   -- Ada.Wide_Wide_Text_IO
      RO_WW_Fixed_IO,                     -- Ada.Wide_Wide_Text_IO
 
+     RE_Stream_T,                        -- CUDA.Driver_Types
+
+     RE_Dim3,                            -- CUDA.Vector_Types
+
      RE_Integer_8,                       -- Interfaces
      RE_Integer_16,                      -- Interfaces
      RE_Integer_32,                      -- Interfaces
@@ -1901,6 +1914,10 @@ package Rtsfind is
      RO_WW_Decimal_IO                    => Ada_Wide_Wide_Text_IO,
      RO_WW_Fixed_IO                      => Ada_Wide_Wide_Text_IO,
 
+     RE_Stream_T                         => CUDA_Driver_Types,
+
+     RE_Dim3                             => CUDA_Vector_Types,
+
      RE_Integer_8                        => Interfaces,
      RE_Integer_16                       => Interfaces,
      RE_Integer_32                       => Interfaces,
index eb8f2a0494fceb36cd12812446eea3e8b139cada..f7019caebea8b702298ad00165928fffcd86c575 100644 (file)
@@ -3789,7 +3789,8 @@ package body Sem_Prag is
       Arg2 : Node_Id;
       Arg3 : Node_Id;
       Arg4 : Node_Id;
-      --  First four pragma arguments (pragma argument association nodes, or
+      Arg5 : Node_Id;
+      --  First five pragma arguments (pragma argument association nodes, or
       --  Empty if the corresponding argument does not exist).
 
       type Name_List is array (Natural range <>) of Name_Id;
@@ -11535,6 +11536,7 @@ package body Sem_Prag is
       Arg2      := Empty;
       Arg3      := Empty;
       Arg4      := Empty;
+      Arg5      := Empty;
 
       if Present (Pragma_Argument_Associations (N)) then
          Arg_Count := List_Length (Pragma_Argument_Associations (N));
@@ -11548,6 +11550,10 @@ package body Sem_Prag is
 
                if Present (Arg3) then
                   Arg4 := Next (Arg3);
+
+                  if Present (Arg4) then
+                     Arg5 := Next (Arg4);
+                  end if;
                end if;
             end if;
          end if;
@@ -14765,6 +14771,140 @@ package body Sem_Prag is
                   & "effect?j?", N);
             end if;
 
+         --------------------
+         -- CUDA_Execute --
+         --------------------
+
+         --    pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
+         --                         EXPRESSION,
+         --                         EXPRESSION,
+         --                         [, EXPRESSION
+         --                         [, EXPRESSION]]);
+
+         when Pragma_CUDA_Execute => CUDA_Execute : declare
+
+            function Is_Acceptable_Dim3 (N : Node_Id) return Boolean;
+            --  Returns True if N is an acceptable argument for CUDA_Execute,
+            --  false otherwise.
+
+            ------------------------
+            -- Is_Acceptable_Dim3 --
+            ------------------------
+
+            function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is
+               Tmp : Node_Id;
+            begin
+               if Etype (N) = RTE (RE_Dim3) or else Is_Integer_Type (Etype (N))
+               then
+                  return True;
+               end if;
+
+               if Nkind (N) = N_Aggregate
+                 and then List_Length (Expressions (N)) = 3
+               then
+                  Tmp := First (Expressions (N));
+                  while Present (Tmp) loop
+                     Analyze_And_Resolve (Tmp, Any_Integer);
+                     Tmp := Next (Tmp);
+                  end loop;
+                  return True;
+               end if;
+
+               return False;
+            end Is_Acceptable_Dim3;
+
+            --  Local variables
+
+            Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg3);
+            Grid_Dimensions  : constant Node_Id := Get_Pragma_Arg (Arg2);
+            Kernel_Call      : constant Node_Id := Get_Pragma_Arg (Arg1);
+            Shared_Memory    : Node_Id;
+            Stream           : Node_Id;
+
+            --  Start of processing for CUDA_Execute
+
+         begin
+
+            GNAT_Pragma;
+            Check_At_Least_N_Arguments (3);
+            Check_At_Most_N_Arguments (5);
+
+            Analyze_And_Resolve (Kernel_Call);
+            if Nkind (Kernel_Call) /= N_Function_Call
+               or else Etype (Kernel_Call) /= Standard_Void_Type
+            then
+               --  In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
+               --  GNAT sees Kernel_Call as an N_Function_Call since
+               --  Kernel_Call "looks" like an expression. However, only
+               --  procedures can be kernels, so to make things easier for the
+               --  user the error message complains about Kernel_Call not being
+               --  a procedure call.
+
+               Error_Msg_N ("first argument of & must be a procedure call", N);
+            end if;
+
+            Analyze (Grid_Dimensions);
+            if not Is_Acceptable_Dim3 (Grid_Dimensions) then
+               Error_Msg_N
+                 ("second argument of & must be an Integer, Dim3 or aggregate "
+                  & "containing 3 Integers", N);
+            end if;
+
+            Analyze (Block_Dimensions);
+            if not Is_Acceptable_Dim3 (Block_Dimensions) then
+               Error_Msg_N
+                 ("third argument of & must be an Integer, Dim3 or aggregate "
+                  & "containing 3 Integers", N);
+            end if;
+
+            if Present (Arg4) then
+               Shared_Memory := Get_Pragma_Arg (Arg4);
+               Analyze_And_Resolve (Shared_Memory, Any_Integer);
+
+               if Present (Arg5) then
+                  Stream := Get_Pragma_Arg (Arg5);
+                  Analyze_And_Resolve (Stream, RTE (RE_Stream_T));
+               end if;
+            end if;
+         end CUDA_Execute;
+
+         -----------------
+         -- CUDA_Global --
+         -----------------
+
+         --  pragma CUDA_Global (IDENTIFIER);
+
+         when Pragma_CUDA_Global => CUDA_Global : declare
+            Arg_Node    : Node_Id;
+            Kernel_Proc : Entity_Id;
+            Pack_Id     : Entity_Id;
+         begin
+            GNAT_Pragma;
+            Check_At_Least_N_Arguments (1);
+            Check_At_Most_N_Arguments (1);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Arg_Is_Local_Name (Arg1);
+
+            Arg_Node := Get_Pragma_Arg (Arg1);
+            Analyze (Arg_Node);
+
+            Kernel_Proc := Entity (Arg_Node);
+            Pack_Id := Scope (Kernel_Proc);
+
+            if Ekind (Kernel_Proc) /= E_Procedure then
+               Error_Msg_NE ("& must be a procedure", N, Kernel_Proc);
+
+            elsif Ekind (Pack_Id) /= E_Package
+              or else not Is_Library_Level_Entity (Pack_Id)
+            then
+               Error_Msg_NE
+                  ("& must reside in a library-level package", N, Kernel_Proc);
+
+            else
+               Set_Is_CUDA_Kernel (Kernel_Proc);
+            end if;
+         end CUDA_Global;
+
          ----------------
          -- CPP_Vtable --
          ----------------
@@ -30690,6 +30830,8 @@ package body Sem_Prag is
       Pragma_C_Pass_By_Copy                 =>  0,
       Pragma_Comment                        => -1,
       Pragma_Common_Object                  =>  0,
+      Pragma_CUDA_Execute                   => -1,
+      Pragma_CUDA_Global                    => -1,
       Pragma_Compile_Time_Error             => -1,
       Pragma_Compile_Time_Warning           => -1,
       Pragma_Compiler_Unit                  => -1,
index bdc449502c7a2d3f324b5a3cd83f7d72e60fdcff..460fc9ce4774ba1d0a43d75dd1063baa8539bfbc 100644 (file)
@@ -49,6 +49,7 @@ package Sem_Prag is
       Pragma_Contract_Cases               => True,
       Pragma_Convention                   => True,
       Pragma_CPU                          => True,
+      Pragma_CUDA_Global                  => True,
       Pragma_Default_Initial_Condition    => True,
       Pragma_Default_Storage_Pool         => True,
       Pragma_Depends                      => True,
index c4486ff3a71995fd2fcd5f31edc6b5cbed1d6595..6310442f9e89333e210682fe97e74e8a81f1c581 100644 (file)
@@ -514,6 +514,8 @@ 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_Execute                   : constant Name_Id := N + $; -- GNAT
+   Name_CUDA_Global                    : constant Name_Id := N + $; -- GNAT
 
    --  Note: CPU is not in this list because its name matches the name of
    --  the corresponding attribute. However, it is included in the definition
@@ -1998,6 +2000,8 @@ package Snames is
       Pragma_CPP_Constructor,
       Pragma_CPP_Virtual,
       Pragma_CPP_Vtable,
+      Pragma_CUDA_Execute,
+      Pragma_CUDA_Global,
       Pragma_Deadline_Floor,
       Pragma_Debug,
       Pragma_Default_Initial_Condition,