OSDN Git Service

ada/
authorhainque <hainque@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 9 Jun 2009 15:32:03 +0000 (15:32 +0000)
committerhainque <hainque@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 9 Jun 2009 15:32:03 +0000 (15:32 +0000)
        * gcc-interface/utils2.c (build_call_alloc_dealloc_proc): New
        helper for build_call_alloc_dealloc with arguments to be interpreted
        identically.  Process the case where a GNAT_PROC to call is provided.
        (maybe_wrap_malloc): New helper for build_call_alloc_dealloc, to build
        and return an allocator for DATA_SIZE bytes aimed at containing a
        DATA_TYPE object, using the default __gnat_malloc allocator.  Honor
        DATA_TYPE alignments greater than what the latter offers.
        (maybe_wrap_free): New helper for build_call_alloc_dealloc, to
        release a DATA_TYPE object designated by DATA_PTR using the
        __gnat_free entry point.
        (build_call_alloc_dealloc): Expect object data type instead of naked
        alignment constraint. Use the new helpers.
        (build_allocator): Remove special processing for the super-aligned
        case, now handled by build_call_alloc_dealloc.  Pass data type instead
        of the former alignment argument, as expected by the new interface.
        * gcc-interface/gigi.h (build_call_alloc_dealloc): Adjust prototype
        and comment.
        * gcc-interface/trans.c (gnat_to_gnu) <case N_Free_Statement>:
        Remove special processing for the super-aligned case, now handled
        by build_call_alloc_dealloc.  Pass data type instead of the former
        alignment argument, as expected by the new interface.

        testsuite/
        * gnat.dg/align_max.adb: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148314 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/ada/ChangeLog
gcc/ada/gcc-interface/gigi.h
gcc/ada/gcc-interface/trans.c
gcc/ada/gcc-interface/utils2.c
gcc/testsuite/ChangeLog
gcc/testsuite/gnat.dg/align_max.adb [new file with mode: 0644]

index f6ca7d7..03b7de5 100644 (file)
@@ -1,3 +1,28 @@
+2009-06-09  Olivier Hainque  <hainque@adacore.com>
+
+       * gcc-interface/utils2.c (build_call_alloc_dealloc_proc): New
+       helper for build_call_alloc_dealloc with arguments to be interpreted
+       identically.  Process the case where a GNAT_PROC to call is provided.
+       (maybe_wrap_malloc): New helper for build_call_alloc_dealloc, to build
+       and return an allocator for DATA_SIZE bytes aimed at containing a
+       DATA_TYPE object, using the default __gnat_malloc allocator.  Honor
+       DATA_TYPE alignments greater than what the latter offers.
+       (maybe_wrap_free): New helper for build_call_alloc_dealloc, to
+       release a DATA_TYPE object designated by DATA_PTR using the
+       __gnat_free entry point.
+       (build_call_alloc_dealloc): Expect object data type instead of naked
+       alignment constraint. Use the new helpers.
+       (build_allocator): Remove special processing for the super-aligned
+       case, now handled by build_call_alloc_dealloc.  Pass data
+       type instead of the former alignment argument, as expected by the new
+       interface.
+       * gcc-interface/gigi.h (build_call_alloc_dealloc): Adjust prototype
+       and comment.
+       * gcc-interface/trans.c (gnat_to_gnu) <case N_Free_Statement>:
+       Remove special processing for the super-aligned case, now handled
+       by build_call_alloc_dealloc.  Pass data type instead of the former
+       alignment argument, as expected by the new interface.
+       
 2009-06-08  Alexandre Oliva  <aoliva@redhat.com>
 
        * lib-writ.adb (flag_compare_debug): Import.
