[Ada] Implement AI12-0175 Preelaborable packages with address clauses

2020-06-12  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* rtsfind.ads (RTU_Id): Add System_Address_To_Access_Conversions.
	* sem_elab.adb (Elaboration_Phase_Active): Alphabetize.
	(Finalize_All_Data_Structures): Likewise.
	(Error_Preelaborated_Call): New procedure.
	(Build_Call_Marker): Set Is_Preelaborable_Call flag in marker.
	(Build_Access_Marker): Likewise.
	(Build_Subprogram_Invocation): Likewise.
	(Build_Task_Activation): Likewise.
	(Check_Preelaborated_Call): Return when the call is preelaborable.
	Call Error_Preelaborated_Call to give the error otherwise.
	(Check_Elab_Call): Likewise.
	* sem_util.adb (Is_Preelaborable_Function): New predicate.
	(Is_Non_Preelaborable_Construct.Visit): Recurse on the
	Explicit_Actual_Parameter field of N_Parameter_Association.
	(Is_Non_Preelaborable_Construct.Visit_Subexpression): In Ada 2020,
	for a call to a preelaborable function, visit the parameter list;
	otherwise, raise Non_Preelaborable exception.
	(Is_Preelaborable_Construct): Likewise, but recursively check the
	parameters instead and return false upon failure, otherwise true.
	* sinfo.ads (Is_Preelaborable_Call): New flag in call marker nodes.
	(Is_Preelaborable_Call): New inline function.
	(Set_Is_Preelaborable_Call): New inline procedure.
	* sinfo.adb (Is_Preelaborable_Call): New inline function.
	(Set_Is_Preelaborable_Call): New inline procedure.

diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index df980233ea62378d9e7dcb81816f9b153944ab8c..ad113fd72444e8de4f50786d649e94a8bdc10f74 100644 (file)
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -173,6 +173,7 @@ package Rtsfind is
       --  Children of System
 
       System_Address_Image,
+      System_Address_To_Access_Conversions,
       System_Arith_64,
       System_AST_Handling,
       System_Assertions,

diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index 0fa3d14b69a4a1f4285b49b18305fff9d537a8a5..8aa1ca7b15618022dfdd0fa188a1bcc14c878469 100644 (file)
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -1952,6 +1952,18 @@ package body Sem_Elab is
    pragma Inline (Compilation_Unit);
    --  Return the N_Compilation_Unit node of unit Unit_Id
 
+   function Elaboration_Phase_Active return Boolean;
+   pragma Inline (Elaboration_Phase_Active);
+   --  Determine whether the elaboration phase of the compilation has started
+
+   procedure Error_Preelaborated_Call (N : Node_Id);
+   --  Give an error or warning for a non-static/non-preelaborable call in a
+   --  preelaborated unit.
+
+   procedure Finalize_All_Data_Structures;
+   pragma Inline (Finalize_All_Data_Structures);
+   --  Destroy all internal data structures
+
    function Find_Enclosing_Instance (N : Node_Id) return Node_Id;
    pragma Inline (Find_Enclosing_Instance);
    --  Find the declaration or body of the nearest expanded instance which
@@ -1972,14 +1984,6 @@ package body Sem_Elab is
    --  Return the type of subprogram Subp_Id's first formal parameter. If the
    --  subprogram lacks formal parameters, return Empty.
 
-   function Elaboration_Phase_Active return Boolean;
-   pragma Inline (Elaboration_Phase_Active);
-   --  Determine whether the elaboration phase of the compilation has started
-
-   procedure Finalize_All_Data_Structures;
-   pragma Inline (Finalize_All_Data_Structures);
-   --  Destroy all internal data structures
-
    function Has_Body (Pack_Decl : Node_Id) return Boolean;
    pragma Inline (Has_Body);
    --  Determine whether package declaration Pack_Decl has a corresponding body
@@ -3745,6 +3749,15 @@ package body Sem_Elab is
       Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N));
       Set_Target                (Marker, Subp_Id);
 
+      --  Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+      --  unchecked conversions are preelaborable.
+
+      if Ada_Version >= Ada_2020 then
+         Set_Is_Preelaborable_Call (Marker, Is_Preelaborable_Construct (N));
+      else
+         Set_Is_Preelaborable_Call (Marker, False);
+      end if;
+
       --  The marker is inserted prior to the original call. This placement has
       --  several desirable effects:
 
