[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) <Attribute_Tag>:
	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 ab14a49811770632d5fc9b6d2a534ca75a55ecd1..7b36daec9aee8bfc112a43c2834a6cd0109542ae 100644 (file)
--- 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 5e36c3adee497aa5012230a8f972313b0b7791ed..30c293c3465a6eeb6237f7e0e75645f981f540bc 100644 (file)
--- 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 da8f3cc384f8c14954ac0dd0b0528503eaf25f5b..88948f73473515b6da1fb4491ef2a359caa071ca 100644 (file)
--- 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);