index 4d19b42..7bc89ee 100644 (file)
@@ -843,13 +843,13 @@ extern tree build_component_ref (tree record_variable, tree component,
    If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
    generate an allocator.
 
-   GNU_SIZE is the size of the object in bytes and ALIGN is the alignment
-   in bits.  GNAT_PROC, if present, is a procedure to call and GNAT_POOL
-   is the storage pool to use.  If not present, malloc and free are used.
-   GNAT_NODE is used to provide an error location for restriction violation
-   messages.  */
+   GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
+   object type, used to determine the to-be-honored address alignment.
+   GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
+   pool to use.  If not present, malloc and free are used.  GNAT_NODE is used
+   to provide an error location for restriction violation messages.  */
 extern tree build_call_alloc_dealloc (tree gnu_obj, tree gnu_size,
-                                      unsigned align, Entity_Id gnat_proc,
+                                      tree gnu_type, Entity_Id gnat_proc,
                                      Entity_Id gnat_pool, Node_Id gnat_node);
 
 /* Build a GCC tree to correspond to allocating an object of TYPE whose
index 2c471f1..d37e3c1 100644 (file)
@@ -5101,9 +5101,6 @@ gnat_to_gnu (Node_Id gnat_node)
          tree gnu_obj_type;
          tree gnu_actual_obj_type = 0;
          tree gnu_obj_size;
-         unsigned int align;
-         unsigned int default_allocator_alignment
-           = get_target_default_allocator_alignment () * BITS_PER_UNIT;
 
          /* If this is a thin pointer, we must dereference it to create
             a fat pointer, then go back below to a thin pointer.  The
@@ -5142,7 +5139,6 @@ gnat_to_gnu (Node_Id gnat_node)
            gnu_actual_obj_type = gnu_obj_type;
 
          gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
-         align = TYPE_ALIGN (gnu_obj_type);
 
          if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
              && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
@@ -5159,42 +5155,11 @@ gnat_to_gnu (Node_Id gnat_node)
                                         gnu_ptr, gnu_byte_offset);
            }
 
-         /* If the object was allocated from the default storage pool, the
-            alignment was greater than what the allocator provides, and this
-            is not a fat or thin pointer, what we have in gnu_ptr here is an
-            address dynamically adjusted to match the alignment requirement
-            (see build_allocator).  What we need to pass to free is the
-            initial allocator's return value, which has been stored just in
-            front of the block we have.  */
-
-         if (No (Procedure_To_Call (gnat_node))
-             && align > default_allocator_alignment
-             && ! TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
-           {
-             /* We set GNU_PTR
-                as * (void **)((void *)GNU_PTR - (void *)sizeof(void *))
-                in two steps:  */
-
-             /* GNU_PTR (void *)
-                = (void *)GNU_PTR - (void *)sizeof (void *))  */
-             gnu_ptr
-               = build_binary_op
-                   (POINTER_PLUS_EXPR, ptr_void_type_node,
-                    convert (ptr_void_type_node, gnu_ptr),
-                    size_int (-POINTER_SIZE/BITS_PER_UNIT));
-
-             /* GNU_PTR (void *) = *(void **)GNU_PTR  */
-             gnu_ptr
-               = build_unary_op
-                   (INDIRECT_REF, NULL_TREE,
-                    convert (build_pointer_type (ptr_void_type_node),
-                             gnu_ptr));
-           }
-
-         gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
-                                                Procedure_To_Call (gnat_node),
-                                                Storage_Pool (gnat_node),
-                                                gnat_node);
+         gnu_result
+             = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type,
+                                         Procedure_To_Call (gnat_node),
+                                         Storage_Pool (gnat_node),
+                                         gnat_node);
        }
       break;
 
index ec72a27..aab01f9 100644 (file)
@@ -1830,95 +1830,99 @@ build_component_ref (tree record_variable, tree component,
                                   N_Raise_Constraint_Error));
 }
 \f
-/* Build a GCC tree to call an allocation or deallocation function.
-   If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
-   generate an allocator.
+/* Helper for build_call_alloc_dealloc, with arguments to be interpreted
+   identically.  Process the case where a GNAT_PROC to call is provided.  */
 