@@ -4878,6 +4891,8 @@ package body Sem_Elab is
                        (Marker, Elaboration_Checks_OK (Attr_Rep));
             Set_Is_Elaboration_Warnings_OK_Node
                        (Marker, Elaboration_Warnings_OK (Attr_Rep));
+            Set_Is_Preelaborable_Call
+                       (Marker, False);
             Set_Is_Source_Call
                        (Marker, Comes_From_Source (Attr));
             Set_Is_SPARK_Mode_On_Node
@@ -8838,6 +8853,29 @@ package body Sem_Elab is
       return Elaboration_Phase = Active;
    end Elaboration_Phase_Active;
 
+   ------------------------------
+   -- Error_Preelaborated_Call --
+   ------------------------------
+
+   procedure Error_Preelaborated_Call (N : Node_Id) is
+   begin
+      --  This is a warning in GNAT mode allowing such calls to be used in the
+      --  predefined library units with appropriate care.
+
+      Error_Msg_Warn := GNAT_Mode;
+
+      --  Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+      --  unchecked conversions are preelaborable.
+
+      if Ada_Version >= Ada_2020 then
+         Error_Msg_N
+           ("<<non-preelaborable call not allowed in preelaborated unit", N);
+      else
+         Error_Msg_N
+           ("<<non-static call not allowed in preelaborated unit", N);
+      end if;
+   end Error_Preelaborated_Call;
+
    ----------------------------------
    -- Finalize_All_Data_Structures --
    ----------------------------------
@@ -11894,6 +11932,7 @@ package body Sem_Elab is
          Set_Is_Elaboration_Checks_OK_Node   (Marker, False);
          Set_Is_Elaboration_Warnings_OK_Node (Marker, False);
          Set_Is_Ignored_Ghost_Node           (Marker, False);
+         Set_Is_Preelaborable_Call           (Marker, False);
          Set_Is_Source_Call                  (Marker, False);
          Set_Is_SPARK_Mode_On_Node           (Marker, False);
 
@@ -11933,6 +11972,7 @@ package body Sem_Elab is
          Set_Is_Elaboration_Checks_OK_Node   (Marker, False);
          Set_Is_Elaboration_Warnings_OK_Node (Marker, False);
          Set_Is_Ignored_Ghost_Node           (Marker, False);
+         Set_Is_Preelaborable_Call           (Marker, False);
          Set_Is_Source_Call                  (Marker, False);
          Set_Is_SPARK_Mode_On_Node           (Marker, False);
 
@@ -13758,6 +13798,11 @@ package body Sem_Elab is
          if not Is_Source_Call (Call) then
             return;
 
+         --  Nothing to do when the call is preelaborable by definition
+
+         elsif Is_Preelaborable_Call (Call) then
+            return;
+
          --  Library-level calls are always considered because they are part of
          --  the associated unit's elaboration actions.
 
@@ -13779,13 +13824,10 @@ package body Sem_Elab is
             return;
          end if;
 
-         --  The call appears within a preelaborated unit. Emit a warning only
-         --  for internal uses, otherwise this is an error.
+         --  If the call appears within a preelaborated unit, give an error
 
          if In_Preelaborated_Context (Call) then
-            Error_Msg_Warn := GNAT_Mode;
-            Error_Msg_N
-              ("<<non-static call not allowed in preelaborated unit", Call);
+            Error_Preelaborated_Call (Call);
          end if;
       end Check_Preelaborated_Call;
 
@@ -17506,17 +17548,17 @@ package body Sem_Elab is
             --  Complain if ref that comes from source in preelaborated unit
             --  and we are not inside a subprogram (i.e. we are in elab code).
 
+            --  Ada 2020 (AI12-0175): Calls to certain functions that are
+            --  essentially unchecked conversions are preelaborable.
+
             if Comes_From_Source (N)
               and then In_Preelaborated_Unit
               and then not In_Inlined_Body
               and then Nkind (N) /= N_Attribute_Reference
+              and then not (Ada_Version >= Ada_2020
+                             and then Is_Preelaborable_Construct (N))
             then
