@@ -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>;
@@ -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);
@@ -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,
@@ -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;
@@ -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 --
---------------------------
@@ -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
@@ -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);
@@ -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;
@@ -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
@@ -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
@@ -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,
From: Eric Botcazou <ebotcazou@adacore.com> This decouples the attachment to the appropriate finalization collection of dynamically allocated objects that need finalization from their allocation. The current implementation immediately attaches them after allocating them, which means that they will be finalized even if their initialization does not complete successfully. The new implementation instead generates the same sequence as the one generated for (statically) declared objects, that is to say, allocation, initialization and attachment in this order. gcc/ada/ * exp_ch3.adb (Build_Default_Initialization): Do not generate the protection for finalization collections. (Build_Heap_Or_Pool_Allocator): Set the No_Initialization flag on the declaration of the temporary. * exp_ch4.adb (Build_Aggregate_In_Place): Do not build an allocation procedure here. (Expand_Allocator_Expression): Build an allocation procedure, if it is required, only just before rewriting the allocator. (Expand_N_Allocator): Do not build an allocation procedure if the No_Initialization flag is set on the allocator, except for those generated for special return objects. In other cases, build an allocation procedure, if it is required, only before rewriting the allocator. * exp_ch7.ads (Make_Address_For_Finalize): New function declaration. * exp_ch7.adb (Finalization Management): Update description for dynamically allocated objects. (Make_Address_For_Finalize): Remove declaration. (Find_Last_Init): Change to function and move to... (Process_Object_Declaration): Adjust to above change. * exp_util.ads (Build_Allocate_Deallocate_Proc): Add Mark parameter with Empty default and document it. (Find_Last_Init): New function declaration. * exp_util.adb (Build_Allocate_Deallocate_Proc): Add Mark parameter with Empty default and pass it in recursive call. Deal with type conversions created for interface types. Adjust call sequence to Allocate_Any_Controlled by changing Collection to In/Out parameter and removing Finalize_Address parameter. For a controlled object, generate a conditional call to Attach_Object_To_Collection for an allocation and to Detach_Object_From_Collection for a deallocation. (Find_Last_Init): ...here. Compute the initialization type for an allocator whose designating type is class wide specifically and also handle concurrent types. * rtsfind.ads (RE_Id): Add RE_Attach_Object_To_Collection and RE_Detach_Object_From_Collection. (RE_Unit_Table): Add entries for RE_Attach_Object_To_Collection and RE_Detach_Object_From_Collection. * libgnat/s-finpri.ads (Finalization_Started): Delete. (Attach_Node_To_Collection): Likewise. (Detach_Node_From_Collection): Move to... (Attach_Object_To_Collection): New procedure declaration. (Detach_Object_From_Collection): Likewise. (Finalization_Collection): Remove Atomic for Finalization_Started. Add pragma Inline for Initialize. * libgnat/s-finpri.adb: Add clause for Ada.Unchecked_Conversion. (To_Collection_Node_Ptr): New instance of Ada.Unchecked_Conversion. (Detach_Node_From_Collection): ...here. (Attach_Object_To_Collection): New procedure. (Detach_Object_From_Collection): Likewise. (Finalization_Started): Delete. (Finalize): Replace allocation with attachment in comments. * libgnat/s-stposu.ads (Allocate_Any_Controlled): Rename parameter Context_Subpool into Named_Subpool, parameter Context_Collection into Collection and change it to In/Out, and remove Fin_Address. * libgnat/s-stposu.adb: Remove clause for Ada.Unchecked_Conversion and Finalization_Primitives. (To_Collection_Node_Ptr): Delete. (Allocate_Any_Controlled): Rename parameter Context_Subpool into Named_Subpool, parameter Context_Collection into Collection and change it to In/Out, and remove Fin_Address. Do not lock/unlock and do not attach the object, instead only displace its address. (Deallocate_Any_Controlled): Do not lock/unlock and do not detach the object. (Header_Size_With_Padding): Use qualified name for Header_Size. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 5 +- gcc/ada/exp_ch4.adb | 20 +- gcc/ada/exp_ch7.adb | 370 +++---------------------- gcc/ada/exp_ch7.ads | 7 + gcc/ada/exp_util.adb | 520 ++++++++++++++++++++++++++++++++--- gcc/ada/exp_util.ads | 25 +- gcc/ada/libgnat/s-finpri.adb | 84 ++++-- gcc/ada/libgnat/s-finpri.ads | 26 +- gcc/ada/libgnat/s-stposu.adb | 196 ++++--------- gcc/ada/libgnat/s-stposu.ads | 40 ++- gcc/ada/rtsfind.ads | 4 + 11 files changed, 714 insertions(+), 583 deletions(-)