We want to favor large static aggregate at library level, but within
subprograms, we want to favor loops instead when relevant.
As part of this work we uncovered a missing freeze on allocator subtype
marks showing up with this change, as well as the need to generate
predicate checks within init procs when the expression involved is not
compiler generated.
Tested on x86_64-pc-linux-gnu, committed on trunk
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.diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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));
