From: Justin Squirek Date: Tue, 18 Jan 2022 09:46:23 +0000 (+0100) Subject: [Ada] Fix invalid memory access on finalization of class-wide type X-Git-Tag: basepoints/gcc-14~7008 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=a252a471df552cf2c0a688a3472094fe234b7ab6;p=thirdparty%2Fgcc.git [Ada] Fix invalid memory access on finalization of class-wide type This patch corrects issues in the compiler whereby finalization of a heap- allocated class-wide type may cause an invalid memory read at runtime when the type in question contains a component whose type has a large alignment. gcc/ada/ * exp_attr.adb (Expand_N_Attribute_Reference) : Deal specifically wth class-wide equivalent types without a parent. * exp_util.adb (Build_Allocate_Deallocate_Proc): Extract allocator node for calculation of alignment actual and modify alignment for allocators of class-wide types with associated expressions. (Make_CW_Equivalent_Type): Handle interface types differently when generating the equivalent record. * sem_aux.adb (First_Tag_Component): Accept class-wide equivalent types too. --- diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index ab14a498117..7b36daec9ae 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6704,7 +6704,21 @@ package body Exp_Attr is Prefix_Is_Type := False; end if; - if Is_Class_Wide_Type (Ttyp) then + -- In the case of a class-wide equivalent type without a parent, + -- the _Tag component has been built in Make_CW_Equivalent_Type + -- manually and must be referenced directly. + + if Ekind (Ttyp) = E_Class_Wide_Subtype + and then Present (Equivalent_Type (Ttyp)) + and then No (Parent_Subtype (Equivalent_Type (Ttyp))) + then + Ttyp := Equivalent_Type (Ttyp); + + -- In all the other cases of class-wide type, including an equivalent + -- type with a parent, the _Tag component ultimately present is that + -- of the root type. + + elsif Is_Class_Wide_Type (Ttyp) then Ttyp := Root_Type (Ttyp); end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 5e36c3adee4..30c293c3465 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -890,6 +890,8 @@ package body Exp_Util is Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); Actuals : List_Id; + Alloc_Nod : Node_Id := Empty; + Alloc_Expr : Node_Id := Empty; Fin_Addr_Id : Entity_Id; Fin_Mas_Act : Node_Id; Fin_Mas_Id : Entity_Id; @@ -897,6 +899,36 @@ package body Exp_Util is Subpool : Node_Id := Empty; begin + -- When we are building an allocator procedure, extract the allocator + -- node for later processing and calculation of alignment. + + if Is_Allocate then + + if Nkind (Expr) = N_Allocator then + Alloc_Nod := Expr; + + -- When Expr is an object declaration we have to examine its + -- expression. + + elsif Nkind (Expr) = N_Object_Declaration + and then Nkind (Expression (Expr)) = N_Allocator + then + Alloc_Nod := Expression (Expr); + + -- Otherwise, we raise an error because we should have found one + + else + raise Program_Error; + end if; + + -- Extract the qualified expression if there is one from the + -- allocator. + + if Nkind (Expression (Alloc_Nod)) = N_Qualified_Expression then + Alloc_Expr := Expression (Alloc_Nod); + end if; + end if; + -- Step 1: Construct all the actuals for the call to library routine -- Allocate_Any_Controlled / Deallocate_Any_Controlled. @@ -967,19 +999,27 @@ package body Exp_Util is Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc)); Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc)); - if (Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ)) + -- Class-wide allocations without expressions and non-class-wide + -- allocations can be performed without getting the alignment from + -- the type's Type Specific Record. + + if ((Is_Allocate and then No (Alloc_Expr)) + or else + not Is_Class_Wide_Type (Desig_Typ)) and then not Use_Secondary_Stack_Pool then Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc)); - -- For deallocation of class-wide types we obtain the value of - -- alignment from the Type Specific Record of the deallocated object. + -- For operations on class-wide types we obtain the value of + -- alignment from the Type Specific Record of the relevant object. -- This is needed because the frontend expansion of class-wide types -- into equivalent types confuses the back end. else -- Generate: -- Obj.all'Alignment + -- or + -- Alloc_Expr'Alignment -- ... because 'Alignment applied to class-wide types is expanded -- into the code that reads the value of alignment from the TSD @@ -992,7 +1032,10 @@ package body Exp_Util is Unchecked_Convert_To (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, Prefix => - Make_Explicit_Dereference (Loc, Relocate_Node (Expr)), + (if No (Alloc_Expr) then + Make_Explicit_Dereference (Loc, Relocate_Node (Expr)) + else + Relocate_Node (Expression (Alloc_Expr))), Attribute_Name => Name_Alignment))); end if; @@ -9480,8 +9523,8 @@ package body Exp_Util is -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8); -- end Equiv_T; -- - -- ??? Note that this type does not guarantee same alignment as all - -- derived types + -- Note that this type does not guarantee same alignment as all derived + -- types. -- -- Note: for the freezing circuitry, this looks like a record extension, -- and so we need to make sure that the scalar storage order is the same @@ -9539,7 +9582,8 @@ package body Exp_Util is if not Is_Interface (Root_Typ) then -- subtype rg__xx is - -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit + -- Storage_Offset range 1 .. (Expr'size - typ'object_size) + -- / Storage_Unit Sizexpr := Make_Op_Subtract (Loc, @@ -9554,13 +9598,20 @@ package body Exp_Util is Attribute_Name => Name_Object_Size)); else -- subtype rg__xx is - -- Storage_Offset range 1 .. Expr'size / Storage_Unit + -- Storage_Offset range 1 .. (Expr'size - Ada.Tags.Tag'object_size) + -- / Storage_Unit Sizexpr := - Make_Attribute_Reference (Loc, - Prefix => - OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)), - Attribute_Name => Name_Size); + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)), + Attribute_Name => Name_Size), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (RTE (RE_Tag), Loc), + Attribute_Name => Name_Object_Size)); end if; Set_Paren_Count (Sizexpr, 1); @@ -9596,13 +9647,17 @@ package body Exp_Util is New_List (New_Occurrence_Of (Range_Type, Loc)))))); -- type Equiv_T is record - -- [ _parent : Tnn; ] - -- E : Str_Type; + -- _Parent : Snn; -- not interface + -- _Tag : Ada.Tags.Tag -- interface + -- Cnn : Str_Type; -- end Equiv_T; Equiv_Type := Make_Temporary (Loc, 'T'); Mutate_Ekind (Equiv_Type, E_Record_Type); - Set_Parent_Subtype (Equiv_Type, Constr_Root); + + if not Is_Interface (Root_Typ) then + Set_Parent_Subtype (Equiv_Type, Constr_Root); + end if; -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special -- treatment for this type. In particular, even though _parent's type @@ -9630,6 +9685,17 @@ package body Exp_Util is (Equiv_Type, Reverse_Storage_Order (Base_Type (Root_Utyp))); Set_Reverse_Bit_Order (Equiv_Type, Reverse_Bit_Order (Base_Type (Root_Utyp))); + + else + Append_To (Comp_List, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTag), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Tag), Loc)))); end if; Append_To (Comp_List, @@ -9654,6 +9720,13 @@ package body Exp_Util is -- the generation of spurious warnings under ZFP run-time. Insert_Actions (E, List_Def, Suppress => All_Checks); + + -- In the case of an interface type mark the tag for First_Tag_Component + + if Is_Interface (Root_Typ) then + Set_Is_Tag (First_Entity (Equiv_Type)); + end if; + return Equiv_Type; end Make_CW_Equivalent_Type; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index da8f3cc384f..88948f73473 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -410,8 +410,10 @@ package body Sem_Aux is Ctyp : Entity_Id; begin + pragma Assert (Is_Tagged_Type (Typ) + or else Is_Class_Wide_Equivalent_Type (Typ)); + Ctyp := Typ; - pragma Assert (Is_Tagged_Type (Ctyp)); if Is_Class_Wide_Type (Ctyp) then Ctyp := Root_Type (Ctyp);