[Ada] Fix another alloc/free discrepancy for unconstrained arrays

Olivier Hainque hainque@adacore.com
Fri Dec 7 10:43:00 GMT 2007


This is an annoying old bug, filed as PR ada/34173, which showed up on
a testcase introduced when a fix for another problem was introduced

  http://gcc.gnu.org/ml/gcc-patches/2007-11/msg01095.html

The testcase below misbehaves on a number of targets because the
address we pass to Free does not match what the corresponding malloc
call returned.

   with Ada.Unchecked_Deallocation;
   procedure Unc_Memfree is

      type List is array (Natural range <>) of Integer;
      for List'Alignment use Standard'Maximum_Alignment;

      type Fat_List_Access is access all List;

      procedure Release_Fat is new Ada.Unchecked_Deallocation
        (Object => List, Name => Fat_List_Access);

      My_Fat_List : Fat_List_Access;

   begin
      My_Fat_List := new List (1 .. 3);
      Release_Fat (My_Fat_List);
   end;
              
 The alloc/free discrepency for this case stems from a difference
 in the DECL_ALIGN attached to the ARRAY field of an object with
 template, as computed in two different places.

 The easiest way to observe this is from breakpoints on
 build_unc_object_type. This is called twice on the testcase at hand:

 1/ from gnat_to_gnu_entity to process the E_Array_Type node
 2/ from build_allocator to process the allocation request

 On x86 for 1/, the alignment of List is *not* propagated in the ARRAY
 field of the unconstrained object type, eventhough it is set on the
 corresponding array type.  This is


 Breakpoint 1, build_unc_object_type

    (gdb) pt type
    <record_type 0xb71b0564 p__list___XUT type_3 BLK
       fields <field_decl 0xb71b05c0 BOUNDS
           chain <field_decl 0xb71b061c ARRAY
                                        ^^^^^
                  type <array_type 0xb71b02e0 p__list___XUA>
                  align 32 offset_align 128 bit offset <integer_cst 64>
                  ^^^^^^^^
 despite

    (gdb) pt object_type
    <array_type 0xb71b02e0 p__list___XUA
       type <integer_type 0xb71b0284 integer
       ...
       align 128 symtab 0 alias set -1
       ^^^^^^^^^

 There are multiple factors at play to get there:

  a/ gigi first creates a field decl with the expected alignment,
     DECL_USER_ALIGN is not set on it,

  b/ We get into

     layout_decl
      if (! DECL_USER_ALIGN (decl) && ...
        { ...
        #ifdef ADJUST_FIELD_ALIGN
          DECL_ALIGN (decl) = ADJUST_FIELD_ALIGN (decl, DECL_ALIGN (decl));
        ...

 c/ this routes to x86_field_alignment which downgrades the field alignment
    because this is an array of integers.


 From build_allocator, the object_type is a padding record type,
 x86_field_alignment leaves the alignment set by gigi alone and we get

    chain <field_decl 0xb71b0ebc ARRAY type <record_type p__S3b___PAD>
            BLK file p.adb line 22
            align 128

 From there, the array is placed 16bytes off the bounds, while
 N_Free_Statements thinks its only 8bytes off from the unconstrained
 type description.

 N_Free_Statement uses this offset to compute the storage address
 to 'free' from the array address, as per

          if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
              && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
            {
              tree gnu_char_ptr_type = build_pointer_type (char_type_node);
              tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
              tree gnu_byte_offset
                = convert (gnu_char_ptr_type,
                           size_diffop (size_zero_node, gnu_pos));

              gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
              gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
                                         gnu_ptr, gnu_byte_offset);
            }

 and it gets it wrong.

 The fix applied here is to ensure that the ARRAY field has
 DECL_USER_ALIGN set when the alignment comes from an alignment clause,
 which is legitimate in any case and prevents the downgrade from
 layout_decl.

 Tested locally on x86-pc-linux-gnu.
 Bootstrapped and reg tested on x86_64-pc-linux-gnu.
 Committing to mainline.

 2007-12-07  Olivier Hainque  <hainque@adacore.com>
 
	PR ada/34173
	* decl.c (gnat_to_gnu_entity) <case E_Array_Type>: When setting
	the alignment on the GCC XUA array type, set TYPE_USER_ALIGN if
	this is from an alignment clause on the GNAT entity.
	* utils.c (create_field_decl): Rewrite the computation of DECL_ALIGN
	to distinguish the case where we set it from the type's alignment.
	When so, propagate TYPE_USER_ALIGN into DECL_USER_ALIGN to indicate
	whether this alignment was set from an explicit alignment clause.

-------------- next part --------------
Index: ada/ChangeLog
===================================================================
*** ada/ChangeLog	(revision 130671)
--- ada/ChangeLog	(working copy)
***************
*** 1,3 ****
--- 1,14 ----
+ 2007-12-07  Olivier Hainque  <hainque@adacore.com>
+ 
+ 	PR ada/34173
+ 	* decl.c (gnat_to_gnu_entity) <case E_Array_Type>: When setting
+ 	the alignment on the GCC XUA array type, set TYPE_USER_ALIGN if
+ 	this is from an alignment clause on the GNAT entity.
+ 	* utils.c (create_field_decl): Rewrite the computation of DECL_ALIGN
+ 	to distinguish the case where we set it from the type's alignment.
+ 	When so, propagate TYPE_USER_ALIGN into DECL_USER_ALIGN to indicate
+ 	whether this alignment was set from an explicit alignment clause.
+ 
  2007-12-06  Eric Botcazou  <ebotcazou@adacore.com>
  
  	* decl.c (make_packable_type): Revert last change.
Index: ada/decl.c
===================================================================
*** ada/decl.c	(revision 130649)
--- ada/decl.c	(working copy)
*************** gnat_to_gnu_entity (Entity_Id gnat_entit
*** 1795,1801 ****
  	  }
  
  	/* If an alignment is specified, use it if valid.  But ignore it for
! 	   types that represent the unpacked base type for packed arrays.  */
  	if (No (Packed_Array_Type (gnat_entity))
  	    && Known_Alignment (gnat_entity))
  	  {
--- 1795,1803 ----
  	  }
  
  	/* If an alignment is specified, use it if valid.  But ignore it for
! 	   types that represent the unpacked base type for packed arrays.  If
! 	   the alignment was requested with an explicit user alignment clause,
! 	   state so.  */
  	if (No (Packed_Array_Type (gnat_entity))
  	    && Known_Alignment (gnat_entity))
  	  {
*************** gnat_to_gnu_entity (Entity_Id gnat_entit
*** 1803,1808 ****
--- 1805,1812 ----
  	    TYPE_ALIGN (tem)
  	      = validate_alignment (Alignment (gnat_entity), gnat_entity,
  				    TYPE_ALIGN (tem));
+ 	    if (Present (Alignment_Clause (gnat_entity)))
+ 	      TYPE_USER_ALIGN (tem) = 1;
  	  }
  
  	TYPE_CONVENTION_FORTRAN_P (tem)
Index: ada/utils.c
===================================================================
*** ada/utils.c	(revision 130649)
--- ada/utils.c	(working copy)
*************** create_field_decl (tree field_name, tree
*** 1578,1588 ****
      }
  
    DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
!   DECL_ALIGN (field_decl)
!     = MAX (DECL_ALIGN (field_decl),
! 	   DECL_BIT_FIELD (field_decl) ? 1
! 	   : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT
! 	   : TYPE_ALIGN (field_type));
  
    if (pos)
      {
--- 1578,1601 ----
      }
  
    DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
! 
!   /* Bump the alignment if need be, either for bitfield/packing purposes or
!      to satisfy the type requirements if no such consideration applies.  When
!      we get the alignment from the type, indicate if this is from an explicit
!      user request, which prevents stor-layout from lowering it later on.  */
!   {
!     int bit_align
!       = (DECL_BIT_FIELD (field_decl) ? 1
! 	 : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0);
! 
!     if (bit_align > DECL_ALIGN (field_decl))
!       DECL_ALIGN (field_decl) = bit_align;
!     else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl))
!       {
! 	DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
! 	DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type);
!       }
!   }
  
    if (pos)
      {
Index: testsuite/gnat.dg/unc_memops.adb
===================================================================
*** testsuite/gnat.dg/unc_memops.adb	(revision 0)
--- testsuite/gnat.dg/unc_memops.adb	(revision 0)
***************
*** 0 ****
--- 1,63 ----
+ 
+ package body Unc_Memops is
+ 
+    use type System.Address;
+ 
+    type Addr_Array_T is array (1 .. 20) of Addr_T;
+ 
+    type Addr_Stack_T is record
+       Store : Addr_Array_T;
+       Size  : Integer := 0;
+    end record;
+ 
+    procedure Push (Addr : Addr_T; As : access addr_stack_t) is
+    begin
+       As.Size := As.Size + 1;
+       As.Store (As.Size) := Addr;
+    end;
+ 
+    function Pop (As : access Addr_Stack_T) return Addr_T is
+       Addr : Addr_T := As.Store (As.Size);
+    begin
+       As.Size := As.Size - 1;
+       return Addr;
+    end;
+ 
+    --
+ 
+    Addr_Stack : aliased Addr_Stack_T;
+    Symetry_Expected : Boolean := False;
+ 
+    procedure Expect_Symetry (Status : Boolean) is
+    begin
+       Symetry_Expected := Status;
+    end;
+ 
+    function  Alloc (Size : size_t) return Addr_T is
+       function malloc (Size : Size_T) return Addr_T;
+       pragma Import (C, Malloc, "malloc");
+ 
+       Ptr : Addr_T := malloc (Size);
+    begin
+       if Symetry_Expected then
+          Push (Ptr, Addr_Stack'Access);
+       end if;
+       return Ptr;
+    end;
+ 
+    procedure Free (Ptr : addr_t) is
+    begin
+       if Symetry_Expected
+         and then Ptr /= Pop (Addr_Stack'Access)
+       then
+          raise Program_Error;
+       end if;
+    end;
+ 
+    function  Realloc (Ptr  : addr_t; Size : size_t) return Addr_T is
+    begin
+       raise Program_Error;
+       return System.Null_Address;
+    end;
+ 
+ end;
Index: testsuite/gnat.dg/unc_memops.ads
===================================================================
*** testsuite/gnat.dg/unc_memops.ads	(revision 0)
--- testsuite/gnat.dg/unc_memops.ads	(revision 0)
***************
*** 0 ****
--- 1,24 ----
+ with System;
+ 
+ package Unc_Memops is
+    pragma Elaborate_Body;
+ 
+    type size_t is mod 2 ** Standard'Address_Size;
+    subtype addr_t is System.Address;
+ 
+    function  Alloc (Size : size_t) return addr_t;
+    procedure Free (Ptr : addr_t);
+    function  Realloc (Ptr  : addr_t; Size : size_t) return addr_t;
+ 
+    procedure Expect_Symetry (Status : Boolean);
+    --  Whether we expect "free"s to match "alloc" return values in
+    --  reverse order, like alloc->X, alloc->Y should be followed by
+    --  free Y, free X.
+ 
+ private
+ 
+    pragma Export (C, Alloc,   "__gnat_malloc");
+    pragma Export (C, Free,    "__gnat_free");
+    pragma Export (C, Realloc, "__gnat_realloc");
+ 
+ end;
Index: testsuite/gnat.dg/unc_memfree.adb
===================================================================
*** testsuite/gnat.dg/unc_memfree.adb	(revision 0)
--- testsuite/gnat.dg/unc_memfree.adb	(revision 0)
***************
*** 0 ****
--- 1,34 ----
+ --  { dg-do run }
+ 
+ with Ada.Unchecked_Deallocation;
+ with Unc_Memops;
+ 
+ procedure Unc_Memfree is
+ 
+    type List is array (Natural range <>) of Integer;
+    for List'Alignment use Standard'Maximum_Alignment;
+ 
+    type Fat_List_Access is access all List;
+ 
+    type Thin_List_Access is access all List;
+    for Thin_List_Access'Size use Standard'Address_Size;
+ 
+    procedure Release_Fat is new Ada.Unchecked_Deallocation
+      (Object => List, Name => Fat_List_Access);
+ 
+    procedure Release_Thin is new Ada.Unchecked_Deallocation
+      (Object => List, Name => Thin_List_Access);
+ 
+    My_Fat_List : Fat_List_Access;
+    My_Thin_List : Thin_List_Access;
+ begin
+    Unc_Memops.Expect_Symetry (True);
+ 
+    My_Fat_List := new List (1 .. 3);
+    Release_Fat (My_Fat_List);
+ 
+    My_Thin_List := new List (1 .. 3);
+    Release_Thin (My_Thin_List);
+ 
+    Unc_Memops.Expect_Symetry (False);
+ end;
Index: testsuite/ChangeLog
===================================================================
*** testsuite/ChangeLog	(revision 130671)
--- testsuite/ChangeLog	(working copy)
***************
*** 1,3 ****
--- 1,9 ----
+ 2007-12-07  Olivier Hainque  <hainque@adacore.com>
+ 
+ 	PR ada/34173
+ 	* gnat.dg/unc_memops.ad[sb]: Support for ...
+ 	* gnat.dg/unc_memfree.adb: New test.
+ 	
  2007-12-06  Sebastian Pop  <sebastian.pop@amd.com>
  
  	* gfortran.dg/ltrans-7.f90: New.


More information about the Gcc-patches mailing list