diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst index fc3ca5f7adf..feceff24e21 100644 --- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst +++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst @@ -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 diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 0d839b9b691..e51ab691860 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2026,8 +2026,22 @@ package Einfo is -- checks for infinite recursion. -- Has_Relaxed_Finalization [base type only] --- Defined in all type entities. Indicates that the type is subject to --- relaxed semantics for the finalization operations. +-- 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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 50c3cd430ce..371cb118243 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 35c2628fe25..7ff54cb2c40 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index a6912f7ad48..044b14ad305 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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 + -- + -- 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 -- -- 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 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 + -- + -- procedure Fin_Id is ... -- Body + -- + -- 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 -- ------------------------------------- diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 70b0a06af4b..22303d4c22f 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -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; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 4feef7e1f9f..24c2fdd4f97 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -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} diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 80cfb41b983..ea1d2f9d71a 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -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 diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb index 9767090cb4a..a6c9db341a4 100644 --- a/gcc/ada/libgnat/s-finpri.adb +++ b/gcc/ada/libgnat/s-finpri.adb @@ -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; ----------------------- diff --git a/gcc/ada/libgnat/s-finpri.ads b/gcc/ada/libgnat/s-finpri.ads index 851917b5924..a61a7d772ec 100644 --- a/gcc/ada/libgnat/s-finpri.ads +++ b/gcc/ada/libgnat/s-finpri.ads @@ -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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 9b85d65862b..852055a3586 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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.