diff options
Diffstat (limited to 'gcc/ada/exp_ch7.adb')
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 181 |
1 files changed, 87 insertions, 94 deletions
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 67af1d7..4d2b834 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -696,6 +696,15 @@ package body Exp_Ch7 is -- Set the Finalize_Address primitive for the object that has been -- attached to a finalization Master_Node. + function Shift_Address_For_Descriptor + (Addr : Node_Id; + Typ : Entity_Id; + Op_Nam : Name_Id) return Node_Id + with Pre => Is_Array_Type (Typ) + and then not Is_Constrained (Typ) + and then Op_Nam in Name_Op_Add | Name_Op_Subtract; + -- Add to Addr, or subtract from Addr, the size of the descriptor of Typ + ---------------------------------- -- Attach_Object_To_Master_Node -- ---------------------------------- @@ -2466,7 +2475,6 @@ package body Exp_Ch7 is -- Local variables Decl : Node_Id; - Expr : Node_Id; Obj_Id : Entity_Id; Obj_Typ : Entity_Id; Pack_Id : Entity_Id; @@ -2516,7 +2524,6 @@ package body Exp_Ch7 is elsif Nkind (Decl) = N_Object_Declaration then Obj_Id := Defining_Identifier (Decl); Obj_Typ := Base_Type (Etype (Obj_Id)); - Expr := Expression (Decl); -- Bypass any form of processing for objects which have their -- finalization disabled. This applies only to objects at the @@ -2572,21 +2579,10 @@ package body Exp_Ch7 is Processing_Actions (Decl, Strict => not Has_Relaxed_Finalization (Obj_Typ)); - -- The object is of the form: - -- Obj : Access_Typ := Non_BIP_Function_Call'reference; - - -- Obj : Access_Typ := - -- BIP_Function_Call (BIPalloc => 2, ...)'reference; + -- The object is an access-to-controlled that must be finalized elsif Is_Access_Type (Obj_Typ) - and then Needs_Finalization - (Available_View (Designated_Type (Obj_Typ))) - and then Present (Expr) - and then - (Is_Secondary_Stack_BIP_Func_Call (Expr) - or else - (Is_Non_BIP_Func_Call (Expr) - and then not Is_Related_To_Func_Return (Obj_Id))) + and then Is_Finalizable_Access (Decl) then Processing_Actions (Decl, @@ -2783,16 +2779,31 @@ package body Exp_Ch7 is Master_Node_Id := Make_Defining_Identifier (Master_Node_Loc, Chars => New_External_Name (Chars (Obj_Id), Suffix => "MN")); + Master_Node_Decl := Make_Master_Node_Declaration (Master_Node_Loc, Master_Node_Id, Obj_Id); Push_Scope (Scope (Obj_Id)); + + -- Avoid generating duplicate names for master nodes + + if Ekind (Obj_Id) = E_Loop_Parameter + and then + Present (Current_Entity_In_Scope (Chars (Master_Node_Id))) + then + Set_Chars (Master_Node_Id, + New_External_Name (Chars (Obj_Id), + Suffix => "MN", + Suffix_Index => -1)); + end if; + if not Has_Strict_Ctrl_Objs or else Count = 1 then Prepend_To (Decls, Master_Node_Decl); else Insert_Before (Decl, Master_Node_Decl); end if; + Analyze (Master_Node_Decl); Pop_Scope; @@ -5260,6 +5271,13 @@ package body Exp_Ch7 is Obj_Typ : Entity_Id; begin + -- Ignored Ghost objects do not need any cleanup actions because + -- they will not appear in the final tree. + + if Is_Ignored_Ghost_Entity (Obj_Id) then + return; + end if; + -- 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. @@ -5537,35 +5555,14 @@ package body Exp_Ch7 is -- 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. + -- so we need to shift it back to skip the dope vector. if Is_Array_Type (Utyp) and then not Is_Constrained (First_Subtype (Utyp)) then - -- Shift the address from the start of the elements to the - -- start of the dope vector: - - -- V - (Utyp'Descriptor_Size / Storage_Unit) - Obj_Addr := - Make_Function_Call (Loc, - Name => - Make_Expanded_Name (Loc, - Chars => Name_Op_Subtract, - Prefix => - New_Occurrence_Of - (RTU_Entity (System_Storage_Elements), Loc), - Selector_Name => - Make_Identifier (Loc, Name_Op_Subtract)), - Parameter_Associations => New_List ( - Obj_Addr, - Make_Op_Divide (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Utyp, Loc), - Attribute_Name => Name_Descriptor_Size), - Right_Opnd => - Make_Integer_Literal (Loc, System_Storage_Unit)))); + Shift_Address_For_Descriptor + (Obj_Addr, First_Subtype (Utyp), Name_Op_Subtract); end if; return Obj_Addr; @@ -8174,6 +8171,10 @@ package body Exp_Ch7 is Ptr_Typ : Entity_Id; begin + -- Array types: picking the (unconstrained) base type as designated type + -- requires allocating the bounds alongside the data, so we only do this + -- when the first subtype itself was declared as unconstrained. + if Is_Array_Type (Typ) then if Is_Constrained (First_Subtype (Typ)) then Desig_Typ := First_Subtype (Typ); @@ -8269,63 +8270,18 @@ package body Exp_Ch7 is -- lays in front of the elements and then use a thin pointer to perform -- the address-to-access conversion. - if Is_Array_Type (Typ) - and then not Is_Constrained (First_Subtype (Typ)) - then - declare - Dope_Id : Entity_Id; - - begin - -- Ensure that Ptr_Typ is a thin pointer; generate: - -- for Ptr_Typ'Size use System.Address'Size; - - Append_To (Decls, - Make_Attribute_Definition_Clause (Loc, - Name => New_Occurrence_Of (Ptr_Typ, Loc), - Chars => Name_Size, - Expression => - Make_Integer_Literal (Loc, System_Address_Size))); - - -- Generate: - -- Dnn : constant Storage_Offset := - -- Desig_Typ'Descriptor_Size / Storage_Unit; + if Is_Array_Type (Typ) and then not Is_Constrained (Desig_Typ) then + Obj_Expr := + Shift_Address_For_Descriptor (Obj_Expr, Desig_Typ, Name_Op_Add); - Dope_Id := Make_Temporary (Loc, 'D'); + -- Ensure that Ptr_Typ is a thin pointer; generate: + -- for Ptr_Typ'Size use System.Address'Size; - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Dope_Id, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), - Expression => - Make_Op_Divide (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Desig_Typ, Loc), - Attribute_Name => Name_Descriptor_Size), - Right_Opnd => - Make_Integer_Literal (Loc, System_Storage_Unit)))); - - -- Shift the address from the start of the dope vector to the - -- start of the elements: - -- - -- V + Dnn - - Obj_Expr := - Make_Function_Call (Loc, - Name => - Make_Expanded_Name (Loc, - Chars => Name_Op_Add, - Prefix => - New_Occurrence_Of - (RTU_Entity (System_Storage_Elements), Loc), - Selector_Name => - Make_Identifier (Loc, Name_Op_Add)), - Parameter_Associations => New_List ( - Obj_Expr, - New_Occurrence_Of (Dope_Id, Loc))); - end; + Append_To (Decls, + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (Ptr_Typ, Loc), + Chars => Name_Size, + Expression => Make_Integer_Literal (Loc, System_Address_Size))); end if; Fin_Call := @@ -8903,6 +8859,43 @@ package body Exp_Ch7 is return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped; end Node_To_Be_Wrapped; + ---------------------------------- + -- Shift_Address_For_Descriptor -- + ---------------------------------- + + function Shift_Address_For_Descriptor + (Addr : Node_Id; + Typ : Entity_Id; + Op_Nam : Name_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Addr); + Dummy : constant Entity_Id := RTE (RE_Storage_Offset); + -- Make sure System_Storage_Elements is loaded for RTU_Entity + + begin + -- Generate: + -- Addr +/- (Typ'Descriptor_Size / Storage_Unit) + + return + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Op_Nam, + Prefix => + New_Occurrence_Of + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => Make_Identifier (Loc, Op_Nam)), + Parameter_Associations => New_List ( + Addr, + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Descriptor_Size), + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit)))); + end Shift_Address_For_Descriptor; + ---------------------------- -- Store_Actions_In_Scope -- ---------------------------- |