[multiple changes]

2011-08-29  Robert Dewar  <dewar@adacore.com>

	* frontend.adb, gnat1drv.adb: Minor reformatting.

2011-08-29  Tristan Gingold  <gingold@adacore.com>

	* s-pooglo.adb (Allocate, Deallocate): Take into account the alignment.
	* a-fihema.adb (Allocate, Deallocate): Ditto.  Possibly add padding
	space in front of the header.

From-SVN: r178181

6 files changed, 100 insertions, 25 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index f48eafe..b63a9f3 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2011-08-29  Robert Dewar  <dewar@adacore.com>
+
+	* frontend.adb, gnat1drv.adb: Minor reformatting.
+
+2011-08-29  Tristan Gingold  <gingold@adacore.com>
+
+	* s-pooglo.adb (Allocate, Deallocate): Take into account the alignment.
+	* a-fihema.adb (Allocate, Deallocate): Ditto.  Possibly add padding
+	space in front of the header.
+
 2011-08-29  Johannes Kanig  <kanig@adacore.com>
 
 	* frontend.adb (Frontend): Exit after creating Standard package when
diff --git a/gcc/ada/a-fihema.adb b/gcc/ada/a-fihema.adb
index 3759e71..2eadd0c 100644
--- a/gcc/ada/a-fihema.adb
+++ b/gcc/ada/a-fihema.adb
@@ -51,10 +51,6 @@ package body Ada.Finalization.Heap_Management is
    --  Allocate/Deallocate to determine the Storage_Size passed to the
    --  underlying pool.
 
-   Header_Offset : constant Storage_Offset := Header_Size;
-   --  Offset from the header to the actual object. Used to get from the
-   --  address of a header to the address of the actual object, and vice-versa.
-
    function Address_To_Node_Ptr is
      new Ada.Unchecked_Conversion (Address, Node_Ptr);
 
@@ -136,10 +132,21 @@ package body Ada.Finalization.Heap_Management is
          end if;
 
          declare
-            N_Addr : Address;
-            N_Ptr  : Node_Ptr;
+            Header_Offset : Storage_Offset;
+            N_Addr        : Address;
+            N_Ptr         : Node_Ptr;
 
          begin
+            --  Offset from the header to the actual object. The header is
+            --  just in front of the object. There may be padding space before
+            --  the header.
+
+            if Alignment > Header_Size then
+               Header_Offset := Alignment;
+            else
+               Header_Offset := Header_Size;
+            end if;
+
             --  Use the underlying pool to allocate enough space for the object
             --  and the list header. The returned address points to the list
             --  header. If locking is necessary, it will be done by the
@@ -148,13 +155,14 @@ package body Ada.Finalization.Heap_Management is
             Allocate
               (Collection.Base_Pool.all,
                N_Addr,
-               Storage_Size + Header_Size,
+               Storage_Size + Header_Offset,
                Alignment);
 
             --  Map the allocated memory into a Node record. This converts the
             --  top of the allocated bits into a list header.
 
