@@ -590,8 +590,7 @@ Example:
procedure Finalize (Obj : in out Ctrl);
procedure Initialize (Obj : in out Ctrl);
-As of this writing, the relaxed semantics for finalization operations are
-only implemented for dynamically allocated objects.
+As of this writing, the RFC is implemented except for the `No_Raise` aspect.
Link to the original RFC:
https://github.com/AdaCore/ada-spark-rfcs/blob/topic/finalization-rehaul/considered/rfc-generalized-finalization.md
@@ -2026,8 +2026,22 @@ package Einfo is
-- checks for infinite recursion.
-- Has_Relaxed_Finalization [base type only]
+-- Defined in all type entities. Set only for controlled types and types
+-- with controlled components. Indicates that the type is subject to the
+-- relaxed semantics for the finalization operations. These semantics are
+-- made up of two independent parts:
+--
+-- 1. The compiler is permitted to perform no automatic finalization of
+-- heap-allocated objects: Finalize is only called when the object is
+-- explicitly deallocated, or when the object is assigned a new value.
+-- As a consequence, no finalization collection is created for access
+-- types designating the type, and no header is allocated in front of
+-- heap-allocated objects of the type.
+--
+-- 2. If an exception is raised out of the Adjust or Finalize procedures,
+-- the compiler is permitted to enforce none of the guarantees given
+-- by the RM 7.6.1(14/1) and following subclauses, and to instead just
+-- let the exception be propagated upward.
-- Has_Shift_Operator [base type only]
-- Defined in integer types. Set in the base type of an integer type for
@@ -14363,11 +14363,7 @@ package body Exp_Ch4 is
pragma Assert (Present (Fin_Context));
Insert_Action_After (Fin_Context,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Finalize_Object), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Master_Node_Id, Loc))));
+ Make_Finalize_Call_For_Node (Loc, Master_Node_Id));
end if;
-- Mark the transient object to avoid double finalization
@@ -3203,14 +3203,12 @@ package body Exp_Ch5 is
end if;
-- We need to set up an exception handler for implementing
- -- 7.6.1(18). The remaining adjustments are tackled by the
- -- implementation of adjust for record_controllers (see
- -- s-finimp.adb).
-
- -- This is skipped if we have no finalization
+ -- 7.6.1(18), but this is skipped if the type has relaxed
+ -- semantics for finalization.
if Expand_Ctrl_Actions
and then not Restriction_Active (No_Finalization)
+ and then not Has_Relaxed_Finalization (Typ)
then
L := New_List (
Make_Block_Statement (Loc,
@@ -3245,29 +3243,32 @@ package body Exp_Ch5 is
and then Abort_Allowed
then
declare
- Blk : constant Entity_Id :=
- New_Internal_Entity
- (E_Block, Current_Scope, Sloc (N), 'B');
AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
+ HSS : constant Node_Id := Handled_Statement_Sequence (N);
+
+ Blk_Id : Entity_Id;
begin
Set_Is_Abort_Block (N);
-
- Set_Scope (Blk, Current_Scope);
- Set_Etype (Blk, Standard_Void_Type);
- Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
+ Add_Block_Identifier (N, Blk_Id);
Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
- Set_At_End_Proc (Handled_Statement_Sequence (N),
- New_Occurrence_Of (AUD, Loc));
- -- Present the Abort_Undefer_Direct function to the backend
- -- so that it can inline the call to the function.
+ -- Like above, no need to deal with exception propagation
+ -- if the type has relaxed semantics for finalization.
- Add_Inlined_Body (AUD, N);
+ if Has_Relaxed_Finalization (Typ) then
+ Append_To (L, Build_Runtime_Call (Loc, RE_Abort_Undefer));
- Expand_At_End_Handler
- (Handled_Statement_Sequence (N), Blk);
+ else
+ Set_At_End_Proc (HSS, New_Occurrence_Of (AUD, Loc));
+ Expand_At_End_Handler (HSS, Blk_Id);
+
+ -- Present Abort_Undefer_Direct procedure to the back end
+ -- so that it can inline the call to the procedure.
+
+ Add_Inlined_Body (AUD, N);
+ end if;
end;
end if;
@@ -45,6 +45,7 @@ with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with GNAT_CUDA; use GNAT_CUDA;
+with Inline; use Inline;
with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -574,6 +575,11 @@ package body Exp_Ch7 is
-- conversion to the class-wide type in the case where the operation is
-- abstract.
+ function Finalize_Address_For_Node (Node : Entity_Id) return Entity_Id
+ renames Einfo.Entities.Finalization_Master_Node;
+ -- Return the Finalize_Address primitive for the object that has been
+ -- attached to a finalization Master_Node.
+
function Make_Call
(Loc : Source_Ptr;
Proc_Id : Entity_Id;
@@ -621,6 +627,11 @@ package body Exp_Ch7 is
-- [Deep_]Finalize (Acc_Typ (V).all);
-- end;
+ procedure Set_Finalize_Address_For_Node (Node, Fin_Id : Entity_Id)
+ renames Einfo.Entities.Set_Finalization_Master_Node;
+ -- Set the Finalize_Address primitive for the object that has been
+ -- attached to a finalization Master_Node.
+
----------------------------------
-- Attach_Object_To_Master_Node --
----------------------------------
@@ -915,6 +926,8 @@ package body Exp_Ch7 is
Attribute_Name => Name_Unrestricted_Access),
New_Occurrence_Of (Master_Node, Loc)));
+ Set_Finalize_Address_For_Node (Master_Node, Fin_Id);
+
Insert_After_And_Analyze
(Master_Node_Ins, Master_Node_Attach, Suppress => All_Checks);
end Attach_Object_To_Master_Node;
@@ -1734,6 +1747,10 @@ package body Exp_Ch7 is
Finalizer_Stmts : List_Id := No_List;
-- The statement list of the finalizer body
+ Has_Strict_Ctrl_Objs : Boolean := False;
+ -- A general flag which indicates whether N has at least one controlled
+ -- object with strict semantics for finalization.
+
Has_Tagged_Types : Boolean := False;
-- A general flag which indicates whether N has at least one library-
-- level tagged type declaration.
@@ -1805,11 +1822,12 @@ package body Exp_Ch7 is
begin
pragma Assert (Present (Decls));
- -- If the context contains controlled objects, then we create the
- -- finalization master, unless there is a single such object: in
- -- this common case, we'll directly finalize the object.
+ -- If the context contains controlled objects with strict semantics
+ -- for finalization, then we create the finalization master, unless
+ -- there is a single such object: in this common case, we'll directly
+ -- finalize the object.
- if Has_Ctrl_Objs then
+ if Has_Strict_Ctrl_Objs then
if Count > 1 then
if For_Package_Spec then
Master_Name :=
@@ -1900,15 +1918,41 @@ package body Exp_Ch7 is
-- The default name is _finalizer
else
- -- Generation of a finalization procedure exclusively for 'Old
- -- interally generated constants requires different name since
- -- there will need to be multiple finalization routines in the
- -- same scope. See Build_Finalizer for details.
-
Fin_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Name_uFinalizer));
+ -- The visibility semantics of At_End handlers force a strange
+ -- separation of spec and body for stack-related finalizers:
+
+ -- declare : Enclosing_Scope
+ -- procedure _finalizer;
+ -- begin
+ -- <controlled objects>
+ -- procedure _finalizer is
+ -- ...
+ -- at end
+ -- _finalizer;
+ -- end;
+
+ -- Both spec and body are within the same construct and scope, but
+ -- the body is part of the handled sequence of statements. This
+ -- placement confuses the elaboration mechanism on targets where
+ -- At_End handlers are expanded into "when all others" handlers:
+
+ -- exception
+ -- when all others =>
+ -- _finalizer; -- appears to require elab checks
+ -- at end
+ -- _finalizer;
+ -- end;
+
+ -- Since the compiler guarantees that the body of a _finalizer is
+ -- always inserted in the same construct where the At_End handler
+ -- resides, there is no need for elaboration checks.
+
+ Set_Kill_Elaboration_Checks (Fin_Id);
+
-- Inlining the finalizer produces a substantial speedup at -O2.
-- It is inlined by default at -O3. Either way, it is called
-- exactly twice (once on the normal path, and once for
@@ -1974,7 +2018,7 @@ package body Exp_Ch7 is
-- Abort_Undefer; -- Added if abort is allowed
-- end Fin_Id;
- -- If there are controlled objects to be finalized, generate:
+ -- If there are strict controlled objects to be finalized, generate:
-- procedure Fin_Id is
-- Abort : constant Boolean := Triggered_By_Abort;
@@ -1991,7 +2035,10 @@ package body Exp_Ch7 is
-- <exception propagation>
-- end Fin_Id;
- if Has_Ctrl_Objs and then Count > 1 then
+ -- If there are only controlled objects with relaxed semantics for
+ -- finalization, only the <finalization statements> are generated.
+
+ if Has_Strict_Ctrl_Objs and then Count > 1 then
Fin_Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
@@ -2099,7 +2146,7 @@ package body Exp_Ch7 is
-- Raise_From_Controlled_Operation (E);
-- end if;
- if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
+ if Has_Strict_Ctrl_Objs and Exceptions_OK and not For_Package then
Append_To (Finalizer_Stmts,
Build_Raise_Statement (Finalizer_Data));
end if;
@@ -2149,10 +2196,53 @@ package body Exp_Ch7 is
-- Non-package case
else
+ -- Insert the spec for the finalizer. The At_End handler must be
+ -- able to call the body which resides in a nested structure.
+
+ -- declare
+ -- procedure Fin_Id; -- Spec
+ -- begin
+ -- <objects and possibly statements>
+ -- procedure Fin_Id is ... -- Body
+ -- <statements>
+ -- at end
+ -- Fin_Id; -- At_End handler
+ -- end;
+
pragma Assert (Present (Decls));
Append_To (Decls, Fin_Spec);
- Append_To (Decls, Fin_Body);
+
+ -- When the finalizer acts solely as a cleanup routine, the body
+ -- is inserted right after the spec.
+
+ if Acts_As_Clean and not Has_Ctrl_Objs then
+ Insert_After (Fin_Spec, Fin_Body);
+
+ -- In other cases the body is inserted after the last statement
+
+ else
+ -- Manually freeze the spec. This is somewhat of a hack because
+ -- a subprogram is frozen when its body is seen and the freeze
+ -- node appears right before the body. However, in this case,
+ -- the spec must be frozen earlier since the At_End handler
+ -- must be able to call it.
+ --
+ -- declare
+ -- procedure Fin_Id; -- Spec
+ -- [Fin_Id] -- Freeze node
+ -- begin
+ -- ...
+ -- at end
+ -- Fin_Id; -- At_End handler
+ -- end;
+
+ Ensure_Freeze_Node (Fin_Id);
+ Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
+ Set_Is_Frozen (Fin_Id);
+
+ Append_To (Stmts, Fin_Body);
+ end if;
end if;
Analyze (Fin_Spec, Suppress => All_Checks);
@@ -2227,11 +2317,13 @@ package body Exp_Ch7 is
procedure Processing_Actions
(Decl : Node_Id;
- Is_Protected : Boolean := False);
+ Is_Protected : Boolean := False;
+ Strict : Boolean := False);
-- Depending on the mode of operation of Process_Declarations, either
-- increment the controlled object count or process the declaration.
-- The Flag Is_Protected is set when the declaration denotes a simple
- -- protected object.
+ -- protected object. The flag Strict is true when the declaration is
+ -- for a controlled object with strict semantics for finalization.
--------------------------
-- Process_Package_Body --
@@ -2256,7 +2348,8 @@ package body Exp_Ch7 is
procedure Processing_Actions
(Decl : Node_Id;
- Is_Protected : Boolean := False)
+ Is_Protected : Boolean := False;
+ Strict : Boolean := False)
is
begin
-- Library-level tagged type
@@ -2277,6 +2370,9 @@ package body Exp_Ch7 is
else
if Preprocess then
Count := Count + 1;
+ if Strict then
+ Has_Strict_Ctrl_Objs := True;
+ end if;
else
Process_Object_Declaration (Decl, Is_Protected);
@@ -2291,6 +2387,7 @@ package body Exp_Ch7 is
Obj_Id : Entity_Id;
Obj_Typ : Entity_Id;
Pack_Id : Entity_Id;
+ Prev : Node_Id;
Spec : Node_Id;
Typ : Entity_Id;
@@ -2301,10 +2398,13 @@ package body Exp_Ch7 is
return;
end if;
- -- Process all declarations in reverse order
+ -- Process all declarations in reverse order and be prepared for them
+ -- to be moved during the processing.
Decl := Last_Non_Pragma (Decls);
while Present (Decl) loop
+ Prev := Prev_Non_Pragma (Decl);
+
-- Library-level tagged types
if Nkind (Decl) = N_Full_Type_Declaration then
@@ -2385,7 +2485,8 @@ package body Exp_Ch7 is
and then not Has_Completion (Obj_Id)
and then No (BIP_Initialization_Call (Obj_Id)))
then
- Processing_Actions (Decl);
+ Processing_Actions
+ (Decl, Strict => not Has_Relaxed_Finalization (Obj_Typ));
-- The object is of the form:
-- Obj : Access_Typ := Non_BIP_Function_Call'reference;
@@ -2403,7 +2504,10 @@ package body Exp_Ch7 is
(Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id)))
then
- Processing_Actions (Decl);
+ Processing_Actions
+ (Decl,
+ Strict => not Has_Relaxed_Finalization
+ (Available_View (Designated_Type (Obj_Typ))));
-- Simple protected objects which use the type System.Tasking.
-- Protected_Objects.Protection to manage their locks should
@@ -2445,7 +2549,8 @@ package body Exp_Ch7 is
and then Has_Simple_Protected_Object (Obj_Typ)
and then not Restricted_Profile
then
- Processing_Actions (Decl, Is_Protected => True);
+ Processing_Actions
+ (Decl, Is_Protected => True, Strict => True);
end if;
-- Inspect the freeze node of an access-to-controlled type and
@@ -2513,7 +2618,7 @@ package body Exp_Ch7 is
Process_Package_Body (Proper_Body (Unit (Library_Unit (Decl))));
end if;
- Prev_Non_Pragma (Decl);
+ Decl := Prev;
end loop;
end Process_Declarations;
@@ -2556,15 +2661,15 @@ package body Exp_Ch7 is
Obj_Typ := Available_View (Designated_Type (Obj_Typ));
end if;
- -- 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
- -- avoid double processing.
+ -- If the object is a Master_Node, then nothing to do, unless there
+ -- is no or a single controlled object with strict semantics, in
+ -- which case we move its declaration, call marker (if any) and
+ -- initialization call, and also mark it to avoid double processing.
if Is_RTE (Obj_Typ, RE_Master_Node) then
Master_Node_Id := Obj_Id;
- if Count = 1 then
+ if not Has_Strict_Ctrl_Objs or else Count = 1 then
if Nkind (Next (Decl)) = N_Call_Marker then
Prepend_To (Decls, Remove_Next (Next (Decl)));
end if;
@@ -2575,15 +2680,16 @@ package body Exp_Ch7 is
end if;
-- Create the declaration of the Master_Node for the object and
- -- insert it before the declaration of the object itself, except
- -- for the case where it is the only object because it will play
- -- the role of a degenerated master and therefore needs to be
- -- inserted at the same place the master would have been.
+ -- insert it before the declaration of the object itself, unless
+ -- there is no or a single controlled object with strict semantics,
+ -- because it will effectively play the role of a degenerated master
+ -- and therefore needs to be inserted at the same place the master
+ -- would have been.
else pragma Assert (No (Finalization_Master_Node (Obj_Id)));
- -- For one object, use the Sloc the master would have had
+ -- In the latter case, use the Sloc the master would have had
- if Count = 1 then
+ if not Has_Strict_Ctrl_Objs or else Count = 1 then
Master_Node_Loc := Sloc (N);
else
Master_Node_Loc := Loc;
@@ -2597,7 +2703,7 @@ package body Exp_Ch7 is
Master_Node_Id, Obj_Id);
Push_Scope (Scope (Obj_Id));
- if Count = 1 then
+ if not Has_Strict_Ctrl_Objs or else Count = 1 then
Prepend_To (Decls, Master_Node_Decl);
else
Insert_Before (Decl, Master_Node_Decl);
@@ -2839,9 +2945,9 @@ package body Exp_Ch7 is
-- Now build the attachment call that will initialize the object's
-- Master_Node using the object's address and type's finalization
-- procedure and then attach the Master_Node to the master, unless
- -- there is a single controlled object.
+ -- there is no or a single controlled object with strict semantics.
- if Count = 1 then
+ if not Has_Strict_Ctrl_Objs or else Count = 1 then
-- Finalize_Address is not generated in CodePeer mode because the
-- body contains address arithmetic. So we don't want to generate
-- the attach in this case. Ditto if the object is a Master_Node.
@@ -2860,16 +2966,13 @@ package body Exp_Ch7 is
Prefix => New_Occurrence_Of (Fin_Id, Loc),
Attribute_Name => Name_Unrestricted_Access),
New_Occurrence_Of (Master_Node_Id, Loc)));
+
+ Set_Finalize_Address_For_Node (Master_Node_Id, Fin_Id);
end if;
-- We also generate the direct finalization call here
- Fin_Call :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Finalize_Object), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Master_Node_Id, Loc)));
+ Fin_Call := Make_Finalize_Call_For_Node (Loc, Master_Node_Id);
-- For CodePeer, the exception handlers normally generated here
-- generate complex flowgraphs which result in capacity problems.
@@ -2882,7 +2985,10 @@ package body Exp_Ch7 is
-- to be live. That is what we are interested in, not what
-- happens after the exception is raised.
- if Exceptions_OK and not CodePeer_Mode then
+ if Has_Strict_Ctrl_Objs
+ and then Exceptions_OK
+ and then not CodePeer_Mode
+ then
Fin_Call :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
@@ -5079,11 +5185,7 @@ package body Exp_Ch7 is
-- Then add the finalization call for the object
Insert_After_And_Analyze (Insert_Nod,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Finalize_Object), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Master_Node_Id, Loc))));
+ Make_Finalize_Call_For_Node (Loc, Master_Node_Id));
-- Otherwise generate a direct finalization call for the object
@@ -7936,6 +8038,14 @@ package body Exp_Ch7 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)));
+ -- If the type has relaxed semantics for finalization, the indirect
+ -- calls to Finalize_Address may be turned into direct ones and, in
+ -- this case, inlining them is generally profitable.
+
+ if Has_Relaxed_Finalization (Typ) then
+ Set_Is_Inlined (Proc_Id);
+ end if;
+
Set_TSS (Typ, Proc_Id);
end Make_Finalize_Address_Body;
@@ -8134,6 +8244,62 @@ package body Exp_Ch7 is
return New_List (Fin_Block);
end Make_Finalize_Address_Stmts;
+ ---------------------------------
+ -- Make_Finalize_Call_For_Node --
+ ---------------------------------
+
+ function Make_Finalize_Call_For_Node
+ (Loc : Source_Ptr;
+ Node : Entity_Id) return Node_Id
+ is
+ Fin_Id : constant Entity_Id := Finalize_Address_For_Node (Node);
+
+ Fin_Call : Node_Id;
+ Fin_Ref : Node_Id;
+
+ begin
+ -- Finalize_Address is not generated in CodePeer mode because the
+ -- body contains address arithmetic. So we don't want to generate
+ -- the call in this case.
+
+ if CodePeer_Mode then
+ return Make_Null_Statement (Loc);
+ end if;
+
+ -- The Finalize_Address primitive may be missing when the Master_Node
+ -- is written down in the source code for testing purposes.
+
+ if Present (Fin_Id) then
+ Fin_Ref :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Fin_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+
+ else
+ Fin_Ref :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Node, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Finalize_Address));
+ end if;
+
+ Fin_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Finalize_Object), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Node, Loc),
+ Fin_Ref));
+
+ -- Present Finalize_Address procedure to the back end so that it can
+ -- inline the call to the procedure made by Finalize_Object.
+
+ if Present (Fin_Id) and then Is_Inlined (Fin_Id) then
+ Add_Inlined_Body (Fin_Id, Fin_Call);
+ end if;
+
+ return Fin_Call;
+ end Make_Finalize_Call_For_Node;
+
-------------------------------------
-- Make_Handler_For_Ctrl_Operation --
-------------------------------------
@@ -222,6 +222,11 @@ package Exp_Ch7 is
-- an address into a pointer and subsequently calls Deep_Finalize on the
-- dereference.
+ function Make_Finalize_Call_For_Node
+ (Loc : Source_Ptr;
+ Node : Entity_Id) return Node_Id;
+ -- Create a call to finalize the object attached to the given Master_Node
+
function Make_Init_Call
(Obj_Ref : Node_Id;
Typ : Entity_Id) return Node_Id;
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT Reference Manual , Jun 27, 2024
+GNAT Reference Manual , Jul 29, 2024
AdaCore
@@ -29529,8 +29529,7 @@ procedure Finalize (Obj : in out Ctrl);
procedure Initialize (Obj : in out Ctrl);
@end example
-As of this writing, the relaxed semantics for finalization operations are
-only implemented for dynamically allocated objects.
+As of this writing, the RFC is implemented except for the @cite{No_Raise} aspect.
Link to the original RFC:
@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/topic/finalization-rehaul/considered/rfc-generalized-finalization.md}
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT User's Guide for Native Platforms , Jun 24, 2024
+GNAT User's Guide for Native Platforms , Jul 29, 2024
AdaCore
@@ -29670,8 +29670,8 @@ to permit their use in free software.
@printindex ge
-@anchor{d1}@w{ }
@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ }
+@anchor{d1}@w{ }
@c %**end of body
@bye
@@ -138,7 +138,7 @@ package body System.Finalization_Primitives is
Node : in out Master_Node)
is
begin
- pragma Assert (Node.Object_Address = System.Null_Address
+ pragma Assert (Node.Object_Address = Null_Address
and then Node.Finalize_Address = null);
Node.Object_Address := Object_Address;
@@ -310,7 +310,7 @@ package body System.Finalization_Primitives is
if Master.Exceptions_OK then
while Node /= null loop
begin
- Finalize_Object (Node.all);
+ Finalize_Object (Node.all, Node.Finalize_Address);
exception
when Exc : others =>
@@ -337,7 +337,7 @@ package body System.Finalization_Primitives is
else
while Node /= null loop
- Finalize_Object (Node.all);
+ Finalize_Object (Node.all, Node.Finalize_Address);
Node := Node.Next;
end loop;
@@ -361,16 +361,18 @@ package body System.Finalization_Primitives is
-- Finalize_Object --
---------------------
- procedure Finalize_Object (Node : in out Master_Node) is
- FA : constant Finalize_Address_Ptr := Node.Finalize_Address;
+ procedure Finalize_Object
+ (Node : in out Master_Node;
+ Finalize_Address : Finalize_Address_Ptr)
+ is
+ Addr : constant System.Address := Node.Object_Address;
begin
- if FA /= null then
- pragma Assert (Node.Object_Address /= System.Null_Address);
-
- Node.Finalize_Address := null;
+ if Addr /= Null_Address then
+ Node.Object_Address := Null_Address;
- FA (Node.Object_Address);
+ pragma Assert (Node.Finalize_Address = Finalize_Address);
+ Finalize_Address (Addr);
end if;
end Finalize_Object;
@@ -407,7 +409,7 @@ package body System.Finalization_Primitives is
procedure Suppress_Object_Finalize_At_End (Node : in out Master_Node) is
begin
- Node.Finalize_Address := null;
+ Node.Object_Address := Null_Address;
end Suppress_Object_Finalize_At_End;
-----------------------
@@ -102,9 +102,15 @@ package System.Finalization_Primitives with Preelaborate is
-- reverse of the order in which they were attached. Calls to the procedure
-- with a Master that has already been finalized have no effects.
- procedure Finalize_Object (Node : in out Master_Node);
- -- Finalizes the controlled object attached to Node. Calls to the procedure
- -- with a Node that has already been finalized have no effects.
+ procedure Finalize_Object
+ (Node : in out Master_Node;
+ Finalize_Address : Finalize_Address_Ptr);
+ -- Finalizes the controlled object attached to Node by generating a call to
+ -- Finalize_Address on it, which has to be equal to Node.Finalize_Address.
+ -- The weird redundancy is intended to help the optimizer turn an indirect
+ -- call to Finalize_Address into a direct one and then inline it if needed,
+ -- after having inlined Finalize_Object itself. Calls to the procedure with
+ -- a Node that has already been finalized have no effects.
procedure Suppress_Object_Finalize_At_End (Node : in out Master_Node);
-- Changes the state of Node to effectively suppress a call to Node's
@@ -179,7 +185,7 @@ private
type Master_Node is record
Finalize_Address : Finalize_Address_Ptr := null;
- Object_Address : System.Address := System.Null_Address;
+ Object_Address : System.Address := Null_Address;
Next : Master_Node_Ptr := null;
end record;
@@ -7103,6 +7103,10 @@ package body Sem_Ch6 is
and then Exception_Junk (Last_Stm))
or else Nkind (Last_Stm) in N_Push_xxx_Label | N_Pop_xxx_Label
+ -- Don't count subprogram bodies, for example finalizers
+
+ or else Nkind (Last_Stm) = N_Subprogram_Body
+
-- Inserted code, such as finalization calls, is irrelevant; we
-- only need to check original source. If we see a transfer of
-- control, we stop.
From: Eric Botcazou <ebotcazou@adacore.com> These semantics state that the compiler is permitted to enforce none of the guarantees specified by the RM 7.6.1(14/1) and following subclauses, and to instead just let the exception be propagated upward. The guarantees impose a significant overhead in terms of complexity and run-time performance compared to similar constructs in other languages, and the goal is to reduce it significantly, if not eliminate it totally: for example, untagged record types declared with the Finalizable aspect, the relaxed finalization semantics and inline Initialize/Adjust/Finalize primitives, and used with abort disabled: pragma Restrictions (No_Abort_Statements); pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); pragma Restrictions (No_Asynchronous_Control); should behave like simple C++ classes. The implementation morally boils down to undoing the changes made a few months ago to the support of finalization for controlled objects, i.e. to getting rid of the added linked list and the associated indirection for controlled objects with relaxed finalization semantics. But, in order to keep a unified processing for both kinds of controlled objects and not to bring back the issues addressed by the aforementioned changes, the work is split between the front-end and the code generator: the front-end drops the linked list and the code generator is in charge of eliminating the indirection with the help of the optimizer. gcc/ada/ * doc/gnat_rm/gnat_language_extensions.rst (Generalized Finalization): Update status. * einfo.ads (Has_Relaxed_Finalization): Add more details. * exp_ch4.adb (Process_Transients_In_Expression): Invoke Make_Finalize_Call_For_Node instead of building the call. * exp_ch5.adb (Expand_N_Assignment_Statement): Do not set up an exception handler around the assignment for a controlled type with relaxed finalization semantics. Streamline the code implementing the protection against aborts and do not use an At_End handler for a controlled type with relaxed finalization semantics. * exp_ch7.ads (Make_Finalize_Call_For_Node): New function. * exp_ch7.adb (Finalize_Address_For_Node): New function renaming. (Set_Finalize_Address_For_Node): New procedure renaming. (Attach_Object_To_Master_Node): Also attach the Finalize_Address primitive to the Master_Node statically. (Build_Finalizer): Add Has_Strict_Ctrl_Objs local variable. Insert back the body of the finalizer at the end of the statement list in the non-package case and restore the associated support code to that effect. When all the controlled objects have the relaxed finalization semantics, do not create a Finalization_Master and finalize the objects directly instead. (Processing_Actions): Add Strict parameter and use it to set the Has_Strict_Ctrl_Objs variable. (Process_Declarations): Make main loop more robust and adjust calls to Processing_Actions. (Make_Finalize_Address_Body): Mark the primitive as inlined if the type has relaxed finalization semantics. (Make_Finalize_Call_For_Node): New function. * sem_ch6.adb (Check_Statement_Sequence): Skip subprogram bodies. * libgnat/s-finpri.ads (Finalize_Object): Add Finalize_Address parameter. (Master_Node): Remove superfluous qualification. * libgnat/s-finpri.adb (Attach_Object_To_Node): Likewise. (Finalize_Master): Adjust calls to Finalize_Object. (Finalize_Object): Add Finalize_Address parameter and assert that it is equal to the component of the node. Use the Object_Address component as guard. (Suppress_Object_Finalize_At_End): Clear Object_Address component. * gnat_rm.texi: Regenerate. * gnat_ugn.texi: Regenerate. Tested on x86_64-pc-linux-gnu, committed on master. --- .../doc/gnat_rm/gnat_language_extensions.rst | 3 +- gcc/ada/einfo.ads | 18 +- gcc/ada/exp_ch4.adb | 6 +- gcc/ada/exp_ch5.adb | 39 +-- gcc/ada/exp_ch7.adb | 260 ++++++++++++++---- gcc/ada/exp_ch7.ads | 5 + gcc/ada/gnat_rm.texi | 5 +- gcc/ada/gnat_ugn.texi | 4 +- gcc/ada/libgnat/s-finpri.adb | 24 +- gcc/ada/libgnat/s-finpri.ads | 14 +- gcc/ada/sem_ch6.adb | 4 + 11 files changed, 287 insertions(+), 95 deletions(-)