diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 13a0c8e7500f79a8fe294b08d5b10ff9573c2b1a..5764b22b80027ae106b682a2cf3464aef171bfb7 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -1176,11 +1176,13 @@ package body Exp_Ch3 is
end if;
end if;
- -- Build an abort block to protect the initialization calls
+ -- Build an abort block to protect the initialization calls, except for
+ -- a finalization collection, which does not need any protection.
if Abort_Allowed
and then Present (Comp_Init)
and then Present (Obj_Init)
+ and then not Is_RTE (Typ, RE_Finalization_Collection)
then
-- Generate:
-- Abort_Defer;
@@ -6955,6 +6957,7 @@ package body Exp_Ch3 is
Defining_Identifier => Local_Id,
Object_Definition =>
New_Occurrence_Of (Ptr_Typ, Loc)));
+ Set_No_Initialization (Last (Decls));
-- Allocate the object, generate:
-- Local_Id := <Alloc_Expr>;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 342828aa6724d527d669836666c72d64023ea7e8..b1f7593de2ac109c2f858aa85c2f0ee50bc0049d 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -592,11 +592,10 @@ package body Exp_Ch4 is
Preserve_Comes_From_Source (Expression (Temp_Decl), N);
- -- Insert declaration, assignment and build the allocation procedure
+ -- Insert the declaration and generate the in-place assignment
Insert_Action (N, Temp_Decl);
Convert_Aggr_In_Allocator (N, Exp, Temp);
- Build_Allocate_Deallocate_Proc (Temp_Decl);
end Build_Aggregate_In_Place;
-- Local variables
@@ -806,7 +805,6 @@ package body Exp_Ch4 is
Expression => Node);
Insert_Action (N, Temp_Decl);
- Build_Allocate_Deallocate_Proc (Temp_Decl);
end if;
-- Ada 2005 (AI-251): Handle allocators whose designated type is an
@@ -859,7 +857,6 @@ package body Exp_Ch4 is
Expression => Node);
Insert_Action (N, Temp_Decl);
- Build_Allocate_Deallocate_Proc (Temp_Decl);
end if;
-- Generate an additional object containing the address of the
@@ -968,6 +965,7 @@ package body Exp_Ch4 is
Apply_Accessibility_Check_For_Allocator (N, Exp, Temp);
+ Build_Allocate_Deallocate_Proc (Declaration_Node (Temp), Mark => N);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
@@ -991,6 +989,7 @@ package body Exp_Ch4 is
then
Temp := Make_Temporary (Loc, 'P', N);
Build_Aggregate_In_Place (Temp, PtrT);
+ Build_Allocate_Deallocate_Proc (Declaration_Node (Temp), Mark => N);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
@@ -4600,10 +4599,15 @@ package body Exp_Ch4 is
Expand_Allocator_Expression (N);
-- If no initialization is necessary, just create a custom Allocate if
- -- the context requires it.
+ -- the context requires it; that is the case only for allocators built
+ -- for the special return objects because, in other cases, the custom
+ -- Allocate will be created later during the expansion of the original
+ -- allocator without the No_Initialization flag.
elsif No_Initialization (N) then
- Build_Allocate_Deallocate_Proc (N);
+ if For_Special_Return_Object (N) then
+ Build_Allocate_Deallocate_Proc (Parent (N));
+ end if;
-- If the allocator is for a type which requires initialization, and
-- there is no initial value (i.e. operand is a subtype indication
@@ -4662,7 +4666,6 @@ package body Exp_Ch4 is
Expression => Relocate_Node (N));
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
- Build_Allocate_Deallocate_Proc (Temp_Decl);
-- Generate:
-- Temp.all := ...
@@ -4682,6 +4685,7 @@ package body Exp_Ch4 is
Set_Assignment_OK (Name (Stmt));
Insert_Action (N, Stmt, Suppress => All_Checks);
+ Build_Allocate_Deallocate_Proc (Temp_Decl);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
end;
@@ -4799,7 +4803,6 @@ package body Exp_Ch4 is
Expression => Relocate_Node (N));
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
- Build_Allocate_Deallocate_Proc (Temp_Decl);
-- If the designated type is a task type or contains tasks,
-- create a specific block to activate the created tasks.
@@ -4818,6 +4821,7 @@ package body Exp_Ch4 is
Insert_Actions (N, Init_Stmts, Suppress => All_Checks);
end if;
+ Build_Allocate_Deallocate_Proc (Temp_Decl);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index a62c7441a488e0fce3eed920e2a1ee838b6f8904..e978a778f1e5029bc4849ad251d09c6ff9608918 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -245,6 +245,34 @@ package body Exp_Ch7 is
-- at end
-- _Finalizer;
+ -- Here is the version with a dynamically allocated object:
+
+ -- declare
+ -- X : P_Ctrl := new Ctrl;
+
+ -- begin
+ -- null;
+ -- end;
+ --
+ -- is expanded into:
+
+ -- declare
+ -- Cnn : System.Finalization_Primitives.Finalization_Collection_Ptr :=
+ -- P_CtrlFC'unrestricted_access;
+ -- [...]
+ -- Pnn : constant P_Ctrl := new Ctrl[...][...];
+ -- Bnn : begin
+ -- Abort_Defer;
+ -- Initialize (Pnn.all);
+ -- System.Finalization_Primitives.Attach_To_Collection
+ -- (Pnn.all'address,
+ -- CtrlFD'unrestricted_access,
+ -- Cnn.all);
+ -- at end
+ -- Abort_Undefer;
+ -- end Bnn;
+ -- X : P_Ctrl := Pnn;
+
-- The implementation uses two different strategies for the finalization
-- of (statically) declared objects and of dynamically allocated objects.
@@ -274,11 +302,10 @@ package body Exp_Ch7 is
-- recognized by Requires_Cleanup_Actions and picked up by Build_Finalizer.
-- For dynamically allocated objects, there is no post-processing phase and
- -- the objects are automatically attached and detached when they are being
- -- allocated or deallocated. In other words, there are no direct attachment
- -- or detachment actions generated by the compiler; instead they are fully
- -- carried out by the run-time library when it is invoked by the allocation
- -- and deallocation actions generated by the compiler.
+ -- the attachment to the finalization chain of the access type, as well the
+ -- the detachment from this chain for unchecked deallocation, are generated
+ -- directly by the compiler during the expansion of allocators and calls to
+ -- instances of the Unchecked_Deallocation procedure.
type Final_Primitives is
(Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
@@ -514,13 +541,6 @@ package body Exp_Ch7 is
-- of the formal of Proc, or force a conversion to the class-wide type in
-- the case where the operation is abstract.
- function Make_Address_For_Finalize
- (Loc : Source_Ptr;
- Obj_Ref : Node_Id;
- Obj_Typ : Entity_Id) return Node_Id;
- -- Build the address of an object denoted by Obj_Ref and Obj_Typ for use as
- -- the actual parameter in a call to a Finalize_Address procedure.
-
function Make_Call
(Loc : Source_Ptr;
Proc_Id : Entity_Id;
@@ -2528,306 +2548,6 @@ package body Exp_Ch7 is
Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
Loc : constant Source_Ptr := Sloc (Decl);
- Init_Typ : Entity_Id;
- -- The initialization type of the related object declaration. Note
- -- that this is not necessarily the same type as Obj_Typ because of
- -- possible type derivations.
-
- Obj_Typ : Entity_Id;
- -- The type of the related object declaration
-
- procedure Find_Last_Init
- (Last_Init : out Node_Id;
- Body_Insert : out Node_Id);
- -- Find the last initialization call related to object declaration
- -- Decl. Last_Init denotes the last initialization call which follows
- -- Decl. Body_Insert denotes a node where the finalizer body could be
- -- potentially inserted after (if blocks are involved).
-
- --------------------
- -- Find_Last_Init --
- --------------------
-
- procedure Find_Last_Init
- (Last_Init : out Node_Id;
- Body_Insert : out Node_Id)
- is
- function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
- -- Find the last initialization call within the statements of
- -- block Blk.
-
- function Is_Init_Call (N : Node_Id) return Boolean;
- -- Determine whether node N denotes one of the initialization
- -- procedures of types Init_Typ or Obj_Typ.
-
- function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
- -- Obtain the next statement which follows list member Stmt while
- -- ignoring artifacts related to access-before-elaboration checks.
-
- -----------------------------
- -- Find_Last_Init_In_Block --
- -----------------------------
-
- function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
- HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
- Stmt : Node_Id;
-
- begin
- -- Examine the individual statements of the block in reverse to
- -- locate the last initialization call.
-
- if Present (HSS) and then Present (Statements (HSS)) then
- Stmt := Last (Statements (HSS));
- while Present (Stmt) loop
-
- -- Peek inside nested blocks in case aborts are allowed
-
- if Nkind (Stmt) = N_Block_Statement then
- return Find_Last_Init_In_Block (Stmt);
-
- elsif Is_Init_Call (Stmt) then
- return Stmt;
- end if;
-
- Prev (Stmt);
- end loop;
- end if;
-
- return Empty;
- end Find_Last_Init_In_Block;
-
- ------------------
- -- Is_Init_Call --
- ------------------
-
- function Is_Init_Call (N : Node_Id) return Boolean is
- function Is_Init_Proc_Of
- (Subp_Id : Entity_Id;
- Typ : Entity_Id) return Boolean;
- -- Determine whether subprogram Subp_Id is a valid init proc of
- -- type Typ.
-
- ---------------------
- -- Is_Init_Proc_Of --
- ---------------------
-
- function Is_Init_Proc_Of
- (Subp_Id : Entity_Id;
- Typ : Entity_Id) return Boolean
- is
- Deep_Init : Entity_Id := Empty;
- Prim_Init : Entity_Id := Empty;
- Type_Init : Entity_Id := Empty;
-
- begin
- -- Obtain all possible initialization routines of the
- -- related type and try to match the subprogram entity
- -- against one of them.
-
- -- Deep_Initialize
-
- Deep_Init := TSS (Typ, TSS_Deep_Initialize);
-
- -- Primitive Initialize
-
- if Is_Controlled (Typ) then
- Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
-
- if Present (Prim_Init) then
- Prim_Init := Ultimate_Alias (Prim_Init);
- end if;
- end if;
-
- -- Type initialization routine
-
- if Has_Non_Null_Base_Init_Proc (Typ) then
- Type_Init := Base_Init_Proc (Typ);
- end if;
-
- return
- (Present (Deep_Init) and then Subp_Id = Deep_Init)
- or else
- (Present (Prim_Init) and then Subp_Id = Prim_Init)
- or else
- (Present (Type_Init) and then Subp_Id = Type_Init);
- end Is_Init_Proc_Of;
-
- -- Local variables
-
- Call_Id : Entity_Id;
-
- -- Start of processing for Is_Init_Call
-
- begin
- if Nkind (N) = N_Procedure_Call_Statement
- and then Nkind (Name (N)) = N_Identifier
- then
- Call_Id := Entity (Name (N));
-
- -- Consider both the type of the object declaration and its
- -- related initialization type.
-
- return
- Is_Init_Proc_Of (Call_Id, Init_Typ)
- or else
- Is_Init_Proc_Of (Call_Id, Obj_Typ);
- end if;
-
- return False;
- end Is_Init_Call;
-
- -----------------------------
- -- Next_Suitable_Statement --
- -----------------------------
-
- function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
- Result : Node_Id;
-
- begin
- -- Skip call markers and Program_Error raises installed by the
- -- ABE mechanism.
-
- Result := Next (Stmt);
- while Present (Result) loop
- exit when Nkind (Result) not in
- N_Call_Marker | N_Raise_Program_Error;
-
- Next (Result);
- end loop;
-
- return Result;
- end Next_Suitable_Statement;
-
- -- Local variables
-
- Call : Node_Id;
- Stmt : Node_Id;
- Stmt_2 : Node_Id;
-
- Deep_Init_Found : Boolean := False;
- -- A flag set when a call to [Deep_]Initialize has been found
-
- -- Start of processing for Find_Last_Init
-
- begin
- Last_Init := Decl;
- Body_Insert := Empty;
-
- -- Objects that capture controlled function results do not require
- -- initialization.
-
- if Nkind (Decl) = N_Object_Declaration
- and then Nkind (Expression (Decl)) = N_Reference
- then
- return;
- end if;
-
- if Present (Freeze_Node (Obj_Id)) then
- Stmt := First (Actions (Freeze_Node (Obj_Id)));
- Body_Insert := Freeze_Node (Obj_Id);
- else
- Stmt := Next_Suitable_Statement (Decl);
- end if;
-
- -- For an object with suppressed initialization, we check whether
- -- there is in fact no initialization expression. If there is not,
- -- then this is an object declaration that has been turned into a
- -- different object declaration that calls the build-in-place
- -- function in a 'Reference attribute, as in "F(...)'Reference".
- -- We search for that later object declaration, so that the
- -- attachment will be inserted after the call. Otherwise, if the
- -- call raises an exception, we will finalize the (uninitialized)
- -- object, which is wrong.
-
- if Nkind (Decl) = N_Object_Declaration
- and then No_Initialization (Decl)
- then
- if No (Expression (Last_Init)) then
- loop
- Next (Last_Init);
- exit when No (Last_Init);
- exit when Nkind (Last_Init) = N_Object_Declaration
- and then Nkind (Expression (Last_Init)) = N_Reference
- and then Nkind (Prefix (Expression (Last_Init))) =
- N_Function_Call
- and then Is_Expanded_Build_In_Place_Call
- (Prefix (Expression (Last_Init)));
- end loop;
- end if;
-
- return;
-
- -- If the initialization is in the declaration, we're done, so
- -- early return if we have no more statements or they have been
- -- rewritten, which means that they were in the source code.
-
- elsif No (Stmt) or else Original_Node (Stmt) /= Stmt then
- return;
-
- -- In all other cases the initialization calls follow the related
- -- object. The general structure of object initialization built by
- -- routine Default_Initialize_Object is as follows:
-
- -- [begin -- aborts allowed
- -- Abort_Defer;]
- -- Type_Init_Proc (Obj);
- -- [begin] -- exceptions allowed
- -- Deep_Initialize (Obj);
- -- [exception -- exceptions allowed
- -- when others =>
- -- Deep_Finalize (Obj, Self => False);
- -- raise;
- -- end;]
- -- [at end -- aborts allowed
- -- Abort_Undefer;
- -- end;]
-
- -- When aborts are allowed, the initialization calls are housed
- -- within a block.
-
- elsif Nkind (Stmt) = N_Block_Statement then
- Last_Init := Find_Last_Init_In_Block (Stmt);
- Body_Insert := Stmt;
-
- -- Otherwise the initialization calls follow the related object
-
- else
- Stmt_2 := Next_Suitable_Statement (Stmt);
-
- -- Check for an optional call to Deep_Initialize which may
- -- appear within a block depending on whether the object has
- -- controlled components.
-
- if Present (Stmt_2) then
- if Nkind (Stmt_2) = N_Block_Statement then
- Call := Find_Last_Init_In_Block (Stmt_2);
-
- if Present (Call) then
- Deep_Init_Found := True;
- Last_Init := Call;
- Body_Insert := Stmt_2;
- end if;
-
- elsif Is_Init_Call (Stmt_2) then
- Deep_Init_Found := True;
- Last_Init := Stmt_2;
- Body_Insert := Last_Init;
- end if;
- end if;
-
- -- If the object lacks a call to Deep_Initialize, then it must
- -- have a call to its related type init proc.
-
- if not Deep_Init_Found and then Is_Init_Call (Stmt) then
- Last_Init := Stmt;
- Body_Insert := Last_Init;
- end if;
- end if;
- end Find_Last_Init;
-
- -- Local variables
-
- Body_Ins : Node_Id;
Fin_Call : Node_Id;
Fin_Id : Entity_Id;
Master_Node_Attach : Node_Id;
@@ -2836,6 +2556,7 @@ package body Exp_Ch7 is
Master_Node_Ins : Node_Id;
Master_Node_Loc : Source_Ptr;
Obj_Ref : Node_Id;
+ Obj_Typ : Entity_Id;
-- Start of processing for Process_Object_Declaration
@@ -2855,23 +2576,6 @@ package body Exp_Ch7 is
Obj_Typ := Available_View (Designated_Type (Obj_Typ));
end if;
- -- Handle the initialization type of the object declaration
-
- Init_Typ := Obj_Typ;
- loop
- if Is_Private_Type (Init_Typ)
- and then Present (Full_View (Init_Typ))
- then
- Init_Typ := Full_View (Init_Typ);
-
- elsif Is_Untagged_Derivation (Init_Typ) then
- Init_Typ := Root_Type (Init_Typ);
-
- else
- exit;
- end if;
- end loop;
-
-- If the object is a Master_Node, then nothing to do, except if it
-- is the only object, in which case we move its declaration, call
-- marker (if any) and initialization call, as well as mark it to
@@ -2936,27 +2640,25 @@ package body Exp_Ch7 is
if Present (BIP_Initialization_Call (Obj_Id)) then
Master_Node_Ins := BIP_Initialization_Call (Obj_Id);
- Body_Ins := Empty;
-- The object is initialized by an aggregate. The Master_Node
-- insertion point is after the last aggregate assignment.
elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
Master_Node_Ins := Last_Aggregate_Assignment (Obj_Id);
- Body_Ins := Empty;
-- In other cases the Master_Node is inserted after the last call
-- to either [Deep_]Initialize or the type-specific init proc.
else
- Find_Last_Init (Master_Node_Ins, Body_Ins);
+ Master_Node_Ins := Find_Last_Init (Decl);
end if;
-- In all other cases the Master_Node is inserted after the last call
-- to either [Deep_]Initialize or the type-specific init proc.
else
- Find_Last_Init (Master_Node_Ins, Body_Ins);
+ Master_Node_Ins := Find_Last_Init (Decl);
end if;
-- If the Initialize function is null or trivial, the call will have
@@ -3096,6 +2798,7 @@ package body Exp_Ch7 is
if CodePeer_Mode or else Obj_Id = Master_Node_Id then
Master_Node_Attach := Make_Null_Statement (Loc);
+
else
Master_Node_Attach :=
Make_Procedure_Call_Statement (Loc,
@@ -3163,6 +2866,7 @@ package body Exp_Ch7 is
elsif CodePeer_Mode then
Master_Node_Attach := Make_Null_Statement (Loc);
+
else
Master_Node_Attach :=
Make_Procedure_Call_Statement (Loc,
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 73a822b4806c32efcbf4a2441a185b652121d70b..712671a427e057612349e0b81b30e98a3ed9cc5e 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -189,6 +189,13 @@ package Exp_Ch7 is
-- one of N_Block_Statement, N_Subprogram_Body, N_Task_Body, N_Entry_Body,
-- or N_Extended_Return_Statement.
+ function Make_Address_For_Finalize
+ (Loc : Source_Ptr;
+ Obj_Ref : Node_Id;
+ Obj_Typ : Entity_Id) return Node_Id;
+ -- Build the address of an object denoted by Obj_Ref and Obj_Typ for use as
+ -- the actual parameter in a call to a Finalize_Address procedure.
+
function Make_Adjust_Call
(Obj_Ref : Node_Id;
Typ : Entity_Id;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index d3d0132cfd8b158db441458dc72307215e05effb..057cf3ebc48008aee77e683c58649c7edc9cfeb9 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -721,7 +721,10 @@ package body Exp_Util is
-- Build_Allocate_Deallocate_Proc --
------------------------------------
- procedure Build_Allocate_Deallocate_Proc (N : Node_Id) is
+ procedure Build_Allocate_Deallocate_Proc
+ (N : Node_Id;
+ Mark : Node_Id := Empty)
+ is
Is_Allocate : constant Boolean := Nkind (N) /= N_Free_Statement;
function Find_Object (E : Node_Id) return Node_Id;
@@ -829,12 +832,18 @@ package body Exp_Util is
-- Obtain the attributes of the allocation
if Is_Allocate then
- if Nkind (N) = N_Object_Declaration then
+ if Nkind (N) in N_Assignment_Statement | N_Object_Declaration then
Expr := Expression (N);
else
Expr := N;
end if;
+ -- Deal with type conversions created for interface types
+
+ if Nkind (Expr) = N_Unchecked_Type_Conversion then
+ Expr := Expression (Expr);
+ end if;
+
-- In certain cases, an allocator with a qualified expression may be
-- relocated and used as the initialization expression of a temporary
-- and the analysis of the declaration of this temporary may in turn
@@ -856,7 +865,7 @@ package body Exp_Util is
and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
then
- Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)));
+ Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), Mark);
return;
end if;
@@ -970,10 +979,9 @@ package body Exp_Util is
Actuals : List_Id;
Alloc_Expr : Node_Id := Empty;
- Fin_Addr_Id : Entity_Id;
- Fin_Coll_Act : Node_Id;
Fin_Coll_Id : Entity_Id;
Proc_To_Call : Entity_Id;
+ Ptr_Coll_Id : Entity_Id;
Subpool : Node_Id := Empty;
begin
@@ -1015,46 +1023,41 @@ package body Exp_Util is
-- c) Finalization collection
- if Needs_Fin then
- Fin_Coll_Id := Finalization_Collection (Ptr_Typ);
- Fin_Coll_Act := New_Occurrence_Of (Fin_Coll_Id, Loc);
-
- -- Handle the case where the collection is actually a pointer
- -- to a collection. This arises in build-in-place functions.
+ Fin_Coll_Id := Make_Temporary (Loc, 'C');
+ Ptr_Coll_Id := Finalization_Collection (Ptr_Typ);
- if Is_Access_Type (Etype (Fin_Coll_Id)) then
- Append_To (Actuals, Fin_Coll_Act);
- else
- Append_To (Actuals,
- Make_Attribute_Reference (Loc,
- Prefix => Fin_Coll_Act,
- Attribute_Name => Name_Unrestricted_Access));
- end if;
- else
- Append_To (Actuals, Make_Null (Loc));
- end if;
-
- -- d) Finalize_Address
-
- -- Primitive Finalize_Address is never generated in CodePeer mode
- -- since it contains an Unchecked_Conversion.
+ -- Create the temporary which represents the collection of
+ -- the expression. Generate:
+ --
+ -- C : Finalization_Collection_Ptr :=
+ -- Finalization_Collection (Ptr_Typ)'Access
+ --
+ -- Handle the case where a collection is actually a pointer
+ -- to a collection. This arises in build-in-place functions.
- if Needs_Fin and then not CodePeer_Mode then
- Fin_Addr_Id := Finalize_Address (Desig_Typ);
- pragma Assert (Present (Fin_Addr_Id));
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Fin_Coll_Id,
+ Object_Definition =>
+ New_Occurrence_Of
+ (RTE (RE_Finalization_Collection_Ptr), Loc),
+ Expression =>
+ (if not Needs_Fin
+ then Make_Null (Loc)
+ elsif Is_Access_Type (Etype (Ptr_Coll_Id))
+ then New_Occurrence_Of (Ptr_Coll_Id, Loc)
+ else
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Ptr_Coll_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
- Append_To (Actuals,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access));
- else
- Append_To (Actuals, Make_Null (Loc));
- end if;
+ Append_To (Actuals, New_Occurrence_Of (Fin_Coll_Id, Loc));
end if;
- -- e) Address
- -- f) Storage_Size
- -- g) Alignment
+ -- d) Address
+ -- e) Storage_Size
+ -- f) Alignment
Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc));
Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc));
@@ -1094,11 +1097,12 @@ package body Exp_Util is
Attribute_Name => Name_Alignment)));
end if;
- -- h) Is_Controlled
+ -- g) Is_Controlled
if Needs_Fin then
Is_Controlled : declare
Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
+
Flag_Expr : Node_Id;
Param : Node_Id;
Pref : Node_Id;
@@ -1206,6 +1210,112 @@ package body Exp_Util is
Expression => Flag_Expr));
Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
+
+ -- Finalize_Address is not generated in CodePeer mode because
+ -- the body contains address arithmetic. So we don't want to
+ -- generate the attach or detach in this case.
+
+ if CodePeer_Mode then
+ null;
+
+ -- Nothing to generate if the flag is statically false
+
+ elsif Is_Entity_Name (Flag_Expr)
+ and then Entity (Flag_Expr) = Standard_False
+ then
+ null;
+
+ -- Generate:
+ -- if F then
+ -- Attach_Object_To_Collection
+ -- (Temp.all'Address,
+ -- Desig_Typ_FD'Access,
+ -- Fin_Coll_Id.all);
+ -- end if;
+
+ elsif Is_Allocate then
+ declare
+ Stmt : Node_Id;
+ Temp : Entity_Id;
+
+ begin
+ -- The original allocator must have been rewritten by
+ -- the caller at this point and a temporary introduced.
+
+ case Nkind (N) is
+ when N_Assignment_Statement =>
+ Temp := New_Copy_Tree (Name (N));
+
+ when N_Object_Declaration =>
+ Temp :=
+ New_Occurrence_Of (Defining_Identifier (N), Loc);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Stmt :=
+ Make_If_Statement (Loc,
+ Condition =>
+ New_Occurrence_Of (Flag_Id, Loc),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Attach_Object_To_Collection), Loc),
+ Parameter_Associations => New_List (
+ Make_Address_For_Finalize (Loc,
+ Make_Explicit_Dereference (Loc, Temp),
+ Desig_Typ),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Finalize_Address (Desig_Typ), Loc),
+ Attribute_Name => Name_Unrestricted_Access),
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of (Fin_Coll_Id, Loc))))));
+
+ -- If we have a mark past the initialization, then insert
+ -- the statement there, otherwise insert after either the
+ -- assignment or the last initialization statement of the
+ -- declaration of the temporary.
+
+ if Present (Mark) then
+ Insert_Action (Mark, Stmt, Suppress => All_Checks);
+
+ elsif Nkind (N) = N_Assignment_Statement then
+ Insert_After_And_Analyze
+ (N, Stmt, Suppress => All_Checks);
+
+ else
+ Insert_After_And_Analyze
+ (Find_Last_Init (N), Stmt, Suppress => All_Checks);
+ end if;
+ end;
+
+ -- Generate:
+ -- if F then
+ -- Detach_Object_From_Collection (Temp.all'Address);
+ -- end if;
+
+ else
+ Insert_Action (N,
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Flag_Id, Loc),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Detach_Object_From_Collection), Loc),
+ Parameter_Associations => New_List (
+ Make_Address_For_Finalize (Loc,
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of
+ (Entity (Expression (N)), Loc)),
+ Desig_Typ))))),
+ Suppress => All_Checks);
+ end if;
+
end Is_Controlled;
-- The object is not controlled
@@ -1214,7 +1324,7 @@ package body Exp_Util is
Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc));
end if;
- -- i) On_Subpool
+ -- h) On_Subpool
if Is_Allocate then
Append_To (Actuals,
@@ -6130,6 +6240,332 @@ package body Exp_Util is
end if;
end Find_Interface_Tag;
+ --------------------
+ -- Find_Last_Init --
+ --------------------
+
+ function Find_Last_Init (Decl : Node_Id) return Node_Id is
+ Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
+
+ Init_Typ : Entity_Id;
+ -- The initialization type of the related object declaration. Note
+ -- that this is not necessarily the same type as Obj_Typ because of
+ -- possible type derivations.
+
+ Obj_Typ : Entity_Id;
+ -- The (designated) type of the object declaration
+
+ function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
+ -- Find the last initialization call within the statements of block Blk
+
+ function Is_Init_Call (N : Node_Id) return Boolean;
+ -- Determine whether node N denotes one of the initialization procedures
+ -- of types Init_Typ or Typ.
+
+ function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
+ -- Obtain the next statement which follows list member Stmt while
+ -- ignoring artifacts related to access-before-elaboration checks.
+
+ -----------------------------
+ -- Find_Last_Init_In_Block --
+ -----------------------------
+
+ function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
+ HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
+
+ Stmt : Node_Id;
+
+ begin
+ -- Examine the individual statements of the block in reverse to
+ -- locate the last initialization call.
+
+ if Present (HSS) and then Present (Statements (HSS)) then
+ Stmt := Last (Statements (HSS));
+
+ while Present (Stmt) loop
+ -- Peek inside nested blocks in case aborts are allowed
+
+ if Nkind (Stmt) = N_Block_Statement then
+ return Find_Last_Init_In_Block (Stmt);
+
+ elsif Is_Init_Call (Stmt) then
+ return Stmt;
+ end if;
+
+ Prev (Stmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end Find_Last_Init_In_Block;
+
+ ------------------
+ -- Is_Init_Call --
+ ------------------
+
+ function Is_Init_Call (N : Node_Id) return Boolean is
+ function Is_Init_Proc_Of
+ (Subp : Entity_Id;
+ Typ : Entity_Id) return Boolean;
+ -- Determine whether subprogram Subp_Id is a valid init proc of
+ -- type Typ.
+
+ ---------------------
+ -- Is_Init_Proc_Of --
+ ---------------------
+
+ function Is_Init_Proc_Of
+ (Subp : Entity_Id;
+ Typ : Entity_Id) return Boolean
+ is
+ Deep_Init : Entity_Id := Empty;
+ Prim_Init : Entity_Id := Empty;
+ Type_Init : Entity_Id := Empty;
+
+ begin
+ -- Obtain all possible initialization routines of the
+ -- related type and try to match the subprogram entity
+ -- against one of them.
+
+ -- Deep_Initialize
+
+ Deep_Init := TSS (Typ, TSS_Deep_Initialize);
+
+ -- Primitive Initialize
+
+ if Is_Controlled (Typ) then
+ Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
+
+ if Present (Prim_Init) then
+ Prim_Init := Ultimate_Alias (Prim_Init);
+ end if;
+ end if;
+
+ -- Type initialization routine
+
+ if Has_Non_Null_Base_Init_Proc (Typ) then
+ Type_Init := Base_Init_Proc (Typ);
+ end if;
+
+ return
+ (Present (Deep_Init) and then Subp = Deep_Init)
+ or else
+ (Present (Prim_Init) and then Subp = Prim_Init)
+ or else
+ (Present (Type_Init) and then Subp = Type_Init);
+ end Is_Init_Proc_Of;
+
+ -- Local variables
+
+ Call_Id : Entity_Id;
+
+ -- Start of processing for Is_Init_Call
+
+ begin
+ if Nkind (N) = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Name (N))
+ then
+ Call_Id := Entity (Name (N));
+
+ -- Consider both the type of the object declaration and its
+ -- related initialization type.
+
+ return
+ Is_Init_Proc_Of (Call_Id, Init_Typ)
+ or else
+ Is_Init_Proc_Of (Call_Id, Obj_Typ);
+ end if;
+
+ return False;
+ end Is_Init_Call;
+
+ -----------------------------
+ -- Next_Suitable_Statement --
+ -----------------------------
+
+ function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
+ Result : Node_Id;
+
+ begin
+ -- Skip call markers and Program_Error raises installed by the
+ -- ABE mechanism.
+
+ Result := Next (Stmt);
+ while Present (Result) loop
+ exit when Nkind (Result) not in
+ N_Call_Marker | N_Raise_Program_Error;
+
+ Next (Result);
+ end loop;
+
+ return Result;
+ end Next_Suitable_Statement;
+
+ -- Local variables
+
+ Call : Node_Id;
+ Last_Init : Node_Id;
+ Stmt : Node_Id;
+ Stmt_2 : Node_Id;
+
+ Deep_Init_Found : Boolean := False;
+ -- A flag set when a call to [Deep_]Initialize has been found
+
+ -- Start of processing for Find_Last_Init
+
+ begin
+ Last_Init := Decl;
+
+ -- Objects that capture controlled function results do not require
+ -- initialization.
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Nkind (Expression (Decl)) = N_Reference
+ then
+ return Last_Init;
+ end if;
+
+ Obj_Typ := Base_Type (Etype (Obj_Id));
+
+ if Is_Access_Type (Obj_Typ) then
+ Obj_Typ := Available_View (Designated_Type (Obj_Typ));
+ end if;
+
+ -- Handle the initialization type of the object declaration
+
+ if Is_Class_Wide_Type (Obj_Typ)
+ and then Nkind (Decl) = N_Object_Declaration
+ and then Nkind (Expression (Decl)) = N_Allocator
+ then
+ Init_Typ := Base_Type (Etype (Expression (Expression (Decl))));
+ else
+ Init_Typ := Obj_Typ;
+ end if;
+
+ loop
+ if Is_Private_Type (Init_Typ)
+ and then Present (Full_View (Init_Typ))
+ then
+ Init_Typ := Base_Type (Full_View (Init_Typ));
+
+ elsif Is_Concurrent_Type (Init_Typ)
+ and then Present (Corresponding_Record_Type (Init_Typ))
+ then
+ Init_Typ := Corresponding_Record_Type (Init_Typ);
+
+ elsif Is_Untagged_Derivation (Init_Typ) then
+ Init_Typ := Root_Type (Init_Typ);
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ if Present (Freeze_Node (Obj_Id)) then
+ Stmt := First (Actions (Freeze_Node (Obj_Id)));
+ else
+ Stmt := Next_Suitable_Statement (Decl);
+ end if;
+
+ -- For an object with suppressed initialization, we check whether
+ -- there is in fact no initialization expression. If there is not,
+ -- then this is an object declaration that has been turned into a
+ -- different object declaration that calls the build-in-place
+ -- function in a 'Reference attribute, as in "F(...)'Reference".
+ -- We search for that later object declaration, so that the
+ -- attachment will be inserted after the call. Otherwise, if the
+ -- call raises an exception, we will finalize the (uninitialized)
+ -- object, which is wrong.
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then No_Initialization (Decl)
+ then
+ if No (Expression (Last_Init)) then
+ loop
+ Next (Last_Init);
+
+ exit when No (Last_Init);
+ exit when Nkind (Last_Init) = N_Object_Declaration
+ and then Nkind (Expression (Last_Init)) = N_Reference
+ and then Nkind (Prefix (Expression (Last_Init))) =
+ N_Function_Call
+ and then Is_Expanded_Build_In_Place_Call
+ (Prefix (Expression (Last_Init)));
+ end loop;
+ end if;
+
+ return Last_Init;
+
+ -- If the initialization is in the declaration, we're done, so
+ -- early return if we have no more statements or they have been
+ -- rewritten, which means that they were in the source code.
+
+ elsif No (Stmt) or else Original_Node (Stmt) /= Stmt then
+ return Last_Init;
+
+ -- In all other cases the initialization calls follow the related
+ -- object. The general structure of object initialization built by
+ -- routine Default_Initialize_Object is as follows:
+
+ -- [begin -- aborts allowed
+ -- Abort_Defer;]
+ -- Type_Init_Proc (Obj);
+ -- [begin] -- exceptions allowed
+ -- Deep_Initialize (Obj);
+ -- [exception -- exceptions allowed
+ -- when others =>
+ -- Deep_Finalize (Obj, Self => False);
+ -- raise;
+ -- end;]
+ -- [at end -- aborts allowed
+ -- Abort_Undefer;
+ -- end;]
+
+ -- When aborts are allowed, the initialization calls are housed
+ -- within a block.
+
+ elsif Nkind (Stmt) = N_Block_Statement then
+ Call := Find_Last_Init_In_Block (Stmt);
+
+ if Present (Call) then
+ Last_Init := Call;
+ end if;
+
+ -- Otherwise the initialization calls follow the related object
+
+ else
+ Stmt_2 := Next_Suitable_Statement (Stmt);
+
+ -- Check for an optional call to Deep_Initialize which may
+ -- appear within a block depending on whether the object has
+ -- controlled components.
+
+ if Present (Stmt_2) then
+ if Nkind (Stmt_2) = N_Block_Statement then
+ Call := Find_Last_Init_In_Block (Stmt_2);
+
+ if Present (Call) then
+ Deep_Init_Found := True;
+ Last_Init := Call;
+ end if;
+
+ elsif Is_Init_Call (Stmt_2) then
+ Deep_Init_Found := True;
+ Last_Init := Stmt_2;
+ end if;
+ end if;
+
+ -- If the object lacks a call to Deep_Initialize, then it must
+ -- have a call to its related type init proc.
+
+ if not Deep_Init_Found and then Is_Init_Call (Stmt) then
+ Last_Init := Stmt;
+ end if;
+ end if;
+
+ return Last_Init;
+ end Find_Last_Init;
+
---------------------------
-- Find_Optional_Prim_Op --
---------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 4e7a4bba2cf1ab24beda7ce80f324ecbf656ccf1..3c7e70ed13b70481eb0848cc86a26391b1873e82 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -234,17 +234,27 @@ package Exp_Util is
-- Return the static value of a statically known attribute reference
-- Pref'Constrained.
- procedure Build_Allocate_Deallocate_Proc (N : Node_Id);
+ procedure Build_Allocate_Deallocate_Proc
+ (N : Node_Id;
+ Mark : Node_Id := Empty);
-- Create a custom Allocate/Deallocate to be associated with an allocation
- -- or deallocation:
+ -- or deallocation for:
--
-- 1) controlled objects
-- 2) class-wide objects
- -- 3) any kind of object on a subpool
+ -- 3) any kind of objects on a subpool
--
- -- N must be an allocator or the declaration of a temporary variable which
- -- represents the expression of the original allocator node, otherwise N
- -- must be a free statement.
+ -- Moreover, for objects that need finalization, generate the attachment
+ -- actions to resp. detachment actions from the appropriate collection.
+ --
+ -- N must be an allocator or the declaration of a temporary initialized by
+ -- an allocator or an assignment of an allocator to a temporary, otherwise
+ -- N must be a free statement of a temporary.
+ --
+ -- Mark must be set to a mark past the initialization of the allocator if
+ -- it is initialized (the allocator itself is OK) or left empty otherwise.
+ -- It is used to determine the place where objects that need finalization
+ -- can be attached to the appropriate collection.
function Build_Abort_Undefer_Block
(Loc : Source_Ptr;
@@ -564,6 +574,9 @@ package Exp_Util is
-- WARNING: There is a matching C declaration of this subprogram in fe.h
+ function Find_Last_Init (Decl : Node_Id) return Node_Id;
+ -- Find the last initialization call related to object declaration Decl
+
function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
-- Find the first primitive operation of a tagged type T with name Name.
-- This function allows the use of a primitive operation which is not
diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb
index 1fbd391c66c9b7a897c95a505d387512b6b7dfba..8026b3fb284bbffe8974abd18fd9e529a68ae6c6 100644
--- a/gcc/ada/libgnat/s-finpri.adb
+++ b/gcc/ada/libgnat/s-finpri.adb
@@ -29,7 +29,8 @@
-- --
------------------------------------------------------------------------------
-with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Unchecked_Conversion;
with System.Soft_Links; use System.Soft_Links;
@@ -37,6 +38,12 @@ package body System.Finalization_Primitives is
use type System.Storage_Elements.Storage_Offset;
+ function To_Collection_Node_Ptr is
+ new Ada.Unchecked_Conversion (Address, Collection_Node_Ptr);
+
+ procedure Detach_Node_From_Collection (Node : not null Collection_Node_Ptr);
+ -- Removes a collection node from its associated finalization collection
+
---------------------------
-- Add_Offset_To_Address --
---------------------------
@@ -49,23 +56,57 @@ package body System.Finalization_Primitives is
return System.Storage_Elements."+" (Addr, Offset);
end Add_Offset_To_Address;
- -------------------------------
- -- Attach_Node_To_Collection --
- -------------------------------
+ ---------------------------------
+ -- Attach_Object_To_Collection --
+ ---------------------------------
- procedure Attach_Node_To_Collection
- (Node : not null Collection_Node_Ptr;
+ procedure Attach_Object_To_Collection
+ (Object_Address : System.Address;
Finalize_Address : not null Finalize_Address_Ptr;
Collection : in out Finalization_Collection)
is
+ Node : constant Collection_Node_Ptr :=
+ To_Collection_Node_Ptr (Object_Address - Header_Size);
+
begin
+ Lock_Task.all;
+
+ -- Do not allow the attachment of controlled objects while the
+ -- associated collection is being finalized.
+
+ -- Synchronization:
+ -- Read - attachment, finalization
+ -- Write - finalization
+
+ if Collection.Finalization_Started then
+ raise Program_Error with "attachment after finalization started";
+ end if;
+
+ -- Check whether primitive Finalize_Address is available. If it is
+ -- not, then either the expansion of the designated type failed or
+ -- the expansion of the allocator failed. This is a compiler bug.
+
+ pragma Assert
+ (Finalize_Address /= null, "primitive Finalize_Address not available");
+
Node.Finalize_Address := Finalize_Address;
Node.Prev := Collection.Head'Unchecked_Access;
Node.Next := Collection.Head.Next;
Collection.Head.Next.Prev := Node;
Collection.Head.Next := Node;
- end Attach_Node_To_Collection;
+
+ Unlock_Task.all;
+
+ exception
+ when others =>
+
+ -- Unlock the task in case the attachment failed and reraise the
+ -- exception.
+
+ Unlock_Task.all;
+ raise;
+ end Attach_Object_To_Collection;
-----------------------------
-- Attach_Object_To_Master --
@@ -128,16 +169,23 @@ package body System.Finalization_Primitives is
end if;
end Detach_Node_From_Collection;
- --------------------------
- -- Finalization_Started --
- --------------------------
+ -----------------------------------
+ -- Detach_Object_From_Collection --
+ -----------------------------------
- function Finalization_Started
- (Master : Finalization_Collection) return Boolean
+ procedure Detach_Object_From_Collection
+ (Object_Address : System.Address)
is
+ Node : constant Collection_Node_Ptr :=
+ To_Collection_Node_Ptr (Object_Address - Header_Size);
+
begin
- return Master.Finalization_Started;
- end Finalization_Started;
+ Lock_Task.all;
+
+ Detach_Node_From_Collection (Node);
+
+ Unlock_Task.all;
+ end Detach_Object_From_Collection;
--------------
-- Finalize --
@@ -168,7 +216,7 @@ package body System.Finalization_Primitives is
Lock_Task.all;
-- Synchronization:
- -- Read - allocation, finalization
+ -- Read - attachment, finalization
-- Write - finalization
if Collection.Finalization_Started then
@@ -180,13 +228,13 @@ package body System.Finalization_Primitives is
return;
end if;
- -- Lock the collection to prevent any allocation while the objects are
+ -- Lock the collection to prevent any attachment while the objects are
-- being finalized. The collection remains locked because either it is
-- explicitly deallocated or the associated access type is about to go
-- out of scope.
-- Synchronization:
- -- Read - allocation, finalization
+ -- Read - attachment, finalization
-- Write - finalization
Collection.Finalization_Started := True;
@@ -201,7 +249,7 @@ package body System.Finalization_Primitives is
Curr_Ptr := Collection.Head.Next;
-- Synchronization:
- -- Write - allocation, deallocation, finalization
+ -- Write - attachment, detachment, finalization
Detach_Node_From_Collection (Curr_Ptr);
diff --git a/gcc/ada/libgnat/s-finpri.ads b/gcc/ada/libgnat/s-finpri.ads
index 9fe9ef47eb7618dc2cf0244f24d16df70c982569..874a82f53499d1a8c1a94e125aa1aa5993911c13 100644
--- a/gcc/ada/libgnat/s-finpri.ads
+++ b/gcc/ada/libgnat/s-finpri.ads
@@ -143,10 +143,6 @@ package System.Finalization_Primitives with Preelaborate is
-- collection, in some arbitrary order. Calls to this procedure with
-- a collection that has already been finalized have no effect.
- function Finalization_Started
- (Master : Finalization_Collection) return Boolean;
- -- Return the finalization status of a collection
-
type Collection_Node is private;
-- Each controlled object associated with a finalization collection has
-- an associated object of this type.
@@ -157,17 +153,20 @@ package System.Finalization_Primitives with Preelaborate is
-- A reference to a collection node. Since this type may not be used to
-- allocate objects, its storage size is zero.
- procedure Attach_Node_To_Collection
- (Node : not null Collection_Node_Ptr;
+ procedure Attach_Object_To_Collection
+ (Object_Address : System.Address;
Finalize_Address : not null Finalize_Address_Ptr;
Collection : in out Finalization_Collection);
- -- Associates a collection node with a finalization collection. The node
+ -- Associates a controlled object allocated for some access type with a
+ -- given finalization collection. Finalize_Address denotes the operation
+ -- to be called to finalize the object (which could be a user-declared
+ -- Finalize procedure or a procedure generated by the compiler). An object
-- can be associated with at most one finalization collection.
- procedure Detach_Node_From_Collection (Node : not null Collection_Node_Ptr);
- -- Removes a collection node from its associated finalization collection.
- -- Calls to the procedure with a Node that has already been detached have
- -- no effects.
+ procedure Detach_Object_From_Collection (Object_Address : System.Address);
+ -- Removes a controlled object from its associated finalization collection.
+ -- Calls to the procedure with an object that has already been detached
+ -- have no effects.
function Header_Size return System.Storage_Elements.Storage_Count;
-- Return the size of type Collection_Node as Storage_Count
@@ -231,10 +230,13 @@ private
-- The head of the circular doubly-linked list of Collection_Nodes
Finalization_Started : Boolean := False;
- pragma Atomic (Finalization_Started);
-- A flag used to detect allocations which occur during the finalization
-- of a collection. The allocations must raise Program_Error. This may
-- arise in a multitask environment.
end record;
+ -- This operation is very simple and thus can be performed in line
+
+ pragma Inline (Initialize);
+
end System.Finalization_Primitives;
diff --git a/gcc/ada/libgnat/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb
index 8d232fa0d61eec35d516c4a791a6218450ac8912..38dc69f976a1a7f384a8bc99184c6b2a9b48a522 100644
--- a/gcc/ada/libgnat/s-stposu.adb
+++ b/gcc/ada/libgnat/s-stposu.adb
@@ -29,23 +29,18 @@
-- --
------------------------------------------------------------------------------
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Unchecked_Conversion;
+with Ada.Exceptions; use Ada.Exceptions;
with System.Address_Image;
-with System.Finalization_Primitives; use System.Finalization_Primitives;
-with System.IO; use System.IO;
-with System.Soft_Links; use System.Soft_Links;
-with System.Storage_Elements; use System.Storage_Elements;
+with System.IO; use System.IO;
+with System.Soft_Links; use System.Soft_Links;
+with System.Storage_Elements; use System.Storage_Elements;
with System.Storage_Pools.Subpools.Finalization;
use System.Storage_Pools.Subpools.Finalization;
package body System.Storage_Pools.Subpools is
- function To_Collection_Node_Ptr is
- new Ada.Unchecked_Conversion (Address, Collection_Node_Ptr);
-
procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
-- Attach a subpool node to a pool
@@ -99,25 +94,24 @@ package body System.Storage_Pools.Subpools is
-----------------------------
procedure Allocate_Any_Controlled
- (Pool : in out Root_Storage_Pool'Class;
- Context_Subpool : Subpool_Handle;
- Context_Collection : Finalization_Primitives.Finalization_Collection_Ptr;
- Fin_Address : Finalization_Primitives.Finalize_Address_Ptr;
- Addr : out System.Address;
- Storage_Size : System.Storage_Elements.Storage_Count;
- Alignment : System.Storage_Elements.Storage_Count;
- Is_Controlled : Boolean;
- On_Subpool : Boolean)
+ (Pool : in out Root_Storage_Pool'Class;
+ Named_Subpool : Subpool_Handle;
+ Collection : in out
+ Finalization_Primitives.Finalization_Collection_Ptr;
+ Addr : out System.Address;
+ Storage_Size : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count;
+ Is_Controlled : Boolean;
+ On_Subpool : Boolean)
is
+ use type System.Finalization_Primitives.Finalization_Collection_Ptr;
+
Is_Subpool_Allocation : constant Boolean :=
Pool in Root_Storage_Pool_With_Subpools'Class;
- Collection : Finalization_Collection_Ptr := null;
- N_Addr : Address;
- N_Ptr : Collection_Node_Ptr;
- N_Size : Storage_Count;
- Subpool : Subpool_Handle := null;
- Lock_Taken : Boolean := False;
+ N_Addr : Address;
+ N_Size : Storage_Count;
+ Subpool : Subpool_Handle;
Header_And_Padding : Storage_Offset;
-- This offset includes the size of a collection node plus an additional
@@ -134,7 +128,7 @@ package body System.Storage_Pools.Subpools is
-- Case of an allocation without a Subpool_Handle. Dispatch to the
-- implementation of Default_Subpool_For_Pool.
- if Context_Subpool = null then
+ if Named_Subpool = null then
Subpool :=
Default_Subpool_For_Pool
(Root_Storage_Pool_With_Subpools'Class (Pool));
@@ -142,7 +136,7 @@ package body System.Storage_Pools.Subpools is
-- Allocation with a Subpool_Handle
else
- Subpool := Context_Subpool;
+ Subpool := Named_Subpool;
end if;
-- Ensure proper ownership and chaining of the subpool
@@ -166,13 +160,13 @@ package body System.Storage_Pools.Subpools is
-- type has failed to create one. This is a compiler bug.
pragma Assert
- (Context_Collection /= null, "no collection in pool allocation");
+ (Collection /= null, "no collection in pool allocation");
-- If a subpool is present, then this is the result of erroneous
-- allocator expansion. This is not a serious error, but it should
-- still be detected.
- if Context_Subpool /= null then
+ if Named_Subpool /= null then
raise Program_Error
with "subpool not required in pool allocation";
end if;
@@ -185,38 +179,14 @@ package body System.Storage_Pools.Subpools is
raise Program_Error
with "pool of access type does not support subpools";
end if;
-
- Collection := Context_Collection;
end if;
- -- Step 2: Collection, Finalize_Address-related runtime checks and size
- -- calculations.
+ -- Step 2: Size calculation
-- Allocation of a descendant from [Limited_]Controlled, a class-wide
-- object or a record with controlled components.
if Is_Controlled then
- Lock_Taken := True;
- Lock_Task.all;
-
- -- Do not allow the allocation of controlled objects while the
- -- associated collection is being finalized.
-
- -- Synchronization:
- -- Read - allocation, finalization
- -- Write - finalization
-
- if Finalization_Started (Collection.all) then
- raise Program_Error with "allocation after finalization started";
- end if;
-
- -- Check whether primitive Finalize_Address is available. If it is
- -- not, then either the expansion of the designated type failed or
- -- the expansion of the allocator failed. This is a compiler bug.
-
- pragma Assert
- (Fin_Address /= null, "primitive Finalize_Address not available");
-
-- The size must account for the hidden header preceding the object.
-- Account for possible padding space before the header due to a
-- larger alignment.
@@ -248,62 +218,35 @@ package body System.Storage_Pools.Subpools is
Allocate (Pool, N_Addr, N_Size, Alignment);
end if;
- -- Step 4: Attachment
+ -- Step 4: Displacement of address
if Is_Controlled then
- -- Note that we already did "Lock_Task.all;" in Step 2 above
-
-- Map the allocated memory into a collection node. This converts the
-- top of the allocated bits into a list header. If there is padding
-- due to larger alignment, the padding is placed at the beginning:
- -- N_Addr N_Ptr
- -- | |
- -- V V
- -- +-------+---------------+----------------------+
- -- |Padding| Header | Object |
- -- +-------+---------------+----------------------+
- -- ^ ^ ^
- -- | +- Header_Size -+
- -- | |
- -- +- Header_And_Padding --+
-
- N_Ptr :=
- To_Collection_Node_Ptr (N_Addr + Header_And_Padding - Header_Size);
-
- -- Attach the allocated object to the finalization collection
-
- -- Synchronization:
- -- Write - allocation, deallocation, finalization
-
- Attach_Node_To_Collection (N_Ptr, Fin_Address, Collection.all);
+ -- N_Addr Addr
+ -- | |
+ -- V V
+ -- +-------+---------------+----------------------+
+ -- |Padding| Header | Object |
+ -- +-------+---------------+----------------------+
+ -- ^ ^ ^
+ -- | +- Header_Size -+
+ -- | |
+ -- +- Header_And_Padding --+
-- Move the address from the hidden list header to the start of the
-- object. This operation effectively hides the list header.
Addr := N_Addr + Header_And_Padding;
- Unlock_Task.all;
- Lock_Taken := False;
-
-- Non-controlled allocation
else
Addr := N_Addr;
end if;
-
- exception
- when others =>
-
- -- Unlock the task in case the allocation step failed and reraise the
- -- exception.
-
- if Lock_Taken then
- Unlock_Task.all;
- end if;
-
- raise;
end Allocate_Any_Controlled;
------------
@@ -341,7 +284,6 @@ package body System.Storage_Pools.Subpools is
Is_Controlled : Boolean)
is
N_Addr : Address;
- N_Ptr : Collection_Node_Ptr;
N_Size : Storage_Count;
Header_And_Padding : Storage_Offset;
@@ -349,68 +291,39 @@ package body System.Storage_Pools.Subpools is
-- padding due to a larger alignment.
begin
- -- Step 1: Detachment
+ -- Step 1: Displacement of address
if Is_Controlled then
- Lock_Task.all;
-
- begin
- -- Account for possible padding space before the header due to a
- -- larger alignment.
-
- Header_And_Padding := Header_Size_With_Padding (Alignment);
-
- -- N_Addr N_Ptr Addr (from input)
- -- | | |
- -- V V V
- -- +-------+---------------+----------------------+
- -- |Padding| Header | Object |
- -- +-------+---------------+----------------------+
- -- ^ ^ ^
- -- | +- Header_Size -+
- -- | |
- -- +- Header_And_Padding --+
-
- -- Convert the bits preceding the object into a list header
-
- N_Ptr := To_Collection_Node_Ptr (Addr - Header_Size);
-
- -- Detach the object from the related finalization collection.
- -- This action does not need to know the context used during
- -- allocation.
-
- -- Synchronization:
- -- Write - allocation, deallocation, finalization
-
- Detach_Node_From_Collection (N_Ptr);
-
- -- Move the address from the object to the beginning of the list
- -- header.
+ -- Account for possible padding space before the header due to a
+ -- larger alignment.
- N_Addr := Addr - Header_And_Padding;
+ Header_And_Padding := Header_Size_With_Padding (Alignment);
- -- The size of the deallocated object must include the size of the
- -- hidden list header.
+ -- N_Addr Addr
+ -- | |
+ -- V V
+ -- +-------+---------------+----------------------+
+ -- |Padding| Header | Object |
+ -- +-------+---------------+----------------------+
+ -- ^ ^ ^
+ -- | +- Header_Size -+
+ -- | |
+ -- +- Header_And_Padding --+
- N_Size := Storage_Size + Header_And_Padding;
+ -- Move the address from the object to the beginning of the header
- Unlock_Task.all;
+ N_Addr := Addr - Header_And_Padding;
- exception
- when others =>
+ -- The size of the deallocated object must include that of the header
- -- Unlock the task in case the computations performed above
- -- fail for some reason.
+ N_Size := Storage_Size + Header_And_Padding;
- Unlock_Task.all;
- raise;
- end;
else
N_Addr := Addr;
N_Size := Storage_Size;
end if;
- -- Step 2: Deallocation
+ -- Step 2: Deallocation of object
-- Dispatch to the proper implementation of Deallocate. This action
-- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
@@ -542,7 +455,8 @@ package body System.Storage_Pools.Subpools is
(Alignment : System.Storage_Elements.Storage_Count)
return System.Storage_Elements.Storage_Count
is
- Size : constant Storage_Count := Header_Size;
+ Size : constant Storage_Count :=
+ System.Finalization_Primitives.Header_Size;
begin
if Size mod Alignment = 0 then
diff --git a/gcc/ada/libgnat/s-stposu.ads b/gcc/ada/libgnat/s-stposu.ads
index f3b908d53e499a8924d7c9b11be3d8f7b9fef34b..a2f306a0c9359ddec6e2a51ba5c40a719e3aeca8 100644
--- a/gcc/ada/libgnat/s-stposu.ads
+++ b/gcc/ada/libgnat/s-stposu.ads
@@ -242,15 +242,15 @@ private
-- to Allocate_Any.
procedure Allocate_Any_Controlled
- (Pool : in out Root_Storage_Pool'Class;
- Context_Subpool : Subpool_Handle;
- Context_Collection : Finalization_Primitives.Finalization_Collection_Ptr;
- Fin_Address : Finalization_Primitives.Finalize_Address_Ptr;
- Addr : out System.Address;
- Storage_Size : System.Storage_Elements.Storage_Count;
- Alignment : System.Storage_Elements.Storage_Count;
- Is_Controlled : Boolean;
- On_Subpool : Boolean);
+ (Pool : in out Root_Storage_Pool'Class;
+ Named_Subpool : Subpool_Handle;
+ Collection : in out
+ Finalization_Primitives.Finalization_Collection_Ptr;
+ Addr : out System.Address;
+ Storage_Size : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count;
+ Is_Controlled : Boolean;
+ On_Subpool : Boolean);
-- Compiler interface. This version of Allocate handles all possible cases,
-- either on a pool or a pool_with_subpools, regardless of the controlled
-- status of the allocated object. Parameter usage:
@@ -258,16 +258,13 @@ private
-- * Pool - The pool associated with the access type. Pool can be any
-- derivation from Root_Storage_Pool, including a pool_with_subpools.
--
- -- * Context_Subpool - The subpool handle name of an allocator. If no
- -- subpool handle is present at the point of allocation, the actual
- -- would be null.
- --
- -- * Context_Collection - The finalization collection associated with the
- -- access type. If the access type's designated type is not controlled,
- -- the actual would be null.
+ -- * Named_Subpool - The subpool identified by the handle name of an
+ -- allocator. If no handle name is present, the actual would be null.
--
- -- * Fin_Address - TSS routine Finalize_Address of the designated type.
- -- If the designated type is not controlled, the actual would be null.
+ -- * Collection - The finalization collection associated with the access
+ -- type if its designated type is controlled. If it is not, the actual
+ -- would be null. If the object is allocated on a subpool, the parameter
+ -- is updated to the collection of the subpool.
--
-- * Addr - The address of the allocated object.
--
@@ -276,8 +273,8 @@ private
-- * Alignment - The alignment of the allocated object.
--
-- * Is_Controlled - A flag which determines whether the allocated object
- -- is controlled. When set to True, the machinery generates additional
- -- data.
+ -- is controlled. When set to True, the machinery allocates more space
+ -- and returns a displaced address.
--
-- * On_Subpool - A flag which determines whether the a subpool handle
-- name is present at the point of allocation. This is used for error
@@ -303,8 +300,7 @@ private
-- * Alignment - The alignment of the allocated object.
--
-- * Is_Controlled - A flag which determines whether the allocated object
- -- is controlled. When set to True, the machinery generates additional
- -- data.
+ -- is controlled. When set to True, the address must be displaced.
procedure Detach (N : not null SP_Node_Ptr);
-- Unhook a subpool node from an arbitrary subpool list
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index d67dc0e678370ef0953435bb1fbe228d4f47af22..50c77867dcdc70298f9c21c3e5d22707852cba4f 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -918,9 +918,11 @@ package Rtsfind is
RE_Attr_Long_Long_Float, -- System.Fat_LLF
RE_Add_Offset_To_Address, -- System.Finalization_Primitives
+ RE_Attach_Object_To_Collection, -- System.Finalization_Primitives
RE_Attach_Object_To_Master, -- System.Finalization_Primitives
RE_Attach_Object_To_Node, -- System.Finalization_Primitives
RE_Chain_Node_To_Master, -- System.Finalization_Primitives
+ RE_Detach_Object_From_Collection, -- System.Finalization_Primitives
RE_Finalization_Collection, -- System.Finalization_Primitives
RE_Finalization_Collection_Ptr, -- System.Finalization_Primitives
RE_Finalization_Master, -- System.Finalization_Primitives
@@ -2567,9 +2569,11 @@ package Rtsfind is
RE_Attr_Long_Long_Float => System_Fat_LLF,
RE_Add_Offset_To_Address => System_Finalization_Primitives,
+ RE_Attach_Object_To_Collection => System_Finalization_Primitives,
RE_Attach_Object_To_Master => System_Finalization_Primitives,
RE_Attach_Object_To_Node => System_Finalization_Primitives,
RE_Chain_Node_To_Master => System_Finalization_Primitives,
+ RE_Detach_Object_From_Collection => System_Finalization_Primitives,
RE_Finalization_Collection => System_Finalization_Primitives,
RE_Finalization_Collection_Ptr => System_Finalization_Primitives,
RE_Finalization_Master => System_Finalization_Primitives,