-   GNU_SIZE is the size of the object in bytes and ALIGN is the alignment
-   in bits.  GNAT_PROC, if present, is a procedure to call and GNAT_POOL
-   is the storage pool to use.  If not present, malloc and free are used.
-   GNAT_NODE is used to provide an error location for restriction violation
-   messages.  */
-
-tree
-build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
-                          Entity_Id gnat_proc, Entity_Id gnat_pool,
-                          Node_Id gnat_node)
+static inline tree
+build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
+                              Entity_Id gnat_proc, Entity_Id gnat_pool)
 {
-  tree gnu_align = size_int (align / BITS_PER_UNIT);
+  tree gnu_proc = gnat_to_gnu (gnat_proc);
+  tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
+  tree gnu_call;
 
-  gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
-
-  if (Present (gnat_proc))
+  /* The storage pools are obviously always tagged types, but the
+     secondary stack uses the same mechanism and is not tagged.  */
+  if (Is_Tagged_Type (Etype (gnat_pool)))
     {
-      /* The storage pools are obviously always tagged types, but the
-        secondary stack uses the same mechanism and is not tagged.  */
-      if (Is_Tagged_Type (Etype (gnat_pool)))
-       {
-         /* The size is the third parameter; the alignment is the
-             same type.  */
-         Entity_Id gnat_size_type
-           = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
-         tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
-         tree gnu_proc = gnat_to_gnu (gnat_proc);
-         tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
-         tree gnu_pool = gnat_to_gnu (gnat_pool);
-         tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
-         tree gnu_call;
-
-         gnu_size = convert (gnu_size_type, gnu_size);
-         gnu_align = convert (gnu_size_type, gnu_align);
-
-         /* The first arg is always the address of the storage pool; next
-            comes the address of the object, for a deallocator, then the
-            size and alignment.  */
-         if (gnu_obj)
-           gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
-                                       gnu_proc_addr, 4, gnu_pool_addr,
-                                       gnu_obj, gnu_size, gnu_align);
-         else
-           gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
-                                       gnu_proc_addr, 3, gnu_pool_addr,
-                                       gnu_size, gnu_align);
-         TREE_SIDE_EFFECTS (gnu_call) = 1;
-         return gnu_call;
-       }
+      /* The size is the third parameter; the alignment is the
+        same type.  */
+      Entity_Id gnat_size_type
+       = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
+      tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
+
+      tree gnu_pool = gnat_to_gnu (gnat_pool);
+      tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
+      tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
+
+      gnu_size = convert (gnu_size_type, gnu_size);
+      gnu_align = convert (gnu_size_type, gnu_align);
+
+      /* The first arg is always the address of the storage pool; next
+        comes the address of the object, for a deallocator, then the
+        size and alignment.  */
+      if (gnu_obj)
+       gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
+                                   gnu_proc_addr, 4, gnu_pool_addr,
+                                   gnu_obj, gnu_size, gnu_align);
+      else
+       gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
+                                   gnu_proc_addr, 3, gnu_pool_addr,
+                                   gnu_size, gnu_align);
+    }
 
-      /* Secondary stack case.  */
+  /* Secondary stack case.  */
+  else
+    {
+      /* The size is the second parameter.  */
+      Entity_Id gnat_size_type
+       = Etype (Next_Formal (First_Formal (gnat_proc)));
+      tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
+
+      gnu_size = convert (gnu_size_type, gnu_size);
+
+      /* The first arg is the address of the object, for a deallocator,
+        then the size.  */
+      if (gnu_obj)
+       gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
+                                   gnu_proc_addr, 2, gnu_obj, gnu_size);
       else
