From 152f64c2c6c31b6574258312c867e15703add0fd Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 2 Mar 2020 08:43:20 -0500 Subject: [PATCH] [Ada] Use small limit for aggregates inside subprograms gcc/ada/ * exp_aggr.adb (Max_Aggregate_Size): Use small limit for aggregate inside subprograms. * sprint.adb (Sprint_Node_Actual [N_Object_Declaration]): Do not print the initialization expression if the No_Initialization flag is set. * sem_util.ads, sem_util.adb (Predicate_Enabled): New. * exp_ch4.adb (Expand_N_Type_Conversion): Code cleanup and apply predicate check consistently. * exp_ch6.adb (Expand_Actuals.By_Ref_Predicate_Check): Ditto. * sem_ch3.adb (Analyze_Object_Declaration): Ditto. * exp_ch3.adb (Build_Assignment): Revert handling of predicate check for allocators with qualified expressions, now handled in Freeze_Expression directly. * sem_aggr.adb: Fix typos. * checks.adb: Code refactoring: use Predicate_Enabled. (Apply_Predicate_Check): Code cleanup. * freeze.adb (Freeze_Expression): Freeze the subtype mark before a qualified expression on an allocator. * exp_util.ads, exp_util.adb (Within_Internal_Subprogram): Renamed Predicate_Check_In_Scope to clarify usage, refine handling of predicates within init procs which should be enabled when the node comes from source. * sem_ch13.adb (Freeze_Entity_Checks): Update call to Predicate_Check_In_Scope. --- gcc/ada/checks.adb | 235 +++++++++++++++++++++---------------------- gcc/ada/exp_aggr.adb | 6 ++ gcc/ada/exp_ch3.adb | 20 +--- gcc/ada/exp_ch4.adb | 13 ++- gcc/ada/exp_ch6.adb | 3 +- gcc/ada/exp_util.adb | 36 ++++--- gcc/ada/exp_util.ads | 10 +- gcc/ada/freeze.adb | 15 +++ gcc/ada/sem_aggr.adb | 4 +- gcc/ada/sem_ch13.adb | 8 +- gcc/ada/sem_ch3.adb | 3 +- gcc/ada/sem_util.adb | 11 ++ gcc/ada/sem_util.ads | 5 + gcc/ada/sprint.adb | 1 + 14 files changed, 196 insertions(+), 174 deletions(-) diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 2f6760067c4..46a878e7e38 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2746,153 +2746,146 @@ package body Checks is S : Entity_Id; begin - if Predicate_Checks_Suppressed (Empty) then - return; - - elsif Predicates_Ignored (Typ) then + if not Predicate_Enabled (Typ) + or else not Predicate_Check_In_Scope (N) + then return; + end if; - elsif Present (Predicate_Function (Typ)) then - S := Current_Scope; - while Present (S) and then not Is_Subprogram (S) loop - S := Scope (S); - end loop; - - -- A predicate check does not apply within internally generated - -- subprograms, such as TSS functions. + S := Current_Scope; + while Present (S) and then not Is_Subprogram (S) loop + S := Scope (S); + end loop; - if Within_Internal_Subprogram then - return; + -- If the check appears within the predicate function itself, it means + -- that the user specified a check whose formal is the predicated + -- subtype itself, rather than some covering type. This is likely to be + -- a common error, and thus deserves a warning. - -- If the check appears within the predicate function itself, it - -- means that the user specified a check whose formal is the - -- predicated subtype itself, rather than some covering type. This - -- is likely to be a common error, and thus deserves a warning. + if Present (S) and then S = Predicate_Function (Typ) then + Error_Msg_NE + ("predicate check includes a call to& that requires a " + & "predicate check??", Parent (N), Fun); + Error_Msg_N + ("\this will result in infinite recursion??", Parent (N)); - elsif Present (S) and then S = Predicate_Function (Typ) then + if Is_First_Subtype (Typ) then Error_Msg_NE - ("predicate check includes a call to& that requires a " - & "predicate check??", Parent (N), Fun); - Error_Msg_N - ("\this will result in infinite recursion??", Parent (N)); + ("\use an explicit subtype of& to carry the predicate", + Parent (N), Typ); + end if; - if Is_First_Subtype (Typ) then - Error_Msg_NE - ("\use an explicit subtype of& to carry the predicate", - Parent (N), Typ); - end if; + Insert_Action (N, + Make_Raise_Storage_Error (Sloc (N), + Reason => SE_Infinite_Recursion)); + return; + end if; - Insert_Action (N, - Make_Raise_Storage_Error (Sloc (N), - Reason => SE_Infinite_Recursion)); + -- Normal case of predicate active - -- Here for normal case of predicate active + -- If the expression is an IN parameter, the predicate will have + -- been applied at the point of call. An additional check would + -- be redundant, or will lead to out-of-scope references if the + -- call appears within an aspect specification for a precondition. - else - -- If the expression is an IN parameter, the predicate will have - -- been applied at the point of call. An additional check would - -- be redundant, or will lead to out-of-scope references if the - -- call appears within an aspect specification for a precondition. - - -- However, if the reference is within the body of the subprogram - -- that declares the formal, the predicate can safely be applied, - -- which may be necessary for a nested call whose formal has a - -- different predicate. - - if Is_Entity_Name (N) - and then Ekind (Entity (N)) = E_In_Parameter - then - declare - In_Body : Boolean := False; - P : Node_Id := Parent (N); + -- However, if the reference is within the body of the subprogram + -- that declares the formal, the predicate can safely be applied, + -- which may be necessary for a nested call whose formal has a + -- different predicate. - begin - while Present (P) loop - if Nkind (P) = N_Subprogram_Body - and then - ((Present (Corresponding_Spec (P)) - and then - Corresponding_Spec (P) = Scope (Entity (N))) - or else - Defining_Unit_Name (Specification (P)) = - Scope (Entity (N))) - then - In_Body := True; - exit; - end if; + if Is_Entity_Name (N) + and then Ekind (Entity (N)) = E_In_Parameter + then + declare + In_Body : Boolean := False; + P : Node_Id := Parent (N); - P := Parent (P); - end loop; + begin + while Present (P) loop + if Nkind (P) = N_Subprogram_Body + and then + ((Present (Corresponding_Spec (P)) + and then + Corresponding_Spec (P) = Scope (Entity (N))) + or else + Defining_Unit_Name (Specification (P)) = + Scope (Entity (N))) + then + In_Body := True; + exit; + end if; - if not In_Body then - return; - end if; - end; + P := Parent (P); + end loop; + + if not In_Body then + return; end if; + end; + end if; - -- If the type has a static predicate and the expression is known - -- at compile time, see if the expression satisfies the predicate. + -- If the type has a static predicate and the expression is known + -- at compile time, see if the expression satisfies the predicate. - Check_Expression_Against_Static_Predicate (N, Typ); + Check_Expression_Against_Static_Predicate (N, Typ); - if not Expander_Active then - return; - end if; + if not Expander_Active then + return; + end if; - Par := Parent (N); - if Nkind (Par) = N_Qualified_Expression then - Par := Parent (Par); - end if; + Par := Parent (N); + if Nkind (Par) = N_Qualified_Expression then + Par := Parent (Par); + end if; - -- For an entity of the type, generate a call to the predicate - -- function, unless its type is an actual subtype, which is not - -- visible outside of the enclosing subprogram. + -- For an entity of the type, generate a call to the predicate + -- function, unless its type is an actual subtype, which is not + -- visible outside of the enclosing subprogram. - if Is_Entity_Name (N) - and then not Is_Actual_Subtype (Typ) - then - Insert_Action (N, - Make_Predicate_Check - (Typ, New_Occurrence_Of (Entity (N), Sloc (N)))); - - -- If the expression is an aggregate in an assignment, apply the - -- check to the LHS after the assignment, rather than create a - -- redundant temporary. This is only necessary in rare cases - -- of array types (including strings) initialized with an - -- aggregate with an "others" clause, either coming from source - -- or generated by an Initialize_Scalars pragma. - - elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) - and then Nkind (Par) = N_Assignment_Statement - then - Insert_Action_After (Par, - Make_Predicate_Check - (Typ, Duplicate_Subexpr (Name (Par)))); + if Is_Entity_Name (N) + and then not Is_Actual_Subtype (Typ) + then + Insert_Action (N, + Make_Predicate_Check + (Typ, New_Occurrence_Of (Entity (N), Sloc (N)))); + return; - -- Similarly, if the expression is an aggregate in an object - -- declaration, apply it to the object after the declaration. - -- This is only necessary in rare cases of tagged extensions - -- initialized with an aggregate with an "others => <>" clause. + elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then - elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) - and then Nkind (Par) = N_Object_Declaration - then - Insert_Action_After (Par, - Make_Predicate_Check (Typ, - New_Occurrence_Of (Defining_Identifier (Par), Sloc (N)))); + -- If the expression is an aggregate in an assignment, apply the + -- check to the LHS after the assignment, rather than create a + -- redundant temporary. This is only necessary in rare cases + -- of array types (including strings) initialized with an + -- aggregate with an "others" clause, either coming from source + -- or generated by an Initialize_Scalars pragma. - -- If the expression is not an entity it may have side effects, - -- and the following call will create an object declaration for - -- it. We disable checks during its analysis, to prevent an - -- infinite recursion. + if Nkind (Par) = N_Assignment_Statement then + Insert_Action_After (Par, + Make_Predicate_Check + (Typ, Duplicate_Subexpr (Name (Par)))); + return; - else - Insert_Action (N, - Make_Predicate_Check - (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks); - end if; + -- Similarly, if the expression is an aggregate in an object + -- declaration, apply it to the object after the declaration. + -- This is only necessary in rare cases of tagged extensions + -- initialized with an aggregate with an "others => <>" clause. + + elsif Nkind (Par) = N_Object_Declaration then + Insert_Action_After (Par, + Make_Predicate_Check (Typ, + New_Occurrence_Of (Defining_Identifier (Par), Sloc (N)))); + return; end if; end if; + + -- If the expression is not an entity it may have side effects, + -- and the following call will create an object declaration for + -- it. We disable checks during its analysis, to prevent an + -- infinite recursion. + + Insert_Action (N, + Make_Predicate_Check + (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks); end Apply_Predicate_Check; ----------------------- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index eb5cc29e44f..7a6b5b9ad16 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -8181,6 +8181,10 @@ package body Exp_Aggr is -- if components are static it is much more efficient to construct a -- one-dimensional equivalent array with static components. + -- Finally we also use a small limit when we're within a subprogram + -- since we want to favor loops (potentially transformed to memset + -- calls) in this context. + if CodePeer_Mode then return 100; elsif Restriction_Active (No_Elaboration_Code) @@ -8190,6 +8194,8 @@ package body Exp_Aggr is and then Static_Elaboration_Desired (Current_Scope)) then return 2 ** 24; + elsif Ekind (Current_Scope) in Subprogram_Kind then + return 64; else return Default_Size; end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index fb23931ae63..3402a087b6c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2061,27 +2061,11 @@ package body Exp_Ch3 is -- which provides for a better error message. if Comes_From_Source (Exp) - and then Has_Predicates (Typ) - and then not Predicate_Checks_Suppressed (Empty) - and then not Predicates_Ignored (Typ) + and then Predicate_Enabled (Typ) then Append (Make_Predicate_Check (Typ, Exp), Res); end if; - if Nkind (Exp) = N_Allocator - and then Nkind (Expression (Exp)) = N_Qualified_Expression - then - declare - Subtype_Entity : constant Entity_Id - := Entity (Subtype_Mark (Expression (Exp))); - begin - if Has_Predicates (Subtype_Entity) then - Append (Make_Predicate_Check - (Subtype_Entity, Expression (Expression (Exp))), Res); - end if; - end; - end if; - return Res; exception @@ -8350,7 +8334,7 @@ package body Exp_Ch3 is -- subtypes to which these checks do not apply. elsif Has_Invariants (Def_Id) then - if Within_Internal_Subprogram + if not Predicate_Check_In_Scope (Def_Id) or else (Ekind (Current_Scope) = E_Function and then Is_Predicate_Function (Current_Scope)) then diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e3af266f551..dbf3e3bef6b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -12506,8 +12506,7 @@ package body Exp_Ch4 is -- guard is necessary to prevent infinite recursions when we generate -- internal conversions for the purpose of checking predicates. - if Present (Predicate_Function (Target_Type)) - and then not Predicates_Ignored (Target_Type) + if Predicate_Enabled (Target_Type) and then Target_Type /= Operand_Type and then Comes_From_Source (N) then @@ -12515,14 +12514,14 @@ package body Exp_Ch4 is New_Expr : constant Node_Id := Duplicate_Subexpr (N); begin - -- Avoid infinite recursion on the subsequent expansion of - -- of the copy of the original type conversion. When needed, - -- a range check has already been applied to the expression. + -- Avoid infinite recursion on the subsequent expansion of the + -- copy of the original type conversion. When needed, a range + -- check has already been applied to the expression. Set_Comes_From_Source (New_Expr, False); Insert_Action (N, - Make_Predicate_Check (Target_Type, New_Expr), - Suppress => Range_Check); + Make_Predicate_Check (Target_Type, New_Expr), + Suppress => Range_Check); end; end if; end Expand_N_Type_Conversion; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 329f3b53a9c..076bbbae0de 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2472,8 +2472,7 @@ package body Exp_Ch6 is Atyp := Aund; end if; - if Has_Predicates (Atyp) - and then Present (Predicate_Function (Atyp)) + if Predicate_Enabled (Atyp) -- Skip predicate checks for special cases diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 236d9ce6158..27609c78363 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9681,10 +9681,9 @@ package body Exp_Util is return Make_Null_Statement (Loc); end if; - -- Do not generate a check within an internal subprogram (stream - -- functions and the like, including predicate functions). + -- Do not generate a check within stream functions and the like. - if Within_Internal_Subprogram then + if not Predicate_Check_In_Scope (Expr) then return Make_Null_Statement (Loc); end if; @@ -13715,11 +13714,11 @@ package body Exp_Util is return False; end Within_Case_Or_If_Expression; - -------------------------------- - -- Within_Internal_Subprogram -- - -------------------------------- + ------------------------------ + -- Predicate_Check_In_Scope -- + ------------------------------ - function Within_Internal_Subprogram return Boolean is + function Predicate_Check_In_Scope (N : Node_Id) return Boolean is S : Entity_Id; begin @@ -13728,10 +13727,23 @@ package body Exp_Util is S := Scope (S); end loop; - return Present (S) - and then Get_TSS_Name (S) /= TSS_Null - and then not Is_Predicate_Function (S) - and then not Is_Predicate_Function_M (S); - end Within_Internal_Subprogram; + if Present (S) then + + -- Predicate checks should only be enabled in init procs for + -- expressions coming from source. + + if Is_Init_Proc (S) then + return Comes_From_Source (N); + + elsif Get_TSS_Name (S) /= TSS_Null + and then not Is_Predicate_Function (S) + and then not Is_Predicate_Function_M (S) + then + return False; + end if; + end if; + + return True; + end Predicate_Check_In_Scope; end Exp_Util; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index c0a7e9e3fa8..3f882a6f315 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -1195,12 +1195,10 @@ package Exp_Util is function Within_Case_Or_If_Expression (N : Node_Id) return Boolean; -- Determine whether arbitrary node N is within a case or an if expression - function Within_Internal_Subprogram return Boolean; - -- Indicates that some expansion is taking place within the body of a - -- predefined primitive operation. Some expansion activity (e.g. predicate - -- checks) is disabled in such. Because we want to detect invalid uses - -- of function calls within predicates (which lead to infinite recursion) - -- predicate functions themselves are not considered internal here. + function Predicate_Check_In_Scope (N : Node_Id) return Boolean; + -- Return True if predicate checks should be generated in the current + -- scope on the given node. Will return False for example when the current + -- scope is a predefined primitive operation. private pragma Inline (Duplicate_Subexpr); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 65377ca36a8..b24e9172260 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -7182,6 +7182,8 @@ package body Freeze is Parent_P : Node_Id; Typ : Entity_Id; + Allocator_Typ : Entity_Id := Empty; + Freeze_Outside : Boolean := False; -- This flag is set true if the entity must be frozen outside the -- current subprogram. This happens in the case of expander generated @@ -7292,6 +7294,10 @@ package body Freeze is when N_Allocator => Desig_Typ := Designated_Type (Etype (N)); + if Nkind (Expression (N)) = N_Qualified_Expression then + Allocator_Typ := Entity (Subtype_Mark (Expression (N))); + end if; + when N_Aggregate => if Is_Array_Type (Etype (N)) and then Is_Access_Type (Component_Type (Etype (N))) @@ -7334,6 +7340,7 @@ package body Freeze is if No (Typ) and then No (Nam) and then No (Desig_Typ) + and then No (Allocator_Typ) then return; end if; @@ -7803,6 +7810,14 @@ package body Freeze is In_Spec_Expression := False; + -- Freeze the subtype mark before a qualified expression on an + -- allocator as per AARM 13.14(4.a). This is needed in particular to + -- generate predicate functions. + + if Present (Allocator_Typ) then + Freeze_Before (P, Allocator_Typ); + end if; + -- Freeze the designated type of an allocator (RM 13.14(13)) if Present (Desig_Typ) then diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index ffe2ae66a77..2e728464dff 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1499,7 +1499,7 @@ package body Sem_Aggr is -- If an aggregate component has a type with predicates, an explicit -- predicate check must be applied, as for an assignment statement, - -- because the aggegate might not be expanded into individual + -- because the aggregate might not be expanded into individual -- component assignments. If the expression covers several components -- the analysis and the predicate check take place later. @@ -4105,7 +4105,7 @@ package body Sem_Aggr is -- If an aggregate component has a type with predicates, an explicit -- predicate check must be applied, as for an assignment statement, - -- because the aggegate might not be expanded into individual + -- because the aggregate might not be expanded into individual -- component assignments. if Has_Predicates (Expr_Type) diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index c6a177d21b3..0351a0f1427 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -12308,16 +12308,16 @@ package body Sem_Ch13 is Inside_Freezing_Actions := Inside_Freezing_Actions - 1; -- If we have a type with predicates, build predicate function. This is - -- not needed in the generic case, nor within TSS subprograms and other - -- predefined primitives. For a derived type, ensure that the parent - -- type is already frozen so that its predicate function has been + -- not needed in the generic case, nor within e.g. TSS subprograms and + -- other predefined primitives. For a derived type, ensure that the + -- parent type is already frozen so that its predicate function has been -- constructed already. This is necessary if the parent is declared -- in a nested package and its own freeze point has not been reached. if Is_Type (E) and then Nongeneric_Case - and then not Within_Internal_Subprogram and then Has_Predicates (E) + and then Predicate_Check_In_Scope (N) then declare Atyp : constant Entity_Id := Nearest_Ancestor (E); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 68bb5fcd503..3907272c31a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4418,8 +4418,7 @@ package body Sem_Ch3 is -- the predicate still applies. if not Suppress_Assignment_Checks (N) - and then Present (Predicate_Function (T)) - and then not Predicates_Ignored (T) + and then Predicate_Enabled (T) and then (not No_Initialization (N) or else (Present (E) and then Nkind (E) = N_Aggregate)) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b88f6f7fb3c..6c2a4992cf6 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -24807,6 +24807,17 @@ package body Sem_Util is return Kind; end Policy_In_Effect; + ----------------------- + -- Predicate_Enabled -- + ----------------------- + + function Predicate_Enabled (Typ : Entity_Id) return Boolean is + begin + return Present (Predicate_Function (Typ)) + and then not Predicates_Ignored (Typ) + and then not Predicate_Checks_Suppressed (Empty); + end Predicate_Enabled; + ---------------------------------- -- Predicate_Tests_On_Arguments -- ---------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 79a6a21b284..017a42a45e0 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2601,6 +2601,11 @@ package Sem_Util is -- Given a policy, return the policy identifier associated with it. If no -- such policy is in effect, the value returned is No_Name. + function Predicate_Enabled (Typ : Entity_Id) return Boolean; + -- Return True if a predicate check should be emitted for the given type + -- Typ, taking into account Predicates_Ignored and + -- Predicate_Checks_Suppressed. + function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean; -- Subp is the entity for a subprogram call. This function returns True if -- predicate tests are required for the arguments in this call (this is the diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 7bfa5017019..8fc91fdc39f 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -2391,6 +2391,7 @@ package body Sprint is if Present (Expression (Node)) and then Expression (Node) /= Error + and then not No_Initialization (Node) then Write_Str (" := "); Sprint_Node (Expression (Node)); -- 2.30.2