[COMMITTED] ada: Partial implementation of redesign of support for object finalization

Message ID	20240506091742.1584713-1-poulhies@adacore.com
State	New
Headers	show Return-Path: <gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org> DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 30EAA385EC44 From: =?utf-8?q?Marc_Poulhi=C3=A8s?= <poulhies@adacore.com> To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou <ebotcazou@adacore.com> Subject: [COMMITTED] ada: Partial implementation of redesign of support for object finalization Date: Mon, 6 May 2024 11:17:42 +0200 Message-ID: <20240506091742.1584713-1-poulhies@adacore.com> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit Precedence: list Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org
Series	[COMMITTED] ada: Partial implementation of redesign of support for object finalization \| expand [COMMITTED] ada: Partial implementation of redesign of support for object finalization

diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 6e1ca305faf..3721a70ffcc 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -597,6 +597,7 @@ GNATRTL_NONTASKING_OBJS= \ s-filatt$(objext) \ s-fileio$(objext) \ s-finmas$(objext) \ + s-finpri$(objext) \ s-finroo$(objext) \ s-flocon$(objext) \ s-fode32$(objext) \ diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 551e9f3c32c..c440053bb78 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -4176,13 +4176,13 @@ package body Contracts is Helper_Decl := Build_Call_Helper_Decl; Mutate_Ekind (Helper_Id, Ekind (Subp_Id)); - -- Add the helper to the freezing actions of the tagged type + -- Add the helper to the freezing actions of the class-wide type - Append_Freeze_Action (Tagged_Type, Helper_Decl); + Append_Freeze_Action (Class_Wide_Type (Tagged_Type), Helper_Decl); Analyze (Helper_Decl); Helper_Body := Build_Call_Helper_Body; - Append_Freeze_Action (Tagged_Type, Helper_Body); + Append_Freeze_Action (Class_Wide_Type (Tagged_Type), Helper_Body); -- If this helper is built as part of building the DTW at the -- freezing point of its tagged type then we cannot defer diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 48706845d14..24964004c05 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1305,6 +1305,16 @@ package Einfo is -- type. Empty for access-to-subprogram types. Empty for access types -- whose designated type does not need finalization actions. +-- Finalization_Master_Node_Or_Object +-- Defined in variables and constants that require finalization actions. +-- The field contains the entity of an object (called a Master_Node) that +-- contains the address of the finalizable object, along with an access +-- value denoting the finalizable object's finalization procedure. The +-- Master_Node may be attached to a finalization list associated with +-- either the global scope or some dynamic scope (block or subprogram). +-- Conversely, for a Master_Node entity, the field contains the entity +-- of the finalizable object. + -- Finalize_Storage_Only [base type only] -- Defined in all types. Set on direct controlled types to which a -- valid Finalize_Storage_Only pragma applies. This flag is also set on @@ -4513,15 +4523,6 @@ package Einfo is -- from another predicate but does not add a predicate of its own, the -- expression may consist of the above xxxPredicate call on its own. --- Status_Flag_Or_Transient_Decl --- Defined in constant, loop, and variable entities. Applies to objects --- that require special treatment by the finalization machinery, such as --- extended return objects, conditional expression results, and objects --- inside N_Expression_With_Actions nodes. The attribute contains the --- entity of a flag which specifies a particular behavior over a region --- of the extended return for the return objects, or the declaration of a --- hook object for conditional expressions and N_Expression_With_Actions. - -- Storage_Size_Variable [implementation base type only] -- Defined in access types and task type entities. This flag is set -- if a valid and effective pragma Storage_Size applies to the base @@ -5294,7 +5295,6 @@ package Einfo is -- Esize -- Extra_Accessibility (constants only) -- Alignment - -- Status_Flag_Or_Transient_Decl -- Actual_Subtype -- Renamed_Object -- Renamed_Entity $$$ @@ -5304,6 +5304,7 @@ package Einfo is -- Related_Type (constants only) -- Initialization_Statements -- BIP_Initialization_Call + -- Finalization_Master_Node_Or_Object -- Last_Aggregate_Assignment -- Activation_Record_Component -- Encapsulating_State (constants only) @@ -6174,7 +6175,6 @@ package Einfo is -- Esize -- Extra_Accessibility -- Alignment - -- Status_Flag_Or_Transient_Decl (transient object only) -- Unset_Reference -- Actual_Subtype -- Renamed_Object @@ -6191,6 +6191,7 @@ package Einfo is -- Related_Type -- Initialization_Statements -- BIP_Initialization_Call + -- Finalization_Master_Node_Or_Object -- Last_Aggregate_Assignment -- Activation_Record_Component -- Encapsulating_State diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 8f32dc206e7..614f1fbe14d 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2701,13 +2701,14 @@ package body Exp_Attr is -- activation record object where the component corresponds to -- prefix of the attribute (for back ends that require "unnesting" -- of nested subprograms), since the address needs to be assigned - -- as-is to such components. + -- as-is to such components. Likewise for a return object. elsif Tagged_Type_Expansion and then Is_Class_Wide_Type (Ptyp) and then Is_Interface (Underlying_Type (Ptyp)) - and then not (Nkind (Pref) in N_Has_Entity - and then Is_Subprogram (Entity (Pref))) + and then not (Is_Entity_Name (Pref) + and then (Is_Subprogram (Entity (Pref)) + or else Is_Return_Object (Entity (Pref)))) and then not Is_Unnested_Component_Init (N) then Rewrite (N, diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index fdedf3294fe..7a137dda3f7 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5021,7 +5021,9 @@ package body Exp_Ch3 is -- Create the body of TSS primitive Finalize_Address. This automatically -- sets the TSS entry for the class-wide type. - Make_Finalize_Address_Body (Typ); + if not Present (Finalize_Address (Typ)) then + Make_Finalize_Address_Body (Typ); + end if; end Expand_Freeze_Class_Wide_Type; ------------------------------------ @@ -5919,12 +5921,7 @@ package body Exp_Ch3 is then null; - -- Do not add the body of the predefined primitives if we are - -- compiling under restriction No_Dispatching_Calls or if we are - -- compiling a CPP tagged type. - - elsif not Restriction_Active (No_Dispatching_Calls) then - + else -- Create the body of TSS primitive Finalize_Address. This must -- be done before the bodies of all predefined primitives are -- created. If Typ is limited, Stream_Input and Stream_Read may @@ -5932,14 +5929,35 @@ package body Exp_Ch3 is -- needs Finalize_Address. Make_Finalize_Address_Body (Typ); - Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq); - Append_Freeze_Actions (Typ, Predef_List); + + -- Do not add the body of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls. + + if not Restriction_Active (No_Dispatching_Calls) then + -- Create the body of the class-wide type's TSS primitive + -- Finalize_Address. This must be done before any class-wide + -- precondition functions are created. + + Make_Finalize_Address_Body (Class_Wide_Type (Typ)); + + Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq); + Append_Freeze_Actions (Typ, Predef_List); + end if; end if; -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden -- inherited functions, then add their bodies to the freeze actions. Append_Freeze_Actions (Typ, Wrapper_Body_List); + + -- Create body of an interface type's class-wide type's TSS primitive + -- Finalize_Address. + + elsif Is_Tagged_Type (Typ) + and then Is_Interface (Typ) + and then not Restriction_Active (No_Dispatching_Calls) + then + Make_Finalize_Address_Body (Class_Wide_Type (Typ)); end if; -- Create extra formals for the primitive operations of the type. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e4a40414872..dd64705c12a 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -14927,25 +14927,17 @@ package body Exp_Ch4 is Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); Hook_Context : constant Node_Id := Find_Hook_Context (Expr); - -- The node on which to insert the hook as an action. This is usually - -- the innermost enclosing non-transient construct. - - Fin_Call : Node_Id; - Hook_Assign : Node_Id; - Hook_Clear : Node_Id; - Hook_Decl : Node_Id; - Hook_Insert : Node_Id; - Ptr_Decl : Node_Id; + -- The node after which to insert deferred finalization actions. This + -- is usually the innermost enclosing non-transient construct. Fin_Context : Node_Id; - -- The node after which to insert the finalization actions of the - -- transient object. + -- The node after which to insert the finalization actions - begin - pragma Assert (Nkind (Expr) in N_Case_Expression - | N_Expression_With_Actions - | N_If_Expression); + Master_Node_Decl : Node_Id; + Master_Node_Id : Entity_Id; + -- Declaration and entity of the Master_Node respectively + begin -- When the context is a Boolean evaluation, all three nodes capture -- the result of their computation in a local temporary: @@ -14979,78 +14971,30 @@ package body Exp_Ch4 is Fin_Context := Hook_Context; end if; - -- Mark the transient object as successfully processed to avoid - -- double finalization. - - Set_Is_Finalized_Transient (Obj_Id); - - -- Construct all the pieces necessary to hook and finalize a - -- transient object. - - Build_Transient_Object_Statements - (Obj_Decl => Obj_Decl, - Fin_Call => Fin_Call, - Hook_Assign => Hook_Assign, - Hook_Clear => Hook_Clear, - Hook_Decl => Hook_Decl, - Ptr_Decl => Ptr_Decl, - Finalize_Obj => False); - - -- Add the access type which provides a reference to the transient - -- object. Generate: - - -- type Ptr_Typ is access all Desig_Typ; + -- Create the declaration of the Master_Node for the object and + -- insert it before the context. It will later be picked up by + -- the general finalization mechanism (see Build_Finalizer). - Insert_Action (Hook_Context, Ptr_Decl); - - -- Add the temporary which acts as a hook to the transient object. - -- Generate: - - -- Hook : Ptr_Id := null; - - Insert_Action (Hook_Context, Hook_Decl); - - -- When the transient object is initialized by an aggregate, the hook - -- must capture the object after the last aggregate assignment takes - -- place. Only then is the object considered initialized. Generate: - - -- Hook := Ptr_Typ (Obj_Id); - -- <or> - -- Hook := Obj_Id'Unrestricted_Access; - - if Ekind (Obj_Id) in E_Constant | E_Variable - and then Present (Last_Aggregate_Assignment (Obj_Id)) - then - Hook_Insert := Last_Aggregate_Assignment (Obj_Id); + Master_Node_Id := Make_Temporary (Loc, 'N'); + Master_Node_Decl := + Make_Master_Node_Declaration (Loc, Master_Node_Id, Obj_Id); + Insert_Action (Hook_Context, Master_Node_Decl); - -- Otherwise the hook seizes the related object immediately - - else - Hook_Insert := Obj_Decl; - end if; - - Insert_After_And_Analyze (Hook_Insert, Hook_Assign); - - -- When the node is part of a return statement, there is no need to - -- insert a finalization call, as the general finalization mechanism - -- (see Build_Finalizer) would take care of the transient object on - -- subprogram exit. Note that it would also be impossible to insert - -- the finalization code after the return statement as this will - -- render it unreachable. + -- When the node is part of a return statement, there is no need + -- to insert a finalization call, as the general finalization + -- mechanism (see Build_Finalizer) would take care of the master + -- on subprogram exit. Note that it would also be impossible to + -- insert the finalization call after the return statement as + -- this will render it unreachable. if Nkind (Fin_Context) = N_Simple_Return_Statement then null; - -- Finalize the hook after the context has been evaluated. Generate: - - -- if Hook /= null then - -- [Deep_]Finalize (Hook.all); - -- Hook := null; - -- end if; + -- Finalize the object after the context has been evaluated - -- But the node returned by Find_Hook_Context may be an operator, - -- which is not a list member. We must locate the proper node - -- in the tree after which to insert the finalization code. + -- Note that the node returned by Find_Hook_Context above may be an + -- operator, which is not a list member. We must locate the proper + -- node in the tree after which to insert the finalization call. else while not Is_List_Member (Fin_Context) loop @@ -15060,17 +15004,16 @@ package body Exp_Ch4 is pragma Assert (Present (Fin_Context)); Insert_Action_After (Fin_Context, - Make_Implicit_If_Statement (Obj_Decl, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc), - Right_Opnd => Make_Null (Loc)), - - Then_Statements => New_List ( - Fin_Call, - Hook_Clear))); + 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)))); end if; + + -- Mark the transient object to avoid double finalization + + Set_Is_Finalized_Transient (Obj_Id); end Process_Transient_In_Expression; -- Local variables diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index ad56cfd6e7e..fcfd1d7f0bf 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -194,10 +194,6 @@ package body Exp_Ch6 is -- the activation Chain. Note: Master_Actual can be Empty, but only if -- there are no tasks. - function Build_Flag_For_Function (Func_Id : Entity_Id) return Entity_Id; - -- Generate code to declare a boolean flag initialized to False in the - -- function Func_Id and return the entity for the flag. - function Caller_Known_Size (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean; @@ -911,53 +907,6 @@ package body Exp_Ch6 is end if; end BIP_Suffix_Kind; - ----------------------------- - -- Build_Flag_For_Function -- - ----------------------------- - - function Build_Flag_For_Function (Func_Id : Entity_Id) return Entity_Id is - Flag_Decl : Node_Id; - Flag_Id : Entity_Id; - Func_Bod : Node_Id; - Loc : Source_Ptr; - - begin - -- Recover the function body - - Func_Bod := Unit_Declaration_Node (Func_Id); - - if Nkind (Func_Bod) = N_Subprogram_Declaration then - Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); - end if; - - if Nkind (Func_Bod) = N_Function_Specification then - Func_Bod := Parent (Func_Bod); -- one more level for child units - end if; - - pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body); - - Loc := Sloc (Func_Bod); - - -- Create a flag to track the function state - - Flag_Id := Make_Temporary (Loc, 'F'); - - -- Insert the flag at the beginning of the function declarations, - -- generate: - -- Fnn : Boolean := False; - - Flag_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Flag_Id, - Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), - Expression => New_Occurrence_Of (Standard_False, Loc)); - - Prepend_To (Declarations (Func_Bod), Flag_Decl); - Analyze (Flag_Decl); - - return Flag_Id; - end Build_Flag_For_Function; - --------------------------- -- Build_In_Place_Formal -- --------------------------- @@ -5622,20 +5571,6 @@ package body Exp_Ch6 is HSS := Handled_Statement_Sequence (N); - -- If the returned object needs finalization actions, the function must - -- perform the appropriate cleanup should it fail to return. The state - -- of the function itself is tracked through a flag which is coupled - -- with the scope finalizer. There is one flag per each return object - -- in case of multiple extended returns. Note that the flag has already - -- been created if the extended return contains a nested return. - - if Needs_Finalization (Etype (Ret_Obj_Id)) - and then No (Status_Flag_Or_Transient_Decl (Ret_Obj_Id)) - then - Set_Status_Flag_Or_Transient_Decl - (Ret_Obj_Id, Build_Flag_For_Function (Func_Id)); - end if; - -- Build a simple_return_statement that returns the return object when -- there is a statement sequence, or no expression, or the analysis of -- the return object declaration generated extra actions, or the result @@ -5689,25 +5624,12 @@ package body Exp_Ch6 is end if; end if; - -- Update the state of the function right before the object is - -- returned. + -- If the returned object needs finalization actions, the function + -- must perform the appropriate cleanup should it fail to return. if Needs_Finalization (Etype (Ret_Obj_Id)) then - declare - Flag_Id : constant Entity_Id := - Status_Flag_Or_Transient_Decl (Ret_Obj_Id); - - begin - pragma Assert (Present (Flag_Id)); - - -- Generate: - -- Fnn := True; - - Append_To (Stmts, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Flag_Id, Loc), - Expression => New_Occurrence_Of (Standard_True, Loc))); - end; + Append_To + (Stmts, Make_Suppress_Object_Finalize_Call (Loc, Ret_Obj_Id)); end if; HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts); @@ -6368,8 +6290,6 @@ package body Exp_Ch6 is declare Ret_Obj_Id : constant Entity_Id := First_Entity (Scope_Id); - Flag_Id : Entity_Id; - begin -- Apply the same processing as Expand_N_Extended_Return_Statement -- if the returned object needs finalization actions. Note that we @@ -6377,22 +6297,8 @@ package body Exp_Ch6 is -- may be multiple nested returns within the extended one. if Needs_Finalization (Etype (Ret_Obj_Id)) then - if Present (Status_Flag_Or_Transient_Decl (Ret_Obj_Id)) then - Flag_Id := Status_Flag_Or_Transient_Decl (Ret_Obj_Id); - else - Flag_Id := - Build_Flag_For_Function (Return_Applies_To (Scope_Id)); - Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id); - end if; - - -- Generate: - -- Fnn := True; - - Insert_Action (N, - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Flag_Id, Loc), - Expression => New_Occurrence_Of (Standard_True, Loc))); + Insert_Action + (N, Make_Suppress_Object_Finalize_Call (Loc, Ret_Obj_Id)); end if; Rewrite (N, diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index e594a534244..75c9e223956 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -74,127 +74,212 @@ package body Exp_Ch7 is -- Finalization Management -- ----------------------------- - -- This part describes how Initialization/Adjustment/Finalization + -- This paragraph describes how Initialization/Adjustment/Finalization -- procedures are generated and called. Two cases must be considered: types - -- that are Controlled (Is_Controlled flag set) and composite types that + -- that are controlled (Is_Controlled flag set) and composite types that -- contain controlled components (Has_Controlled_Component flag set). In -- the first case the procedures to call are the user-defined primitive - -- operations Initialize/Adjust/Finalize. In the second case, GNAT + -- operations Initialize/Adjust/Finalize. In the second case, the compiler -- generates Deep_Initialize, Deep_Adjust and Deep_Finalize that are in -- charge of calling the former procedures on the controlled components. - -- For records with Has_Controlled_Component set, a hidden "controller" - -- component is inserted. This controller component contains its own - -- finalization list on which all controlled components are attached - -- creating an indirection on the upper-level Finalization list. This - -- technique facilitates the management of objects whose number of - -- controlled components changes during execution. This controller - -- component is itself controlled and is attached to the upper-level - -- finalization chain. Its adjust primitive is in charge of calling adjust - -- on the components and adjusting the finalization pointer to match their - -- new location (see a-finali.adb). - - -- It is not possible to use a similar technique for arrays that have - -- Has_Controlled_Component set. In this case, deep procedures are - -- generated that call initialize/adjust/finalize + attachment or - -- detachment on the finalization list for all component. - - -- Initialize calls: they are generated for declarations or dynamic - -- allocations of Controlled objects with no initial value. They are always - -- followed by an attachment to the current Finalization Chain. For the - -- dynamic allocation case this the chain attached to the scope of the - -- access type definition otherwise, this is the chain of the current + -- Initialize calls: they are generated for either declarations or dynamic + -- allocations of controlled objects with no initial value. They are always + -- followed by an attachment to the current finalization chain. For the + -- dynamic allocation case, this is the chain attached to the scope of the + -- access type definition; otherwise, this is the chain of the current -- scope. - -- Adjust Calls: They are generated on 2 occasions: (1) for declarations - -- or dynamic allocations of Controlled objects with an initial value. - -- (2) after an assignment. In the first case they are followed by an - -- attachment to the final chain, in the second case they are not. + -- Adjust calls: they are generated on two occasions: (1) for declarations + -- or dynamic allocations of controlled objects with an initial value (with + -- the exception of function calls), (2) after an assignment. In the first + -- case they are followed by an attachment to the finalization chain, in + -- the second case they are not. - -- Finalization Calls: They are generated on (1) scope exit, (2) - -- assignments, (3) unchecked deallocations. In case (3) they have to - -- be detached from the final chain, in case (2) they must not and in - -- case (1) this is not important since we are exiting the scope anyway. + -- Finalization calls: they are generated on three occasions: (1) on scope + -- exit, (2) assignments, (3) unchecked deallocations. In case (3) objects + -- have to be detached from the finalization chain, in case (2) they must + -- not and in case (1) this is optional as we are exiting the scope anyway. - -- Other details: - - -- Type extensions will have a new record controller at each derivation - -- level containing controlled components. The record controller for - -- the parent/ancestor is attached to the finalization list of the - -- extension's record controller (i.e. the parent is like a component - -- of the extension). - - -- For types that are both Is_Controlled and Has_Controlled_Components, - -- the record controller and the object itself are handled separately. - -- It could seem simpler to attach the object at the end of its record - -- controller but this would not tackle view conversions properly. - - -- A classwide type can always potentially have controlled components - -- but the record controller of the corresponding actual type may not - -- be known at compile time so the dispatch table contains a special - -- field that allows computation of the offset of the record controller - -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset. - - -- Here is a simple example of the expansion of a controlled block : + -- Here is a simple example of the expansion of a controlled block: -- declare - -- X : Controlled; - -- Y : Controlled := Init; - -- - -- type R is record - -- C : Controlled; + -- X : Ctrl; + -- Y : Ctrl := Init; + + -- type Rec is record + -- C : Ctrl; -- end record; - -- W : R; - -- Z : R := (C => X); + + -- W : Rec; + -- Z : Rec := Init; -- begin -- X := Y; -- W := Z; -- end; -- - -- is expanded into + -- is expanded into: -- -- declare - -- _L : System.FI.Finalizable_Ptr; + -- Mnn : System.Finalization_Primitives.Finalization_Scope_Master; - -- procedure _Clean is - -- begin + -- XMN : aliased System.Finalization_Primitives.Master_Node; + -- X : Ctrl; + -- Bnn : begin -- Abort_Defer; - -- System.FI.Finalize_List (_L); + -- Initialize (X); + -- System.Finalization_Primitives.Attach_To_Master + -- (X'address, + -- CtrlFD'unrestricted_access, + -- XMN'unrestricted_access, + -- Mnn); + -- at end -- Abort_Undefer; - -- end _Clean; + -- end Bnn; + + -- YMN : aliased System.Finalization_Primitives.Master_Node; + -- Y : Ctrl := Init; + -- System.Finalization_Primitives.Attach_To_Master + -- (Y'address, + -- CtrlFD'unrestricted_access, + -- YMN'unrestricted_access, + -- Mnn); + + -- type Rec is record + -- C : Ctrl; + -- end record; - -- X : Controlled; - -- begin + -- WMN : aliased System.Finalization_Primitives.Master_Node; + -- W : Rec; + -- Bnn : begin -- Abort_Defer; - -- Initialize (X); - -- Attach_To_Final_List (_L, Finalizable (X), 1); - -- at end: Abort_Undefer; - -- Y : Controlled := Init; - -- Adjust (Y); - -- Attach_To_Final_List (_L, Finalizable (Y), 1); - -- - -- type R is record - -- C : Controlled; - -- end record; - -- W : R; + -- Bnn : begin + -- Deep_Initialize (W); + -- System.Finalization_Primitives.Attach_To_Master + -- (W'address, + -- Rec_FD'unrestricted_access, + -- WMN'unrestricted_access, + -- Mnn); + -- exception + -- when others => + -- Deep_Finalize (W); + -- end Bnn; + -- at end + -- Abort_Undefer; + -- end Bnn; + + -- ZMN : aliaed System.Finalization_Primitives.Master_Node; + -- Z : Rec := Init; + -- System.Finalization_Primitives.Attach_To_Master + -- (Z'address, + -- Rec_FD'unrestricted_access, + -- ZMN'unrestricted_access, + -- Mnn); + + -- procedure _Finalizer is + -- Ann : constant Boolean := Ada.Exceptions.Triggered_By_Abort; + -- Rnn : boolean := False; -- begin -- Abort_Defer; - -- Deep_Initialize (W, _L, 1); - -- at end: Abort_Under; - -- Z : R := (C => X); - -- Deep_Adjust (Z, _L, 1); + -- Bnn : begin + -- System.Finalization_Primitives.Finalize_Master (Mnn); + -- exceptions + -- when others => + -- Rnn := True; + -- end Bnn; + -- Abort_Undefer; + -- if Rnn and then not Ann then + -- [program_error "finalize raised exception"] + -- end if; + -- end _Finalizer; -- begin -- _Assign (X, Y); - -- Deep_Finalize (W, False); - -- <save W's final pointers> + -- Deep_Finalize (W); -- W := Z; - -- <restore W's final pointers> - -- Deep_Adjust (W, _L, 0); + -- Deep_Adjust (W); + -- end; -- at end - -- _Clean; + -- _Finalizer; + + -- In the case of a block containing a single controlled object, the scope + -- master degenerates into a single master node: + + -- declare + -- X : Ctrl := Init; + + -- begin + -- null; + -- end; + + -- is expanded into: + + -- declare + -- XMN : aliased System.Finalization_Primitives.Master_Node; + -- X : Ctrl := Init; + -- System.Finalization_Primitives.Attach_To_Node + -- (X'address, + -- CtrlFD'unrestricted_access, + -- XMN'unrestricted_access); + + -- procedure _Finalizer is + -- Ann : constant Boolean := Ada.Exceptions.Triggered_By_Abort; + -- Rnn : boolean := False; + -- begin + -- Abort_Defer; + -- Bnn : begin + -- System.Finalization_Primitives.Finalize_Object (XMN); + -- exceptions + -- when others => + -- Rnn := True; + -- end Bnn; + -- Abort_Undefer; + -- if Rnn and then not Ann then + -- [program_error "finalize raised exception"] + -- end if; + -- end _Finalizer; + + -- begin + -- null; -- end; + -- at end + -- _Finalizer; + + -- The implementation uses two different strategies for the finalization + -- of (statically) declared objects and of dynamically allocated objects. + + -- For (statically) declared objects, the attachment to the finalization + -- chain of the current scope and the call to the finalization procedure + -- are generated during a post-processing phase of the expansion. These + -- objects are first spotted in declarative parts and statement lists by + -- Requires_Cleanup_Actions; then Build_Finalizer is called on the parent + -- node to generate both the attachment and the finalization actions. + + -- This post processing is fully transparent for the rest of the expansion + -- activities, in other words those have nothing to do or to care about. + -- However this default processing may not be sufficient in specific cases, + -- e.g. for the return object of an extended return statement in a function + -- whose result type is controlled: in this case, the return object must be + -- finalized only if the function returns abnormally. In order to deal with + -- these cases, it is possible to directly generate detachment actions (for + -- the return object case) or finalization actions (for transient objects) + -- during the rest of expansion activities. + + -- These direct actions must be signalled to the post-processing machinery + -- and this is achieved through the handling of Master_Node objects, which + -- are the items actually chained in finalization chains of scope masters. + -- With the default processing, they are created by Build_Finalizer for the + -- controlled objects spotted by Requires_Cleanup_Actions. But when direct + -- actions are carried out, they are generated by these actions and later + -- 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. type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case); @@ -398,6 +483,10 @@ package body Exp_Ch7 is -- the original loop. Such loops can occur due to aggregate expansions and -- other constructs. + ----------------------- + -- Local Subprograms -- + ----------------------- + procedure Check_Visibly_Controlled (Prim : Final_Primitives; Typ : Entity_Id; @@ -1284,6 +1373,13 @@ package body Exp_Ch7 is elsif Is_Frozen (Desig_Typ) and then Present (Finalize_Address (Desig_Typ)) + -- The Finalize_Address procedure for a class-wide type may exist + -- at this point (as created by Expand_Freeze_Record_Type), but + -- may not have been analyzed yet, so the Set_Finalize_Address call + -- generation must be deferred (to Freeze_Type) in that case. + + and then Analyzed (Finalize_Address (Desig_Typ)) + -- The finalization master of an anonymous access type may need -- to be inserted in a specific place in the tree. For instance: @@ -1404,17 +1500,8 @@ package body Exp_Ch7 is -- structures right from the start. Entities and lists are created once -- it has been established that N has at least one controlled object. - Components_Built : Boolean := False; - -- A flag used to avoid double initialization of entities and lists. If - -- the flag is set then the following variables have been initialized: - -- Counter_Id - -- Finalizer_Decls - -- Finalizer_Stmts - -- Jump_Alts - - Counter_Id : Entity_Id := Empty; - Counter_Val : Nat := 0; - -- Name and value of the state counter + Counter_Val : Nat := 0; + -- Holds the number of controlled objects encountered so far Decls : List_Id := No_List; -- Declarative region of N (if available). If N is a package declaration @@ -1424,29 +1511,13 @@ package body Exp_Ch7 is -- Data for the exception Finalizer_Decls : List_Id := No_List; - -- Local variable declarations. This list holds the label declarations - -- of all jump block alternatives as well as the declaration of the - -- local exception occurrence and the raised flag: - -- E : Exception_Occurrence; - -- Raised : Boolean := False; - -- L<counter value> : label; - - Finalizer_Insert_Nod : Node_Id := Empty; - -- Insertion point for the finalizer body. Depending on the context - -- (Nkind of N) and the individual grouping of controlled objects, this - -- node may denote a package declaration or body, package instantiation, - -- block statement or a counter update statement. + -- Local variable declarations + + Finalization_Scope_Master : Entity_Id; + -- The Finalization Scope Master object Finalizer_Stmts : List_Id := No_List; - -- The statement list of the finalizer body. It contains the following: - -- - -- Abort_Defer; -- Added if abort is allowed - -- <call to Prev_At_End> -- Added if exists - -- <cleanup statements> -- Added if Acts_As_Clean - -- <jump block> -- Added if Has_Ctrl_Objs - -- <finalization statements> -- Added if Has_Ctrl_Objs - -- <stack release> -- Added if Mark_Id exists - -- Abort_Undefer; -- Added if abort is allowed + -- The statement list of the finalizer body Has_Ctrl_Objs : Boolean := False; -- A general flag which denotes whether N has at least one controlled @@ -1459,23 +1530,6 @@ package body Exp_Ch7 is HSS : Node_Id := Empty; -- The sequence of statements of N (if available) - Jump_Alts : List_Id := No_List; - -- Jump block alternatives. Depending on the value of the state counter, - -- the control flow jumps to a sequence of finalization statements. This - -- list contains the following: - -- - -- when <counter value> => - -- goto L<counter value>; - - Jump_Block_Insert_Nod : Node_Id := Empty; - -- Specific point in the finalizer statements where the jump block is - -- inserted. - - Last_Top_Level_Ctrl_Construct : Node_Id := Empty; - -- The last controlled construct encountered when processing the top - -- level lists of N. This can be a nested package, an instantiation or - -- an object declaration. - Prev_At_End : Entity_Id := Empty; -- The previous at end procedure of the handled statements block of N @@ -1509,23 +1563,18 @@ package body Exp_Ch7 is procedure Process_Declarations (Decls : List_Id; - Preprocess : Boolean := False; - Top_Level : Boolean := False); + Preprocess : Boolean := False); -- Inspect a list of declarations or statements which may contain -- objects that need finalization. When flag Preprocess is set, the -- routine will simply count the total number of controlled objects in - -- Decls and set Counter_Val accordingly. Top_Level is only relevant - -- when Preprocess is set and if True, the processing is performed for - -- objects in nested package declarations or instances. + -- Decls and set Counter_Val accordingly. procedure Process_Object_Declaration (Decl : Node_Id; - Has_No_Init : Boolean := False; Is_Protected : Boolean := False); -- Generate all the machinery associated with the finalization of a - -- single object. Flag Has_No_Init is used to denote certain contexts - -- where Decl does not have initialization call(s). Flag Is_Protected - -- is set when Decl denotes a simple protected object. + -- single object. Flag Is_Protected is set when Decl denotes a simple + -- protected object. procedure Process_Tagged_Type_Declaration (Decl : Node_Id); -- Generate all the code necessary to unregister the external tag of a @@ -1536,97 +1585,75 @@ package body Exp_Ch7 is ---------------------- procedure Build_Components is - Counter_Decl : Node_Id; - Counter_Typ : Entity_Id; - Counter_Typ_Decl : Node_Id; + Constraints : List_Id; + Scope_Master_Decl : Node_Id; + Scope_Master_Name : Name_Id; begin pragma Assert (Present (Decls)); - -- This routine might be invoked several times when dealing with - -- constructs that have two lists (either two declarative regions - -- or declarations and statements). Avoid double initialization. - - if Components_Built then - return; - end if; - - Components_Built := True; + -- If the context contains controlled objects, then we create the + -- finalization scope master, unless there is a single such object; + -- in this common case, we'll directly finalize the object. if Has_Ctrl_Objs then + if Counter_Val > 1 then + if For_Package_Spec then + Scope_Master_Name := + New_External_Name (Name_uMaster, Suffix => "_spec"); + elsif For_Package_Body then + Scope_Master_Name := + New_External_Name (Name_uMaster, Suffix => "_body"); + else + Scope_Master_Name := New_Internal_Name ('M'); + end if; - -- Create entities for the counter, its type, the local exception - -- and the raised flag. - - Counter_Id := Make_Temporary (Loc, 'C'); - Counter_Typ := Make_Temporary (Loc, 'T'); - - Finalizer_Decls := New_List; - - Build_Object_Declarations - (Finalizer_Data, Finalizer_Decls, Loc, For_Package); - - -- Since the total number of controlled objects is always known, - -- build a subtype of Natural with precise bounds. This allows - -- the backend to optimize the case statement. Generate: - -- - -- subtype Tnn is Natural range 0 .. Counter_Val; - - Counter_Typ_Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Counter_Typ, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc), - Constraint => - Make_Range_Constraint (Loc, - Range_Expression => - Make_Range (Loc, - Low_Bound => - Make_Integer_Literal (Loc, Uint_0), - High_Bound => - Make_Integer_Literal (Loc, Counter_Val))))); - - -- Generate the declaration of the counter itself: - -- - -- Counter : Integer := 0; + Finalization_Scope_Master := + Make_Defining_Identifier (Loc, Scope_Master_Name); - Counter_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Counter_Id, - Object_Definition => New_Occurrence_Of (Counter_Typ, Loc), - Expression => Make_Integer_Literal (Loc, 0)); + -- The scope master is statically parameterized by the context - -- Set the type of the counter explicitly to prevent errors when - -- examining object declarations later on. + Constraints := New_List; + Append_To (Constraints, + New_Occurrence_Of (Boolean_Literals (Exceptions_OK), Loc)); + Append_To (Constraints, + New_Occurrence_Of + (Boolean_Literals (Exception_Extra_Info), Loc)); + Append_To (Constraints, + New_Occurrence_Of (Boolean_Literals (For_Package), Loc)); - Set_Etype (Counter_Id, Counter_Typ); + Scope_Master_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Finalization_Scope_Master, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Finalization_Scope_Master), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constraints))); - if Debug_Generated_Code then - Set_Debug_Info_Needed (Counter_Id); + Prepend_To (Decls, Scope_Master_Decl); + Analyze (Scope_Master_Decl, Suppress => All_Checks); end if; - -- The counter and its type are inserted before the source - -- declarations of N. - - Prepend_To (Decls, Counter_Decl); - Prepend_To (Decls, Counter_Typ_Decl); - - -- The counter and its associated type must be manually analyzed - -- since N has already been analyzed. + if Exceptions_OK then + Finalizer_Decls := New_List; - Analyze (Counter_Typ_Decl); - Analyze (Counter_Decl); + Build_Object_Declarations + (Finalizer_Data, Finalizer_Decls, Loc, For_Package); - Jump_Alts := New_List; + else + Finalizer_Decls := No_List; + end if; end if; -- If the context requires additional cleanup, the finalization -- machinery is added after the cleanup code. if Acts_As_Clean then - Finalizer_Stmts := Clean_Stmts; - Jump_Block_Insert_Nod := Last (Finalizer_Stmts); + Finalizer_Stmts := Clean_Stmts; else Finalizer_Stmts := New_List; end if; @@ -1643,10 +1670,8 @@ package body Exp_Ch7 is procedure Create_Finalizer is Body_Id : Entity_Id; Fin_Body : Node_Id; + Fin_Call : Node_Id; Fin_Spec : Node_Id; - Jump_Block : Node_Id; - Label : Node_Id; - Label_Id : Entity_Id; begin -- Step 1: Creation of the finalizer name @@ -1675,37 +1700,6 @@ package body Exp_Ch7 is 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 @@ -1738,69 +1732,16 @@ package body Exp_Ch7 is -- Step 3: Creation of the finalizer body - -- Has_Ctrl_Objs might be set because of a generic package body having - -- controlled objects. In this case, Jump_Alts may be empty and no - -- case nor goto statements are needed. - - if Has_Ctrl_Objs - and then not Is_Empty_List (Jump_Alts) - then - -- Add L0, the default destination to the jump block - - Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0)); - Set_Entity (Label_Id, - Make_Defining_Identifier (Loc, Chars (Label_Id))); - Label := Make_Label (Loc, Label_Id); - - -- Generate: - -- L0 : label; - - Prepend_To (Finalizer_Decls, - Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Entity (Label_Id), - Label_Construct => Label)); - - -- Generate: - -- when others => - -- goto L0; - - Append_To (Jump_Alts, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Goto_Statement (Loc, - Name => New_Occurrence_Of (Entity (Label_Id), Loc))))); - - -- Generate: - -- <<L0>> - - Append_To (Finalizer_Stmts, Label); - - -- Create the jump block which controls the finalization flow - -- depending on the value of the state counter. - - Jump_Block := - Make_Case_Statement (Loc, - Expression => Make_Identifier (Loc, Chars (Counter_Id)), - Alternatives => Jump_Alts); - - if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then - Insert_After (Jump_Block_Insert_Nod, Jump_Block); - else - Prepend_To (Finalizer_Stmts, Jump_Block); - end if; - end if; - -- Add the library-level tagged type unregistration machinery before - -- the jump block circuitry. This ensures that external tags will be - -- removed even if a finalization exception occurs at some point. + -- the finalization circuitry. This ensures that external tags will + -- be removed even if a finalization exception occurs at some point. if Has_Tagged_Types then Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts); end if; -- Add a call to the previous At_End handler if it exists. The call - -- must always precede the jump block. + -- must always precede the finalization circuitry. if Present (Prev_At_End) then Prepend_To (Finalizer_Stmts, @@ -1812,6 +1753,69 @@ package body Exp_Ch7 is Set_At_End_Proc (HSS, Empty); end if; + -- If there are no controlled objects to be finalized, generate; + + -- procedure Fin_Id is + -- begin + -- Abort_Defer; -- Added if abort is allowed + -- <call to Prev_At_End> -- Added if exists + -- <tag unregistration> -- Added if Has_Tagged_Types + -- <cleanup statements> -- Added if Acts_As_Clean + -- <stack release> -- Added if Mark_Id exists + -- Abort_Undefer; -- Added if abort is allowed + -- end Fin_Id; + + -- If there are controlled objects to be finalized, generate: + + -- procedure Fin_Id is + -- Abort : constant Boolean := Triggered_By_Abort; + -- E : Exception_Occurrence; + -- Raised : Boolean := False; + -- begin + -- Abort_Defer; -- Added if abort is allowed + -- <call to Prev_At_End> -- Added if exists + -- <tag unregistration> -- Added if Has_Tagged_Types + -- <cleanup statements> -- Added if Acts_As_Clean + -- <finalization statements> + -- <stack release> -- Added if Mark_Id exists + -- Abort_Undefer; -- Added if abort is allowed + -- end Fin_Id; + + if Has_Ctrl_Objs and then Counter_Val > 1 then + Fin_Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Finalize_Master), Loc), + Parameter_Associations => + New_List + (New_Occurrence_Of (Finalization_Scope_Master, Loc))); + + -- For CodePeer, the exception handlers normally generated here + -- generate complex flowgraphs which result in capacity problems. + -- Omitting these handlers for CodePeer is justified as follows: + + -- If a handler is dead, then omitting it is surely ok + + -- If a handler is live, then CodePeer should flag the + -- potentially-exception-raising construct that causes it + -- 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 + Fin_Call := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Call), + + Exception_Handlers => New_List ( + Build_Exception_Handler + (Finalizer_Data, For_Package)))); + end if; + + Append_To (Finalizer_Stmts, Fin_Call); + end if; + -- Release the secondary stack if Present (Mark_Id) then @@ -1866,7 +1870,7 @@ package body Exp_Ch7 is -- Protect the statements with abort defer/undefer. This is only when -- aborts are allowed and the cleanup statements require deferral or -- there are controlled objects to be finalized. Note that the abort - -- defer/undefer pair does not require an extra block because each + -- defer/undefer pair does not require an extra block because the -- finalization exception is caught in its corresponding finalization -- block. As a result, the call to Abort_Defer always takes place. @@ -1891,29 +1895,6 @@ package body Exp_Ch7 is Build_Raise_Statement (Finalizer_Data)); end if; - -- Generate: - -- procedure Fin_Id is - -- Abort : constant Boolean := Triggered_By_Abort; - -- <or> - -- Abort : constant Boolean := False; -- no abort - - -- E : Exception_Occurrence; -- All added if flag - -- Raised : Boolean := False; -- Has_Ctrl_Objs is set - -- L0 : label; - -- ... - -- Lnn : label; - - -- begin - -- Abort_Defer; -- Added if abort is allowed - -- <call to Prev_At_End> -- Added if exists - -- <cleanup statements> -- Added if Acts_As_Clean - -- <jump block> -- Added if Has_Ctrl_Objs - -- <finalization statements> -- Added if Has_Ctrl_Objs - -- <stack release> -- Added if Mark_Id exists - -- Abort_Undefer; -- Added if abort is allowed - -- <exception propagation> -- Added if Has_Ctrl_Objs - -- end Fin_Id; - -- Create the body of the finalizer Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id)); @@ -1941,124 +1922,33 @@ package body Exp_Ch7 is if For_Package then - -- If the package spec has private declarations, the finalizer - -- body must be added to the end of the list in order to have - -- visibility of all private controlled objects. + -- If a package spec has private declarations, both the finalizer + -- spec and body are inserted at the end of this list. - if For_Package_Spec then - if Present (Priv_Decls) then - Append_To (Priv_Decls, Fin_Spec); - Append_To (Priv_Decls, Fin_Body); - else - Append_To (Decls, Fin_Spec); - Append_To (Decls, Fin_Body); - end if; + if For_Package_Spec and then Present (Priv_Decls) then + Append_To (Priv_Decls, Fin_Spec); + Append_To (Priv_Decls, Fin_Body); - -- For package bodies, both the finalizer spec and body are - -- inserted at the end of the package declarations. + -- Otherwise, and for a package body, both the finalizer spec and + -- body are inserted at the end of the package declarations. else Append_To (Decls, Fin_Spec); Append_To (Decls, Fin_Body); end if; - Analyze (Fin_Spec); - Analyze (Fin_Body); - -- Non-package case else - -- Create the spec for the finalizer. The At_End handler must be - -- able to call the body which resides in a nested structure. - - -- Generate: - -- 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 (Spec_Decls)); - -- It maybe possible that we are finalizing 'Old objects which - -- exist in the spec declarations. When this is the case the - -- Finalizer_Insert_Node will come before the end of the - -- Spec_Decls. So, to mitigate this, we insert the finalizer spec - -- earlier at the Finalizer_Insert_Nod instead of appending to the - -- end of Spec_Decls to prevent its body appearing before its - -- corresponding spec. - - if Present (Finalizer_Insert_Nod) - and then List_Containing (Finalizer_Insert_Nod) = Spec_Decls - then - Insert_After_And_Analyze (Finalizer_Insert_Nod, Fin_Spec); - Finalizer_Insert_Nod := Fin_Spec; - - -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls - - else - Append_To (Spec_Decls, Fin_Spec); - Analyze (Fin_Spec); - end if; - - -- 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 all other cases the body is inserted after either: - -- - -- 1) The counter update statement of the last controlled object - -- 2) The last top level nested controlled package - -- 3) The last top level controlled instantiation - - 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); - - -- In the case where the last construct to contain a controlled - -- object is either a nested package, an instantiation or a - -- freeze node, the body must be inserted directly after the - -- construct, except if the insertion point is already placed - -- after the construct, typically in the statement list. - - if Nkind (Last_Top_Level_Ctrl_Construct) in - N_Freeze_Entity | N_Package_Declaration | N_Package_Body - and then not - (List_Containing (Last_Top_Level_Ctrl_Construct) = Spec_Decls - and then Present (Stmts) - and then List_Containing (Finalizer_Insert_Nod) = Stmts) - then - Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct; - end if; - - Insert_After (Finalizer_Insert_Nod, Fin_Body); - end if; - - Analyze (Fin_Body, Suppress => All_Checks); + Append_To (Spec_Decls, Fin_Spec); + Append_To (Spec_Decls, Fin_Body); end if; + Analyze (Fin_Spec, Suppress => All_Checks); + Analyze (Fin_Body, Suppress => All_Checks); + -- Never consider that the finalizer procedure is enabled Ghost, even -- when the corresponding unit is Ghost, as this would lead to an -- an external name with a ___ghost_ prefix that the binder cannot @@ -2121,34 +2011,19 @@ package body Exp_Ch7 is procedure Process_Declarations (Decls : List_Id; - Preprocess : Boolean := False; - Top_Level : Boolean := False) + Preprocess : Boolean := False) is - Decl : Node_Id; - Expr : Node_Id; - Obj_Id : Entity_Id; - Obj_Typ : Entity_Id; - Pack_Id : Entity_Id; - Spec : Node_Id; - Typ : Entity_Id; - - Old_Counter_Val : Nat; - -- This variable is used to determine whether a nested package or - -- instance contains at least one controlled object. - procedure Process_Package_Body (Decl : Node_Id); -- Process an N_Package_Body node procedure Processing_Actions - (Has_No_Init : Boolean := False; + (Decl : Node_Id; Is_Protected : Boolean := False); -- Depending on the mode of operation of Process_Declarations, either -- increment the controlled object counter, set the controlled object -- flag and store the last top level construct or process the current - -- declaration. Flag Has_No_Init is used to propagate scenarios where - -- the current declaration may not have initialization proc(s). Flag - -- Is_Protected should be set when the current declaration denotes a - -- simple protected object. + -- declaration. Flag Is_Protected is set when the current declaration + -- denotes a simple protected object. -------------------------- -- Process_Package_Body -- @@ -2163,19 +2038,7 @@ package body Exp_Ch7 is null; elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package then - Old_Counter_Val := Counter_Val; Process_Declarations (Declarations (Decl), Preprocess); - - -- The nested package body is the last construct to contain - -- a controlled object. - - if Preprocess - and then Top_Level - and then No (Last_Top_Level_Ctrl_Construct) - and then Counter_Val > Old_Counter_Val - then - Last_Top_Level_Ctrl_Construct := Decl; - end if; end if; end Process_Package_Body; @@ -2184,7 +2047,7 @@ package body Exp_Ch7 is ------------------------ procedure Processing_Actions - (Has_No_Init : Boolean := False; + (Decl : Node_Id; Is_Protected : Boolean := False) is begin @@ -2194,10 +2057,6 @@ package body Exp_Ch7 is if Preprocess then Has_Tagged_Types := True; - if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then - Last_Top_Level_Ctrl_Construct := Decl; - end if; - -- Unregister tagged type, unless No_Tagged_Type_Registration -- is active. @@ -2212,16 +2071,22 @@ package body Exp_Ch7 is Counter_Val := Counter_Val + 1; Has_Ctrl_Objs := True; - if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then - Last_Top_Level_Ctrl_Construct := Decl; - end if; - else - Process_Object_Declaration (Decl, Has_No_Init, Is_Protected); + Process_Object_Declaration (Decl, Is_Protected); end if; end if; end Processing_Actions; + -- Local variables + + Decl : Node_Id; + Expr : Node_Id; + Obj_Id : Entity_Id; + Obj_Typ : Entity_Id; + Pack_Id : Entity_Id; + Spec : Node_Id; + Typ : Entity_Id; + -- Start of processing for Process_Declarations begin @@ -2253,7 +2118,7 @@ package body Exp_Ch7 is and then not Restriction_Active (No_Tagged_Type_Registration) and then RTE_Available (RE_Register_Tag) then - Processing_Actions; + Processing_Actions (Decl); end if; -- Regular object declarations @@ -2285,6 +2150,15 @@ package body Exp_Ch7 is elsif Is_Ignored_For_Finalization (Obj_Id) then null; + -- Conversely, if one of the above cases created a Master_Node, + -- finalization actions are required for the associated object. + -- Note that we need to make sure that we will not process both + -- the Master_Node and the associated object here. + + elsif Present (Finalization_Master_Node_Or_Object (Obj_Id)) then + pragma Assert (Is_RTE (Obj_Typ, RE_Master_Node)); + Processing_Actions (Decl); + -- Ignored Ghost objects do not need any cleanup actions -- because they will not appear in the final tree. @@ -2305,7 +2179,7 @@ package body Exp_Ch7 is and then not Has_Completion (Obj_Id) and then No (BIP_Initialization_Call (Obj_Id))) then - Processing_Actions; + Processing_Actions (Decl); -- The object is of the form: -- Obj : Access_Typ := Non_BIP_Function_Call'reference; @@ -2323,29 +2197,7 @@ package body Exp_Ch7 is (Is_Non_BIP_Func_Call (Expr) and then not Is_Related_To_Func_Return (Obj_Id))) then - Processing_Actions (Has_No_Init => True); - - -- Processing for "hook" objects generated for transient - -- objects declared inside an Expression_With_Actions. - - elsif Is_Access_Type (Obj_Typ) - and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) - and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = - N_Object_Declaration - then - Processing_Actions (Has_No_Init => True); - - -- Process intermediate results of an if expression with one - -- of the alternatives using a controlled function call. - - elsif Is_Access_Type (Obj_Typ) - and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) - and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = - N_Defining_Identifier - and then Present (Expr) - and then Nkind (Expr) = N_Null - then - Processing_Actions (Has_No_Init => True); + Processing_Actions (Decl); -- Simple protected objects which use type System.Tasking. -- Protected_Objects.Protection to manage their locks should @@ -2383,7 +2235,7 @@ package body Exp_Ch7 is and then not In_Library_Level_Package_Body (Obj_Id) and then Has_Simple_Protected_Object (Obj_Typ) then - Processing_Actions (Is_Protected => True); + Processing_Actions (Decl, Is_Protected => True); end if; -- Specific cases of object renamings @@ -2404,16 +2256,6 @@ package body Exp_Ch7 is elsif Is_Ignored_Ghost_Entity (Obj_Id) then null; - - -- Return object of extended return statements. This case is - -- recognized and marked by the expansion of extended return - -- statements (see Expand_N_Extended_Return_Statement). - - elsif Needs_Finalization (Obj_Typ) - and then Is_Return_Object (Obj_Id) - and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) - then - Processing_Actions (Has_No_Init => True); end if; -- Inspect the freeze node of an access-to-controlled type and @@ -2443,24 +2285,12 @@ package body Exp_Ch7 is (Available_View (Designated_Type (Typ)))) or else (Is_Type (Typ) and then Needs_Finalization (Typ)) then - Old_Counter_Val := Counter_Val; - -- Freeze nodes are considered to be identical to packages -- and blocks in terms of nesting. The difference is that -- a finalization master created inside the freeze node is -- at the same nesting level as the node itself. Process_Declarations (Actions (Decl), Preprocess); - - -- The freeze node contains a finalization master - - if Preprocess - and then Top_Level - and then No (Last_Top_Level_Ctrl_Construct) - and then Counter_Val > Old_Counter_Val - then - Last_Top_Level_Ctrl_Construct := Decl; - end if; end if; -- Nested package declarations, avoid generics @@ -2476,23 +2306,10 @@ package body Exp_Ch7 is null; elsif Ekind (Pack_Id) /= E_Generic_Package then - Old_Counter_Val := Counter_Val; Process_Declarations (Private_Declarations (Spec), Preprocess); Process_Declarations (Visible_Declarations (Spec), Preprocess); - - -- Either the visible or the private declarations contain a - -- controlled object. The nested package declaration is the - -- last such construct. - - if Preprocess - and then Top_Level - and then No (Last_Top_Level_Ctrl_Construct) - and then Counter_Val > Old_Counter_Val - then - Last_Top_Level_Ctrl_Construct := Decl; - end if; end if; -- Nested package bodies, avoid generics @@ -2516,11 +2333,19 @@ package body Exp_Ch7 is procedure Process_Object_Declaration (Decl : Node_Id; - Has_No_Init : Boolean := False; Is_Protected : Boolean := False) is - Loc : constant Source_Ptr := Sloc (Decl); - Obj_Id : constant Entity_Id := Defining_Identifier (Decl); + Def_Id : constant Entity_Id := Defining_Identifier (Decl); + Obj_Id : constant Entity_Id := + (if Is_RTE (Etype (Def_Id), RE_Master_Node) + then Finalization_Master_Node_Or_Object (Def_Id) + else Def_Id); + Obj_Decl : constant Entity_Id := Declaration_Node (Obj_Id); + Func_Id : constant Entity_Id := + (if Is_Return_Object (Obj_Id) + then Return_Applies_To (Scope (Obj_Id)) + else Empty); + Loc : constant Source_Ptr := Sloc (Obj_Decl); Init_Typ : Entity_Id; -- The initialization type of the related object declaration. Note @@ -2530,7 +2355,9 @@ package body Exp_Ch7 is Obj_Typ : Entity_Id; -- The type of the related object declaration - function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id; + function Build_BIP_Cleanup_Stmts + (Func_Id : Entity_Id; + Obj_Addr : Node_Id) return Node_Id; -- Func_Id denotes a build-in-place function. Generate the following -- cleanup code: -- @@ -2538,16 +2365,15 @@ package body Exp_Ch7 is -- and then BIPfinalizationmaster /= null -- then -- declare - -- type Ptr_Typ is access Obj_Typ; + -- type Ptr_Typ is access Fun_Typ; -- for Ptr_Typ'Storage_Pool -- use Base_Pool (BIPfinalizationmaster); -- begin - -- Free (Ptr_Typ (Temp)); + -- Free (Ptr_Typ (Obj_Addr)); -- end; -- end if; -- - -- Obj_Typ is the type of the current object, Temp is the original - -- allocation which Obj_Id renames. + -- Fun_Typ is the return type of the Func_Id. procedure Find_Last_Init (Last_Init : out Node_Id; @@ -2557,20 +2383,26 @@ package body Exp_Ch7 is -- Decl. Body_Insert denotes a node where the finalizer body could be -- potentially inserted after (if blocks are involved). + 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 actual parameter in a call to a Finalize_Address procedure. + ----------------------------- -- Build_BIP_Cleanup_Stmts -- ----------------------------- function Build_BIP_Cleanup_Stmts - (Func_Id : Entity_Id) return Node_Id + (Func_Id : Entity_Id; + Obj_Addr : Node_Id) return Node_Id is Decls : constant List_Id := New_List; Fin_Mas_Id : constant Entity_Id := Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); Func_Typ : constant Entity_Id := Etype (Func_Id); - Temp_Id : constant Entity_Id := - Entity (Prefix (Name (Parent (Obj_Id)))); Cond : Node_Id; Free_Blk : Node_Id; @@ -2632,8 +2464,7 @@ package body Exp_Ch7 is Free_Stmt := Make_Free_Statement (Loc, Expression => - Unchecked_Convert_To (Ptr_Typ, - New_Occurrence_Of (Temp_Id, Loc))); + Unchecked_Convert_To (Ptr_Typ, Obj_Addr)); Set_Storage_Pool (Free_Stmt, Pool_Id); @@ -2644,7 +2475,7 @@ package body Exp_Ch7 is -- declare -- <Decls> -- begin - -- Free (Ptr_Typ (Temp_Id)); + -- Free (Ptr_Typ (Obj_Addr)); -- end; Free_Blk := @@ -2865,17 +2696,24 @@ package body Exp_Ch7 is -- Start of processing for Find_Last_Init begin - Last_Init := Decl; + Last_Init := Obj_Decl; Body_Insert := Empty; - -- Object renamings and objects associated with controlled - -- function results do not require initialization. + -- Objects that capture controlled function results do not require + -- initialization. - if Has_No_Init then + if Nkind (Obj_Decl) = N_Object_Declaration + and then Nkind (Expression (Obj_Decl)) = N_Reference + then return; end if; - Stmt := Next_Suitable_Statement (Decl); + 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 (Obj_Decl); + end if; -- For an object with suppressed initialization, we check whether -- there is in fact no initialization expression. If there is not, @@ -2883,11 +2721,13 @@ package body Exp_Ch7 is -- 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 - -- Inc_Decl will be inserted after the call. Otherwise, if 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 No_Initialization (Decl) then + if Nkind (Obj_Decl) = N_Object_Declaration + and then No_Initialization (Obj_Decl) + then if No (Expression (Last_Init)) then loop Next (Last_Init); @@ -2971,55 +2811,89 @@ package body Exp_Ch7 is end if; end Find_Last_Init; - -- Local variables + ------------------------------- + -- Make_Address_For_Finalize -- + ------------------------------- - Body_Ins : Node_Id; - Count_Ins : Node_Id; - Fin_Call : Node_Id; - Fin_Stmts : List_Id := No_List; - Inc_Decl : Node_Id; - Label : Node_Id; - Label_Id : Entity_Id; - Obj_Ref : Node_Id; + function Make_Address_For_Finalize + (Loc : Source_Ptr; + Obj_Ref : Node_Id; + Obj_Typ : Entity_Id) return Node_Id + is + Obj_Addr : Node_Id; - -- Start of processing for Process_Object_Declaration + begin + Obj_Addr := + Make_Attribute_Reference (Loc, + Prefix => Obj_Ref, + Attribute_Name => Name_Address); + + -- If the type of a constrained array has an unconstrained first + -- subtype, its Finalize_Address primitive expects the address of + -- an object with a dope vector (see Make_Finalize_Address_Stmts). + -- This is achieved by setting Is_Constr_Subt_For_UN_Aliased, but + -- the address of the object is still that of its elements, so we + -- need to shift it. + + if Is_Array_Type (Obj_Typ) + and then not Is_Constrained (First_Subtype (Obj_Typ)) + then + -- Shift the address from the start of the elements to the + -- start of the dope vector: - begin - -- Handle the object type and the reference to the object. Note - -- that objects having simple protected components must retain - -- their original form for the processing below to work. + -- V - (Obj_Typ'Descriptor_Size / Storage_Unit) - Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); - Obj_Typ := Base_Type (Etype (Obj_Id)); + -- Note that this is done through a wrapper routine as RTSfind + -- cannot retrieve operations with string name of the form "+". - loop - if Is_Access_Type (Obj_Typ) then - Obj_Typ := Directly_Designated_Type (Obj_Typ); - Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); + Obj_Addr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc), + Parameter_Associations => New_List ( + Obj_Addr, + Make_Op_Minus (Loc, + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Obj_Typ, Loc), + Attribute_Name => Name_Descriptor_Size), + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit))))); + end if; - elsif Is_Concurrent_Type (Obj_Typ) - and then Present (Corresponding_Record_Type (Obj_Typ)) - and then not Is_Protected - then - Obj_Typ := Corresponding_Record_Type (Obj_Typ); - Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); + return Obj_Addr; + end Make_Address_For_Finalize; - elsif Is_Private_Type (Obj_Typ) - and then Present (Full_View (Obj_Typ)) - then - Obj_Typ := Full_View (Obj_Typ); - Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); + -- Local variables - elsif Obj_Typ /= Base_Type (Obj_Typ) then - Obj_Typ := Base_Type (Obj_Typ); - Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); + Body_Ins : Node_Id; + Fin_Call : Node_Id; + Fin_Id : Entity_Id; + Master_Node_Attach : Node_Id; + Master_Node_Decl : Node_Id; + Master_Node_Id : Entity_Id; + Master_Node_Ins : Node_Id; + Obj_Ref : Node_Id; - else - exit; - end if; - end loop; + -- Start of processing for Process_Object_Declaration - Set_Etype (Obj_Ref, Obj_Typ); + begin + -- Handle the object type and the reference to the object. Note + -- that objects having simple protected components or of a CW type + -- must retain their original type for the processing below to work. + + Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); + Obj_Typ := Etype (Obj_Id); + if not Is_Protected and then not Is_Class_Wide_Type (Obj_Typ) then + Obj_Typ := Base_Type (Obj_Typ); + end if; + + if Is_Access_Type (Obj_Typ) then + Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); + Obj_Typ := Available_View (Designated_Type (Obj_Typ)); + end if; -- Handle the initialization type of the object declaration @@ -3038,189 +2912,316 @@ package body Exp_Ch7 is end if; end loop; - -- Set a new value for the state counter and insert the statement - -- after the object declaration. Generate: + -- 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 scope master and therefore needs to + -- inserted at the same place the scope master would have been. + + if Present (Finalization_Master_Node_Or_Object (Obj_Id)) then + Master_Node_Id := Finalization_Master_Node_Or_Object (Obj_Id); + + -- Move declaration, call marker if any and initialization call + -- and mark the Master_Node to avoid double processing + + if Counter_Val = 1 then + Master_Node_Decl := Declaration_Node (Master_Node_Id); + if Nkind (Next (Master_Node_Decl)) = N_Call_Marker then + Prepend_To (Decls, Remove_Next (Next (Master_Node_Decl))); + end if; + Prepend_To (Decls, Remove_Next (Master_Node_Decl)); + Remove (Master_Node_Decl); + Prepend_To (Decls, Master_Node_Decl); + Set_Is_Ignored_For_Finalization (Master_Node_Id); + end if; + + else + Master_Node_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Obj_Id), Suffix => "MN")); + Master_Node_Decl := + Make_Master_Node_Declaration (Loc, Master_Node_Id, Obj_Id); + + Push_Scope (Scope (Obj_Id)); + if Counter_Val = 1 then + Prepend_To (Decls, Master_Node_Decl); + else + Insert_Before (Obj_Decl, Master_Node_Decl); + end if; + Analyze (Master_Node_Decl); + Pop_Scope; - -- Counter := <value>; + -- Mark the Master_Node to avoid double processing - Inc_Decl := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Counter_Id, Loc), - Expression => Make_Integer_Literal (Loc, Counter_Val)); + Set_Is_Ignored_For_Finalization (Master_Node_Id); + end if; - -- Insert the counter after all initialization has been done. The + -- Attach the Master_Node after all initialization has been done. The -- place of insertion depends on the context. if Ekind (Obj_Id) in E_Constant | E_Variable then -- The object is initialized by a build-in-place function call. - -- The counter insertion point is after the function call. + -- The Master_Node insertion point is after the function call. if Present (BIP_Initialization_Call (Obj_Id)) then - Count_Ins := BIP_Initialization_Call (Obj_Id); + Master_Node_Ins := BIP_Initialization_Call (Obj_Id); Body_Ins := Empty; - -- The object is initialized by an aggregate. Insert the counter - -- after the last aggregate assignment. + -- 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 - Count_Ins := Last_Aggregate_Assignment (Obj_Id); + Master_Node_Ins := Last_Aggregate_Assignment (Obj_Id); Body_Ins := Empty; - -- In all other cases the counter is inserted after the last call + -- 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 (Count_Ins, Body_Ins); + Find_Last_Init (Master_Node_Ins, Body_Ins); end if; - -- In all other cases the counter is inserted after the last call to - -- either [Deep_]Initialize or the type-specific init proc. + -- 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 (Count_Ins, Body_Ins); + Find_Last_Init (Master_Node_Ins, Body_Ins); end if; -- If the Initialize function is null or trivial, the call will have - -- been replaced with a null statement, in which case place counter - -- declaration after object declaration itself. + -- been replaced with a null statement and we place the attachment + -- of the Master_Node after the declaration of the object itself. - if No (Count_Ins) then - Count_Ins := Decl; + if No (Master_Node_Ins) then + Master_Node_Ins := Obj_Decl; end if; - Insert_After (Count_Ins, Inc_Decl); - Analyze (Inc_Decl); - - -- If the current declaration is the last in the list, the finalizer - -- body needs to be inserted after the set counter statement for the - -- current object declaration. This is complicated by the fact that - -- the set counter statement may appear in abort deferred block. In - -- that case, the proper insertion place is after the block. - - if No (Finalizer_Insert_Nod) then + -- Processing for simple protected objects. Such objects require + -- manual finalization of their lock managers. Generate: - -- Insertion after an abort deferred block + -- procedure obj_type_nnFD (v :system__address) is + -- type Ptr_Typ is access all Obj_Typ; + -- Rnn : Obj_Typ renames Ptr_Typ!(v).all; + -- begin + -- $system__tasking__protected_objects__finalize_protection + -- (Obj_TypV!(Rnn)._object); + -- exception + -- when others => + -- null; + -- end obj_type_nnFD; - if Present (Body_Ins) then - Finalizer_Insert_Nod := Body_Ins; - else - Finalizer_Insert_Nod := Inc_Decl; - end if; - end if; + if Is_Protected + or else (Has_Simple_Protected_Object (Obj_Typ) + and then No (Finalize_Address (Obj_Typ))) + then + declare + Param : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_V); + Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'P'); + Ren_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); + Ren_Ref : constant Node_Id := New_Occurrence_Of (Ren_Id, Loc); - -- Create the associated label with this object, generate: + Fin_Body : Node_Id; + Fin_Call : Node_Id; + Fin_Stmts : List_Id := No_List; + HSS : Node_Id; - -- L<counter> : label; + begin + Set_Etype (Ren_Ref, Obj_Typ); - Label_Id := - Make_Identifier (Loc, New_External_Name ('L', Counter_Val)); - Set_Entity - (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id))); - Label := Make_Label (Loc, Label_Id); + if Is_Simple_Protected_Type (Obj_Typ) then + Fin_Call := Cleanup_Protected_Object (Obj_Decl, Ren_Ref); - Prepend_To (Finalizer_Decls, - Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Entity (Label_Id), - Label_Construct => Label)); + if Present (Fin_Call) then + Fin_Stmts := New_List (Fin_Call); + end if; - -- Create the associated jump with this object, generate: + elsif Is_Array_Type (Obj_Typ) then + Fin_Stmts := Cleanup_Array (Obj_Decl, Ren_Ref, Obj_Typ); - -- when <counter> => - -- goto L<counter>; + else + Fin_Stmts := Cleanup_Record (Obj_Decl, Ren_Ref, Obj_Typ); + end if; - Prepend_To (Jump_Alts, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List ( - Make_Integer_Literal (Loc, Counter_Val)), - Statements => New_List ( - Make_Goto_Statement (Loc, - Name => New_Occurrence_Of (Entity (Label_Id), Loc))))); + if No (Fin_Stmts) then + return; + end if; - -- Insert the jump destination, generate: + HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Fin_Stmts); + + if Exceptions_OK then + Set_Exception_Handlers (HSS, New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Null_Statement (Loc))))); + end if; - -- <<L<counter>>> + Fin_Id := + Make_Defining_Identifier (Loc, + Make_TSS_Name_Local (Obj_Typ, TSS_Finalize_Address)); + + Fin_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Fin_Id, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Param, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Address), Loc)))), + + Declarations => New_List ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Obj_Typ, Loc))), + + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Ren_Id, + Subtype_Mark => + New_Occurrence_Of (Obj_Typ, Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To + (Ptr_Typ, New_Occurrence_Of (Param, Loc))))), + + Handled_Statement_Sequence => HSS); + + Push_Scope (Scope (Obj_Id)); + Insert_After_And_Analyze + (Master_Node_Ins, Fin_Body, Suppress => All_Checks); + Pop_Scope; + + Master_Node_Ins := Fin_Body; + end; - Append_To (Finalizer_Stmts, Label); + -- If we are dealing with a return object of a build-in-place + -- function, generate the following cleanup statements: - -- Disable warnings on Obj_Id. This works around an issue where GCC - -- is not able to detect that Obj_Id is protected by a counter and - -- emits spurious warnings. + -- if BIPallocfrom > Secondary_Stack'Pos + -- and then BIPfinalizationmaster /= null + -- then + -- declare + -- type Ptr_Typ is access Obj_Typ; + -- for Ptr_Typ'Storage_Pool use + -- Base_Pool (BIPfinalizationmaster.all).all; + -- begin + -- Free (Ptr_Typ (Obj'Address)); + -- end; + -- end if; - if not Comes_From_Source (Obj_Id) then - Set_Warnings_Off (Obj_Id); - end if; + -- The generated code effectively detaches the temporary from the + -- caller finalization master and deallocates the object. - -- Processing for simple protected objects. Such objects require - -- manual finalization of their lock managers. + elsif Present (Func_Id) + and then Is_Build_In_Place_Function (Func_Id) + and then Needs_BIP_Finalization_Master (Func_Id) + then + declare + Ptr_Typ : constant Node_Id := Make_Temporary (Loc, 'P'); + Param : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_V); - if Is_Protected then - if Is_Simple_Protected_Type (Obj_Typ) then - Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref); + Fin_Body : Node_Id; + Fin_Stmts : List_Id; - if Present (Fin_Call) then - Fin_Stmts := New_List (Fin_Call); - end if; + begin + Fin_Stmts := Make_Finalize_Address_Stmts (Obj_Typ); - elsif Is_Array_Type (Obj_Typ) then - Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ); + Append_To (Fin_Stmts, + Build_BIP_Cleanup_Stmts + (Func_Id, New_Occurrence_Of (Param, Loc))); - else - Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ); - end if; + Fin_Id := + Make_Defining_Identifier (Loc, + Make_TSS_Name_Local + (Obj_Typ, TSS_Finalize_Address)); + + Fin_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Fin_Id, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Param, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Address), Loc)))), + + Declarations => New_List ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Obj_Typ, Loc)))), - -- Generate: - -- begin - -- System.Tasking.Protected_Objects.Finalize_Protection - -- (Obj._object); + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Fin_Stmts)); - -- exception - -- when others => - -- null; - -- end; + Push_Scope (Scope (Obj_Id)); + Insert_After_And_Analyze + (Master_Node_Ins, Fin_Body, Suppress => All_Checks); + Pop_Scope; - if Present (Fin_Stmts) and then Exceptions_OK then - Fin_Stmts := New_List ( - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Fin_Stmts, + Master_Node_Ins := Fin_Body; + end; - Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => New_List ( - Make_Others_Choice (Loc)), + else + Fin_Id := Finalize_Address (Obj_Typ); - Statements => New_List ( - Make_Null_Statement (Loc))))))); + if No (Fin_Id) and then Ekind (Obj_Typ) = E_Class_Wide_Subtype then + Fin_Id := TSS (Obj_Typ, TSS_Finalize_Address); end if; + end if; - -- Processing for regular controlled objects - - else - -- Generate: - -- begin - -- [Deep_]Finalize (Obj); + -- 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. - -- exception - -- when Id : others => - -- if not Raised then - -- Raised := True; - -- Save_Occurrence (E, Id); - -- end if; - -- end; + if Counter_Val = 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. - Fin_Call := - Make_Final_Call ( - Obj_Ref => Obj_Ref, - Typ => Obj_Typ); + if CodePeer_Mode then + Master_Node_Attach := Make_Null_Statement (Loc); + else + Master_Node_Attach := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Attach_Object_To_Node), Loc), + Parameter_Associations => New_List ( + Make_Address_For_Finalize (Loc, Obj_Ref, Obj_Typ), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Fin_Id, Loc), + Attribute_Name => Name_Unrestricted_Access), + New_Occurrence_Of (Master_Node_Id, Loc))); + end if; - -- Guard against a missing [Deep_]Finalize when the object type - -- was not properly frozen. + -- We also generate the direct finalization call here - if No (Fin_Call) then - Fin_Call := Make_Null_Statement (Loc); - 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 (Master_Node_Id, Loc))); -- For CodePeer, the exception handlers normally generated here -- generate complex flowgraphs which result in capacity problems. @@ -3234,7 +3235,7 @@ package body Exp_Ch7 is -- happens after the exception is raised. if Exceptions_OK and not CodePeer_Mode then - Fin_Stmts := New_List ( + Fin_Call := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -3242,119 +3243,37 @@ package body Exp_Ch7 is Exception_Handlers => New_List ( Build_Exception_Handler - (Finalizer_Data, For_Package))))); - - -- When exception handlers are prohibited, the finalization call - -- appears unprotected. Any exception raised during finalization - -- will bypass the circuitry which ensures the cleanup of all - -- remaining objects. - - else - Fin_Stmts := New_List (Fin_Call); - end if; - - -- If we are dealing with a return object of a build-in-place - -- function, generate the following cleanup statements: - - -- if BIPallocfrom > Secondary_Stack'Pos - -- and then BIPfinalizationmaster /= null - -- then - -- declare - -- type Ptr_Typ is access Obj_Typ; - -- for Ptr_Typ'Storage_Pool use - -- Base_Pool (BIPfinalizationmaster.all).all; - -- begin - -- Free (Ptr_Typ (Temp)); - -- end; - -- end if; - - -- The generated code effectively detaches the temporary from the - -- caller finalization master and deallocates the object. - - if Is_Return_Object (Obj_Id) then - declare - Func_Id : constant Entity_Id := - Return_Applies_To (Scope (Obj_Id)); - - begin - if Is_Build_In_Place_Function (Func_Id) - and then Needs_BIP_Finalization_Master (Func_Id) - then - Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id)); - end if; - end; + (Finalizer_Data, For_Package)))); end if; - if Ekind (Obj_Id) in E_Constant | E_Variable - and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) - then - -- Temporaries created for the purpose of "exporting" a - -- transient object out of an Expression_With_Actions (EWA) - -- need guards. The following illustrates the usage of such - -- temporaries. - - -- Access_Typ : access [all] Obj_Typ; - -- Temp : Access_Typ := null; - -- <Counter> := ...; - - -- do - -- Ctrl_Trans : [access [all]] Obj_Typ := ...; - -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer - -- <or> - -- Temp := Ctrl_Trans'Unchecked_Access; - -- in ... end; - - -- The finalization machinery does not process EWA nodes as - -- this may lead to premature finalization of expressions. Note - -- that Temp is marked as being properly initialized regardless - -- of whether the initialization of Ctrl_Trans succeeded. Since - -- a failed initialization may leave Temp with a value of null, - -- add a guard to handle this case: - - -- if Obj /= null then - -- <object finalization statements> - -- end if; - - if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = - N_Object_Declaration - then - Fin_Stmts := New_List ( - Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Obj_Id, Loc), - Right_Opnd => Make_Null (Loc)), - Then_Statements => Fin_Stmts)); - - -- Return objects use a flag to aid in processing their - -- potential finalization when the enclosing function fails - -- to return properly. Generate: - - -- if not Flag then - -- <object finalization statements> - -- end if; - - else - Fin_Stmts := New_List ( - Make_If_Statement (Loc, - Condition => - Make_Op_Not (Loc, - Right_Opnd => - New_Occurrence_Of - (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)), + Append_To (Finalizer_Stmts, Fin_Call); + else + -- 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. - Then_Statements => Fin_Stmts)); - end if; + if CodePeer_Mode then + Master_Node_Attach := Make_Null_Statement (Loc); + else + Master_Node_Attach := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Attach_Object_To_Master), Loc), + Parameter_Associations => New_List ( + Make_Address_For_Finalize (Loc, Obj_Ref, Obj_Typ), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Fin_Id, Loc), + Attribute_Name => Name_Unrestricted_Access), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Master_Node_Id, Loc), + Attribute_Name => Name_Unrestricted_Access), + New_Occurrence_Of (Finalization_Scope_Master, Loc))); end if; end if; - Append_List_To (Finalizer_Stmts, Fin_Stmts); - - -- Since the declarations are examined in reverse, the state counter - -- must be decremented in order to keep with the true position of - -- objects. - - Counter_Val := Counter_Val - 1; + Insert_After_And_Analyze + (Master_Node_Ins, Master_Node_Attach, Suppress => All_Checks); end Process_Object_Declaration; ------------------------------------- @@ -3453,14 +3372,13 @@ package body Exp_Ch7 is -- correct number of controlled object by the time the private -- declarations are processed. - Process_Declarations (Decls, Preprocess => True, Top_Level => True); + Process_Declarations (Decls, Preprocess => True); -- From all the possible contexts, only package specifications may -- have private declarations. if For_Package_Spec then - Process_Declarations - (Priv_Decls, Preprocess => True, Top_Level => True); + Process_Declarations (Priv_Decls, Preprocess => True); end if; -- The current context may lack controlled objects, but require some @@ -3468,14 +3386,14 @@ package body Exp_Ch7 is -- cases, the finalizer must be created and carry the additional -- statements. - if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then + if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then Build_Components; end if; -- The preprocessing has determined that the context has controlled -- objects or library-level tagged types. - if Has_Ctrl_Objs or Has_Tagged_Types then + if Has_Ctrl_Objs or else Has_Tagged_Types then -- Private declarations are processed first in order to preserve -- possible dependencies between public and private objects. @@ -3492,8 +3410,8 @@ package body Exp_Ch7 is else -- Preprocess both declarations and statements - Process_Declarations (Decls, Preprocess => True, Top_Level => True); - Process_Declarations (Stmts, Preprocess => True, Top_Level => True); + Process_Declarations (Decls, Preprocess => True); + Process_Declarations (Stmts, Preprocess => True); -- At this point it is known that N has controlled objects. Ensure -- that N has a declarative list since the finalizer spec will be @@ -3510,11 +3428,11 @@ package body Exp_Ch7 is -- cases, the finalizer must be created and carry the additional -- statements. - if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then + if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then Build_Components; end if; - if Has_Ctrl_Objs or Has_Tagged_Types then + if Has_Ctrl_Objs or else Has_Tagged_Types then Process_Declarations (Stmts); Process_Declarations (Decls); end if; @@ -3522,7 +3440,7 @@ package body Exp_Ch7 is -- Step 3: Finalizer creation - if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then + if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then Create_Finalizer; end if; @@ -5395,10 +5313,6 @@ package body Exp_Ch7 is Last_Object : Node_Id; Related_Node : Node_Id) is - Must_Hook : Boolean; - -- Flag denoting whether the context requires transient object - -- export to the outer finalizer. - function Is_Subprogram_Call (N : Node_Id) return Traverse_Result; -- Return Abandon if arbitrary node denotes a subprogram call @@ -5406,13 +5320,11 @@ package body Exp_Ch7 is new Traverse_Func (Is_Subprogram_Call); procedure Process_Transient_In_Scope - (Obj_Decl : Node_Id; - Blk_Data : Finalization_Exception_Data; - Blk_Stmts : List_Id); + (Obj_Decl : Node_Id; + Insert_Nod : Node_Id; + Must_Export : Boolean); -- Generate finalization actions for a single transient object - -- denoted by object declaration Obj_Decl. Blk_Data is the - -- exception data of the enclosing block. Blk_Stmts denotes the - -- statements of the enclosing block. + -- denoted by object declaration Obj_Decl. ------------------------ -- Is_Subprogram_Call -- @@ -5453,202 +5365,84 @@ package body Exp_Ch7 is -------------------------------- procedure Process_Transient_In_Scope - (Obj_Decl : Node_Id; - Blk_Data : Finalization_Exception_Data; - Blk_Stmts : List_Id) + (Obj_Decl : Node_Id; + Insert_Nod : Node_Id; + Must_Export : Boolean) is - Loc : constant Source_Ptr := Sloc (Obj_Decl); - Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); - Fin_Call : Node_Id; - Fin_Stmts : List_Id; - Hook_Assign : Node_Id; - Hook_Clear : Node_Id; - Hook_Decl : Node_Id; - Hook_Insert : Node_Id; - Ptr_Decl : Node_Id; - - begin - -- Mark the transient object as successfully processed to avoid - -- double finalization. - - Set_Is_Finalized_Transient (Obj_Id); - - -- Construct all the pieces necessary to hook and finalize the - -- transient object. - - Build_Transient_Object_Statements - (Obj_Decl => Obj_Decl, - Fin_Call => Fin_Call, - Hook_Assign => Hook_Assign, - Hook_Clear => Hook_Clear, - Hook_Decl => Hook_Decl, - Ptr_Decl => Ptr_Decl); - - -- The context contains at least one subprogram call which may - -- raise an exception. This scenario employs "hooking" to pass - -- transient objects to the enclosing finalizer in case of an - -- exception. - - if Must_Hook then + Loc : constant Source_Ptr := Sloc (Obj_Decl); + Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); - -- Add the access type which provides a reference to the - -- transient object. Generate: + Master_Node_Id : Entity_Id; + Master_Node_Decl : Node_Id; + Obj_Ref : Node_Id; + Obj_Typ : Entity_Id; - -- type Ptr_Typ is access all Desig_Typ; - - Insert_Action (Obj_Decl, Ptr_Decl); - - -- Add the temporary which acts as a hook to the transient - -- object. Generate: - - -- Hook : Ptr_Typ := null; - - Insert_Action (Obj_Decl, Hook_Decl); - - -- When the transient object is initialized by an aggregate, - -- the hook must capture the object after the last aggregate - -- assignment takes place. Only then is the object considered - -- fully initialized. Generate: - - -- Hook := Ptr_Typ (Obj_Id); - -- <or> - -- Hook := Obj_Id'Unrestricted_Access; + begin + -- If the object needs to be exported to the outer finalizer, + -- create the declaration of the Master_Node for the object, + -- which will later be picked up by Build_Finalizer. Then add + -- the finalization call for the object. + + if Must_Export then + Master_Node_Id := Make_Temporary (Loc, 'N'); + Master_Node_Decl := + Make_Master_Node_Declaration (Loc, Master_Node_Id, Obj_Id); + Insert_Before_And_Analyze (Obj_Decl, Master_Node_Decl); + + 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)))); - -- Similarly if we have a build in place call: we must - -- initialize Hook only after the call has happened, otherwise - -- Obj_Id will not be initialized yet. + -- Otherwise generate a direct finalization call for the object - if Ekind (Obj_Id) in E_Constant | E_Variable then - if Present (Last_Aggregate_Assignment (Obj_Id)) then - Hook_Insert := Last_Aggregate_Assignment (Obj_Id); - elsif Present (BIP_Initialization_Call (Obj_Id)) then - Hook_Insert := BIP_Initialization_Call (Obj_Id); - else - Hook_Insert := Obj_Decl; - end if; + else + -- Handle the object type and the reference to the object - -- Otherwise the hook seizes the related object immediately + Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); + Obj_Typ := Base_Type (Etype (Obj_Id)); - else - Hook_Insert := Obj_Decl; + if Is_Access_Type (Obj_Typ) then + Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); + Obj_Typ := Available_View (Designated_Type (Obj_Typ)); end if; - Insert_After_And_Analyze (Hook_Insert, Hook_Assign); + Insert_After_And_Analyze (Insert_Nod, + Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Obj_Typ)); end if; - -- When exception propagation is enabled wrap the hook clear - -- statement and the finalization call into a block to catch - -- potential exceptions raised during finalization. Generate: - - -- begin - -- [Hook := null;] - -- [Deep_]Finalize (Obj_Ref); - - -- exception - -- when others => - -- if not Raised then - -- Raised := True; - -- Save_Occurrence - -- (Enn, Get_Current_Excep.all.all); - -- end if; - -- end; - - if Exceptions_OK then - Fin_Stmts := New_List; - - if Must_Hook then - Append_To (Fin_Stmts, Hook_Clear); - end if; - - Append_To (Fin_Stmts, Fin_Call); - - Prepend_To (Blk_Stmts, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Fin_Stmts, - Exception_Handlers => New_List ( - Build_Exception_Handler (Blk_Data))))); - - -- Otherwise generate: - - -- [Hook := null;] - -- [Deep_]Finalize (Obj_Ref); - - -- Note that the statements are inserted in reverse order to - -- achieve the desired final order outlined above. + -- Mark the transient object to avoid double finalization - else - Prepend_To (Blk_Stmts, Fin_Call); - - if Must_Hook then - Prepend_To (Blk_Stmts, Hook_Clear); - end if; - end if; + Set_Is_Finalized_Transient (Obj_Id); end Process_Transient_In_Scope; -- Local variables - Built : Boolean := False; - Blk_Data : Finalization_Exception_Data; - Blk_Decl : Node_Id := Empty; - Blk_Decls : List_Id := No_List; - Blk_Ins : Node_Id; - Blk_Stmts : List_Id := No_List; - Loc : Source_Ptr := No_Location; - Obj_Decl : Node_Id; + Insert_Nod : Node_Id; + -- Insertion node for the finalization actions + + Must_Export : Boolean; + -- Flag denoting whether the context requires transient object + -- export to the outer finalizer. + + Obj_Decl : Node_Id; -- Start of processing for Process_Transients_In_Scope begin -- The expansion performed by this routine is as follows: - -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ; - -- Hook_1 : Ptr_Typ_1 := null; + -- Ctrl_Trans_Obj_1MN : Master_Node; -- Ctrl_Trans_Obj_1 : ...; - -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access; -- . . . - -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ; - -- Hook_N : Ptr_Typ_N := null; + -- Ctrl_Trans_Obj_NMN : Master_Node; -- Ctrl_Trans_Obj_N : ...; - -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access; - - -- declare - -- Abrt : constant Boolean := ...; - -- Ex : Exception_Occurrence; - -- Raised : Boolean := False; - - -- begin - -- Abort_Defer; - - -- begin - -- Hook_N := null; - -- [Deep_]Finalize (Ctrl_Trans_Obj_N); - - -- exception - -- when others => - -- if not Raised then - -- Raised := True; - -- Save_Occurrence (Ex, Get_Current_Excep.all.all); - -- end; - -- . . . - -- begin - -- Hook_1 := null; - -- [Deep_]Finalize (Ctrl_Trans_Obj_1); - - -- exception - -- when others => - -- if not Raised then - -- Raised := True; - -- Save_Occurrence (Ex, Get_Current_Excep.all.all); - -- end; - - -- Abort_Undefer; - -- if Raised and not Abrt then - -- Raise_From_Controlled_Operation (Ex); - -- end if; - -- end; + -- Finalize_Object (Ctrl_Trans_Obj_NMN); + -- . . . + -- Finalize_Object (Ctrl_Trans_Obj_1MN); -- Recognize a scenario where the transient context is an object -- declaration initialized by a build-in-place function call: @@ -5667,114 +5461,38 @@ package body Exp_Ch7 is if Nkind (N) = N_Object_Declaration and then Present (BIP_Initialization_Call (Defining_Identifier (N))) then - Must_Hook := True; - Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N)); + Must_Export := True; + Insert_Nod := BIP_Initialization_Call (Defining_Identifier (N)); -- Search the context for at least one subprogram call. If found, the -- machinery exports all transient objects to the enclosing finalizer -- due to the possibility of abnormal call termination. else - Must_Hook := Has_Subprogram_Call (N) = Abandon; - Blk_Ins := Last_Object; + Must_Export := Has_Subprogram_Call (N) = Abandon; + Insert_Nod := Last_Object; end if; - Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup); + Insert_List_After_And_Analyze (Insert_Nod, Act_Cleanup); - -- Examine all objects in the list First_Object .. Last_Object + -- Examine all the objects in the list First_Object .. Last_Object + -- but skip the node to be wrapped because it is not transient as + -- far as this scope is concerned. Obj_Decl := First_Object; while Present (Obj_Decl) loop - if Nkind (Obj_Decl) = N_Object_Declaration + if Obj_Decl /= Related_Node + and then Nkind (Obj_Decl) = N_Object_Declaration and then Analyzed (Obj_Decl) and then Is_Finalizable_Transient (Obj_Decl, N) - - -- Do not process the node to be wrapped since it will be - -- handled by the enclosing finalizer. - - and then Obj_Decl /= Related_Node then - Loc := Sloc (Obj_Decl); - - -- Before generating the cleanup code for the first transient - -- object, create a wrapper block which houses all hook clear - -- statements and finalization calls. This wrapper is needed by - -- the back end. - - if not Built then - Built := True; - Blk_Stmts := New_List; - - -- Generate: - -- Abrt : constant Boolean := ...; - -- Ex : Exception_Occurrence; - -- Raised : Boolean := False; - - if Exceptions_OK then - Blk_Decls := New_List; - Build_Object_Declarations (Blk_Data, Blk_Decls, Loc); - end if; - - Blk_Decl := - Make_Block_Statement (Loc, - Declarations => Blk_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Blk_Stmts)); - end if; - - -- Construct all necessary circuitry to hook and finalize a - -- single transient object. - - pragma Assert (Present (Blk_Stmts)); - Process_Transient_In_Scope - (Obj_Decl => Obj_Decl, - Blk_Data => Blk_Data, - Blk_Stmts => Blk_Stmts); + Process_Transient_In_Scope (Obj_Decl, Insert_Nod, Must_Export); end if; - -- Terminate the scan after the last object has been processed to - -- avoid touching unrelated code. - - if Obj_Decl = Last_Object then - exit; - end if; + exit when Obj_Decl = Last_Object; Next (Obj_Decl); end loop; - - -- Complete the decoration of the enclosing finalization block and - -- insert it into the tree. - - if Present (Blk_Decl) then - - pragma Assert (Present (Blk_Stmts)); - pragma Assert (Loc /= No_Location); - - -- Note that this Abort_Undefer does not require a extra block or - -- an AT_END handler because each finalization exception is caught - -- in its own corresponding finalization block. As a result, the - -- call to Abort_Defer always takes place. - - if Abort_Allowed then - Prepend_To (Blk_Stmts, - Build_Runtime_Call (Loc, RE_Abort_Defer)); - - Append_To (Blk_Stmts, - Build_Runtime_Call (Loc, RE_Abort_Undefer)); - end if; - - -- Generate: - -- if Raised and then not Abrt then - -- Raise_From_Controlled_Operation (Ex); - -- end if; - - if Exceptions_OK then - Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data)); - end if; - - Insert_After_And_Analyze (Blk_Ins, Blk_Decl); - end if; end Process_Transients_In_Scope; -- Local variables @@ -8347,6 +8065,7 @@ package body Exp_Ch7 is else raise Program_Error; end if; + else raise Program_Error; end if; @@ -8905,6 +8624,29 @@ package body Exp_Ch7 is Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True))); end Make_Local_Deep_Finalize; + ---------------------------------- + -- Make_Master_Node_Declaration -- + ---------------------------------- + + function Make_Master_Node_Declaration + (Loc : Source_Ptr; + Master_Node : Entity_Id; + Obj : Entity_Id) return Node_Id + is + begin + Set_Finalization_Master_Node_Or_Object (Obj, Master_Node); + + Mutate_Ekind (Master_Node, E_Variable); + Set_Finalization_Master_Node_Or_Object (Master_Node, Obj); + + return + Make_Object_Declaration (Loc, + Defining_Identifier => Master_Node, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Master_Node), Loc)); + end Make_Master_Node_Declaration; + ------------------------------------ -- Make_Set_Finalize_Address_Call -- ------------------------------------ @@ -8947,6 +8689,43 @@ package body Exp_Ch7 is Attribute_Name => Name_Unrestricted_Access))); end Make_Set_Finalize_Address_Call; + ---------------------------------------- + -- Make_Suppress_Object_Finalize_Call -- + ---------------------------------------- + + function Make_Suppress_Object_Finalize_Call + (Loc : Source_Ptr; + Obj : Entity_Id) return Node_Id + is + Master_Node_Decl : Node_Id; + Master_Node_Id : Entity_Id; + + begin + -- Create the declaration of the Master_Node for the object and + -- insert it before the declaration of the object itself. + + if Present (Finalization_Master_Node_Or_Object (Obj)) then + Master_Node_Id := Finalization_Master_Node_Or_Object (Obj); + + else + Master_Node_Id := Make_Temporary (Loc, 'N'); + Master_Node_Decl := + Make_Master_Node_Declaration (Loc, Master_Node_Id, Obj); + Insert_Before_And_Analyze (Declaration_Node (Obj), Master_Node_Decl); + + -- Mark the object to avoid double finalization + + Set_Is_Ignored_For_Finalization (Obj); + end if; + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Suppress_Object_Finalize_At_End), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Master_Node_Id, Loc))); + end Make_Suppress_Object_Finalize_Call; + -------------------------- -- Make_Transient_Block -- -------------------------- diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index bcc12132c96..c606bb9d79b 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -231,6 +231,12 @@ package Exp_Ch7 is -- Create a special version of Deep_Finalize with identifier Nam. The -- routine has state information and can perform partial finalization. + function Make_Master_Node_Declaration + (Loc : Source_Ptr; + Master_Node : Entity_Id; + Obj : Entity_Id) return Node_Id; + -- Build the declaration of the Master_Node for the object Obj + function Make_Set_Finalize_Address_Call (Loc : Source_Ptr; Ptr_Typ : Entity_Id) return Node_Id; @@ -240,6 +246,12 @@ package Exp_Ch7 is -- Set_Finalize_Address -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); + function Make_Suppress_Object_Finalize_Call + (Loc : Source_Ptr; + Obj : Entity_Id) return Node_Id; + -- Build a call to suppress the finalization of the object Obj, only after + -- creating the Master_Node of Obj if it does not already exist. + -------------------------------------------- -- Task and Protected Object finalization -- -------------------------------------------- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 04d114694ab..25190a65ebf 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4775,136 +4775,6 @@ package body Exp_Util is return Alloc_Obj; end Build_Temporary_On_Secondary_Stack; - --------------------------------------- - -- Build_Transient_Object_Statements -- - --------------------------------------- - - procedure Build_Transient_Object_Statements - (Obj_Decl : Node_Id; - Fin_Call : out Node_Id; - Hook_Assign : out Node_Id; - Hook_Clear : out Node_Id; - Hook_Decl : out Node_Id; - Ptr_Decl : out Node_Id; - Finalize_Obj : Boolean := True) - is - Loc : constant Source_Ptr := Sloc (Obj_Decl); - Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); - Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); - - Desig_Typ : Entity_Id; - Hook_Expr : Node_Id; - Hook_Id : Entity_Id; - Obj_Ref : Node_Id; - Ptr_Typ : Entity_Id; - - begin - -- Recover the type of the object - - Desig_Typ := Obj_Typ; - - if Is_Access_Type (Desig_Typ) then - Desig_Typ := Available_View (Designated_Type (Desig_Typ)); - end if; - - -- Create an access type which provides a reference to the transient - -- object. Generate: - - -- type Ptr_Typ is access all Desig_Typ; - - Ptr_Typ := Make_Temporary (Loc, 'A'); - Mutate_Ekind (Ptr_Typ, E_General_Access_Type); - Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ); - - Ptr_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ptr_Typ, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))); - - -- Create a temporary check which acts as a hook to the transient - -- object. Generate: - - -- Hook : Ptr_Typ := null; - - Hook_Id := Make_Temporary (Loc, 'T'); - Mutate_Ekind (Hook_Id, E_Variable); - Set_Etype (Hook_Id, Ptr_Typ); - - Hook_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Hook_Id, - Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), - Expression => Make_Null (Loc)); - - -- Mark the temporary as a hook. This signals the machinery in - -- Build_Finalizer to recognize this special case. - - Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl); - - -- Hook the transient object to the temporary. Generate: - - -- Hook := Ptr_Typ (Obj_Id); - -- <or> - -- Hool := Obj_Id'Unrestricted_Access; - - if Is_Access_Type (Obj_Typ) then - Hook_Expr := - Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc)); - else - Hook_Expr := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc), - Attribute_Name => Name_Unrestricted_Access); - end if; - - Hook_Assign := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Hook_Id, Loc), - Expression => Hook_Expr); - - -- Crear the hook prior to finalizing the object. Generate: - - -- Hook := null; - - Hook_Clear := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Hook_Id, Loc), - Expression => Make_Null (Loc)); - - -- Finalize the object. Generate: - - -- [Deep_]Finalize (Obj_Ref[.all]); - - if Finalize_Obj then - Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); - - if Is_Access_Type (Obj_Typ) then - Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); - Set_Etype (Obj_Ref, Desig_Typ); - end if; - - Fin_Call := - Make_Final_Call - (Obj_Ref => Obj_Ref, - Typ => Desig_Typ); - - -- Otherwise finalize the hook. Generate: - - -- [Deep_]Finalize (Hook.all); - - else - Fin_Call := - Make_Final_Call ( - Obj_Ref => - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Hook_Id, Loc)), - Typ => Desig_Typ); - end if; - end Build_Transient_Object_Statements; - ----------------------------- -- Check_Float_Op_Overflow -- ----------------------------- @@ -13092,6 +12962,15 @@ package body Exp_Util is elsif Is_Ignored_For_Finalization (Obj_Id) then null; + -- Conversely, if one of the above cases created a Master_Node, + -- finalization actions are required for the associated object. + -- Note that we need to make sure that we will not process both + -- the Master_Node and the associated object here. + + elsif Present (Finalization_Master_Node_Or_Object (Obj_Id)) then + pragma Assert (Is_RTE (Obj_Typ, RE_Master_Node)); + return True; + -- Ignored Ghost objects do not need any cleanup actions because -- they will not appear in the final tree. @@ -13132,28 +13011,6 @@ package body Exp_Util is then return True; - -- Processing for "hook" objects generated for transient objects - -- declared inside an Expression_With_Actions. - - elsif Is_Access_Type (Obj_Typ) - and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) - and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = - N_Object_Declaration - then - return True; - - -- Processing for intermediate results of if expressions where - -- one of the alternatives uses a controlled function call. - - elsif Is_Access_Type (Obj_Typ) - and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) - and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = - N_Defining_Identifier - and then Present (Expr) - and then Nkind (Expr) = N_Null - then - return True; - -- Simple protected objects which use type System.Tasking. -- Protected_Objects.Protection to manage their locks should be -- treated as controlled since they require manual cleanup. @@ -13211,16 +13068,6 @@ package body Exp_Util is elsif Is_Ignored_Ghost_Entity (Obj_Id) then null; - - -- Return object of extended return statements. This case is - -- recognized and marked by the expansion of extended return - -- statements (see Expand_N_Extended_Return_Statement). - - elsif Needs_Finalization (Obj_Typ) - and then Is_Return_Object (Obj_Id) - and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) - then - return True; end if; -- Inspect the freeze node of an access-to-controlled type and look diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 17239c220fe..b968f448bba 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -364,35 +364,6 @@ package Exp_Util is -- This should be used when Typ can potentially be large, to avoid putting -- too much pressure on the primary stack, for example with storage models. - procedure Build_Transient_Object_Statements - (Obj_Decl : Node_Id; - Fin_Call : out Node_Id; - Hook_Assign : out Node_Id; - Hook_Clear : out Node_Id; - Hook_Decl : out Node_Id; - Ptr_Decl : out Node_Id; - Finalize_Obj : Boolean := True); - -- Subsidiary to the processing of transient objects in transient scopes, - -- if expressions, case expressions, and expression_with_action nodes. - -- Obj_Decl denotes the declaration of the transient object. Generate the - -- following nodes: - -- - -- * Fin_Call - the call to [Deep_]Finalize which cleans up the transient - -- object if flag Finalize_Obj is set to True, or finalizes the hook when - -- the flag is False. - -- - -- * Hook_Assign - the assignment statement which captures a reference to - -- the transient object in the hook. - -- - -- * Hook_Clear - the assignment statement which resets the hook to null - -- - -- * Hook_Decl - the declaration of the hook object - -- - -- * Ptr_Decl - the full type declaration of the hook type - -- - -- These nodes are inserted in specific places depending on the context by - -- the various Process_Transient_xxx routines. - procedure Check_Float_Op_Overflow (N : Node_Id); -- Called where we could have a floating-point binary operator where we -- must check for infinities if we are operating in Check_Float_Overflow diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index f1aeef2d60b..cdd9b9577e2 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -539,6 +539,7 @@ package Gen_IL.Fields is Extra_Formal, Extra_Formals, Finalization_Master, + Finalization_Master_Node_Or_Object, Finalize_Storage_Only, Finalizer, First_Entity, @@ -905,7 +906,6 @@ package Gen_IL.Fields is Static_Elaboration_Desired, Static_Initialization, Static_Real_Or_String_Predicate, - Status_Flag_Or_Transient_Decl, Storage_Size_Variable, Stored_Constraint, Stores_Attribute_Old_Prefix, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 5f9d32905db..a30013a117c 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -335,12 +335,12 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (Activation_Record_Component, Node_Id), Sm (Alignment, Unat), Sm (Esize, Uint), + Sm (Finalization_Master_Node_Or_Object, Node_Id), Sm (Interface_Name, Node_Id), Sm (Is_Finalized_Transient, Flag), Sm (Is_Ignored_For_Finalization, Flag), Sm (Linker_Section_Pragma, Node_Id), - Sm (Related_Expression, Node_Id), - Sm (Status_Flag_Or_Transient_Decl, Node_Id))); + Sm (Related_Expression, Node_Id))); Ab (Constant_Or_Variable_Kind, Allocatable_Kind, (Sm (Actual_Subtype, Node_Id), diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb new file mode 100644 index 00000000000..50f49d76f25 --- /dev/null +++ b/gcc/ada/libgnat/s-finpri.adb @@ -0,0 +1,176 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2023, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; use Ada.Exceptions; + +with System.Soft_Links; use System.Soft_Links; + +package body System.Finalization_Primitives is + + ----------------------------- + -- Attach_Object_To_Master -- + ----------------------------- + + procedure Attach_Object_To_Master + (Object_Address : System.Address; + Finalize_Address : not null Finalize_Address_Ptr; + Node : not null Master_Node_Ptr; + Master : in out Finalization_Scope_Master) + is + begin + Attach_Object_To_Node (Object_Address, Finalize_Address, Node.all); + + Node.Next := Master.Head; + Master.Head := Node; + end Attach_Object_To_Master; + + --------------------------- + -- Attach_Object_To_Node -- + --------------------------- + + procedure Attach_Object_To_Node + (Object_Address : System.Address; + Finalize_Address : not null Finalize_Address_Ptr; + Node : in out Master_Node) + is + begin + pragma Assert (Node.Object_Address = System.Null_Address + and then Node.Finalize_Address = null); + + Node.Object_Address := Object_Address; + Node.Finalize_Address := Finalize_Address; + end Attach_Object_To_Node; + + --------------------- + -- Finalize_Master -- + --------------------- + + procedure Finalize_Master (Master : in out Finalization_Scope_Master) is + procedure Raise_From_Controlled_Operation (X : Exception_Occurrence); + pragma Import (Ada, Raise_From_Controlled_Operation, + "__gnat_raise_from_controlled_operation"); + + Finalization_Exception_Raised : Boolean := False; + Exc_Occur : Exception_Occurrence; + Node : Master_Node_Ptr; + + begin + Node := Master.Head; + + -- If exceptions are enabled, we catch them locally and reraise one + -- once all the finalization actions have been completed. + + if Master.Exceptions_OK then + while Node /= null loop + -- Check that the Master_Node has a nonnull address + + if Node.Object_Address = System.Null_Address then + raise Program_Error with "finalize with null address"; + end if; + + begin + Finalize_Object (Node.all); + + exception + when Exc : others => + if not Finalization_Exception_Raised then + Finalization_Exception_Raised := True; + + if Master.Library_Level then + if Master.Extra_Info then + Save_Library_Occurrence (Exc'Unrestricted_Access); + else + Save_Library_Occurrence (null); + end if; + + elsif Master.Extra_Info then + Save_Occurrence (Exc_Occur, Exc); + end if; + end if; + end; + + Node := Node.Next; + end loop; + + -- Otherwise we call finalization procedures without protection + + else + while Node /= null loop + -- Check that the Master_Node has a nonnull address + + if Node.Object_Address = System.Null_Address then + raise Program_Error with "finalize with null address"; + end if; + + Finalize_Object (Node.all); + + Node := Node.Next; + end loop; + end if; + + Master.Head := null; + + -- If one of the finalization actions raised an exception, and we are + -- not at library level, then reraise the exception. + + if Finalization_Exception_Raised and then not Master.Library_Level then + if Master.Extra_Info then + Raise_From_Controlled_Operation (Exc_Occur); + else + raise Program_Error with "finalize/adjust raised exception"; + end if; + end if; + end Finalize_Master; + + --------------------- + -- Finalize_Object -- + --------------------- + + procedure Finalize_Object (Node : in out Master_Node) is + FA : constant Finalize_Address_Ptr := Node.Finalize_Address; + + begin + if FA /= null then + Node.Finalize_Address := null; + FA (Node.Object_Address); + end if; + end Finalize_Object; + + ------------------------------------- + -- Suppress_Object_Finalize_At_End -- + ------------------------------------- + + procedure Suppress_Object_Finalize_At_End (Node : in out Master_Node) is + begin + Node.Finalize_Address := null; + end Suppress_Object_Finalize_At_End; + +end System.Finalization_Primitives; diff --git a/gcc/ada/libgnat/s-finpri.ads b/gcc/ada/libgnat/s-finpri.ads new file mode 100644 index 00000000000..1ffe24bb644 --- /dev/null +++ b/gcc/ada/libgnat/s-finpri.ads @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2023, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package encapsulates the types and operations used by the compiler +-- to support finalization of objects of Ada controlled types (types derived +-- from types Controlled and Limited_Controlled). + +package System.Finalization_Primitives with Preelaborate is + + type Finalize_Address_Ptr is access procedure (Obj : System.Address); + -- Values of this type denote finalization procedures associated with + -- objects that have controlled parts. For convenience, such objects + -- are simply referred to as controlled objects in the remainder of + -- this package. + + type Master_Node is private; + -- Each controlled object associated with a finalization master has an + -- associated master node created by the compiler. + + type Master_Node_Ptr is access all Master_Node; + for Master_Node_Ptr'Storage_Size use 0; + -- A reference to a master node. Since this type may not be used to + -- allocate objects, its storage size is zero. + + -------------------------------------------------------------------------- + -- Types and operations of finalization masters: A finalization master + -- is used to manage a set of controlled objects declared at the library + -- level of the program or associated with the declarative part of a + -- subprogram or other closed scopes (block statements, for example). + + type Finalization_Scope_Master + (Exceptions_OK : Boolean; + Extra_Info : Boolean; + Library_Level : Boolean) is limited private; + -- Objects of this type encapsulate an ordered list of zero or more master + -- nodes, each of which is associated with a controlled object. + + procedure Attach_Object_To_Master + (Object_Address : System.Address; + Finalize_Address : not null Finalize_Address_Ptr; + Node : not null Master_Node_Ptr; + Master : in out Finalization_Scope_Master); + -- Associates a controlled object and its master node with a given master. + -- 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 master. + + procedure Attach_Object_To_Node + (Object_Address : System.Address; + Finalize_Address : not null Finalize_Address_Ptr; + Node : in out Master_Node); + -- Associates a controlled object with its master node only. This is used + -- when there is a single object to be finalized in the context. + + procedure Finalize_Master (Master : in out Finalization_Scope_Master); + -- Finalizes each of the controlled objects associated with Master, in the + -- reverse of the order in which they were attached, and releases the space + -- that was allocated on the secondary stack if Master.SS_Mark is not null. + -- Calls to this 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 + + procedure Suppress_Object_Finalize_At_End (Node : in out Master_Node); + -- Changes the state of Node to effectively suppress a call to Node's + -- associated object's Finalize procedure. This is called at the end + -- of an extended return statement of a function whose result type + -- needs finalization, to ensure that the function's return object is + -- not finalized within the function in the case the return statement + -- is completed normally (it will still be finalized if an exception + -- is raised before the normal completion of the return statement). + +private + + -- Master node type structure + + type Master_Node is record + Object_Address : System.Address := System.Null_Address; + Finalize_Address : Finalize_Address_Ptr := null; + Next : Master_Node_Ptr := null; + end record; + + -- Finalization scope master type structure. A unique master is associated + -- with each scope containing controlled objects. + + type Finalization_Scope_Master + (Exceptions_OK : Boolean; + Extra_Info : Boolean; + Library_Level : Boolean) is limited + record + Head : Master_Node_Ptr := null; + end record; + + -- These operations need to be performed in line for maximum performance + + pragma Inline (Attach_Object_To_Master); + pragma Inline (Attach_Object_To_Node); + pragma Inline (Finalize_Object); + pragma Inline (Suppress_Object_Finalize_At_End); + +end System.Finalization_Primitives; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 2b09f697c42..f36713b0559 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -255,6 +255,7 @@ package Rtsfind is System_Fat_LLF, System_Fat_SFlt, System_Finalization_Masters, + System_Finalization_Primitives, System_Finalization_Root, System_Fore_Decimal_32, System_Fore_Decimal_64, @@ -924,6 +925,14 @@ package Rtsfind is RE_Set_Base_Pool, -- System.Finalization_Masters RE_Set_Finalize_Address, -- System.Finalization_Masters + RE_Attach_Object_To_Master, -- System.Finalization_Primitives + RE_Attach_Object_To_Node, -- System.Finalization_Primitives + RE_Finalize_Master, -- System.Finalization_Primitives + RE_Finalize_Object, -- System.Finalization_Primitives + RE_Finalization_Scope_Master, -- System.Finalization_Primitives + RE_Master_Node, -- System.Finalization_Primitives + RE_Suppress_Object_Finalize_At_End, -- System.Finalization_Primitives + RE_Root_Controlled, -- System.Finalization_Root RE_Fore_Decimal32, -- System.Fore_Decimal_32 @@ -2568,6 +2577,14 @@ package Rtsfind is RE_Set_Base_Pool => System_Finalization_Masters, RE_Set_Finalize_Address => System_Finalization_Masters, + RE_Attach_Object_To_Master => System_Finalization_Primitives, + RE_Attach_Object_To_Node => System_Finalization_Primitives, + RE_Finalize_Master => System_Finalization_Primitives, + RE_Finalize_Object => System_Finalization_Primitives, + RE_Finalization_Scope_Master => System_Finalization_Primitives, + RE_Master_Node => System_Finalization_Primitives, + RE_Suppress_Object_Finalize_At_End => System_Finalization_Primitives, + RE_Root_Controlled => System_Finalization_Root, RE_Fore_Decimal32 => System_Fore_Decimal_32, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 894bc95b50c..578c57c10fa 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5198,6 +5198,17 @@ package body Sem_Ch3 is else Validate_Controlled_Object (Id); end if; + + -- If the type of a constrained array has an unconstrained first + -- subtype, its Finalize_Address primitive expects the address of + -- an object with a dope vector (see Make_Finalize_Address_Stmts). + + if Is_Array_Type (Etype (Id)) + and then Is_Constrained (Etype (Id)) + and then not Is_Constrained (First_Subtype (Etype (Id))) + then + Set_Is_Constr_Array_Subt_With_Bounds (Etype (Id)); + end if; end if; if Has_Task (Etype (Id)) then

[COMMITTED] ada: Partial implementation of redesign of support for object finalization

Commit Message

Patch