-       {
-         /* The size is the second parameter.  */
-         Entity_Id gnat_size_type
-           = Etype (Next_Formal (First_Formal (gnat_proc)));
-         tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
-         tree gnu_proc = gnat_to_gnu (gnat_proc);
-         tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
-         tree gnu_call;
-
-         gnu_size = convert (gnu_size_type, gnu_size);
-
-         /* The first arg is the address of the object, for a deallocator,
-            then the size.  */
-         if (gnu_obj)
-           gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
-                                       gnu_proc_addr, 2, gnu_obj, gnu_size);
-         else
-           gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
-                                       gnu_proc_addr, 1, gnu_size);
-         TREE_SIDE_EFFECTS (gnu_call) = 1;
-         return gnu_call;
-       }
+       gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
+                                   gnu_proc_addr, 1, gnu_size);
     }
 
-  if (gnu_obj)
-    return build_call_1_expr (free_decl, gnu_obj);
+  TREE_SIDE_EFFECTS (gnu_call) = 1;
+  return gnu_call;
+}
+
+/* Helper for build_call_alloc_dealloc, to build and return an allocator for
+   DATA_SIZE bytes aimed at containing a DATA_TYPE object, using the default
+   __gnat_malloc allocator.  Honor DATA_TYPE alignments greater than what the
+   latter offers.  */
+
+static inline tree
+maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node)
+{
+  /* When the DATA_TYPE alignment is stricter than what malloc offers
+     (super-aligned case), we allocate an "aligning" wrapper type and return
+     the address of its single data field with the malloc's return value
+     stored just in front.  */
+
+  unsigned int data_align = TYPE_ALIGN (data_type);
+  unsigned int default_allocator_alignment
+      = get_target_default_allocator_alignment () * BITS_PER_UNIT;
+
+  tree aligning_type
+    = ((data_align > default_allocator_alignment)
+       ? make_aligning_type (data_type, data_align, data_size,
+                            default_allocator_alignment,
+                            POINTER_SIZE / BITS_PER_UNIT)
+       : NULL_TREE);
 
-  /* Assert that we no longer can be called with this special pool.  */
-  gcc_assert (gnat_pool != -1);
+  tree size_to_malloc
+    = aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size;
 
-  /* Check that we aren't violating the associated restriction.  */
-  if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
-    Check_No_Implicit_Heap_Alloc (gnat_node);
+  tree malloc_ptr;
 
   /* On VMS, if 64-bit memory is disabled or pointers are 64-bit and the
      allocator size is 32-bit or Convention C, allocate 32-bit memory.  */
@@ -1927,9 +1931,127 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
          || (POINTER_SIZE == 64
              && (UI_To_Int (Esize (Etype (gnat_node))) == 32
                  || Convention (Etype (gnat_node)) == Convention_C))))
-    return build_call_1_expr (malloc32_decl, gnu_size);
+    malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc);
+  else
+    malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc);
 
