@@ -864,12 +864,12 @@ package Einfo is
-- and IN OUT parameters in the absence of errors).
-- Delay_Cleanups
+-- Defined in entities that have finalization lists (subprograms, blocks
+-- and tasks) or finalizers (package specs and bodies). Set if there are
+-- pending package body instantiations for the corresponding entity. If
+-- it is set, then generation of cleanup actions for the corresponding
+-- entity must be delayed, since the insertion of the package bodies may
+-- affect cleanup generation (see Inline for further details).
-- Delta_Value
-- Defined in fixed and decimal types. Points to a universal real
@@ -281,29 +281,6 @@ package body Exp_Ch7 is
-- does not contain the above constructs, the routine returns an empty
-- list.
- procedure Build_Finalizer
- (N : Node_Id;
- Clean_Stmts : List_Id;
- Mark_Id : Entity_Id;
- Top_Decls : List_Id;
- Defer_Abort : Boolean;
- Fin_Id : out Entity_Id);
- -- N may denote an accept statement, block, entry body, package body,
- -- package spec, protected body, subprogram body, or a task body. Create
- -- a procedure which contains finalization calls for all controlled objects
- -- declared in the declarative or statement region of N. The calls are
- -- built in reverse order relative to the original declarations. In the
- -- case of a task body, the routine delays the creation of the finalizer
- -- until all statements have been moved to the task body procedure.
- -- Clean_Stmts may contain additional context-dependent code used to abort
- -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
- -- Mark_Id is the secondary stack used in the current context or Empty if
- -- missing. Top_Decls is the list on which the declaration of the finalizer
- -- is attached in the non-package case. Defer_Abort indicates that the
- -- statements passed in perform actions that require abort to be deferred,
- -- such as for task termination. Fin_Id is the finalizer declaration
- -- entity.
-
procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
-- N is a construct that contains a handled sequence of statements, Fin_Id
-- is the entity of a finalizer. Create an At_End handler that covers the
@@ -2498,73 +2475,6 @@ package body Exp_Ch7 is
end if;
end if;
- -- Call the xxx__finalize_body procedure of a library level
- -- package instantiation if the body contains finalization
- -- statements.
-
- if Present (Generic_Parent (Spec))
- and then Is_Library_Level_Entity (Pack_Id)
- and then Present (Body_Entity (Generic_Parent (Spec)))
- then
- if Preprocess then
- declare
- P : Node_Id;
- begin
- P := Parent (Body_Entity (Generic_Parent (Spec)));
- while Present (P)
- and then Nkind (P) /= N_Package_Body
- loop
- P := Parent (P);
- end loop;
-
- if Present (P) then
- Old_Counter_Val := Counter_Val;
- Process_Declarations (Declarations (P), Preprocess);
-
- -- Note that we are processing the generic body
- -- template and not the actually instantiation
- -- (which is generated too late for us to process
- -- it), so there is no need to update in particular
- -- Last_Top_Level_Ctrl_Construct here.
-
- if Counter_Val > Old_Counter_Val then
- Counter_Val := Old_Counter_Val;
- Set_Has_Controlled_Component (Pack_Id);
- end if;
- end if;
- end;
-
- elsif Has_Controlled_Component (Pack_Id) then
-
- -- We import the xxx__finalize_body routine since the
- -- generic body will be instantiated later.
-
- declare
- Id : constant Node_Id :=
- Make_Defining_Identifier (Loc,
- New_Finalizer_Name (Defining_Unit_Name (Spec),
- For_Spec => False));
-
- begin
- Set_Has_Qualified_Name (Id);
- Set_Has_Fully_Qualified_Name (Id);
- Set_Is_Imported (Id);
- Set_Has_Completion (Id);
- Set_Interface_Name (Id,
- Make_String_Literal (Loc,
- Strval => Get_Name_String (Chars (Id))));
-
- Append_New_To (Finalizer_Stmts,
- Make_Subprogram_Declaration (Loc,
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Id)));
- Append_To (Finalizer_Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Id, Loc)));
- end;
- end if;
- end if;
-
-- Nested package bodies, avoid generics
elsif Nkind (Decl) = N_Package_Body then
@@ -3541,34 +3451,15 @@ package body Exp_Ch7 is
end if;
end if;
- -- Do not process nested packages since those are handled by the
- -- enclosing scope's finalizer. Do not process non-expanded package
- -- instantiations since those will be re-analyzed and re-expanded.
+ -- We do not need to process nested packages since they are handled by
+ -- the finalizer of the enclosing scope, including at library level.
+ -- And we do not build two finalizers for an instance without body that
+ -- is a library unit (see Analyze_Package_Instantiation).
if For_Package
- and then
- (not Is_Library_Level_Entity (Spec_Id)
-
- -- Nested packages are library-level entities, but do not need to
- -- be processed separately.
-
- or else Scope_Depth (Spec_Id) /= Uint_1
-
- -- Do not build two finalizers for an instance without body that
- -- is a library unit (see Analyze_Package_Instantiation).
-
- or else (Is_Generic_Instance (Spec_Id)
- and then Package_Instantiation (Spec_Id) = N))
-
- -- Still need to process library-level package body instances, whose
- -- instantiation was deferred and thus could not be seen during the
- -- processing of the enclosing scope, and which may contain objects
- -- requiring finalization.
-
- and then not
- (For_Package_Body
- and then Is_Library_Level_Entity (Spec_Id)
- and then Is_Generic_Instance (Spec_Id))
+ and then (not Is_Compilation_Unit (Spec_Id)
+ or else (Is_Generic_Instance (Spec_Id)
+ and then Package_Instantiation (Spec_Id) = N))
then
return;
end if;
@@ -5188,7 +5079,9 @@ package body Exp_Ch7 is
-- Encode entity names in package body
procedure Expand_N_Package_Body (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Entity (N);
Spec_Id : constant Entity_Id := Corresponding_Spec (N);
+
Fin_Id : Entity_Id;
begin
@@ -5242,7 +5135,9 @@ package body Exp_Ch7 is
Qualify_Entity_Names (N);
- if Ekind (Spec_Id) /= E_Generic_Package then
+ if Ekind (Spec_Id) /= E_Generic_Package
+ and then not Delay_Cleanups (Id)
+ then
Build_Finalizer
(N => N,
Clean_Stmts => No_List,
@@ -5369,7 +5264,9 @@ package body Exp_Ch7 is
Qualify_Entity_Names (N);
- if Ekind (Id) /= E_Generic_Package then
+ if Ekind (Id) /= E_Generic_Package
+ and then not Delay_Cleanups (Id)
+ then
Build_Finalizer
(N => N,
Clean_Stmts => No_List,
@@ -118,6 +118,29 @@ package Exp_Ch7 is
-- finalization master must be analyzed. Insertion_Node is the insertion
-- point before which the master is to be inserted.
+ procedure Build_Finalizer
+ (N : Node_Id;
+ Clean_Stmts : List_Id;
+ Mark_Id : Entity_Id;
+ Top_Decls : List_Id;
+ Defer_Abort : Boolean;
+ Fin_Id : out Entity_Id);
+ -- N may denote an accept statement, block, entry body, package body,
+ -- package spec, protected body, subprogram body, or a task body. Create
+ -- a procedure which contains finalization calls for all controlled objects
+ -- declared in the declarative or statement region of N. The calls are
+ -- built in reverse order relative to the original declarations. In the
+ -- case of a task body, the routine delays the creation of the finalizer
+ -- until all statements have been moved to the task body procedure.
+ -- Clean_Stmts may contain additional context-dependent code used to abort
+ -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
+ -- Mark_Id is the secondary stack used in the current context or Empty if
+ -- missing. Top_Decls is the list on which the declaration of the finalizer
+ -- is attached in the non-package case. Defer_Abort indicates that the
+ -- statements passed in perform actions that require abort to be deferred,
+ -- such as for task termination. Fin_Id is the finalizer declaration
+ -- entity.
+
procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id);
-- Build one controlling procedure when a late body overrides one of the
-- controlling operations.
@@ -334,17 +334,17 @@ package body Inline is
-- Deferred Cleanup Actions --
------------------------------
- -- The cleanup actions for scopes that contain instantiations is delayed
- -- until after expansion of those instantiations, because they may contain
- -- finalizable objects or tasks that affect the cleanup code. A scope
- -- that contains instantiations only needs to be finalized once, even
- -- if it contains more than one instance. We keep a list of scopes
- -- that must still be finalized, and call cleanup_actions after all
- -- the instantiations have been completed.
+ -- The cleanup actions for scopes that contain package instantiations with
+ -- a body are delayed until after the package body is instantiated. because
+ -- the body may contain finalizable objects or other constructs that affect
+ -- the cleanup code. A scope that contains such instantiations only needs
+ -- to be finalized once, even though it may contain more than one instance.
+ -- We keep a list of scopes that must still be finalized and Cleanup_Scopes
+ -- will be invoked after all the body instantiations have been completed.
To_Clean : Elist_Id;
- procedure Add_Scope_To_Clean (Inst : Entity_Id);
+ procedure Add_Scope_To_Clean (Scop : Entity_Id);
-- Build set of scopes on which cleanup actions must be performed
procedure Cleanup_Scopes;
@@ -783,7 +783,11 @@ package body Inline is
-- Add_Pending_Instantiation --
--------------------------------
- procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is
+ procedure Add_Pending_Instantiation
+ (Inst : Node_Id;
+ Act_Decl : Node_Id;
+ Fin_Scop : Node_Id := Empty)
+ is
Act_Decl_Id : Entity_Id;
Index : Int;
@@ -802,11 +806,12 @@ package body Inline is
-- for later processing by Instantiate_Bodies.
Pending_Instantiations.Append
- ((Act_Decl => Act_Decl,
+ ((Inst_Node => Inst,
+ Act_Decl => Act_Decl,
+ Fin_Scop => Fin_Scop,
Config_Switches => Save_Config_Switches,
Current_Sem_Unit => Current_Sem_Unit,
Expander_Status => Expander_Active,
- Inst_Node => Inst,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Scope_Suppress => Scope_Suppress,
Warnings => Save_Warnings));
@@ -838,37 +843,10 @@ package body Inline is
-- Add_Scope_To_Clean --
------------------------
- procedure Add_Scope_To_Clean (Inst : Entity_Id) is
- Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
+ procedure Add_Scope_To_Clean (Scop : Entity_Id) is
Elmt : Elmt_Id;
begin
- -- If the instance appears in a library-level package declaration,
- -- all finalization is global, and nothing needs doing here.
-
- if Scop = Standard_Standard then
- return;
- end if;
-
- -- If the instance is within a generic unit, no finalization code
- -- can be generated. Note that at this point all bodies have been
- -- analyzed, and the scope stack itself is not present, and the flag
- -- Inside_A_Generic is not set.
-
- declare
- S : Entity_Id;
-
- begin
- S := Scope (Inst);
- while Present (S) and then S /= Standard_Standard loop
- if Is_Generic_Unit (S) then
- return;
- end if;
-
- S := Scope (S);
- end loop;
- end;
-
Elmt := First_Elmt (To_Clean);
while Present (Elmt) loop
if Node (Elmt) = Scop then
@@ -2816,16 +2794,19 @@ package body Inline is
--------------------
procedure Cleanup_Scopes is
- Elmt : Elmt_Id;
Decl : Node_Id;
+ Elmt : Elmt_Id;
+ Fin : Entity_Id;
+ Kind : Entity_Kind;
Scop : Entity_Id;
begin
Elmt := First_Elmt (To_Clean);
while Present (Elmt) loop
Scop := Node (Elmt);
+ Kind := Ekind (Scop);
- if Ekind (Scop) = E_Block then
+ if Kind = E_Block then
Decl := Parent (Block_Node (Scop));
else
@@ -2839,14 +2820,55 @@ package body Inline is
end if;
end if;
- Push_Scope (Scop);
- Expand_Cleanup_Actions (Decl);
- End_Scope;
+ -- Finalizers are built only for package specs and bodies that are
+ -- compilation units, so check that we do not have anything else.
+ -- Moreover, they must be built at most once for each entity during
+ -- the compilation of the main unit. However, if other units are
+ -- later compiled for inlining purposes, they may also contain body
+ -- instances and, therefore, appear again here, so we need to make
+ -- sure that we do not build two finalizers for them (note that the
+ -- contents of the finalizer for these units is irrelevant since it
+ -- is not output in the generated code).
+
+ if Kind in E_Package | E_Package_Body then
+ declare
+ Unit_Entity : constant Entity_Id :=
+ (if Kind = E_Package then Scop else Spec_Entity (Scop));
+
+ begin
+ pragma Assert (Is_Compilation_Unit (Unit_Entity)
+ and then (No (Finalizer (Scop))
+ or else Unit_Entity /= Main_Unit_Entity));
+
+ if No (Finalizer (Scop)) then
+ Build_Finalizer
+ (N => Decl,
+ Clean_Stmts => No_List,
+ Mark_Id => Empty,
+ Top_Decls => No_List,
+ Defer_Abort => False,
+ Fin_Id => Fin);
+
+ if Present (Fin) then
+ Set_Finalizer (Scop, Fin);
+ end if;
+ end if;
+ end;
+
+ else
+ Push_Scope (Scop);
+ Expand_Cleanup_Actions (Decl);
+ End_Scope;
+ end if;
Next_Elmt (Elmt);
end loop;
end Cleanup_Scopes;
+ -----------------------------------------------
+ -- Establish_Actual_Mapping_For_Inlined_Call --
+ -----------------------------------------------
+
procedure Establish_Actual_Mapping_For_Inlined_Call
(N : Node_Id;
Subp : Entity_Id;
@@ -4831,6 +4853,8 @@ package body Inline is
------------------------
procedure Instantiate_Body (Info : Pending_Body_Info) is
+ Scop : Entity_Id;
+
begin
-- If the instantiation node is absent, it has been removed as part
-- of unreachable code.
@@ -4845,9 +4869,47 @@ package body Inline is
elsif Nkind (Info.Inst_Node) = N_Package_Body then
null;
- elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
+ -- For other package instances, instantiate the body and register the
+ -- finalization scope, if any, for subsequent generation of cleanups.
+
+ elsif Nkind (Info.Inst_Node) = N_Package_Instantiation then
+
+ -- If the enclosing finalization scope is a package body, set the
+ -- In_Package_Body flag on its spec. This is required, in the case
+ -- where the body contains other package instantiations that have
+ -- a body, for Analyze_Package_Instantiation to compute a correct
+ -- finalization scope.
+
+ if Present (Info.Fin_Scop)
+ and then Ekind (Info.Fin_Scop) = E_Package_Body
+ then
+ Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), True);
+ end if;
+
Instantiate_Package_Body (Info);
- Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
+
+ if Present (Info.Fin_Scop) then
+ Scop := Info.Fin_Scop;
+
+ -- If the enclosing finalization scope is dynamic, the instance
+ -- may have been relocated, for example if it was declared in a
+ -- protected entry, protected subprogram, or task body.
+
+ if Is_Dynamic_Scope (Scop) then
+ Scop :=
+ Enclosing_Dynamic_Scope (Defining_Entity (Info.Act_Decl));
+ end if;
+
+ Add_Scope_To_Clean (Scop);
+
+ -- Reset the In_Package_Body flag if it was set above
+
+ if Ekind (Info.Fin_Scop) = E_Package_Body then
+ Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), False);
+ end if;
+ end if;
+
+ -- For subprogram instances, always instantiate the body
else
Instantiate_Subprogram_Body (Info);
@@ -61,9 +61,15 @@ package Inline is
-- See full description in body of Sem_Ch12 for more details
type Pending_Body_Info is record
+ Inst_Node : Node_Id;
+ -- Node for instantiation that requires the body
+
Act_Decl : Node_Id;
-- Declaration for package or subprogram spec for instantiation
+ Fin_Scop : Node_Id;
+ -- Enclosing finalization scope for package instantiation
+
Config_Switches : Config_Switches_Type;
-- Capture the values of configuration switches
@@ -76,9 +82,6 @@ package Inline is
-- If the body is instantiated only for semantic checking, expansion
-- must be inhibited.
- Inst_Node : Node_Id;
- -- Node for instantiation that requires the body
-
Scope_Suppress : Suppress_Record;
Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr;
-- Save suppress information at the point of instantiation. Used to
@@ -119,7 +122,10 @@ package Inline is
-- Add E's enclosing unit to Inlined_Bodies so that E can be subsequently
-- retrieved and analyzed. N is the node giving rise to the call to E.
- procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id);
+ procedure Add_Pending_Instantiation
+ (Inst : Node_Id;
+ Act_Decl : Node_Id;
+ Fin_Scop : Node_Id := Empty);
-- Add an entry in the table of generic bodies to be instantiated.
procedure Analyze_Inlined_Bodies;
@@ -4794,66 +4794,68 @@ package body Sem_Ch12 is
Needs_Body := False;
end if;
+ -- If the context requires a full instantiation, set things up for
+ -- subsequent construction of the body.
+
if Needs_Body then
- -- Indicate that the enclosing scopes contain an instantiation,
- -- and that cleanup actions should be delayed until after the
- -- instance body is expanded.
+ declare
+ Fin_Scop, S : Entity_Id;
- Check_Forward_Instantiation (Gen_Decl);
- if Nkind (N) = N_Package_Instantiation then
- declare
- Enclosing_Master : Entity_Id;
+ begin
+ Check_Forward_Instantiation (Gen_Decl);
- begin
- -- Loop to search enclosing masters
+ Fin_Scop := Empty;
- Enclosing_Master := Current_Scope;
- Scope_Loop : while Enclosing_Master /= Standard_Standard loop
- if Ekind (Enclosing_Master) = E_Package then
- if Is_Compilation_Unit (Enclosing_Master) then
- exit Scope_Loop;
- else
- Enclosing_Master := Scope (Enclosing_Master);
- end if;
+ -- For a package instantiation that is not a compilation unit,
+ -- indicate that cleanup actions of the innermost enclosing
+ -- scope for which they are generated should be delayed until
+ -- after the package body is instantiated.
+
+ if Nkind (N) = N_Package_Instantiation
+ and then not Is_Compilation_Unit (Act_Decl_Id)
+ then
+ S := Current_Scope;
+
+ while S /= Standard_Standard loop
+ -- Cleanup actions are not generated within generic units
+ -- or in the formal part of generic units.
- elsif Is_Generic_Unit (Enclosing_Master)
- or else Ekind (Enclosing_Master) = E_Void
+ if Inside_A_Generic
+ or else Is_Generic_Unit (S)
+ or else Ekind (S) = E_Void
then
- -- Cleanup actions will eventually be performed on the
- -- enclosing subprogram or package instance, if any.
- -- Enclosing scope is void in the formal part of a
- -- generic subprogram.
+ exit;
- exit Scope_Loop;
+ -- For package scopes, cleanup actions are generated only
+ -- for compilation units, for spec and body separately.
- else
- Set_Delay_Cleanups (Enclosing_Master);
+ elsif Ekind (S) = E_Package then
+ if Is_Compilation_Unit (S) then
+ if In_Package_Body (S) then
+ Fin_Scop := Body_Entity (S);
+ else
+ Fin_Scop := S;
+ end if;
- while Ekind (Enclosing_Master) = E_Block loop
- Enclosing_Master := Scope (Enclosing_Master);
- end loop;
+ Set_Delay_Cleanups (Fin_Scop);
+ exit;
- if Is_Task_Type (Enclosing_Master) then
- declare
- TBP : constant Node_Id :=
- Get_Task_Body_Procedure
- (Enclosing_Master);
- begin
- if Present (TBP) then
- Set_Delay_Cleanups (TBP);
- end if;
- end;
+ else
+ S := Scope (S);
end if;
- exit Scope_Loop;
- end if;
- end loop Scope_Loop;
- end;
+ -- Cleanup actions are generated for all dynamic scopes
- -- Make entry in table
+ else
+ Fin_Scop := S;
+ Set_Delay_Cleanups (Fin_Scop);
+ exit;
+ end if;
+ end loop;
+ end if;
- Add_Pending_Instantiation (N, Act_Decl);
- end if;
+ Add_Pending_Instantiation (N, Act_Decl, Fin_Scop);
+ end;
end if;
Set_Categorization_From_Pragmas (Act_Decl);
@@ -5252,11 +5254,12 @@ package body Sem_Ch12 is
Instantiate_Package_Body
(Body_Info =>
- ((Act_Decl => Act_Decl,
+ ((Inst_Node => N,
+ Act_Decl => Act_Decl,
+ Fin_Scop => Empty,
Config_Switches => Config_Attrs,
Current_Sem_Unit => Current_Sem_Unit,
Expander_Status => Expander_Active,
- Inst_Node => N,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Scope_Suppress => Scope_Suppress,
Warnings => Save_Warnings)),
@@ -5366,11 +5369,12 @@ package body Sem_Ch12 is
else
Instantiate_Package_Body
(Body_Info =>
- ((Act_Decl => Act_Decl,
+ ((Inst_Node => N,
+ Act_Decl => Act_Decl,
+ Fin_Scop => Empty,
Config_Switches => Save_Config_Switches,
Current_Sem_Unit => Current_Sem_Unit,
Expander_Status => Expander_Active,
- Inst_Node => N,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Scope_Suppress => Scope_Suppress,
Warnings => Save_Warnings)),
@@ -14694,13 +14698,14 @@ package body Sem_Ch12 is
Decl := First_Elmt (Previous_Instances);
while Present (Decl) loop
Info :=
- (Act_Decl =>
+ (Inst_Node => Node (Decl),
+ Act_Decl =>
Instance_Spec (Node (Decl)),
+ Fin_Scop => Empty,
Config_Switches => Save_Config_Switches,
Current_Sem_Unit =>
Get_Code_Unit (Sloc (Node (Decl))),
Expander_Status => Exp_Status,
- Inst_Node => Node (Decl),
Local_Suppress_Stack_Top =>
Local_Suppress_Stack_Top,
Scope_Suppress => Scope_Suppress,
@@ -14754,12 +14759,13 @@ package body Sem_Ch12 is
Instantiate_Package_Body
(Body_Info =>
- ((Act_Decl => True_Parent,
+ ((Inst_Node => Inst_Node,
+ Act_Decl => True_Parent,
+ Fin_Scop => Empty,
Config_Switches => Save_Config_Switches,
Current_Sem_Unit =>
Get_Code_Unit (Sloc (Inst_Node)),
Expander_Status => Exp_Status,
- Inst_Node => Inst_Node,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Scope_Suppress => Scope_Suppress,
Warnings => Save_Warnings)),