-               --  This is a warning in GNAT mode allowing such calls to be
-               --  used in the predefined library with appropriate care.
-
-               Error_Msg_Warn := GNAT_Mode;
-               Error_Msg_N
-                 ("<<non-static call not allowed in preelaborated unit", N);
+               Error_Preelaborated_Call (N);
                return;
             end if;
 

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 948ee60d91e40f4eb5159e4be2cdf1ea20035b87..0a62b10e568164a84a80b284e2753b29e19a0be1 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -133,6 +133,10 @@ package body Sem_Util is
    --  components in the selected variant to determine whether all of them
    --  have a default.
 
+   function Is_Preelaborable_Function (Id : Entity_Id) return Boolean;
+   --  Ada 2020: Determine whether the specified function is suitable as the
+   --  name of a call in a preelaborable construct (RM 10.2.1(7/5)).
+
    type Null_Status_Kind is
      (Is_Null,
       --  This value indicates that a subexpression is known to have a null
@@ -16485,6 +16489,9 @@ package body Sem_Util is
 
                Visit (Discrete_Subtype_Definition (Nod));
 
+            when N_Parameter_Association =>
+               Visit (Explicit_Actual_Parameter (N));
+
             when N_Protected_Definition =>
 
                --  End_Label is left out because it is not relevant for
@@ -16650,6 +16657,21 @@ package body Sem_Util is
                Visit_List (Actions (Expr));
                Visit (Expression (Expr));
 
+            when N_Function_Call =>
+
+               --  Ada 2020 (AI12-0175): Calls to certain functions that are
+               --  essentially unchecked conversions are preelaborable.
+
+               if Ada_Version >= Ada_2020
+                 and then Nkind (Expr) = N_Function_Call
+                 and then Is_Entity_Name (Name (Expr))
+                 and then Is_Preelaborable_Function (Entity (Name (Expr)))
+               then
+                  Visit_List (Parameter_Associations (Expr));
+               else
+                  raise Non_Preelaborable;
+               end if;
+
             when N_If_Expression =>
                Visit_List (Expressions (Expr));
 
@@ -17781,6 +17803,30 @@ package body Sem_Util is
       elsif Nkind (N) = N_Null then
          return True;
 
+      --  Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+      --  unchecked conversions are preelaborable.
+
+      elsif Ada_Version >= Ada_2020
+        and then Nkind (N) = N_Function_Call
+        and then Is_Entity_Name (Name (N))
+        and then Is_Preelaborable_Function (Entity (Name (N)))
+      then
+         declare
+            A : Node_Id;
+         begin
+            A := First_Actual (N);
+
+            while Present (A) loop
+               if not Is_Preelaborable_Construct (A) then
+                  return False;
+               end if;
+
+               Next_Actual (A);
+            end loop;
+         end;
+
+         return True;
+
       --  Otherwise the construct is not preelaborable
 
       else
@@ -17788,6 +17834,50 @@ package body Sem_Util is
       end if;
    end Is_Preelaborable_Construct;
 
+   -------------------------------
+   -- Is_Preelaborable_Function --
+   -------------------------------
+
+   function Is_Preelaborable_Function (Id : Entity_Id) return Boolean is
+      SATAC : constant Rtsfind.RTU_Id := System_Address_To_Access_Conversions;
+      Scop  : constant Entity_Id := Scope (Id);
+
+   begin
+      --  Small optimization: every allowed function has convention Intrinsic
+      --  (see Analyze_Subprogram_Instantiation for the subtlety in the test).
+
+      if not Is_Intrinsic_Subprogram (Id)
+        and then Convention (Id) /= Convention_Intrinsic
+      then
+         return False;
+      end if;
+
+      --  An instance of Unchecked_Conversion
+
+      if Is_Unchecked_Conversion_Instance (Id) then
+         return True;
+      end if;
+
+      --  A function declared in System.Storage_Elements
+
+      if Is_RTU (Scop, System_Storage_Elements) then
+         return True;
+      end if;
+
+      --  The functions To_Pointer and To_Address declared in an instance of
+      --  System.Address_To_Access_Conversions (they are the only ones).
+
+      if Ekind (Scop) = E_Package
+        and then Nkind (Parent (Scop)) = N_Package_Specification
+        and then Present (Generic_Parent (Parent (Scop)))
+        and then Is_RTU (Generic_Parent (Parent (Scop)), SATAC)
+      then
+         return True;
+      end if;
+
+      return False;
+   end Is_Preelaborable_Function;
+
    ---------------------------------
    -- Is_Protected_Self_Reference --
    ---------------------------------

diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index f6e70c12adaccd01f3434b06779d365a4eb7fa52..642e859a5e89d3552619296aaea20fff463f2f10 100644 (file)
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -2096,6 +2096,14 @@ package body Sinfo is
       return Flag13 (N);
    end Is_Power_Of_2_For_Shift;
 
+   function Is_Preelaborable_Call
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Call_Marker);
+      return Flag7 (N);
+   end Is_Preelaborable_Call;
+
    function Is_Prefixed_Call
       (N : Node_Id) return Boolean is
    begin
