ada: Fix latent alignment issue for dynamically-allocated controlled objects

Dynamically-allocated controlled objects are attached to a finalization
collection by means of a hidden header placed right before the object,
which means that the size effectively allocated must naturally account
for the size of this header.  But the allocation must also account for
the alignment of this header in order to have it properly aligned.

gcc/ada/

	* libgnat/s-finpri.ads (Header_Alignment): New function.
	(Header_Size): Adjust description.
	(Master_Node): Put Finalize_Address as first component.
	(Collection_Node): Likewise.
	* libgnat/s-finpri.adb (Header_Alignment): New function.
	(Header_Size): Return the object size in storage units.
	* libgnat/s-stposu.ads (Adjust_Controlled_Dereference): Replace
	collection node with header in description.
	* libgnat/s-stposu.adb (Adjust_Controlled_Dereference): Likewise.
	(Allocate_Any_Controlled): Likewise.  Pass the maximum of the
	specified alignment and that of the header to the allocator.
	(Deallocate_Any_Controlled): Likewise to the deallocator.

4 files changed, 66 insertions, 37 deletions

diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb
index 09f2761..5bd8eea 100644
--- a/gcc/ada/libgnat/s-finpri.adb
+++ b/gcc/ada/libgnat/s-finpri.adb
@@ -389,13 +389,22 @@ package body System.Finalization_Primitives is
       end if;
    end Finalize_Object;
 
+   ----------------------
+   -- Header_Alignment --
+   ----------------------
+
+   function Header_Alignment return System.Storage_Elements.Storage_Count is
+   begin
+      return Collection_Node'Alignment;
+   end Header_Alignment;
+
    -----------------
    -- Header_Size --
    -----------------
 
    function Header_Size return System.Storage_Elements.Storage_Count is
    begin
-      return Collection_Node'Size / Storage_Unit;
+      return Collection_Node'Object_Size / Storage_Unit;
    end Header_Size;
 
    ----------------
diff --git a/gcc/ada/libgnat/s-finpri.ads b/gcc/ada/libgnat/s-finpri.ads
index 4ba13da..468aa58 100644
--- a/gcc/ada/libgnat/s-finpri.ads
+++ b/gcc/ada/libgnat/s-finpri.ads
@@ -168,8 +168,11 @@ package System.Finalization_Primitives with Preelaborate is
    --  Calls to the procedure with an object that has already been detached
    --  have no effects.
 
+   function Header_Alignment return System.Storage_Elements.Storage_Count;
+   --  Return the alignment of type Collection_Node as Storage_Count
+
    function Header_Size return System.Storage_Elements.Storage_Count;
-   --  Return the size of type Collection_Node as Storage_Count
+   --  Return the object size of type Collection_Node as Storage_Count
 
 private
 
@@ -182,11 +185,13 @@ private
 
    --  Finalization masters:
 
-   --  Master node type structure
+   --  Master node type structure. Finalize_Address comes first because it is
+   --  an access-to-subprogram and, therefore, might be twice as large and as
+   --  aligned as an access-to-object on some platforms.
 
    type Master_Node is record
-      Object_Address   : System.Address       := System.Null_Address;
       Finalize_Address : Finalize_Address_Ptr := null;
+      Object_Address   : System.Address       := System.Null_Address;
       Next             : Master_Node_Ptr      := null;
    end record;
 
@@ -211,15 +216,17 @@ private
 
    --  Finalization collections:
 
-   --  Collection node type structure
+   --  Collection node type structure. Finalize_Address comes first because it
+   --  is an access-to-subprogram and, therefore, might be twice as large and
+   --  as aligned as an access-to-object on some platforms.
 
    type Collection_Node is record
-      Enclosing_Collection : Finalization_Collection_Ptr := null;
-      --  A pointer to the collection to which the node is attached
-
       Finalize_Address : Finalize_Address_Ptr := null;
       --  A pointer to the Finalize_Address procedure of the object
 
+      Enclosing_Collection : Finalization_Collection_Ptr := null;
+      --  A pointer to the collection to which the node is attached
+
       Prev : Collection_Node_Ptr := null;
       Next : Collection_Node_Ptr := null;
       --  Collection nodes are managed as a circular doubly-linked list
diff --git a/gcc/ada/libgnat/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb
index 38dc69f..84535d2 100644
--- a/gcc/ada/libgnat/s-stposu.adb
+++ b/gcc/ada/libgnat/s-stposu.adb
@@ -56,12 +56,12 @@ package body System.Storage_Pools.Subpools is
       Header_And_Padding : constant Storage_Offset :=
                              Header_Size_With_Padding (Alignment);
    begin
-      --  Expose the collection node and its padding by shifting the address
-      --  from the start of the object to the beginning pf the padding.
+      --  Expose the header and its padding by shifting the address from the
+      --  start of the object to the beginning of the padding.
 
       Addr := Addr - Header_And_Padding;
 
-      --  Update the size to include the collection node and its padding
+      --  Update the size to include the header and its padding
 
       Storage_Size := Storage_Size + Header_And_Padding;
    end Adjust_Controlled_Dereference;
@@ -109,13 +109,14 @@ package body System.Storage_Pools.Subpools is
       Is_Subpool_Allocation : constant Boolean :=
                                 Pool in Root_Storage_Pool_With_Subpools'Class;
 
