From: Olivier Hainque Date: Tue, 9 Jun 2009 15:32:03 +0000 (+0000) Subject: utils2.c (build_call_alloc_dealloc_proc): New helper for build_call_alloc_dealloc... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ff346f70754c95c575fabaecb428d29115e7a7a5;p=gcc.git utils2.c (build_call_alloc_dealloc_proc): New helper for build_call_alloc_dealloc with arguments to be interpreted... ada/ * 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) : 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. From-SVN: r148314 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f6ca7d7d0ec..03b7de53685 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2009-06-09 Olivier Hainque + + * 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) : + 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 * lib-writ.adb (flag_compare_debug): Import. diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 4d19b42e491..7bc89eef6fd 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -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 diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 2c471f1561f..d37e3c1971f 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -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; diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index ec72a27ebbc..aab01f9b5d7 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. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b08a0b91930..cb9ec0c3f35 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2009-06-09 Olivier Hainque + + * gnat.dg/align_max.adb: New test. + 2009-06-08 Jason Merrill * 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 index 00000000000..26597ea9661 --- /dev/null +++ b/gcc/testsuite/gnat.dg/align_max.adb @@ -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; +