-  return build_call_1_expr (malloc_decl, gnu_size);
+  if (aligning_type)
+    {
+      /* Latch malloc's return value and get a pointer to the aligning field
+        first.  */
+      tree storage_ptr = save_expr (malloc_ptr);
+
+      tree aligning_record_addr
+       = convert (build_pointer_type (aligning_type), storage_ptr);
+
+      tree aligning_record
+       = build_unary_op (INDIRECT_REF, NULL_TREE, aligning_record_addr);
+
+      tree aligning_field
+       = build_component_ref (aligning_record, NULL_TREE,
+                              TYPE_FIELDS (aligning_type), 0);
+
+      tree aligning_field_addr
+        = build_unary_op (ADDR_EXPR, NULL_TREE, aligning_field);
+
+      /* Then arrange to store the allocator's return value ahead
+        and return.  */
+      tree storage_ptr_slot_addr
+       = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
+                          convert (ptr_void_type_node, aligning_field_addr),
+                          size_int (-POINTER_SIZE/BITS_PER_UNIT));
+
+      tree storage_ptr_slot
+       = build_unary_op (INDIRECT_REF, NULL_TREE,
+                         convert (build_pointer_type (ptr_void_type_node),
+                                  storage_ptr_slot_addr));
+
+      return
+       build2 (COMPOUND_EXPR, TREE_TYPE (aligning_field_addr),
+               build_binary_op (MODIFY_EXPR, NULL_TREE,
+                                storage_ptr_slot, storage_ptr),
+               aligning_field_addr);
+    }
+  else
+    return malloc_ptr;
+}
+
+/* Helper for build_call_alloc_dealloc, to release a DATA_TYPE object
+   designated by DATA_PTR using the __gnat_free entry point.  */
+
+static inline tree
+maybe_wrap_free (tree data_ptr, tree data_type)
+{
+  /* In the regular alignment case, we pass the data pointer straight to free.
+     In the superaligned case, we need to retrieve the initial allocator
+     return value, stored in front of the data block at allocation time.  */
+
+  unsigned int data_align = TYPE_ALIGN (data_type);
+  unsigned int default_allocator_alignment
+      = get_target_default_allocator_alignment () * BITS_PER_UNIT;
+
+  tree free_ptr;
+
+  if (data_align > default_allocator_alignment)
+    {
+      /* DATA_FRONT_PTR (void *)
+        = (void *)DATA_PTR - (void *)sizeof (void *))  */
+      tree data_front_ptr
+       = build_binary_op
+         (POINTER_PLUS_EXPR, ptr_void_type_node,
+          convert (ptr_void_type_node, data_ptr),
+          size_int (-POINTER_SIZE/BITS_PER_UNIT));
+
+      /* FREE_PTR (void *) = *(void **)DATA_FRONT_PTR  */
+      free_ptr
+       = build_unary_op
+         (INDIRECT_REF, NULL_TREE,
+          convert (build_pointer_type (ptr_void_type_node), data_front_ptr));
+    }
+  else
+    free_ptr = data_ptr;
+
+  return build_call_1_expr (free_decl, free_ptr);
+}
+
+/* Build a GCC tree to call an allocation or deallocation function.
+   If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
+   generate an allocator.
+
+   GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
+   object type, used to determine the to-be-honored address alignment.
+   GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
+   pool to use.  If not present, malloc and free are used.  GNAT_NODE is used
+   to provide an error location for restriction violation messages.  */
+
+tree
+build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type,
+                          Entity_Id gnat_proc, Entity_Id gnat_pool,
+                          Node_Id gnat_node)
+{
+  gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
+
+  /* Explicit proc to call ?  This one is assumed to deal with the type
+     alignment constraints.  */
+  if (Present (gnat_proc))
+    return build_call_alloc_dealloc_proc (gnu_obj, gnu_size, gnu_type,
+                                         gnat_proc, gnat_pool);
+
+  /* Otherwise, object to "free" or "malloc" with possible special processing
+     for alignments stricter than what the default allocator honors.  */
+  else if (gnu_obj)
+    return maybe_wrap_free (gnu_obj, gnu_type);
+  else
+    {
+      /* Assert that we no longer can be called with this special pool.  */
+      gcc_assert (gnat_pool != -1);
+
+      /* Check that we aren't violating the associated restriction.  */
+      if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
+       Check_No_Implicit_Heap_Alloc (gnat_node);
+
+      return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node);
+    }
 }
 \f
 /* Build a GCC tree to correspond to allocating an object of TYPE whose
@@ -1949,8 +2071,6 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
 {
   tree size = TYPE_SIZE_UNIT (type);
   tree result;
-  unsigned int default_allocator_alignment
-    = get_target_default_allocator_alignment () * BITS_PER_UNIT;
 
   /* If the initializer, if present, is a NULL_EXPR, just return a new one.  */
   if (init && TREE_CODE (init) == NULL_EXPR)
@@ -1977,8 +2097,7 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
       if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
        size = ssize_int (-1);
 
