diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/einfo.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 804 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/gen_il-fields.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/gen_il-gen-gen_entities.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-finpri.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-finpri.ads | 12 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 2 |
10 files changed, 500 insertions, 380 deletions
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 2496400..6f563d5 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1305,15 +1305,13 @@ 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 +-- Finalization_Master_Node -- 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 @@ -5304,7 +5302,7 @@ package Einfo is -- Related_Type (constants only) -- Initialization_Statements -- BIP_Initialization_Call - -- Finalization_Master_Node_Or_Object + -- Finalization_Master_Node -- Last_Aggregate_Assignment -- Activation_Record_Component -- Encapsulating_State (constants only) @@ -6191,7 +6189,7 @@ package Einfo is -- Related_Type -- Initialization_Statements -- BIP_Initialization_Call - -- Finalization_Master_Node_Or_Object + -- Finalization_Master_Node -- Last_Aggregate_Assignment -- Activation_Record_Component -- Encapsulating_State diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index dd64705..5fa47c9 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -14980,6 +14980,10 @@ package body Exp_Ch4 is Make_Master_Node_Declaration (Loc, Master_Node_Id, Obj_Id); Insert_Action (Hook_Context, Master_Node_Decl); + -- Generate the attachment of the object to the Master_Node + + Attach_Object_To_Master_Node (Obj_Decl, Master_Node_Id); + -- 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 diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 4382de9..7a84576 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -515,6 +515,13 @@ package body Exp_Ch7 is -- of the formal of Proc, or force a conversion to the class-wide type in -- the case where the operation is abstract. + function Make_Address_For_Finalize + (Loc : Source_Ptr; + Obj_Ref : Node_Id; + Obj_Typ : Entity_Id) return Node_Id; + -- Build the address of an object denoted by Obj_Ref and Obj_Typ for use as + -- the actual parameter in a call to a Finalize_Address procedure. + function Make_Call (Loc : Source_Ptr; Proc_Id : Entity_Id; @@ -562,6 +569,327 @@ package body Exp_Ch7 is -- [Deep_]Finalize (Acc_Typ (V).all); -- end; + ---------------------------------- + -- Attach_Object_To_Master_Node -- + ---------------------------------- + + procedure Attach_Object_To_Master_Node + (Obj_Decl : Node_Id; + Master_Node : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Obj_Decl); + Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); + Func_Id : constant Entity_Id := + (if Is_Return_Object (Obj_Id) + then Return_Applies_To (Scope (Obj_Id)) + else Empty); + + 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: + -- + -- if BIPallocform > Secondary_Stack'Pos + -- and then BIPfinalizationmaster /= null + -- then + -- declare + -- type Ptr_Typ is access Fun_Typ; + -- for Ptr_Typ'Storage_Pool + -- use Base_Pool (BIPfinalizationmaster); + -- begin + -- Free (Ptr_Typ (Obj_Addr)); + -- end; + -- end if; + -- + -- Fun_Typ is the return type of the Func_Id. + + ----------------------------- + -- Build_BIP_Cleanup_Stmts -- + ----------------------------- + + function Build_BIP_Cleanup_Stmts + (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); + + Cond : Node_Id; + Free_Blk : Node_Id; + Free_Stmt : Node_Id; + Pool_Id : Entity_Id; + Ptr_Typ : Entity_Id; + + begin + -- Generate: + -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; + + Pool_Id := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pool_Id, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Base_Pool), Loc), + Parameter_Associations => New_List ( + Make_Explicit_Dereference (Loc, + Prefix => + New_Occurrence_Of (Fin_Mas_Id, Loc))))))); + + -- Create an access type which uses the storage pool of the + -- caller's finalization master. + + -- Generate: + -- type Ptr_Typ is access Func_Typ; + + Ptr_Typ := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc)))); + + -- Perform minor decoration in order to set the master and the + -- storage pool attributes. + + Mutate_Ekind (Ptr_Typ, E_Access_Type); + Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); + Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); + + if Debug_Generated_Code then + Set_Debug_Info_Needed (Pool_Id); + end if; + + -- Create an explicit free statement. Note that the free uses the + -- caller's pool expressed as a renaming. + + Free_Stmt := + Make_Free_Statement (Loc, + Expression => + Unchecked_Convert_To (Ptr_Typ, Obj_Addr)); + + Set_Storage_Pool (Free_Stmt, Pool_Id); + + -- Create a block to house the dummy type and the instantiation as + -- well as to perform the cleanup the temporary. + + -- Generate: + -- declare + -- <Decls> + -- begin + -- Free (Ptr_Typ (Obj_Addr)); + -- end; + + Free_Blk := + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Free_Stmt))); + + -- Generate: + -- if BIPfinalizationmaster /= null then + + Cond := + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), + Right_Opnd => Make_Null (Loc)); + + -- For unconstrained or tagged results, escalate the condition to + -- include the allocation format. Generate: + + -- if BIPallocform > Secondary_Stack'Pos + -- and then BIPfinalizationmaster /= null + -- then + + if Needs_BIP_Alloc_Form (Func_Id) then + declare + Alloc : constant Entity_Id := + Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); + begin + Cond := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => New_Occurrence_Of (Alloc, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int + (BIP_Allocation_Form'Pos (Secondary_Stack)))), + + Right_Opnd => Cond); + end; + end if; + + -- Generate: + -- if <Cond> then + -- <Free_Blk> + -- end if; + + return + Make_If_Statement (Loc, + Condition => Cond, + Then_Statements => New_List (Free_Blk)); + end Build_BIP_Cleanup_Stmts; + + Fin_Id : Entity_Id; + Master_Node_Attach : Node_Id; + Master_Node_Ins : Node_Id; + Obj_Ref : Node_Id; + Obj_Typ : Entity_Id; + + begin + -- 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. + + if CodePeer_Mode then + return; + end if; + + -- When the transient object is initialized by an aggregate, the + -- attachment must occur after the last aggregate assignment takes + -- place. Only then is the object considered initialized. Likewise + -- if we have a build-in-place call: we must attach only after it. + + if Ekind (Obj_Id) in E_Constant | E_Variable then + if Present (Last_Aggregate_Assignment (Obj_Id)) then + Master_Node_Ins := Last_Aggregate_Assignment (Obj_Id); + elsif Present (BIP_Initialization_Call (Obj_Id)) then + Master_Node_Ins := BIP_Initialization_Call (Obj_Id); + else + Master_Node_Ins := Obj_Decl; + end if; + + else + Master_Node_Ins := Obj_Decl; + end if; + + -- Handle the object type and the reference to the object + + Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); + Obj_Typ := Etype (Obj_Id); + if 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; + + -- If we are dealing with a return object of a build-in-place + -- function, generate the following cleanup statements: + + -- if BIPallocform > 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; + + -- The generated code effectively detaches the temporary from the + -- caller finalization master and deallocates the object. + + if 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); + + Fin_Body : Node_Id; + Fin_Stmts : List_Id; + + begin + Fin_Stmts := Make_Finalize_Address_Stmts (Obj_Typ); + + Append_To (Fin_Stmts, + Build_BIP_Cleanup_Stmts + (Func_Id, New_Occurrence_Of (Param, Loc))); + + 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)))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Fin_Stmts)); + + Insert_After_And_Analyze + (Master_Node_Ins, Fin_Body, Suppress => All_Checks); + + Master_Node_Ins := Fin_Body; + end; + + else + Fin_Id := Finalize_Address (Obj_Typ); + + 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; + + -- Now build the attachment call that will initialize the object's + -- Master_Node using the object's address and finalization procedure. + + 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, Loc))); + + Insert_After_And_Analyze + (Master_Node_Ins, Master_Node_Attach, Suppress => All_Checks); + end Attach_Object_To_Master_Node; + -------------------------------- -- Allows_Finalization_Master -- -------------------------------- @@ -2152,11 +2480,10 @@ package body Exp_Ch7 is -- 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)); + elsif Ekind (Obj_Id) = E_Variable + and then Is_RTE (Obj_Typ, RE_Master_Node) + then Processing_Actions (Decl); -- Ignored Ghost objects do not need any cleanup actions @@ -2335,17 +2662,8 @@ package body Exp_Ch7 is (Decl : Node_Id; Is_Protected : Boolean := False) is - 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); + Obj_Id : constant Entity_Id := Defining_Identifier (Decl); + Loc : constant Source_Ptr := Sloc (Decl); Init_Typ : Entity_Id; -- The initialization type of the related object declaration. Note @@ -2355,26 +2673,6 @@ 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; - Obj_Addr : Node_Id) return Node_Id; - -- Func_Id denotes a build-in-place function. Generate the following - -- cleanup code: - -- - -- if BIPallocfrom > Secondary_Stack'Pos - -- and then BIPfinalizationmaster /= null - -- then - -- declare - -- type Ptr_Typ is access Fun_Typ; - -- for Ptr_Typ'Storage_Pool - -- use Base_Pool (BIPfinalizationmaster); - -- begin - -- Free (Ptr_Typ (Obj_Addr)); - -- end; - -- end if; - -- - -- Fun_Typ is the return type of the Func_Id. - procedure Find_Last_Init (Last_Init : out Node_Id; Body_Insert : out Node_Id); @@ -2383,153 +2681,6 @@ 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; - 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); - - Cond : Node_Id; - Free_Blk : Node_Id; - Free_Stmt : Node_Id; - Pool_Id : Entity_Id; - Ptr_Typ : Entity_Id; - - begin - -- Generate: - -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; - - Pool_Id := Make_Temporary (Loc, 'P'); - - Append_To (Decls, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Pool_Id, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), - Name => - Make_Explicit_Dereference (Loc, - Prefix => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Base_Pool), Loc), - Parameter_Associations => New_List ( - Make_Explicit_Dereference (Loc, - Prefix => - New_Occurrence_Of (Fin_Mas_Id, Loc))))))); - - -- Create an access type which uses the storage pool of the - -- caller's finalization master. - - -- Generate: - -- type Ptr_Typ is access Func_Typ; - - Ptr_Typ := Make_Temporary (Loc, 'P'); - - Append_To (Decls, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ptr_Typ, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc)))); - - -- Perform minor decoration in order to set the master and the - -- storage pool attributes. - - Mutate_Ekind (Ptr_Typ, E_Access_Type); - Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); - Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); - - if Debug_Generated_Code then - Set_Debug_Info_Needed (Pool_Id); - end if; - - -- Create an explicit free statement. Note that the free uses the - -- caller's pool expressed as a renaming. - - Free_Stmt := - Make_Free_Statement (Loc, - Expression => - Unchecked_Convert_To (Ptr_Typ, Obj_Addr)); - - Set_Storage_Pool (Free_Stmt, Pool_Id); - - -- Create a block to house the dummy type and the instantiation as - -- well as to perform the cleanup the temporary. - - -- Generate: - -- declare - -- <Decls> - -- begin - -- Free (Ptr_Typ (Obj_Addr)); - -- end; - - Free_Blk := - Make_Block_Statement (Loc, - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Free_Stmt))); - - -- Generate: - -- if BIPfinalizationmaster /= null then - - Cond := - Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), - Right_Opnd => Make_Null (Loc)); - - -- For unconstrained or tagged results, escalate the condition to - -- include the allocation format. Generate: - - -- if BIPallocform > Secondary_Stack'Pos - -- and then BIPfinalizationmaster /= null - -- then - - if Needs_BIP_Alloc_Form (Func_Id) then - declare - Alloc : constant Entity_Id := - Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); - begin - Cond := - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Gt (Loc, - Left_Opnd => New_Occurrence_Of (Alloc, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int - (BIP_Allocation_Form'Pos (Secondary_Stack)))), - - Right_Opnd => Cond); - end; - end if; - - -- Generate: - -- if <Cond> then - -- <Free_Blk> - -- end if; - - return - Make_If_Statement (Loc, - Condition => Cond, - Then_Statements => New_List (Free_Blk)); - end Build_BIP_Cleanup_Stmts; - -------------------- -- Find_Last_Init -- -------------------- @@ -2696,14 +2847,14 @@ package body Exp_Ch7 is -- Start of processing for Find_Last_Init begin - Last_Init := Obj_Decl; + Last_Init := Decl; Body_Insert := Empty; -- Objects that capture controlled function results do not require -- initialization. - if Nkind (Obj_Decl) = N_Object_Declaration - and then Nkind (Expression (Obj_Decl)) = N_Reference + if Nkind (Decl) = N_Object_Declaration + and then Nkind (Expression (Decl)) = N_Reference then return; end if; @@ -2712,7 +2863,7 @@ package body Exp_Ch7 is Stmt := First (Actions (Freeze_Node (Obj_Id))); Body_Insert := Freeze_Node (Obj_Id); else - Stmt := Next_Suitable_Statement (Obj_Decl); + Stmt := Next_Suitable_Statement (Decl); end if; -- For an object with suppressed initialization, we check whether @@ -2725,8 +2876,8 @@ package body Exp_Ch7 is -- call raises an exception, we will finalize the (uninitialized) -- object, which is wrong. - if Nkind (Obj_Decl) = N_Object_Declaration - and then No_Initialization (Obj_Decl) + if Nkind (Decl) = N_Object_Declaration + and then No_Initialization (Decl) then if No (Expression (Last_Init)) then loop @@ -2811,61 +2962,6 @@ package body Exp_Ch7 is end if; end Find_Last_Init; - ------------------------------- - -- Make_Address_For_Finalize -- - ------------------------------- - - function Make_Address_For_Finalize - (Loc : Source_Ptr; - Obj_Ref : Node_Id; - Obj_Typ : Entity_Id) return Node_Id - is - Obj_Addr : Node_Id; - - 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: - - -- V - (Obj_Typ'Descriptor_Size / Storage_Unit) - - -- Note that this is done through a wrapper routine as RTSfind - -- cannot retrieve operations with string name of the form "+". - - 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; - - return Obj_Addr; - end Make_Address_For_Finalize; - -- Local variables Body_Ins : Node_Id; @@ -2913,30 +3009,31 @@ package body Exp_Ch7 is end if; end loop; - -- 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 the object is a Master_Node, then nothing to do, except if it + -- is the only object, in which case we move its declaration, call + -- marker (if any) and initialization call, as well as mark it to + -- avoid double processing. - if 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 Is_RTE (Obj_Typ, RE_Master_Node) then + Master_Node_Id := Obj_Id; 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))); + if Nkind (Next (Decl)) = N_Call_Marker then + Prepend_To (Decls, Remove_Next (Next (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); + Prepend_To (Decls, Remove_Next (Decl)); + Remove (Decl); + Prepend_To (Decls, Decl); + Set_Is_Ignored_For_Finalization (Obj_Id); end if; - else + -- 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 + -- be inserted at the same place the scope master would have been. + + else pragma Assert (No (Finalization_Master_Node (Obj_Id))); -- For one object, use the Sloc the scope master would have had if Counter_Val = 1 then @@ -2956,7 +3053,7 @@ package body Exp_Ch7 is if Counter_Val = 1 then Prepend_To (Decls, Master_Node_Decl); else - Insert_Before (Obj_Decl, Master_Node_Decl); + Insert_Before (Decl, Master_Node_Decl); end if; Analyze (Master_Node_Decl); Pop_Scope; @@ -3004,7 +3101,7 @@ package body Exp_Ch7 is -- of the Master_Node after the declaration of the object itself. if No (Master_Node_Ins) then - Master_Node_Ins := Obj_Decl; + Master_Node_Ins := Decl; end if; -- Processing for simple protected objects. Such objects require @@ -3041,17 +3138,17 @@ package body Exp_Ch7 is Set_Etype (Ren_Ref, Obj_Typ); if Is_Simple_Protected_Type (Obj_Typ) then - Fin_Call := Cleanup_Protected_Object (Obj_Decl, Ren_Ref); + Fin_Call := Cleanup_Protected_Object (Decl, Ren_Ref); if Present (Fin_Call) then Fin_Stmts := New_List (Fin_Call); end if; elsif Is_Array_Type (Obj_Typ) then - Fin_Stmts := Cleanup_Array (Obj_Decl, Ren_Ref, Obj_Typ); + Fin_Stmts := Cleanup_Array (Decl, Ren_Ref, Obj_Typ); else - Fin_Stmts := Cleanup_Record (Obj_Decl, Ren_Ref, Obj_Typ); + Fin_Stmts := Cleanup_Record (Decl, Ren_Ref, Obj_Typ); end if; if No (Fin_Stmts) then @@ -3116,81 +3213,6 @@ package body Exp_Ch7 is Master_Node_Ins := Fin_Body; end; - -- 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 (Obj'Address)); - -- end; - -- end if; - - -- The generated code effectively detaches the temporary from the - -- caller finalization master and deallocates the object. - - 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); - - Fin_Body : Node_Id; - Fin_Stmts : List_Id; - - begin - Fin_Stmts := Make_Finalize_Address_Stmts (Obj_Typ); - - Append_To (Fin_Stmts, - Build_BIP_Cleanup_Stmts - (Func_Id, New_Occurrence_Of (Param, Loc))); - - 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)))), - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Fin_Stmts)); - - 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; - else Fin_Id := Finalize_Address (Obj_Typ); @@ -3207,9 +3229,9 @@ package body Exp_Ch7 is 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. + -- the attach in this case. Ditto if the object is a Master_Node. - if CodePeer_Mode then + if CodePeer_Mode or else Obj_Id = Master_Node_Id then Master_Node_Attach := Make_Null_Statement (Loc); else Master_Node_Attach := @@ -3257,12 +3279,26 @@ package body Exp_Ch7 is end if; Append_To (Finalizer_Stmts, Fin_Call); + else + -- If the object is a Master_Node, we just need to chain it + + if Obj_Id = Master_Node_Id then + Master_Node_Attach := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Chain_Node_To_Master), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Attribute_Name => Name_Unrestricted_Access), + New_Occurrence_Of (Finalization_Scope_Master, Loc))); + -- 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. - if CodePeer_Mode then + elsif CodePeer_Mode then Master_Node_Attach := Make_Null_Statement (Loc); else Master_Node_Attach := @@ -5390,8 +5426,7 @@ package body Exp_Ch7 is 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. + -- which will later be picked up by Build_Finalizer. if Must_Export then Master_Node_Id := Make_Temporary (Loc, 'N'); @@ -5399,6 +5434,12 @@ package body Exp_Ch7 is Make_Master_Node_Declaration (Loc, Master_Node_Id, Obj_Id); Insert_Before_And_Analyze (Obj_Decl, Master_Node_Decl); + -- Generate the attachment of the object to the Master_Node + + Attach_Object_To_Master_Node (Obj_Decl, Master_Node_Id); + + -- Then add the finalization call for the object + Insert_After_And_Analyze (Insert_Nod, Make_Procedure_Call_Statement (Loc, Name => @@ -5624,6 +5665,60 @@ package body Exp_Ch7 is and then Is_RTE (Find_Protection_Type (T), RE_Protection); end Is_Simple_Protected_Type; + ------------------------------- + -- Make_Address_For_Finalize -- + ------------------------------- + + function Make_Address_For_Finalize + (Loc : Source_Ptr; + Obj_Ref : Node_Id; + Obj_Typ : Entity_Id) return Node_Id + is + Obj_Addr : Node_Id; + + 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_Array_Subt_With_Bounds, + -- 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: + + -- V - (Obj_Typ'Descriptor_Size / Storage_Unit) + + -- Note that this is done through a wrapper routine as RTSfind + -- cannot retrieve operations with string name of the form "+". + + 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; + + return Obj_Addr; + end Make_Address_For_Finalize; + ----------------------- -- Make_Adjust_Call -- ----------------------- @@ -8644,10 +8739,7 @@ package body Exp_Ch7 is 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); + Set_Finalization_Master_Node (Obj, Master_Node); return Make_Object_Declaration (Loc, @@ -8707,6 +8799,8 @@ package body Exp_Ch7 is (Loc : Source_Ptr; Obj : Entity_Id) return Node_Id is + Obj_Decl : constant Node_Id := Declaration_Node (Obj); + Master_Node_Decl : Node_Id; Master_Node_Id : Entity_Id; @@ -8714,14 +8808,18 @@ package body Exp_Ch7 is -- 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); + if Present (Finalization_Master_Node (Obj)) then + Master_Node_Id := Finalization_Master_Node (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); + Insert_Before_And_Analyze (Obj_Decl, Master_Node_Decl); + + -- Generate the attachment of the object to the Master_Node + + Attach_Object_To_Master_Node (Obj_Decl, Master_Node_Id); -- Mark the object to avoid double finalization diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index c606bb9..97fea23 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -35,6 +35,13 @@ package Exp_Ch7 is -- Finalization Management -- ----------------------------- + procedure Attach_Object_To_Master_Node + (Obj_Decl : Node_Id; + Master_Node : Entity_Id); + -- Generate code to attach an object denoted by its declaration Obj_Decl + -- to a master node denoted by Master_Node. The code is inserted after + -- the object is initialized. + procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id); -- Build a finalization master for an anonymous access-to-controlled type -- denoted by Ptr_Typ. The master is inserted in the declarations of the diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index e757327..732a02f 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -12953,11 +12953,10 @@ package body Exp_Util is -- 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)); + elsif Ekind (Obj_Id) = E_Variable + and then Is_RTE (Obj_Typ, RE_Master_Node) + then return True; -- Ignored Ghost objects do not need any cleanup actions because diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 7cf6a38..ac1e0c9 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -538,7 +538,7 @@ package Gen_IL.Fields is Extra_Formal, Extra_Formals, Finalization_Master, - Finalization_Master_Node_Or_Object, + Finalization_Master_Node, Finalize_Storage_Only, Finalizer, First_Entity, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index a30013a..cde016c 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -335,7 +335,7 @@ 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 (Finalization_Master_Node, Node_Id), Sm (Interface_Name, Node_Id), Sm (Is_Finalized_Transient, Flag), Sm (Is_Ignored_For_Finalization, Flag), diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb index 50f49d7..7dc08a9 100644 --- a/gcc/ada/libgnat/s-finpri.adb +++ b/gcc/ada/libgnat/s-finpri.adb @@ -47,9 +47,7 @@ package body System.Finalization_Primitives is is begin Attach_Object_To_Node (Object_Address, Finalize_Address, Node.all); - - Node.Next := Master.Head; - Master.Head := Node; + Chain_Node_To_Master (Node, Master); end Attach_Object_To_Master; --------------------------- @@ -69,6 +67,19 @@ package body System.Finalization_Primitives is Node.Finalize_Address := Finalize_Address; end Attach_Object_To_Node; + -------------------------- + -- Chain_Node_To_Master -- + -------------------------- + + procedure Chain_Node_To_Master + (Node : not null Master_Node_Ptr; + Master : in out Finalization_Scope_Master) + is + begin + Node.Next := Master.Head; + Master.Head := Node; + end Chain_Node_To_Master; + --------------------- -- Finalize_Master -- --------------------- @@ -90,12 +101,6 @@ package body System.Finalization_Primitives is 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); @@ -124,12 +129,6 @@ package body System.Finalization_Primitives is 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; @@ -159,7 +158,10 @@ package body System.Finalization_Primitives is begin if FA /= null then + pragma Assert (Node.Object_Address /= System.Null_Address); + Node.Finalize_Address := null; + FA (Node.Object_Address); end if; end Finalize_Object; diff --git a/gcc/ada/libgnat/s-finpri.ads b/gcc/ada/libgnat/s-finpri.ads index 1ffe24b..de775ca 100644 --- a/gcc/ada/libgnat/s-finpri.ads +++ b/gcc/ada/libgnat/s-finpri.ads @@ -79,7 +79,16 @@ package System.Finalization_Primitives with Preelaborate is 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. + -- when there is a single object to be finalized in the context, as well as + -- for objects that need special processing (return object in an extended + -- return statement or transient objects). + + procedure Chain_Node_To_Master + (Node : not null Master_Node_Ptr; + Master : in out Finalization_Scope_Master); + -- Chain a master node to the given master. This is used to chain the node + -- to the master of the enclosing scope for the objects that need special + -- processing mentioned for Attach_Object_To_Node. procedure Finalize_Master (Master : in out Finalization_Scope_Master); -- Finalizes each of the controlled objects associated with Master, in the @@ -125,6 +134,7 @@ private pragma Inline (Attach_Object_To_Master); pragma Inline (Attach_Object_To_Node); + pragma Inline (Chain_Node_To_Master); pragma Inline (Finalize_Object); pragma Inline (Suppress_Object_Finalize_At_End); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index f36713b..dc06bff 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -927,6 +927,7 @@ package Rtsfind is RE_Attach_Object_To_Master, -- System.Finalization_Primitives RE_Attach_Object_To_Node, -- System.Finalization_Primitives + RE_Chain_Node_To_Master, -- System.Finalization_Primitives RE_Finalize_Master, -- System.Finalization_Primitives RE_Finalize_Object, -- System.Finalization_Primitives RE_Finalization_Scope_Master, -- System.Finalization_Primitives @@ -2579,6 +2580,7 @@ package Rtsfind is RE_Attach_Object_To_Master => System_Finalization_Primitives, RE_Attach_Object_To_Node => System_Finalization_Primitives, + RE_Chain_Node_To_Master => System_Finalization_Primitives, RE_Finalize_Master => System_Finalization_Primitives, RE_Finalize_Object => System_Finalization_Primitives, RE_Finalization_Scope_Master => System_Finalization_Primitives, |