@@ -5563,6 +5571,14 @@ package body Sinfo is
       Set_Flag13 (N, Val);
    end Set_Is_Power_Of_2_For_Shift;
 
+   procedure Set_Is_Preelaborable_Call
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Call_Marker);
+      Set_Flag7 (N, Val);
+   end Set_Is_Preelaborable_Call;
+
    procedure Set_Is_Prefixed_Call
       (N : Node_Id; Val : Boolean := True) is
    begin

diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index ea4f8ed882a17c675dc72d30307a9176637ac40d..d0739b8443a2927feb2868ad887ba7586da10955 100644 (file)
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1849,6 +1849,10 @@ package Sinfo is
    --    conditions holds, and the flag is set, then the division or
    --    multiplication can be (and is) converted to a shift.
 
+   --  Is_Preelaborable_Call (Flag7-Sem)
+   --    Present in call marker nodes. Set when the related call is non-static
+   --    but preelaborable.
+
    --  Is_Prefixed_Call (Flag17-Sem)
    --    This flag is set in a selected component within a generic unit, if
    --    it resolves to a prefixed call to a primitive operation. The flag
@@ -7830,6 +7834,7 @@ package Sinfo is
       --  Is_Source_Call (Flag4-Sem)
       --  Is_Declaration_Level_Node (Flag5-Sem)
       --  Is_Dispatching_Call (Flag6-Sem)
+      --  Is_Preelaborable_Call (Flag7-Sem)
       --  Is_Known_Guaranteed_ABE (Flag18-Sem)
 
       ------------------------
@@ -9767,6 +9772,9 @@ package Sinfo is
    function Is_Power_Of_2_For_Shift
      (N : Node_Id) return Boolean;    -- Flag13
 
+   function Is_Preelaborable_Call
+     (N : Node_Id) return Boolean;    -- Flag7
+
    function Is_Prefixed_Call
      (N : Node_Id) return Boolean;    -- Flag17
 
@@ -10870,6 +10878,9 @@ package Sinfo is
    procedure Set_Is_Power_Of_2_For_Shift
      (N : Node_Id; Val : Boolean := True);    -- Flag13
 
+   procedure Set_Is_Preelaborable_Call
+     (N : Node_Id; Val : Boolean := True);    -- Flag7
+
    procedure Set_Is_Prefixed_Call
      (N : Node_Id; Val : Boolean := True);    -- Flag17
 
@@ -13395,6 +13406,7 @@ package Sinfo is
    pragma Inline (Is_Null_Loop);
    pragma Inline (Is_Overloaded);
    pragma Inline (Is_Power_Of_2_For_Shift);
+   pragma Inline (Is_Preelaborable_Call);
    pragma Inline (Is_Prefixed_Call);
    pragma Inline (Is_Protected_Subprogram_Body);
    pragma Inline (Is_Qualified_Universal_Literal);
@@ -13758,6 +13770,7 @@ package Sinfo is
    pragma Inline (Set_Is_Null_Loop);
    pragma Inline (Set_Is_Overloaded);
    pragma Inline (Set_Is_Power_Of_2_For_Shift);
+   pragma Inline (Set_Is_Preelaborable_Call);
    pragma Inline (Set_Is_Prefixed_Call);
    pragma Inline (Set_Is_Protected_Subprogram_Body);
    pragma Inline (Set_Is_Qualified_Universal_Literal);