This fixes an internal error on an overlay of 2 aliased unconstrained array
objects. These objects have a special layout (they contain the bounds ahead
of the array itself) so overlaying them is a bit delicate.
Tested on x86_64-suse-linux, applied on the mainline.
2015-06-01 Eric Botcazou <ebotca...@adacore.com>
* gcc-interface/gigi.h (build_simple_component_ref): Declare.
* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Deal with
address clause on aliased object with unconstrained nominal subtype.
Mark the aligning variable as artificial, do not convert the address
expression immediately but mark it as constant instead.
* gcc-interface/utils.c (convert): If the target type contains a
template, be prepared for an empty array.
(maybe_unconstrained_array): Likewise.
* gcc-interface/utils2.c (known_alignment) <POINTER_PLUS_EXPR>: Deal
with the pattern built for aligning types.
<INTEGER_CST>: Do not cap the value at BIGGEST_ALIGNMENT.
(build_simple_component_ref): Make public.
If the base object is a constructor that contains a template, fold the
result field by field.
2015-06-01 Eric Botcazou <ebotca...@adacore.com>
* gnat.dg/addr9_1.adb: New test.
* gnat.dg/addr9_2.adb: Likewise.
* gnat.dg/addr9_3.adb: Likewise.
* gnat.dg/addr9_4.adb: Likewise.
--
Eric BotcazouIndex: gcc-interface/utils.c
===================================================================
--- gcc-interface/utils.c (revision 223897)
+++ gcc-interface/utils.c (working copy)
@@ -4092,8 +4092,9 @@ convert (tree type, tree expr)
CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
build_template (TREE_TYPE (TYPE_FIELDS (type)),
obj_type, NULL_TREE));
- CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
- convert (obj_type, expr));
+ if (expr)
+ CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
+ convert (obj_type, expr));
return gnat_build_constructor (type, v);
}
@@ -4699,14 +4700,13 @@ maybe_unconstrained_array (tree exp)
if (TYPE_CONTAINS_TEMPLATE_P (type))
{
- exp = build_component_ref (exp, NULL_TREE,
- DECL_CHAIN (TYPE_FIELDS (type)),
- false);
- type = TREE_TYPE (exp);
+ exp = build_simple_component_ref (exp, NULL_TREE,
+ DECL_CHAIN (TYPE_FIELDS (type)),
+ false);
/* If the array type is padded, convert to the unpadded type. */
- if (TYPE_IS_PADDING_P (type))
- exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp);
+ if (exp && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
+ exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
}
break;
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c (revision 223897)
+++ gcc-interface/decl.c (working copy)
@@ -882,8 +882,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
check_ok_for_atomic_type (gnu_inner, gnat_entity, true);
}
- /* If this is an aliased object with an unconstrained nominal subtype,
- make a type that includes the template. */
+ /* If this is an aliased object with an unconstrained array nominal
+ subtype, make a type that includes the template. We will either
+ allocate or create a variable of that type, see below. */
if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
&& Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
&& !type_annotate_only)
@@ -1149,7 +1150,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
effects in this case. */
if (definition && Present (Address_Clause (gnat_entity)))
{
- Node_Id gnat_expr = Expression (Address_Clause (gnat_entity));
+ const Node_Id gnat_clause = Address_Clause (gnat_entity);
+ Node_Id gnat_expr = Expression (gnat_clause);
tree gnu_address
= present_gnu_tree (gnat_entity)
? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
@@ -1167,6 +1169,40 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
|| compile_time_known_address_p (gnat_expr);
gnu_size = NULL_TREE;
+ /* If this is an aliased object with an unconstrained array nominal
+ subtype, then it can overlay only another aliased object with an
+ unconstrained array nominal subtype and compatible template. */
+ if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
+ && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
+ && !type_annotate_only)
+ {
+ tree rec_type = TREE_TYPE (gnu_type);
+ tree off = byte_position (DECL_CHAIN (TYPE_FIELDS (rec_type)));
+
+ /* This is the pattern built for a regular object. */
+ if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
+ && TREE_OPERAND (gnu_address, 1) == off)
+ gnu_address = TREE_OPERAND (gnu_address, 0);
+ /* This is the pattern built for an overaligned object. */
+ else if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
+ && TREE_CODE (TREE_OPERAND (gnu_address, 1))
+ == PLUS_EXPR
+ && TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 1)
+ == off)
+ gnu_address
+ = build2 (POINTER_PLUS_EXPR, gnu_type,
+ TREE_OPERAND (gnu_address, 0),
+ TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 0));
+ else
+ {
+ post_error_ne ("aliased object& with unconstrained array "
+ "nominal subtype", gnat_clause,
+ gnat_entity);
+ post_error ("\\can overlay only aliased object with "
+ "compatible subtype", gnat_clause);
+ }
+ }
+
/* If this is a deferred constant, the initializer is attached to
the full view. */
if (kind == E_Constant && Present (Full_View (gnat_entity)))
@@ -1183,11 +1219,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
else
gnu_expr
= build2 (COMPOUND_EXPR, gnu_type,
- build_binary_op
- (MODIFY_EXPR, NULL_TREE,
- build_unary_op (INDIRECT_REF, NULL_TREE,
- gnu_address),
- gnu_expr),
+ build_binary_op (INIT_EXPR, NULL_TREE,
+ build_unary_op (INDIRECT_REF,
+ NULL_TREE,
+ gnu_address),
+ gnu_expr),
gnu_address);
}
@@ -1302,8 +1338,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
/* If this object would go into the stack and has an alignment larger
than the largest stack alignment the back-end can honor, resort to
a variable of "aligning type". */
- if (!global_bindings_p () && !static_p && definition
- && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
+ if (definition
+ && !global_bindings_p ()
+ && !static_p
+ && !imported_p
+ && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
{
/* Create the new variable. No need for extra room before the
aligned field as this is in automatic storage. */
@@ -1315,11 +1354,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
= create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
NULL_TREE, gnu_new_type, NULL_TREE, false,
false, false, false, NULL, gnat_entity);
+ DECL_ARTIFICIAL (gnu_new_var) = 1;
/* Initialize the aligned field if we have an initializer. */
if (gnu_expr)
add_stmt_with_node
- (build_binary_op (MODIFY_EXPR, NULL_TREE,
+ (build_binary_op (INIT_EXPR, NULL_TREE,
build_component_ref
(gnu_new_var, NULL_TREE,
TYPE_FIELDS (gnu_new_type), false),
@@ -1330,28 +1370,26 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
gnu_type = build_reference_type (gnu_type);
gnu_expr
= build_unary_op
- (ADDR_EXPR, gnu_type,
+ (ADDR_EXPR, NULL_TREE,
build_component_ref (gnu_new_var, NULL_TREE,
TYPE_FIELDS (gnu_new_type), false));
+ TREE_CONSTANT (gnu_expr) = 1;
used_by_ref = true;
const_flag = true;
gnu_size = NULL_TREE;
}
- /* If this is an aliased object with an unconstrained nominal subtype,
- we make its type a thin reference, i.e. the reference counterpart
- of a thin pointer, so that it points to the array part. This is
- aimed at making it easier for the debugger to decode the object.
- Note that we have to do that this late because of the couple of
- allocation adjustments that might be made just above. */
+ /* If this is an aliased object with an unconstrained array nominal
+ subtype, we make its type a thin reference, i.e. the reference
+ counterpart of a thin pointer, so it points to the array part.
+ This is aimed to make it easier for the debugger to decode the
+ object. Note that we have to do it this late because of the
+ couple of allocation adjustments that might be made above. */
if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
&& Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
&& !type_annotate_only)
{
- tree gnu_array
- = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
-
/* In case the object with the template has already been allocated
just above, we have nothing to do here. */
if (!TYPE_IS_THIN_POINTER_P (gnu_type))
@@ -1362,8 +1400,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
const_flag, Is_Public (gnat_entity),
imported_p || !definition, static_p,
NULL, gnat_entity);
- gnu_expr
- = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
+ gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
TREE_CONSTANT (gnu_expr) = 1;
used_by_ref = true;
@@ -1372,6 +1409,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
gnu_size = NULL_TREE;
}
+ tree gnu_array
+ = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
gnu_type
= build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
}
Index: gcc-interface/utils2.c
===================================================================
--- gcc-interface/utils2.c (revision 223897)
+++ gcc-interface/utils2.c (working copy)
@@ -78,9 +78,9 @@ get_base_type (tree type)
return type;
}
-/* EXP is a GCC tree representing an address. See if we can find how
- strictly the object at that address is aligned. Return that alignment
- in bits. If we don't know anything about the alignment, return 0. */
+/* EXP is a GCC tree representing an address. See if we can find how strictly
+ the object at this address is aligned and, if so, return the alignment of
+ the object in bits. Otherwise return 0. */
unsigned int
known_alignment (tree exp)
@@ -99,13 +99,13 @@ known_alignment (tree exp)
break;
case COMPOUND_EXPR:
- /* The value of a COMPOUND_EXPR is that of it's second operand. */
+ /* The value of a COMPOUND_EXPR is that of its second operand. */
this_alignment = known_alignment (TREE_OPERAND (exp, 1));
break;
case PLUS_EXPR:
case MINUS_EXPR:
- /* If two address are added, the alignment of the result is the
+ /* If two addresses are added, the alignment of the result is the
minimum of the two alignments. */
lhs = known_alignment (TREE_OPERAND (exp, 0));
rhs = known_alignment (TREE_OPERAND (exp, 1));
@@ -113,10 +113,20 @@ known_alignment (tree exp)
break;
case POINTER_PLUS_EXPR:
- lhs = known_alignment (TREE_OPERAND (exp, 0));
- rhs = known_alignment (TREE_OPERAND (exp, 1));
+ /* If this is the pattern built for aligning types, decode it. */
+ if (TREE_CODE (TREE_OPERAND (exp, 1)) == BIT_AND_EXPR
+ && TREE_CODE (TREE_OPERAND (TREE_OPERAND (exp, 1), 0)) == NEGATE_EXPR)
+ {
+ tree op = TREE_OPERAND (TREE_OPERAND (exp, 1), 1);
+ return
+ known_alignment (fold_build1 (BIT_NOT_EXPR, TREE_TYPE (op), op));
+ }
+
/* If we don't know the alignment of the offset, we assume that
of the base. */
+ lhs = known_alignment (TREE_OPERAND (exp, 0));
+ rhs = known_alignment (TREE_OPERAND (exp, 1));
+
if (rhs == 0)
this_alignment = lhs;
else
@@ -124,7 +134,7 @@ known_alignment (tree exp)
break;
case COND_EXPR:
- /* If there is a choice between two values, use the smallest one. */
+ /* If there is a choice between two values, use the smaller one. */
lhs = known_alignment (TREE_OPERAND (exp, 1));
rhs = known_alignment (TREE_OPERAND (exp, 2));
this_alignment = MIN (lhs, rhs);
@@ -135,7 +145,7 @@ known_alignment (tree exp)
unsigned HOST_WIDE_INT c = TREE_INT_CST_LOW (exp);
/* The first part of this represents the lowest bit in the constant,
but it is originally in bytes, not bits. */
- this_alignment = MIN (BITS_PER_UNIT * (c & -c), BIGGEST_ALIGNMENT);
+ this_alignment = (c & -c) * BITS_PER_UNIT;
}
break;
@@ -172,7 +182,7 @@ known_alignment (tree exp)
return known_alignment (t);
}
- /* Fall through... */
+ /* ... fall through ... */
default:
/* For other pointer expressions, we assume that the pointed-to object
@@ -1990,7 +2000,7 @@ gnat_build_constructor (tree type, vec<c
We also handle the fact that we might have been passed a pointer to the
actual record and know how to look for fields in variant parts. */
-static tree
+tree
build_simple_component_ref (tree record_variable, tree component, tree field,
bool no_fold_p)
{
@@ -2128,18 +2138,26 @@ build_simple_component_ref (tree record_
if (TREE_CODE (base) == CONSTRUCTOR
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (base)))
{
- vec<constructor_elt, va_gc> *elts = CONSTRUCTOR_ELTS (base);
- unsigned HOST_WIDE_INT idx;
- tree index, value;
- FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value)
- if (index == field)
- return value;
+ unsigned int len = CONSTRUCTOR_NELTS (base);
+ gcc_assert (len > 0);
+
+ if (field == CONSTRUCTOR_ELT (base, 0)->index)
+ return CONSTRUCTOR_ELT (base, 0)->value;
+
+ if (len > 1)
+ {
+ if (field == CONSTRUCTOR_ELT (base, 1)->index)
+ return CONSTRUCTOR_ELT (base, 1)->value;
+ }
+ else
+ return NULL_TREE;
+
return ref;
}
return fold (ref);
}
-
+
/* Likewise, but generate a Constraint_Error if the reference could not be
found. */
Index: gcc-interface/gigi.h
===================================================================
--- gcc-interface/gigi.h (revision 223897)
+++ gcc-interface/gigi.h (working copy)
@@ -914,6 +914,11 @@ extern tree gnat_build_constructor (tree
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL,
for the field, or both. Don't fold the result if NO_FOLD_P. */
+extern tree build_simple_component_ref (tree record_variable, tree component,
+ tree field, bool no_fold_p);
+
+/* Likewise, but generate a Constraint_Error if the reference could not be
+ found. */
extern tree build_component_ref (tree record_variable, tree component,
tree field, bool no_fold_p);
-- { dg-do compile }
with Ada.Streams; use Ada.Streams;
procedure Addr9_1 is
type Signal_Type is mod 2 ** 16;
type A_Item is record
I : Signal_Type;
Q : Signal_Type;
end record
with Size => 32;
for A_Item use record
I at 0 range 0 .. 15;
Q at 2 range 0 .. 15;
end record;
type A_Array_Type is
array (Positive range <>)
of A_Item
with Alignment => 16;
pragma Pack (A_Array_Type);
type B_Array_Type is new Ada.Streams.Stream_Element_Array
with Alignment => 16;
Ct_Count : constant := 7_000;
package Set is
A : aliased A_Array_Type := (1 .. Ct_Count => <>);
B : aliased B_Array_Type := (1 .. Ct_Count * A_Item'Size / 8 => <>);
for B'Address use A'Address;
end Set;
begin
null;
end;
-- { dg-do compile }
with Ada.Streams; use Ada.Streams;
procedure Addr9_2 is
type Signal_Type is mod 2 ** 16;
type A_Item is record
I : Signal_Type;
Q : Signal_Type;
end record
with Size => 32;
for A_Item use record
I at 0 range 0 .. 15;
Q at 2 range 0 .. 15;
end record;
type A_Array_Type is
array (Positive range <>)
of A_Item
with Alignment => 16;
pragma Pack (A_Array_Type);
type B_Array_Type is new Ada.Streams.Stream_Element_Array
with Alignment => 16;
Ct_Count : constant := 7_000;
package Set is
A : A_Array_Type := (1 .. Ct_Count => <>);
B : aliased B_Array_Type := (1 .. Ct_Count * A_Item'Size / 8 => <>);
for B'Address use A'Address; -- { dg-warning "aliased object" }
end Set;
begin
null;
end;
-- { dg-do compile }
with Ada.Streams; use Ada.Streams;
procedure Addr9_3 is
type Signal_Type is mod 2 ** 16;
type A_Item is record
I : Signal_Type;
Q : Signal_Type;
end record
with Size => 32;
for A_Item use record
I at 0 range 0 .. 15;
Q at 2 range 0 .. 15;
end record;
type A_Array_Type is
array (Positive range <>)
of A_Item
with Alignment => 16;
pragma Pack (A_Array_Type);
type B_Array_Type is new Ada.Streams.Stream_Element_Array
with Alignment => 16;
Ct_Count : constant := 7_000;
package Set is
A : aliased A_Array_Type := (1 .. Ct_Count => <>);
B : B_Array_Type := (1 .. Ct_Count * A_Item'Size / 8 => <>);
for B'Address use A'Address;
end Set;
begin
null;
end;
-- { dg-do compile }
with Ada.Streams; use Ada.Streams;
procedure Addr9_4 is
type Signal_Type is mod 2 ** 16;
type A_Item is record
I : Signal_Type;
Q : Signal_Type;
end record
with Size => 32;
for A_Item use record
I at 0 range 0 .. 15;
Q at 2 range 0 .. 15;
end record;
type A_Array_Type is
array (Positive range <>)
of A_Item
with Alignment => 16;
pragma Pack (A_Array_Type);
type B_Array_Type is new Ada.Streams.Stream_Element_Array
with Alignment => 16;
Ct_Count : constant := 7_000;
package Set is
A : A_Array_Type := (1 .. Ct_Count => <>);
B : B_Array_Type := (1 .. Ct_Count * A_Item'Size / 8 => <>);
for B'Address use A'Address;
end Set;
begin
null;
end;
