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. */
|| (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
{
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)
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));
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. */
--- /dev/null
+-- { 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;
+
projects / gcc.git / commitdiff