utils2.c (build_allocator): Provide the extra arguments to make_aligning_type for super-aligned objects...
2007-04-20 Olivier Hainque <hainque@adacore.com> Eric Botcazou <ebotcazou@adacore.com> * utils2.c (build_allocator): Provide the extra arguments to make_aligning_type for super-aligned objects allocated from the default pool. Leave enough room for a pointer before the aligning field, and store the system's allocator return value there. (build_call_alloc_dealloc): When releasing a super-aligned object, retrieve the system's allocator return value from where build_allocator has stored it, just ahead of the adjusted address we are passed. (build_call_raise): Handle properly the generation of line numbers when the node is marked No_Location. (compare_elmt_bitpos): Use tree_int_cst_compare. Stabilize the sort by using DECL_UID on ties. (build_binary_op) <EQ_EXPR>: Accept fat pointer types with the same main variant. (build_call_raise): Handle converting exception into goto; support new argument KIND. (build_component_ref): Add new arg to build_call_raise. From-SVN: r125383
This commit is contained in:
parent
b3a22f38ea
commit
f2f4ef82f2
195
gcc/ada/utils2.c
195
gcc/ada/utils2.c
|
@ -833,19 +833,22 @@ build_binary_op (enum tree_code op_code, tree result_type,
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Otherwise, the base types must be the same unless the objects are
|
/* Otherwise, the base types must be the same unless the objects are
|
||||||
records. If we have records, use the best type and convert both
|
fat pointers or records. If we have records, use the best type and
|
||||||
operands to that type. */
|
convert both operands to that type. */
|
||||||
if (left_base_type != right_base_type)
|
if (left_base_type != right_base_type)
|
||||||
{
|
{
|
||||||
if (TREE_CODE (left_base_type) == RECORD_TYPE
|
if (TYPE_FAT_POINTER_P (left_base_type)
|
||||||
&& TREE_CODE (right_base_type) == RECORD_TYPE)
|
&& TYPE_FAT_POINTER_P (right_base_type)
|
||||||
|
&& TYPE_MAIN_VARIANT (left_base_type)
|
||||||
|
== TYPE_MAIN_VARIANT (right_base_type))
|
||||||
|
best_type = left_base_type;
|
||||||
|
else if (TREE_CODE (left_base_type) == RECORD_TYPE
|
||||||
|
&& TREE_CODE (right_base_type) == RECORD_TYPE)
|
||||||
{
|
{
|
||||||
/* The only way these are permitted to be the same is if both
|
/* The only way these are permitted to be the same is if both
|
||||||
types have the same name. In that case, one of them must
|
types have the same name. In that case, one of them must
|
||||||
not be self-referential. Use that one as the best type.
|
not be self-referential. Use that one as the best type.
|
||||||
Even better is if one is of fixed size. */
|
Even better is if one is of fixed size. */
|
||||||
best_type = NULL_TREE;
|
|
||||||
|
|
||||||
gcc_assert (TYPE_NAME (left_base_type)
|
gcc_assert (TYPE_NAME (left_base_type)
|
||||||
&& (TYPE_NAME (left_base_type)
|
&& (TYPE_NAME (left_base_type)
|
||||||
== TYPE_NAME (right_base_type)));
|
== TYPE_NAME (right_base_type)));
|
||||||
|
@ -860,12 +863,12 @@ build_binary_op (enum tree_code op_code, tree result_type,
|
||||||
best_type = right_base_type;
|
best_type = right_base_type;
|
||||||
else
|
else
|
||||||
gcc_unreachable ();
|
gcc_unreachable ();
|
||||||
|
|
||||||
left_operand = convert (best_type, left_operand);
|
|
||||||
right_operand = convert (best_type, right_operand);
|
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
gcc_unreachable ();
|
gcc_unreachable ();
|
||||||
|
|
||||||
|
left_operand = convert (best_type, left_operand);
|
||||||
|
right_operand = convert (best_type, right_operand);
|
||||||
}
|
}
|
||||||
|
|
||||||
/* If we are comparing a fat pointer against zero, we need to
|
/* If we are comparing a fat pointer against zero, we need to
|
||||||
|
@ -1459,28 +1462,60 @@ build_call_0_expr (tree fundecl)
|
||||||
|
|
||||||
GNAT_NODE is the gnat node conveying the source location for which the
|
GNAT_NODE is the gnat node conveying the source location for which the
|
||||||
error should be signaled, or Empty in which case the error is signaled on
|
error should be signaled, or Empty in which case the error is signaled on
|
||||||
the current ref_file_name/input_line. */
|
the current ref_file_name/input_line.
|
||||||
|
|
||||||
|
KIND says which kind of exception this is for
|
||||||
|
(N_Raise_{Constraint,Storage,Program}_Error). */
|
||||||
|
|
||||||
tree
|
tree
|
||||||
build_call_raise (int msg, Node_Id gnat_node)
|
build_call_raise (int msg, Node_Id gnat_node, char kind)
|
||||||
{
|
{
|
||||||
tree fndecl = gnat_raise_decls[msg];
|
tree fndecl = gnat_raise_decls[msg];
|
||||||
|
tree label = get_exception_label (kind);
|
||||||
|
tree filename;
|
||||||
|
int line_number;
|
||||||
|
const char *str;
|
||||||
|
int len;
|
||||||
|
|
||||||
const char *str
|
/* If this is to be done as a goto, handle that case. */
|
||||||
|
if (label)
|
||||||
|
{
|
||||||
|
Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
|
||||||
|
tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
|
||||||
|
|
||||||
|
/* If Local_Raise is present, generate
|
||||||
|
Local_Raise (exception'Identity); */
|
||||||
|
if (Present (local_raise))
|
||||||
|
{
|
||||||
|
tree gnu_local_raise
|
||||||
|
= gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
|
||||||
|
tree gnu_exception_entity
|
||||||
|
= gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
|
||||||
|
tree gnu_call
|
||||||
|
= build_call_1_expr (gnu_local_raise,
|
||||||
|
build_unary_op (ADDR_EXPR, NULL_TREE,
|
||||||
|
gnu_exception_entity));
|
||||||
|
|
||||||
|
gnu_result = build2 (COMPOUND_EXPR, void_type_node,
|
||||||
|
gnu_call, gnu_result);}
|
||||||
|
|
||||||
|
return gnu_result;
|
||||||
|
}
|
||||||
|
|
||||||
|
str
|
||||||
= (Debug_Flag_NN || Exception_Locations_Suppressed)
|
= (Debug_Flag_NN || Exception_Locations_Suppressed)
|
||||||
? ""
|
? ""
|
||||||
: (gnat_node != Empty)
|
: (gnat_node != Empty && Sloc (gnat_node) != No_Location)
|
||||||
? IDENTIFIER_POINTER
|
? IDENTIFIER_POINTER
|
||||||
(get_identifier (Get_Name_String
|
(get_identifier (Get_Name_String
|
||||||
(Debug_Source_Name
|
(Debug_Source_Name
|
||||||
(Get_Source_File_Index (Sloc (gnat_node))))))
|
(Get_Source_File_Index (Sloc (gnat_node))))))
|
||||||
: ref_filename;
|
: ref_filename;
|
||||||
|
|
||||||
int len = strlen (str) + 1;
|
len = strlen (str) + 1;
|
||||||
tree filename = build_string (len, str);
|
filename = build_string (len, str);
|
||||||
|
line_number
|
||||||
int line_number
|
= (gnat_node != Empty && Sloc (gnat_node) != No_Location)
|
||||||
= (gnat_node != Empty)
|
|
||||||
? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line;
|
? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line;
|
||||||
|
|
||||||
TREE_TYPE (filename)
|
TREE_TYPE (filename)
|
||||||
|
@ -1502,16 +1537,12 @@ compare_elmt_bitpos (const PTR rt1, const PTR rt2)
|
||||||
{
|
{
|
||||||
tree elmt1 = * (tree *) rt1;
|
tree elmt1 = * (tree *) rt1;
|
||||||
tree elmt2 = * (tree *) rt2;
|
tree elmt2 = * (tree *) rt2;
|
||||||
|
tree field1 = TREE_PURPOSE (elmt1);
|
||||||
|
tree field2 = TREE_PURPOSE (elmt2);
|
||||||
|
int ret;
|
||||||
|
|
||||||
tree pos_field1 = bit_position (TREE_PURPOSE (elmt1));
|
ret = tree_int_cst_compare (bit_position (field1), bit_position (field2));
|
||||||
tree pos_field2 = bit_position (TREE_PURPOSE (elmt2));
|
return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
|
||||||
|
|
||||||
if (tree_int_cst_equal (pos_field1, pos_field2))
|
|
||||||
return 0;
|
|
||||||
else if (tree_int_cst_lt (pos_field1, pos_field2))
|
|
||||||
return -1;
|
|
||||||
else
|
|
||||||
return 1;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Return a CONSTRUCTOR of TYPE whose list is LIST. */
|
/* Return a CONSTRUCTOR of TYPE whose list is LIST. */
|
||||||
|
@ -1552,13 +1583,11 @@ gnat_build_constructor (tree type, tree list)
|
||||||
|
|
||||||
/* For record types with constant components only, sort field list
|
/* For record types with constant components only, sort field list
|
||||||
by increasing bit position. This is necessary to ensure the
|
by increasing bit position. This is necessary to ensure the
|
||||||
constructor can be output as static data, which the gimplifier
|
constructor can be output as static data. */
|
||||||
might force in various circumstances. */
|
|
||||||
if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
|
if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
|
||||||
{
|
{
|
||||||
/* Fill an array with an element tree per index, and ask qsort to order
|
/* Fill an array with an element tree per index, and ask qsort to order
|
||||||
them according to what a bitpos comparison function says. */
|
them according to what a bitpos comparison function says. */
|
||||||
|
|
||||||
tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts);
|
tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts);
|
||||||
int i;
|
int i;
|
||||||
|
|
||||||
|
@ -1568,7 +1597,6 @@ gnat_build_constructor (tree type, tree list)
|
||||||
qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos);
|
qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos);
|
||||||
|
|
||||||
/* Then reconstruct the list from the sorted array contents. */
|
/* Then reconstruct the list from the sorted array contents. */
|
||||||
|
|
||||||
list = NULL_TREE;
|
list = NULL_TREE;
|
||||||
for (i = n_elmts - 1; i >= 0; i--)
|
for (i = n_elmts - 1; i >= 0; i--)
|
||||||
{
|
{
|
||||||
|
@ -1701,7 +1729,8 @@ build_component_ref (tree record_variable, tree component,
|
||||||
abort. */
|
abort. */
|
||||||
gcc_assert (field);
|
gcc_assert (field);
|
||||||
return build1 (NULL_EXPR, TREE_TYPE (field),
|
return build1 (NULL_EXPR, TREE_TYPE (field),
|
||||||
build_call_raise (CE_Discriminant_Check_Failed, Empty));
|
build_call_raise (CE_Discriminant_Check_Failed, Empty,
|
||||||
|
N_Raise_Constraint_Error));
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Build a GCC tree to call an allocation or deallocation function.
|
/* Build a GCC tree to call an allocation or deallocation function.
|
||||||
|
@ -1785,7 +1814,34 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
|
||||||
}
|
}
|
||||||
|
|
||||||
else if (gnu_obj)
|
else if (gnu_obj)
|
||||||
return build_call_1_expr (free_decl, gnu_obj);
|
{
|
||||||
|
/* If the required alignement was greater than what malloc guarantees,
|
||||||
|
what we have in gnu_obj here is an address dynamically adjusted to
|
||||||
|
match the requirement (see build_allocator). What we need to pass
|
||||||
|
to free is the initial underlying allocator's return value, which
|
||||||
|
has been stored just in front of the block we have. */
|
||||||
|
if (align > BIGGEST_ALIGNMENT)
|
||||||
|
{
|
||||||
|
/* We set GNU_OBJ
|
||||||
|
as * (void **)((void *)GNU_OBJ - (void *)sizeof(void *))
|
||||||
|
in two steps: */
|
||||||
|
|
||||||
|
/* GNU_OBJ (void *) = (void *)GNU_OBJ - (void *)sizeof (void *)) */
|
||||||
|
gnu_obj
|
||||||
|
= build_binary_op (MINUS_EXPR, ptr_void_type_node,
|
||||||
|
convert (ptr_void_type_node, gnu_obj),
|
||||||
|
convert (ptr_void_type_node,
|
||||||
|
TYPE_SIZE_UNIT (ptr_void_type_node)));
|
||||||
|
|
||||||
|
/* GNU_OBJ (void *) = *(void **)GNU_OBJ */
|
||||||
|
gnu_obj
|
||||||
|
= build_unary_op (INDIRECT_REF, NULL_TREE,
|
||||||
|
convert (build_pointer_type (ptr_void_type_node),
|
||||||
|
gnu_obj));
|
||||||
|
}
|
||||||
|
|
||||||
|
return build_call_1_expr (free_decl, gnu_obj);
|
||||||
|
}
|
||||||
|
|
||||||
/* ??? For now, disable variable-sized allocators in the stack since
|
/* ??? For now, disable variable-sized allocators in the stack since
|
||||||
we can't yet gimplify an ALLOCATE_EXPR. */
|
we can't yet gimplify an ALLOCATE_EXPR. */
|
||||||
|
@ -1936,25 +1992,62 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
|
||||||
if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
|
if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
|
||||||
size = ssize_int (-1);
|
size = ssize_int (-1);
|
||||||
|
|
||||||
/* If this is a type whose alignment is larger than the
|
/* If this is a type whose alignment is larger than what the underlying
|
||||||
biggest we support in normal alignment and this is in
|
allocator supports and this is in the default storage pool, make an
|
||||||
the default storage pool, make an "aligning type", allocate
|
"aligning" record type with room to store a pointer before the field,
|
||||||
it, point to the field we need, and return that. */
|
allocate an object of that type, store the system's allocator return
|
||||||
if (TYPE_ALIGN (type) > BIGGEST_ALIGNMENT
|
value just in front of the field and return the field's address. */
|
||||||
&& No (gnat_proc))
|
|
||||||
{
|
|
||||||
tree new_type = make_aligning_type (type, TYPE_ALIGN (type), size);
|
|
||||||
|
|
||||||
result = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (new_type),
|
if (TYPE_ALIGN (type) > BIGGEST_ALIGNMENT && No (gnat_proc))
|
||||||
BIGGEST_ALIGNMENT, Empty,
|
{
|
||||||
Empty, gnat_node);
|
/* Construct the aligning type with enough room for a pointer ahead
|
||||||
result = save_expr (result);
|
of the field, then allocate. */
|
||||||
result = convert (build_pointer_type (new_type), result);
|
tree record_type
|
||||||
result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
|
= make_aligning_type (type, TYPE_ALIGN (type), size,
|
||||||
result = build_component_ref (result, NULL_TREE,
|
BIGGEST_ALIGNMENT, POINTER_SIZE / BITS_PER_UNIT);
|
||||||
TYPE_FIELDS (new_type), 0);
|
|
||||||
result = convert (result_type,
|
tree record, record_addr;
|
||||||
build_unary_op (ADDR_EXPR, NULL_TREE, result));
|
|
||||||
|
record_addr
|
||||||
|
= build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (record_type),
|
||||||
|
BIGGEST_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 (MINUS_EXPR, ptr_void_type_node,
|
||||||
|
convert (ptr_void_type_node, result),
|
||||||
|
convert (ptr_void_type_node,
|
||||||
|
TYPE_SIZE_UNIT (ptr_void_type_node)));
|
||||||
|
|
||||||
|
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
|
else
|
||||||
result = convert (result_type,
|
result = convert (result_type,
|
||||||
|
|
Loading…
Reference in New Issue