-            N_Ptr := Address_To_Node_Ptr (N_Addr);
+            N_Ptr := Address_To_Node_Ptr
+              (N_Addr + Header_Offset - Header_Size);
             Attach (N_Ptr, Collection.Objects'Unchecked_Access);
 
             --  Move the address from Prev to the start of the object. This
@@ -224,19 +232,28 @@ package body Ada.Finalization.Heap_Management is
 
       if Has_Header then
          declare
-            N_Addr : Address;
-            N_Ptr  : Node_Ptr;
+            Header_Offset : Storage_Offset;
+            N_Addr        : Address;
+            N_Ptr         : Node_Ptr;
 
          begin
-            --  Move address from the object to beginning of the list header
+            --  Offset from the header to the actual object.
 
-            N_Addr := Addr - Header_Offset;
+            if Alignment > Header_Size then
+               Header_Offset := Alignment;
+            else
+               Header_Offset := Header_Size;
+            end if;
 
-            --  Converts the bits preceding the object into a list header
+            --  Converts from the object to the list header
 
-            N_Ptr := Address_To_Node_Ptr (N_Addr);
+            N_Ptr := Address_To_Node_Ptr (Addr - Header_Size);
             Detach (N_Ptr);
 
+            --  Converts the bits preceding the object the block address.
+
+            N_Addr := Addr - Header_Offset;
+
             --  Use the underlying pool to destroy the object along with the
             --  list header.
 
@@ -340,7 +357,7 @@ package body Ada.Finalization.Heap_Management is
             if Collection.Finalize_Address /= null then
                declare
                   Object_Address : constant Address :=
-                                     Node.all'Address + Header_Offset;
+                                     Node.all'Address + Header_Size;
                   --  Get address of object from address of header
 
                begin
diff --git a/gcc/ada/a-fihema.ads b/gcc/ada/a-fihema.ads
index e3f412f..6e829d2 100644
--- a/gcc/ada/a-fihema.ads
+++ b/gcc/ada/a-fihema.ads
@@ -119,7 +119,8 @@ private
    --  full view of Limited_Controlled, which is NOT limited. Note that default
    --  initialization does not happen for this type (the pointers will not be
    --  automatically set to null), because of the games we're playing with
-   --  address arithmetic.
+   --  address arithmetic. Code in the body assumes that the size of
+   --  this record is a power of 2 to deal with alignment.
 
    type Node is record
       Prev : Node_Ptr;
diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb
index f849d31..2dad57a 100644
--- a/gcc/ada/frontend.adb
+++ b/gcc/ada/frontend.adb
@@ -100,6 +100,7 @@ begin
 
    --  If the -gnatd.H flag is present, we are only interested in the Standard
    --  package, so the frontend has done its job here.
+
    if Debug_Flag_Dot_HH then
       return;
    end if;
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index b494bd4..7ae04fe 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -770,12 +770,18 @@ begin
       Original_Operating_Mode := Operating_Mode;
       Frontend;
 
-      --  Exit with errors if the main source could not be parsed
-      --  Also, when -gnatd.H is present, the source file is not set.
+      --  Exit with errors if the main source could not be parsed. Also, when
+      --  -gnatd.H is present, the source file is not set.
+
       if Sinput.Main_Source_File = No_Source_File then
+
+         --  Handle -gnatd.H debug mode
+
          if Debug_Flag_Dot_HH then
-            --  We lock all the tables to keep the convention that the backend
-            --  needs to unlock the tables it wants to touch.
+
+            --  For -gnatd.H, lock all the tables to keep the convention that
+            --  the backend needs to unlock the tables it wants to touch.
+
             Atree.Lock;
             Elists.Lock;
             Fname.UF.Lock;
@@ -786,8 +792,12 @@ begin
             Sinput.Lock;
             Namet.Lock;
             Stringt.Lock;
+
+            --  And all we need to do is to call the back end
+
             Back_End.Call_Back_End (Back_End.Generate_Object);
          end if;
+
          Errout.Finalize (Last_Call => True);
          Errout.Output_Messages;
          Exit_Program (E_Errors);
diff --git a/gcc/ada/s-pooglo.adb b/gcc/ada/s-pooglo.adb
index dc55962..de96aa0 100644
--- a/gcc/ada/s-pooglo.adb
+++ b/gcc/ada/s-pooglo.adb
@@ -46,13 +46,19 @@ package body System.Pool_Global is
       Storage_Size : SSE.Storage_Count;
       Alignment    : SSE.Storage_Count)
    is
+      use SSE;
       pragma Warnings (Off, Pool);
-      pragma Warnings (Off, Alignment);
 
-      Allocated : System.Address;
+      Aligned_Size    : Storage_Count := Storage_Size;
+      Aligned_Address : System.Address;
+      Allocated       : System.Address;
 
    begin
-      Allocated := Memory.Alloc (Memory.size_t (Storage_Size));
+      if Alignment > Standard'System_Allocator_Alignment then
+         Aligned_Size := Aligned_Size + Alignment;
+      end if;
+
+      Allocated := Memory.Alloc (Memory.size_t (Aligned_Size));
 
       --  The call to Alloc returns an address whose alignment is compatible
       --  with the worst case alignment requirement for the machine; thus the
@@ -60,6 +66,24 @@ package body System.Pool_Global is
 
       if Allocated = Null_Address then
          raise Storage_Error;
+      end if;
+
+      if Alignment > Standard'System_Allocator_Alignment then
+         --  Realign the returned address.
+         Aligned_Address := To_Address
+           (To_Integer (Allocated) + Integer_Address (Alignment)
+              - (To_Integer (Allocated) mod Integer_Address (Alignment)));
+         --  Save the block address.
+         declare
+            Saved_Address : System.Address;
+            pragma Import (Ada, Saved_Address);
+            for Saved_Address'Address use
+               Aligned_Address
+               - Storage_Offset (System.Address'Size / Storage_Unit);
+         begin
+            Saved_Address := Allocated;
+         end;
+         Address := Aligned_Address;
       else
          Address := Allocated;
       end if;
@@ -75,12 +99,24 @@ package body System.Pool_Global is
       Storage_Size : SSE.Storage_Count;
       Alignment    : SSE.Storage_Count)
    is
+      use System.Storage_Elements;
       pragma Warnings (Off, Pool);
       pragma Warnings (Off, Storage_Size);
-      pragma Warnings (Off, Alignment);
 
    begin
-      Memory.Free (Address);
+      if Alignment > Standard'System_Allocator_Alignment then
+         --  Retrieve the block address.
+         declare
+            Saved_Address : System.Address;
+            pragma Import (Ada, Saved_Address);
+            for Saved_Address'Address use
+              Address - Storage_Offset (System.Address'Size / Storage_Unit);
+         begin
+            Memory.Free (Saved_Address);
+         end;
+      else
+         Memory.Free (Address);
+      end if;
    end Deallocate;
 
    ------------------