-      storage = build_call_alloc_dealloc (NULL_TREE, size,
-                                         TYPE_ALIGN (storage_type),
+      storage = build_call_alloc_dealloc (NULL_TREE, size, storage_type,
                                          gnat_proc, gnat_pool, gnat_node);
       storage = convert (storage_ptr_type, protect_multiple_eval (storage));
 
@@ -2050,70 +2169,10 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
   if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
     size = ssize_int (-1);
 
-  /* If this is in the default storage pool and the type alignment is larger
-     than what the default allocator supports, make an "aligning" record type
-     with room to store a pointer before the field, allocate an object of that
-     type, store the system's allocator return value just in front of the
-     field and return the field's address.  */
-
-  if (No (gnat_proc) && TYPE_ALIGN (type) > default_allocator_alignment)
-    {
-      /* Construct the aligning type with enough room for a pointer ahead
-        of the field, then allocate.  */
-      tree record_type
-       = make_aligning_type (type, TYPE_ALIGN (type), size,
-                             default_allocator_alignment,
-                             POINTER_SIZE / BITS_PER_UNIT);
-
-      tree record, record_addr;
-
-      record_addr
-       = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (record_type),
-                                   default_allocator_alignment, Empty, Empty,
-                                   gnat_node);
-
-      record_addr
-       = convert (build_pointer_type (record_type),
-                  save_expr (record_addr));
-
-      record = build_unary_op (INDIRECT_REF, NULL_TREE, record_addr);
-
-      /* Our RESULT (the Ada allocator's value) is the super-aligned address
-        of the internal record field ... */
-      result
-       = build_unary_op (ADDR_EXPR, NULL_TREE,
-                         build_component_ref
-                         (record, NULL_TREE, TYPE_FIELDS (record_type), 0));
-      result = convert (result_type, result);
-
-      /* ... with the system allocator's return value stored just in
-        front.  */
-      {
-       tree ptr_addr
-         = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
-                            convert (ptr_void_type_node, result),
-                            size_int (-POINTER_SIZE/BITS_PER_UNIT));
-
-       tree ptr_ref
-         = convert (build_pointer_type (ptr_void_type_node), ptr_addr);
-
-       result
-         = build2 (COMPOUND_EXPR, TREE_TYPE (result),
-                   build_binary_op (MODIFY_EXPR, NULL_TREE,
-                                    build_unary_op (INDIRECT_REF, NULL_TREE,
-                                                    ptr_ref),
-                                    convert (ptr_void_type_node,
-                                             record_addr)),
-                   result);
-      }
-    }
-  else
-    result = convert (result_type,
-                     build_call_alloc_dealloc (NULL_TREE, size,
-                                               TYPE_ALIGN (type),
-                                               gnat_proc,
-                                               gnat_pool,
-                                               gnat_node));
+  result = convert (result_type,
+                   build_call_alloc_dealloc (NULL_TREE, size, type,
+                                             gnat_proc, gnat_pool,
+                                             gnat_node));
 
   /* If we have an initial value, put the new address into a SAVE_EXPR, assign
      the value, and return the address.  Do this with a COMPOUND_EXPR.  */
index b08a0b9..cb9ec0c 100644 (file)
@@ -1,3 +1,7 @@
+2009-06-09  Olivier Hainque  <hainque@adacore.com>
+
+       * gnat.dg/align_max.adb: New test.
+
 2009-06-08  Jason Merrill  <jason@redhat.com>
 
        * g++.dg/cpp0x/auto15.C: New.
