1 files changed, 208 insertions, 149 deletions

diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index ec72a27..aab01f9b 100644
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -1830,95 +1830,99 @@ build_component_ref (tree record_variable, tree component,
 				   N_Raise_Constraint_Error));
 }
 
-/* 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);
+    }
 }
 
 /* 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.  */