This patch reimplements the "freezing of contracts" semantic because it caused
a quadratic exlosion in the number of subprogram bodies in declarative lists.
The "freezing of constracts" semantic is carried out when an entry, package,
protected, subprogram [stub], or task body is processed.
Prior to the patch, the semantic would analyze the contracts of all eligible
constructs within the same list as the freezing body, upto that body. This
approach would result in the exact same constructs being reanalyzed as each
new freezing body is seen, thus causing a quadratic explostion.
The patch changes the freezing mechanism to perform the freezing in reverse
declarative order, starting from the freezing body. Once the declarative list
is exhausted, or another freezing body is encountered, the processing stops.
This keeps the amount of contract freezing linear with respect to the number
of freezing bodies.
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-11-09 Hristian Kirtchev <kirtc...@adacore.com>
* contracts.adb (Analyze_Contracts): Remove the three parameter
version. This routine now only analyzes contracts and does not perform
any freezing actions.
(Analyze_Previous_Contracts): Removed.
(Freeze_Previous_Contracts): New routine.
* contracts.ads (Analyze_Previous_Contracts): Removed.
(Freeze_Previous_Contracts): New routine.
* sem_ch3.adb (Analyze_Declarations): Analyze the contract of an
enclosing package spec regardless of whether the list denotes the
visible or private declarations. Fix the removal of partial state
refinements when the context is a package spec.
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Freeze previous
contracts.
* sem_ch7.adb (Analyze_Package_Body_Helper): Freeze previous contracts.
* sem_ch9.adb (Analyze_Entry_Body): Freeze previous contracts.
(Analyze_Protected_Body): Freeze previous contracts.
(Analyze_Task_Body): Freeze previous contracts.
* sem_prag.adb: Comment reformatting.
Index: contracts.adb
===================================================================
--- contracts.adb (revision 254579)
+++ contracts.adb (revision 254580)
@@ -53,16 +53,6 @@
package body Contracts is
- procedure Analyze_Contracts
- (L : List_Id;
- Freeze_Nod : Node_Id;
- Freeze_Id : Entity_Id);
- -- Subsidiary to the one parameter version of Analyze_Contracts and routine
- -- Analyze_Previous_Constracts. Analyze the contracts of all constructs in
- -- the list L. If Freeze_Nod is set, then the analysis stops when the node
- -- is reached. Freeze_Id is the entity of some related context which caused
- -- freezing up to node Freeze_Nod.
-
procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id);
-- (CodePeer): Subsidiary procedure to Analyze_Contracts which builds the
-- contract-only subprogram body of eligible subprograms found in L, adds
@@ -351,32 +341,16 @@
-----------------------
procedure Analyze_Contracts (L : List_Id) is
+ Decl : Node_Id;
+
begin
if CodePeer_Mode and then Debug_Flag_Dot_KK then
Build_And_Analyze_Contract_Only_Subprograms (L);
end if;
- Analyze_Contracts (L, Freeze_Nod => Empty, Freeze_Id => Empty);
- end Analyze_Contracts;
-
- procedure Analyze_Contracts
- (L : List_Id;
- Freeze_Nod : Node_Id;
- Freeze_Id : Entity_Id)
- is
- Decl : Node_Id;
-
- begin
Decl := First (L);
while Present (Decl) loop
- -- The caller requests that the traversal stops at a particular node
- -- that causes contract "freezing".
-
- if Present (Freeze_Nod) and then Decl = Freeze_Nod then
- exit;
- end if;
-
-- Entry or subprogram declarations
if Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
@@ -388,7 +362,7 @@
Subp_Id : constant Entity_Id := Defining_Entity (Decl);
begin
- Analyze_Entry_Or_Subprogram_Contract (Subp_Id, Freeze_Id);
+ Analyze_Entry_Or_Subprogram_Contract (Subp_Id);
-- If analysis of a class-wide pre/postcondition indicates
-- that a class-wide clone is needed, analyze its declaration
@@ -410,9 +384,7 @@
-- Objects
elsif Nkind (Decl) = N_Object_Declaration then
- Analyze_Object_Contract
- (Obj_Id => Defining_Entity (Decl),
- Freeze_Id => Freeze_Id);
+ Analyze_Object_Contract (Defining_Entity (Decl));
-- Protected units
@@ -433,8 +405,9 @@
then
Analyze_Task_Contract (Defining_Entity (Decl));
- -- For type declarations, we need to do the pre-analysis of
- -- Iterable aspect specifications.
+ -- For type declarations, we need to do the pre-analysis of Iterable
+ -- aspect specifications.
+
-- Other type aspects need to be resolved here???
elsif Nkind (Decl) = N_Private_Type_Declaration
@@ -443,6 +416,7 @@
declare
E : constant Entity_Id := Defining_Identifier (Decl);
It : constant Node_Id := Find_Aspect (E, Aspect_Iterable);
+
begin
if Present (It) then
Validate_Iterable_Aspect (E, It);
@@ -1127,76 +1101,6 @@
end Analyze_Package_Contract;
--------------------------------
- -- Analyze_Previous_Contracts --
- --------------------------------
-
- procedure Analyze_Previous_Contracts (Body_Decl : Node_Id) is
- Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
- Orig_Decl : constant Node_Id := Original_Node (Body_Decl);
-
- Par : Node_Id;
-
- begin
- -- A body that is in the process of being inlined appears from source,
- -- but carries name _parent. Such a body does not cause "freezing" of
- -- contracts.
-
- if Chars (Body_Id) = Name_uParent then
- return;
- end if;
-
- -- Climb the parent chain looking for an enclosing package body. Do not
- -- use the scope stack, as a body uses the entity of its corresponding
- -- spec.
-
- Par := Parent (Body_Decl);
- while Present (Par) loop
- if Nkind (Par) = N_Package_Body then
- Analyze_Package_Body_Contract
- (Body_Id => Defining_Entity (Par),
- Freeze_Id => Defining_Entity (Body_Decl));
-
- exit;
-
- -- Do not look for an enclosing package body when the construct which
- -- causes freezing is a body generated for an expression function and
- -- it appears within a package spec. This ensures that the traversal
- -- will not reach too far up the parent chain and attempt to freeze a
- -- package body which should not be frozen.
-
- -- package body Enclosing_Body
- -- with Refined_State => (State => Var)
- -- is
- -- package Nested is
- -- type Some_Type is ...;
- -- function Cause_Freezing return ...;
- -- private
- -- function Cause_Freezing is (...);
- -- end Nested;
- --
- -- Var : Nested.Some_Type;
-
- elsif Nkind (Par) = N_Package_Declaration
- and then Nkind (Orig_Decl) = N_Expression_Function
- then
- exit;
- end if;
-
- Par := Parent (Par);
- end loop;
-
- -- Analyze the contracts of all eligible construct up to the body which
- -- caused the "freezing".
-
- if Is_List_Member (Body_Decl) then
- Analyze_Contracts
- (L => List_Containing (Body_Decl),
- Freeze_Nod => Body_Decl,
- Freeze_Id => Body_Id);
- end if;
- end Analyze_Previous_Contracts;
-
- --------------------------------
-- Analyze_Protected_Contract --
--------------------------------
@@ -3097,6 +3001,187 @@
end if;
end Expand_Subprogram_Contract;
+ -------------------------------
+ -- Freeze_Previous_Contracts --
+ -------------------------------
+
+ procedure Freeze_Previous_Contracts (Body_Decl : Node_Id) is
+ function Causes_Contract_Freezing (N : Node_Id) return Boolean;
+ pragma Inline (Causes_Contract_Freezing);
+ -- Determine whether arbitrary node N causes contract freezing
+
+ procedure Freeze_Contracts;
+ pragma Inline (Freeze_Contracts);
+ -- Freeze the contracts of all eligible constructs which precede body
+ -- Body_Decl.
+
+ procedure Freeze_Enclosing_Package_Body;
+ pragma Inline (Freeze_Enclosing_Package_Body);
+ -- Freeze the contract of the nearest package body (if any) which
+ -- encloses body Body_Decl.
+
+ ------------------------------
+ -- Causes_Contract_Freezing --
+ ------------------------------
+
+ function Causes_Contract_Freezing (N : Node_Id) return Boolean is
+ begin
+ return Nkind_In (N, N_Entry_Body,
+ N_Package_Body,
+ N_Protected_Body,
+ N_Subprogram_Body,
+ N_Subprogram_Body_Stub,
+ N_Task_Body);
+ end Causes_Contract_Freezing;
+
+ ----------------------
+ -- Freeze_Contracts --
+ ----------------------
+
+ procedure Freeze_Contracts is
+ Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
+ Decl : Node_Id;
+
+ begin
+ -- Nothing to do when the body which causes freezing does not appear
+ -- in a declarative list because there cannot possibly be constructs
+ -- with contracts.
+
+ if not Is_List_Member (Body_Decl) then
+ return;
+ end if;
+
+ -- Inspect the declarations preceding the body, and freeze individual
+ -- contracts of eligible constructs.
+
+ Decl := Prev (Body_Decl);
+ while Present (Decl) loop
+
+ -- Stop the traversal when a preceding construct that causes
+ -- freezing is encountered as there is no point in refreezing
+ -- the already frozen constructs.
+
+ if Causes_Contract_Freezing (Decl) then
+ exit;
+
+ -- Entry or subprogram declarations
+
+ elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
+ N_Entry_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Subprogram_Declaration)
+ then
+ Analyze_Entry_Or_Subprogram_Contract
+ (Subp_Id => Defining_Entity (Decl),
+ Freeze_Id => Body_Id);
+
+ -- Objects
+
+ elsif Nkind (Decl) = N_Object_Declaration then
+ Analyze_Object_Contract
+ (Obj_Id => Defining_Entity (Decl),
+ Freeze_Id => Body_Id);
+
+ -- Protected units
+
+ elsif Nkind_In (Decl, N_Protected_Type_Declaration,
+ N_Single_Protected_Declaration)
+ then
+ Analyze_Protected_Contract (Defining_Entity (Decl));
+
+ -- Subprogram body stubs
+
+ elsif Nkind (Decl) = N_Subprogram_Body_Stub then
+ Analyze_Subprogram_Body_Stub_Contract (Defining_Entity (Decl));
+
+ -- Task units
+
+ elsif Nkind_In (Decl, N_Single_Task_Declaration,
+ N_Task_Type_Declaration)
+ then
+ Analyze_Task_Contract (Defining_Entity (Decl));
+ end if;
+
+ Prev (Decl);
+ end loop;
+ end Freeze_Contracts;
+
+ -----------------------------------
+ -- Freeze_Enclosing_Package_Body --
+ -----------------------------------
+
+ procedure Freeze_Enclosing_Package_Body is
+ Orig_Decl : constant Node_Id := Original_Node (Body_Decl);
+ Par : Node_Id;
+
+ begin
+ -- Climb the parent chain looking for an enclosing package body. Do
+ -- not use the scope stack, because a body utilizes the entity of its
+ -- corresponding spec.
+
+ Par := Parent (Body_Decl);
+ while Present (Par) loop
+ if Nkind (Par) = N_Package_Body then
+ Analyze_Package_Body_Contract
+ (Body_Id => Defining_Entity (Par),
+ Freeze_Id => Defining_Entity (Body_Decl));
+
+ exit;
+
+ -- Do not look for an enclosing package body when the construct
+ -- which causes freezing is a body generated for an expression
+ -- function and it appears within a package spec. This ensures
+ -- that the traversal will not reach too far up the parent chain
+ -- and attempt to freeze a package body which must not be frozen.
+
+ -- package body Enclosing_Body
+ -- with Refined_State => (State => Var)
+ -- is
+ -- package Nested is
+ -- type Some_Type is ...;
+ -- function Cause_Freezing return ...;
+ -- private
+ -- function Cause_Freezing is (...);
+ -- end Nested;
+ --
+ -- Var : Nested.Some_Type;
+
+ elsif Nkind (Par) = N_Package_Declaration
+ and then Nkind (Orig_Decl) = N_Expression_Function
+ then
+ exit;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+ end Freeze_Enclosing_Package_Body;
+
+ -- Local variables
+
+ Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
+
+ -- Start of processing for Freeze_Previous_Contracts
+
+ begin
+ pragma Assert (Causes_Contract_Freezing (Body_Decl));
+
+ -- A body that is in the process of being inlined appears from source,
+ -- but carries name _parent. Such a body does not cause freezing of
+ -- contracts.
+
+ if Chars (Body_Id) = Name_uParent then
+ return;
+ end if;
+
+ Freeze_Enclosing_Package_Body;
+ Freeze_Contracts;
+ end Freeze_Previous_Contracts;
+
---------------------------------
-- Inherit_Subprogram_Contract --
---------------------------------
Index: contracts.ads
===================================================================
--- contracts.ads (revision 254579)
+++ contracts.ads (revision 254580)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2015-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -128,12 +128,6 @@
-- Initializes
-- Part_Of
- procedure Analyze_Previous_Contracts (Body_Decl : Node_Id);
- -- Analyze the contracts of all source constructs found in the declarative
- -- list which contains entry, package, protected, subprogram, or task body
- -- denoted by Body_Decl. The analysis stops once Body_Decl is reached. In
- -- addition, analyze the contract of the nearest enclosing package body.
-
procedure Analyze_Protected_Contract (Prot_Id : Entity_Id);
-- Analyze all delayed pragmas chained on the contract of protected unit
-- Prot_Id if they appeared at the end of a declarative region. Currently
@@ -165,6 +159,12 @@
-- generic body denoted by Unit by collecting all source contract-related
-- pragmas in the contract of the unit.
+ procedure Freeze_Previous_Contracts (Body_Decl : Node_Id);
+ -- Freeze the contracts of all source constructs found in the declarative
+ -- list which contains entry, package, protected, subprogram, or task body
+ -- denoted by Body_Decl. In addition, freeze the contract of the nearest
+ -- enclosing package body.
+
procedure Inherit_Subprogram_Contract
(Subp : Entity_Id;
From_Subp : Entity_Id);
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 254579)
+++ sem_ch3.adb (revision 254580)
@@ -2818,19 +2818,23 @@
if Present (L) then
Context := Parent (L);
- -- Analyze the contracts of packages and their bodies
+ -- Certain contract annocations have forward visibility semantics and
+ -- must be analyzed after all declarative items have been processed.
+ -- This timing ensures that entities referenced by such contracts are
+ -- visible.
- if Nkind (Context) = N_Package_Specification
- and then L = Visible_Declarations (Context)
- then
- Analyze_Package_Contract (Defining_Entity (Context));
+ -- Analyze the contract of an immediately enclosing package spec or
+ -- body first because other contracts may depend on its information.
- elsif Nkind (Context) = N_Package_Body then
+ if Nkind (Context) = N_Package_Body then
Analyze_Package_Body_Contract (Defining_Entity (Context));
+
+ elsif Nkind (Context) = N_Package_Specification then
+ Analyze_Package_Contract (Defining_Entity (Context));
end if;
- -- Analyze the contracts of various constructs now due to the delayed
- -- visibility needs of their aspects and pragmas.
+ -- Analyze the contracts of various constructs in the declarative
+ -- list.
Analyze_Contracts (L);
@@ -2848,13 +2852,13 @@
Remove_Visible_Refinements (Corresponding_Spec (Context));
Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
- elsif Nkind (Context) = N_Package_Declaration then
+ elsif Nkind (Context) = N_Package_Specification then
-- Partial state refinements are visible up to the end of the
-- package spec declarations. Hide the partial state refinements
-- from visibility to restore the original state conditions.
- Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
+ Remove_Partial_Visible_Refinements (Defining_Entity (Context));
end if;
-- Verify that all abstract states found in any package declared in
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 254579)
+++ sem_ch6.adb (revision 254580)
@@ -3460,7 +3460,7 @@
-- Start of processing for Analyze_Subprogram_Body_Helper
begin
- -- A [generic] subprogram body "freezes" the contract of the nearest
+ -- A [generic] subprogram body freezes the contract of the nearest
-- enclosing package body and all other contracts encountered in the
-- same declarative part up to and excluding the subprogram body:
@@ -3473,17 +3473,17 @@
-- with Refined_Depends => (Input => Constit) ...
-- This ensures that any annotations referenced by the contract of the
- -- [generic] subprogram body are available. This form of "freezing" is
+ -- [generic] subprogram body are available. This form of freezing is
-- decoupled from the usual Freeze_xxx mechanism because it must also
-- work in the context of generics where normal freezing is disabled.
- -- Only bodies coming from source should cause this type of "freezing".
+ -- Only bodies coming from source should cause this type of freezing.
-- Expression functions that act as bodies and complete an initial
-- declaration must be included in this category, hence the use of
-- Original_Node.
if Comes_From_Source (Original_Node (N)) then
- Analyze_Previous_Contracts (N);
+ Freeze_Previous_Contracts (N);
end if;
-- Generic subprograms are handled separately. They always have a
@@ -4358,7 +4358,7 @@
end if;
end if;
- -- A subprogram body "freezes" its own contract. Analyze the contract
+ -- A subprogram body freezes its own contract. Analyze the contract
-- after the declarations of the body have been processed as pragmas
-- are now chained on the contract of the subprogram body.
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb (revision 254579)
+++ sem_ch7.adb (revision 254580)
@@ -707,9 +707,9 @@
end if;
end if;
- -- A [generic] package body "freezes" the contract of the nearest
- -- enclosing package body and all other contracts encountered in the
- -- same declarative part up to and excluding the package body:
+ -- A [generic] package body freezes the contract of the nearest
+ -- enclosing package body and all other contracts encountered in
+ -- the same declarative part up to and excluding the package body:
-- package body Nearest_Enclosing_Package
-- with Refined_State => (State => Constit)
@@ -726,21 +726,21 @@
-- This ensures that any annotations referenced by the contract of a
-- [generic] subprogram body declared within the current package body
- -- are available. This form of "freezing" is decoupled from the usual
+ -- are available. This form of freezing is decoupled from the usual
-- Freeze_xxx mechanism because it must also work in the context of
-- generics where normal freezing is disabled.
- -- Only bodies coming from source should cause this type of "freezing".
+ -- Only bodies coming from source should cause this type of freezing.
-- Instantiated generic bodies are excluded because their processing is
-- performed in a separate compilation pass which lacks enough semantic
-- information with respect to contract analysis. It is safe to suppress
- -- the "freezing" of contracts in this case because this action already
+ -- the freezing of contracts in this case because this action already
-- took place at the end of the enclosing declarative part.
if Comes_From_Source (N)
and then not Is_Generic_Instance (Spec_Id)
then
- Analyze_Previous_Contracts (N);
+ Freeze_Previous_Contracts (N);
end if;
-- A package body is Ghost when the corresponding spec is Ghost. Set
@@ -876,10 +876,6 @@
Declare_Inherited_Private_Subprograms (Spec_Id);
end if;
- -- A package body "freezes" the contract of its initial declaration.
- -- This analysis depends on attribute Corresponding_Spec being set. Only
- -- bodies coming from source shuld cause this type of "freezing".
-
if Present (Declarations (N)) then
Analyze_Declarations (Declarations (N));
Inspect_Deferred_Constant_Completion (Declarations (N));
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb (revision 254579)
+++ sem_ch9.adb (revision 254580)
@@ -1210,13 +1210,13 @@
Entry_Name : Entity_Id;
begin
- -- An entry body "freezes" the contract of the nearest enclosing package
+ -- An entry body freezes the contract of the nearest enclosing package
-- body and all other contracts encountered in the same declarative part
-- up to and excluding the entry body. This ensures that any annotations
-- referenced by the contract of an entry or subprogram body declared
-- within the current protected body are available.
- Analyze_Previous_Contracts (N);
+ Freeze_Previous_Contracts (N);
Tasking_Used := True;
@@ -1794,14 +1794,14 @@
-- Start of processing for Analyze_Protected_Body
begin
- -- A protected body "freezes" the contract of the nearest enclosing
+ -- A protected body freezes the contract of the nearest enclosing
-- package body and all other contracts encountered in the same
- -- declarative part up to and excluding the protected body. This ensures
- -- that any annotations referenced by the contract of an entry or
- -- subprogram body declared within the current protected body are
- -- available.
+ -- declarative part up to and excluding the protected body. This
+ -- ensures that any annotations referenced by the contract of an
+ -- entry or subprogram body declared within the current protected
+ -- body are available.
- Analyze_Previous_Contracts (N);
+ Freeze_Previous_Contracts (N);
Tasking_Used := True;
Set_Ekind (Body_Id, E_Protected_Body);
@@ -2900,13 +2900,13 @@
-- a single task, since Spec_Id is set to the task type).
begin
- -- A task body "freezes" the contract of the nearest enclosing package
+ -- A task body freezes the contract of the nearest enclosing package
-- body and all other contracts encountered in the same declarative part
-- up to and excluding the task body. This ensures that annotations
-- referenced by the contract of an entry or subprogram body declared
-- within the current protected body are available.
- Analyze_Previous_Contracts (N);
+ Freeze_Previous_Contracts (N);
Tasking_Used := True;
Set_Scope (Body_Id, Current_Scope);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 254579)
+++ sem_prag.adb (revision 254580)
@@ -217,7 +217,7 @@
Freeze_Id : Entity_Id);
-- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
-- Pre. Emit a freezing-related error message where Freeze_Id is the entity
- -- of a body which caused contract "freezing" and Contract_Id denotes the
+ -- of a body which caused contract freezing and Contract_Id denotes the
-- entity of the affected contstruct.
procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
@@ -432,7 +432,7 @@
-- Emit a clarification message when the case guard contains
-- at least one undefined reference, possibly due to contract
- -- "freezing".
+ -- freezing.
if Errors /= Serious_Errors_Detected
and then Present (Freeze_Id)
@@ -447,7 +447,7 @@
-- Emit a clarification message when the consequence contains
-- at least one undefined reference, possibly due to contract
- -- "freezing".
+ -- freezing.
if Errors /= Serious_Errors_Detected
and then Present (Freeze_Id)
@@ -3510,7 +3510,7 @@
end if;
-- Emit a clarification message when the encapsulator is undefined,
- -- possibly due to contract "freezing".
+ -- possibly due to contract freezing.
if Errors /= Serious_Errors_Detected
and then Present (Freeze_Id)
@@ -24613,7 +24613,7 @@
Preanalyze_Assert_Expression (Expr, Standard_Boolean);
-- Emit a clarification message when the expression contains at least
- -- one undefined reference, possibly due to contract "freezing".
+ -- one undefined reference, possibly due to contract freezing.
if Errors /= Serious_Errors_Detected
and then Present (Freeze_Id)
@@ -27363,7 +27363,7 @@
Constit_Id := Entity_Of (Constit);
-- When a constituent is declared after a subprogram body
- -- that caused "freezing" of the related contract where
+ -- that caused freezing of the related contract where
-- pragma Refined_State resides, the constituent appears
-- undefined and carries Any_Id as its entity.