diff --git a/gcc/testsuite/gnat.dg/align_max.adb b/gcc/testsuite/gnat.dg/align_max.adb
new file mode 100644 (file)
index 0000000..26597ea
--- /dev/null
@@ -0,0 +1,137 @@
+--  { dg-do run }
+
+with System.Storage_Elements; use System.Storage_Elements;
+with Ada.Unchecked_Deallocation;
+
+procedure Align_MAX is
+
+   Align : constant := Standard'Maximum_Alignment;
+
+   generic
+      type Data_Type (<>) is private;
+      type Access_Type is access Data_Type;
+      with function Allocate return Access_Type;
+      with function Address (Ptr : Access_Type) return System.Address;
+   package Check is
+      --  The hooks below just force asm generation that helps associating
+      --  obscure nested function names with their package instance name.
+      Hook_Allocate : System.Address := Allocate'Address;
+      Hook_Address : System.Address := Address'Address;
+      pragma Volatile (Hook_Allocate);
+      pragma Volatile (Hook_Address);
+
+      procedure Run (Announce : String);
+   end;
+
+   package body Check is
+
+      procedure Free is new
+        Ada.Unchecked_Deallocation (Data_Type, Access_Type);
+
+      procedure Run (Announce : String) is
+         Addr : System.Address;
+         Blocks : array (1 .. 1024) of Access_Type;
+      begin
+         for J in Blocks'Range loop
+            Blocks (J) := Allocate;
+            Addr := Address (Blocks (J));
+            if Addr mod Data_Type'Alignment /= 0 then
+               raise Program_Error;
+            end if;
+         end loop;
+
+         for J in Blocks'Range loop
+            Free (Blocks (J));
+         end loop;
+      end;
+   end;
+
+begin
+   declare
+      type Array_Type is array (Integer range <>) of Integer;
+      for Array_Type'Alignment use Align;
+
+      type FAT_Array_Access is access all Array_Type;
+
+      function Allocate return FAT_Array_Access is
+      begin
+         return new Array_Type (1 .. 1);
+      end;
+
+      function Address (Ptr : FAT_Array_Access) return System.Address is
+      begin
+         return Ptr(1)'Address;
+      end;
+      package Check_FAT is new
+        Check (Array_Type, FAT_Array_Access, Allocate, Address);
+   begin
+      Check_FAT.Run ("Checking FAT pointer to UNC array");
+   end;
+
+   declare
+      type Array_Type is array (Integer range <>) of Integer;
+      for Array_Type'Alignment use Align;
+
+      type THIN_Array_Access is access all Array_Type;
+      for THIN_Array_Access'Size use Standard'Address_Size;
+
+      function Allocate return THIN_Array_Access is
+      begin
+         return new Array_Type (1 .. 1);
+      end;
+
+      function Address (Ptr : THIN_Array_Access) return System.Address is
+      begin
+         return Ptr(1)'Address;
+      end;
+      package Check_THIN is new
+        Check (Array_Type, THIN_Array_Access, Allocate, Address);
+   begin
+      Check_THIN.Run ("Checking THIN pointer to UNC array");
+   end;
+
+   declare
+      type Array_Type is array (Integer range 1 .. 1) of Integer;
+      for Array_Type'Alignment use Align;
+
+      type Array_Access is access all Array_Type;
+
+      function Allocate return Array_Access is
+      begin
+         return new Array_Type;
+      end;
+
+      function Address (Ptr : Array_Access) return System.Address is
+      begin
+         return Ptr(1)'Address;
+      end;
+      package Check_Array is new
+        Check (Array_Type, Array_Access, Allocate, Address);
+   begin
+      Check_Array.Run ("Checking pointer to constrained array");
+   end;
+
+   declare
+      type Record_Type is record
+         Value : Integer;
+      end record;
+      for Record_Type'Alignment use Align;
+
+      type Record_Access is access all Record_Type;
+
+      function Allocate return Record_Access is
+      begin
+         return new Record_Type;
+      end;
+
+      function Address (Ptr : Record_Access) return System.Address is
+      begin
+         return Ptr.all'Address;
+      end;
+      package Check_Record is new
+        Check (Record_Type, Record_Access, Allocate, Address);
+   begin
+      Check_Record.Run ("Checking pointer to record");
+   end;
+end;
+