-      N_Addr  : Address;
-      N_Size  : Storage_Count;
-      Subpool : Subpool_Handle;
+      N_Addr      : Address;
+      N_Alignment : Storage_Count;
+      N_Size      : Storage_Count;
+      Subpool     : Subpool_Handle;
 
       Header_And_Padding : Storage_Offset;
-      --  This offset includes the size of a collection node plus an additional
-      --  padding due to a larger alignment.
+      --  This offset includes the size of a header plus an additional padding
+      --  due to a larger alignment of the object.
 
    begin
       --  Step 1: Pool-related runtime checks
@@ -181,24 +182,31 @@ package body System.Storage_Pools.Subpools is
          end if;
       end if;
 
-      --  Step 2: Size calculation
+      --  Step 2: Size and alignment calculations
 
       --  Allocation of a descendant from [Limited_]Controlled, a class-wide
       --  object or a record with controlled components.
 
       if Is_Controlled then
-         --  The size must account for the hidden header preceding the object.
+         --  The size must account for the hidden header before the object.
          --  Account for possible padding space before the header due to a
-         --  larger alignment.
+         --  larger alignment of the object.
 
          Header_And_Padding := Header_Size_With_Padding (Alignment);
 
          N_Size := Storage_Size + Header_And_Padding;
 
+         --  The alignment must account for the hidden header before the object
+
+         N_Alignment :=
+           System.Storage_Elements.Storage_Count'Max
+             (Alignment, System.Finalization_Primitives.Header_Alignment);
+
       --  Non-controlled allocation
 
       else
-         N_Size := Storage_Size;
+         N_Size      := Storage_Size;
+         N_Alignment := Alignment;
       end if;
 
       --  Step 3: Allocation of object
@@ -209,22 +217,22 @@ package body System.Storage_Pools.Subpools is
       if Is_Subpool_Allocation then
          Allocate_From_Subpool
            (Root_Storage_Pool_With_Subpools'Class (Pool),
-            N_Addr, N_Size, Alignment, Subpool);
+            N_Addr, N_Size, N_Alignment, Subpool);
 
       --  For descendants of Root_Storage_Pool, dispatch to the implementation
       --  of Allocate.
 
       else
-         Allocate (Pool, N_Addr, N_Size, Alignment);
+         Allocate (Pool, N_Addr, N_Size, N_Alignment);
       end if;
 
       --  Step 4: Displacement of address
 
       if Is_Controlled then
-
-         --  Map the allocated memory into a collection node. This converts the
-         --  top of the allocated bits into a list header. If there is padding
-         --  due to larger alignment, the padding is placed at the beginning:
+         --  Move the address from the hidden list header to the start of the
+         --  object. If there is padding due to larger alignment of the object,
+         --  the padding is placed at the beginning. This effectively hides the
+         --  list header:
 
          --    N_Addr                  Addr
          --    |                       |
@@ -237,9 +245,6 @@ package body System.Storage_Pools.Subpools is
          --    |                       |
          --    +- Header_And_Padding --+
 
-         --  Move the address from the hidden list header to the start of the
-         --  object. This operation effectively hides the list header.
-
          Addr := N_Addr + Header_And_Padding;
 
       --  Non-controlled allocation
@@ -283,12 +288,13 @@ package body System.Storage_Pools.Subpools is
       Alignment     : System.Storage_Elements.Storage_Count;
       Is_Controlled : Boolean)
    is
-      N_Addr : Address;
-      N_Size : Storage_Count;
+      N_Addr      : Address;
+      N_Alignment : Storage_Count;
+      N_Size      : Storage_Count;
 
       Header_And_Padding : Storage_Offset;
-      --  This offset includes the size of a collection node plus an additional
-      --  padding due to a larger alignment.
+      --  This offset includes the size of a header plus an additional padding
+      --  due to a larger alignment of the object.
 
    begin
       --  Step 1: Displacement of address
@@ -318,9 +324,16 @@ package body System.Storage_Pools.Subpools is
 
          N_Size := Storage_Size + Header_And_Padding;
 
+         --  The alignment must account for the hidden header before the object
+
+         N_Alignment :=
+           System.Storage_Elements.Storage_Count'Max
+             (Alignment, System.Finalization_Primitives.Header_Alignment);
+
       else
-         N_Addr := Addr;
-         N_Size := Storage_Size;
+         N_Addr      := Addr;
+         N_Size      := Storage_Size;
+         N_Alignment := Alignment;
       end if;
 
       --  Step 2: Deallocation of object
@@ -329,7 +342,7 @@ package body System.Storage_Pools.Subpools is
       --  covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
       --  implementations.
 
-      Deallocate (Pool, N_Addr, N_Size, Alignment);
+      Deallocate (Pool, N_Addr, N_Size, N_Alignment);
    end Deallocate_Any_Controlled;
 
    ------------------------------
diff --git a/gcc/ada/libgnat/s-stposu.ads b/gcc/ada/libgnat/s-stposu.ads
index a2f306a..ed6991e 100644
--- a/gcc/ada/libgnat/s-stposu.ads
+++ b/gcc/ada/libgnat/s-stposu.ads
@@ -236,7 +236,7 @@ private
       Alignment    : System.Storage_Elements.Storage_Count);
    --  Given the memory attributes of a heap-allocated object that is known to
    --  be controlled, adjust the address and size of the object to include the
-   --  collection node inserted by the finalization machinery and its padding.
+   --  hidden header inserted by the finalization machinery and its padding.
 
    --  ??? Once Storage_Pools.Allocate_Any is removed, this should be renamed
    --  to Allocate_Any.