From ec772e4b269206a943b3caa5544d9c7ac1d8de1a Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 20 Mar 2020 23:00:32 +0100 Subject: [PATCH] [Ada] Implement AI12-0175 Preelaborable packages with address clauses 2020-06-12 Eric Botcazou 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. --- gcc/ada/rtsfind.ads | 1 + gcc/ada/sem_elab.adb | 80 +++++++++++++++++++++++++++++++++++----------- gcc/ada/sem_util.adb | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sinfo.adb | 16 ++++++++++ gcc/ada/sinfo.ads | 13 ++++++++ 5 files changed, 181 insertions(+), 19 deletions(-) diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index df98023..ad113fd 100644 --- 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 0fa3d14..8aa1ca7 100644 --- 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 + ("<= 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 - ("< + 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 f6e70c1..642e859 100644 --- 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 ea4f8ed..d0739b8 100644 --- 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); -- 2.7.4