@@ -2119,6 +2119,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
case E_Array_Type:
{
+ const Entity_Id OAT = Original_Array_Type (gnat_entity);
const Entity_Id PAT = Packed_Array_Impl_Type (gnat_entity);
const bool convention_fortran_p
= (Convention (gnat_entity) == Convention_Fortran);
@@ -2392,14 +2393,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
set_typeless_storage_on_aggregate_type (tem);
}
- /* If this is a packed type implemented specially, then process the
- implementation type so it is elaborated in the proper scope. */
- if (Present (PAT))
- gnat_to_gnu_entity (PAT, NULL_TREE, false);
-
- /* Otherwise, if an alignment is specified, use it if valid and, if
- the alignment was requested with an explicit clause, state so. */
- else if (Known_Alignment (gnat_entity))
+ /* If an alignment is specified for an array that is not a packed type
+ implemented specially, use the alignment if it is valid and, if it
+ was requested with an explicit clause, preserve the information. */
+ if (Known_Alignment (gnat_entity) && No (PAT))
{
SET_TYPE_ALIGN (tem,
validate_alignment (Alignment (gnat_entity),
@@ -2418,7 +2415,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
TYPE_BIT_PACKED_ARRAY_TYPE_P (tem)
= (Is_Packed_Array_Impl_Type (gnat_entity)
- ? Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))
+ ? Is_Bit_Packed_Array (OAT)
: Is_Bit_Packed_Array (gnat_entity));
if (Treat_As_Volatile (gnat_entity))
@@ -2447,8 +2444,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
TYPE_ARRAY_MAX_SIZE (tem) = gnu_max_size;
/* See the above description for the rationale. */
- create_type_decl (create_concat_name (gnat_entity, "XUA"), tem,
- artificial_p, debug_info_p, gnat_entity);
+ tree gnu_tmp_decl
+ = create_type_decl (create_concat_name (gnat_entity, "XUA"), tem,
+ artificial_p, debug_info_p, gnat_entity);
TYPE_CONTEXT (tem) = gnu_fat_type;
TYPE_CONTEXT (TYPE_POINTER_TO (tem)) = gnu_fat_type;
@@ -2475,6 +2473,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
SET_TYPE_MODE (gnu_type, BLKmode);
SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
+
+ /* If this is a packed type implemented specially, then process the
+ implementation type so it is elaborated in the proper scope. */
+ if (Present (PAT))
+ {
+ /* Save the XUA type as our equivalent temporarily for the call
+ to gnat_to_gnu_type on the OAT below. */
+ save_gnu_tree (gnat_entity, gnu_tmp_decl, false);
+ gnat_to_gnu_entity (PAT, NULL_TREE, false);
+ save_gnu_tree (gnat_entity, NULL_TREE, false);
+ }
+
+ /* If this is precisely the implementation type and it has the same
+ component as the original type (which happens for peculiar index
+ types), copy the alias set from the latter; this ensures that all
+ implementation types built on the fly have the same alias set. */
+ if (Is_Packed_Array_Impl_Type (gnat_entity)
+ && Component_Type (gnat_entity) == Component_Type (OAT))
+ relate_alias_sets (gnu_type, gnat_to_gnu_type (OAT), ALIAS_SET_COPY);
}
break;
@@ -4763,8 +4780,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& align_clause))
TYPE_USER_ALIGN (gnu_type) = 1;
- /* Record whether a pragma Universal_Aliasing was specified. */
- if (Universal_Aliasing (gnat_entity) && !TYPE_IS_DUMMY_P (gnu_type))
+ /* Record whether a pragma Universal_Aliasing was specified. Also
+ consider that it is always present on interface types because,
+ while they are abstract tagged types and thus no object of these
+ types exists anywhere, they are used to access objects of types
+ that implement them. */
+ if ((Universal_Aliasing (gnat_entity) || Is_Interface (gnat_entity))
+ && !TYPE_IS_DUMMY_P (gnu_type))
{
/* Set TYPE_TYPELESS_STORAGE if this is an aggregate type and
TYPE_UNIVERSAL_ALIASING_P otherwise, since the former is not
@@ -254,8 +254,8 @@ static tree emit_check (tree, tree, int, Node_Id);
static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
static tree convert_with_check (Entity_Id, tree, bool, bool, Node_Id);
-static bool addressable_p (tree gnu_expr, tree gnu_type = NULL_TREE,
- Node_Id gnat_expr = Empty);
+static bool addressable_p (tree, tree);
+static bool aliasable_p (tree, tree);
static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
static tree pos_to_constructor (Node_Id, tree);
static void validate_unchecked_conversion (Node_Id);
@@ -4850,6 +4850,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type);
tree gnu_formal = present_gnu_tree (gnat_formal)
? get_gnu_tree (gnat_formal) : NULL_TREE;
+ tree gnu_actual_type = gnat_to_gnu_type (Etype (gnat_actual));
const bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
const bool is_true_formal_parm
= gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
@@ -4865,8 +4866,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
We do it in the In case too, except for a formal passed by reference
and an actual which is an unchecked conversion to an elementary type
or constrained composite type because it itself can cause the actual
- to be misaligned or the strict aliasing rules to be violated and the
- addressability test needs to be applied to the real object. */
+ to be misaligned and the addressability test needs to be applied to
+ the real object. */
const bool suppress_type_conversion
= ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
&& (!in_param
@@ -4878,6 +4879,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
Node_Id gnat_name = suppress_type_conversion
? Expression (gnat_actual) : gnat_actual;
tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
+ bool aliasing = false;
/* If it's possible we may need to use this expression twice, make sure
that any side-effects are handled via SAVE_EXPRs; likewise if we need
@@ -4893,10 +4895,14 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
/* If we are passing a non-addressable parameter by reference, pass the
address of a copy. In the In Out or Out case, set up to copy back
- out after the call. */
+ out after the call. Moreover, in the case of a conversion, if we
+ are passing a non-aliasable parameter, also pass the address of a
+ copy to avoid breaking strict aliasing rules. */
if (is_by_ref_formal_parm
&& (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
- && !addressable_p (gnu_name, gnu_name_type, gnat_name))
+ && (!addressable_p (gnu_name, gnu_name_type)
+ || (node_is_type_conversion (gnat_actual)
+ && (aliasing = !aliasable_p (gnu_name, gnu_actual_type)))))
{
tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
@@ -4922,6 +4928,37 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
post_error ("misaligned actual cannot be passed by reference??",
gnat_actual);
+ /* If the copy needs to be made because of aliasing considerations,
+ issue a warning because this was historically not necessary. */
+ else if (aliasing)
+ {
+ if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
+ {
+ post_error
+ ("unchecked conversion implemented by copy??",
+ gnat_actual);
+ post_error
+ ("\\?use pragma Universal_Aliasing on either type",
+ gnat_actual);
+ post_error
+ ("\\?to enable RM 13.9(12) implementation permission",
+ gnat_actual);
+ }
+
+ else
+ {
+ post_error
+ ("value conversion implemented by copy??",
+ gnat_actual);
+ post_error
+ ("\\?use pair of types with same root type",
+ gnat_actual);
+ post_error
+ ("\\?to avoid new object in RM 4.6(58.5/5)",
+ gnat_actual);
+ }
+ }
+
/* If the actual type of the object is already the nominal type,
we have nothing to do, except if the size is self-referential
in which case we'll remove the unpadding below. */
@@ -4952,6 +4989,17 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
TREE_TYPE (gnu_name))))
gnu_name = convert (gnu_name_type, gnu_name);
+ /* If the temporary is created because of aliasing considerations,
+ it must be in the target type of the (unchecked) conversion. */
+ if (aliasing)
+ {
+ if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
+ gnu_name = unchecked_convert (gnu_actual_type, gnu_name,
+ No_Truncation (gnat_actual));
+ else
+ gnu_name = convert (gnu_actual_type, gnu_name);
+ }
+
/* If this is an In Out or Out parameter and we're returning a value,
we need to create a temporary for the return value because we must
preserve it before copying back at the very end. */
@@ -5011,6 +5059,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
}
/* Start from the real object and build the actual. */
+ tree gnu_unpadded_actual_type = get_unpadded_type (Etype (gnat_actual));
tree gnu_actual = gnu_name;
/* If atomic access is required for an In or In Out actual parameter,
@@ -5025,8 +5074,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
So do it here for the part we will use as an input, if any. */
if (Ekind (gnat_formal) != E_Out_Parameter
&& TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
- gnu_actual
- = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
+ gnu_actual = convert (gnu_unpadded_actual_type, gnu_actual);
/* Put back the conversion we suppressed above in the computation of the
real object. And even if we didn't suppress any conversion there, we
@@ -5036,12 +5084,11 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
pointer to it, but that's OK when the formal is passed by reference.
We also do not put back a conversion between an actual and a formal
that are unconstrained array types to avoid creating local bounds. */
- tree gnu_actual_type = get_unpadded_type (Etype (gnat_actual));
- if (TYPE_IS_DUMMY_P (gnu_actual_type))
+ if (TYPE_IS_DUMMY_P (gnu_unpadded_actual_type))
gcc_assert (is_true_formal_parm && DECL_BY_REF_P (gnu_formal));
else if (suppress_type_conversion
&& Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
- gnu_actual = unchecked_convert (gnu_actual_type, gnu_actual,
+ gnu_actual = unchecked_convert (gnu_unpadded_actual_type, gnu_actual,
No_Truncation (gnat_actual));
else if ((TREE_CODE (TREE_TYPE (gnu_actual)) == UNCONSTRAINED_ARRAY_TYPE
|| (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
@@ -5049,7 +5096,16 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
&& TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
;
else
- gnu_actual = convert (gnu_actual_type, gnu_actual);
+ gnu_actual = convert (gnu_unpadded_actual_type, gnu_actual);
+
+ /* If the formal parameter is passed by reference, check that building
+ the address of the actual parameter below will not end up violating
+ strict aliasing rules; that's the case for a VIEW_CONVERT_EXPR when
+ the source and target types may not alias each other. */
+ if (is_by_ref_formal_parm
+ && TREE_CODE (gnu_actual) == VIEW_CONVERT_EXPR
+ && (flag_checking || flag_strict_aliasing))
+ gcc_assert (aliasable_p (gnu_actual, gnu_actual_type));
gigi_checking_assert (!Do_Range_Check (gnat_actual));
@@ -5065,8 +5121,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
/* If we have a padded type, be sure we've removed padding. */
if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
- gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
- gnu_actual);
+ gnu_actual = convert (gnu_unpadded_actual_type, gnu_actual);
/* If it is the constructed subtype of an array allocated with
its bounds, the type of the actual includes the template,
@@ -5076,7 +5131,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
&& Is_Constr_Array_Subt_With_Bounds (Etype (gnat_actual)))
- gnu_actual = convert (gnu_actual_type, gnu_actual);
+ gnu_actual = convert (gnu_unpadded_actual_type, gnu_actual);
}
/* There is no need to convert the actual to the formal's type before
@@ -5087,7 +5142,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
/* Put back the conversion we suppressed above for In Out or Out
parameters, since it may set the bounds of the actual. */
if (!in_param && suppress_type_conversion)
- gnu_actual = convert (gnu_actual_type, gnu_actual);
+ gnu_actual = convert (gnu_unpadded_actual_type, gnu_actual);
gnu_actual = convert (gnu_formal_type, gnu_actual);
}
@@ -10065,12 +10120,11 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p,
return convert (gnu_type, gnu_result);
}
-/* Return true if GNU_EXPR can be directly addressed. This is the case
+/* Return true if GNU_EXPR may be directly addressed. This is the case
unless it is an expression involving computation or if it involves a
reference to a bitfield or to an object not sufficiently aligned for
its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
- be directly addressed as an object of this type. GNAT_EXPR is the
- GNAT expression that has been translated into GNU_EXPR.
+ be directly addressed as an object of this type.
*** Notes on addressability issues in the Ada compiler ***
@@ -10127,7 +10181,7 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p,
generated to connect everything together. */
static bool
-addressable_p (tree gnu_expr, tree gnu_type, Node_Id gnat_expr)
+addressable_p (tree gnu_expr, tree gnu_type)
{
/* For an integral type, the size of the actual type of the object may not
be greater than that of the expected type, otherwise an indirect access
@@ -10193,8 +10247,8 @@ addressable_p (tree gnu_expr, tree gnu_type, Node_Id gnat_expr)
case COND_EXPR:
/* We accept &COND_EXPR as soon as both operands are addressable and
expect the outcome to be the address of the selected operand. */
- return (addressable_p (TREE_OPERAND (gnu_expr, 1))
- && addressable_p (TREE_OPERAND (gnu_expr, 2)));
+ return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
+ && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
case COMPONENT_REF:
return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
@@ -10209,40 +10263,22 @@ addressable_p (tree gnu_expr, tree gnu_type, Node_Id gnat_expr)
>= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
/* The field of a padding record is always addressable. */
|| TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
- && addressable_p (TREE_OPERAND (gnu_expr, 0)));
+ && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
case ARRAY_REF: case ARRAY_RANGE_REF:
case REALPART_EXPR: case IMAGPART_EXPR:
case NOP_EXPR:
- return addressable_p (TREE_OPERAND (gnu_expr, 0));
+ return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
case CONVERT_EXPR:
return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
- && addressable_p (TREE_OPERAND (gnu_expr, 0)));
+ && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
case VIEW_CONVERT_EXPR:
{
- tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
+ /* This is addressable only if a copy need not be made downstream. */
tree type = TREE_TYPE (gnu_expr);
- alias_set_type inner_set, set;
-
- /* Taking the address of a VIEW_CONVERT_EXPR of an expression violates
- strict aliasing rules if the source and target types are unrelated.
- This would happen in an Ada program that itself does *not* contain
- such a violation, through type punning done by means of an instance
- of Unchecked_Conversion. Detect this case and force a temporary to
- prevent the violation from occurring, which is always allowed by
- the semantics of function calls in Ada, unless the source type or
- the target type have alias set 0, i.e. may alias anything. */
- if (Present (gnat_expr)
- && Nkind (gnat_expr) == N_Unchecked_Type_Conversion
- && Nkind (Original_Node (gnat_expr)) == N_Function_Call
- && (inner_set = get_alias_set (inner_type)) != 0
- && (set = get_alias_set (type)) != 0
- && inner_set != set)
- return false;
-
- /* Otherwise this is addressable if we can avoid a copy. */
+ tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
&& (!STRICT_ALIGNMENT
|| TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
@@ -10254,7 +10290,7 @@ addressable_p (tree gnu_expr, tree gnu_type, Node_Id gnat_expr)
|| TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
|| TYPE_ALIGN_OK (type)
|| TYPE_ALIGN_OK (inner_type))))
- && addressable_p (TREE_OPERAND (gnu_expr, 0)));
+ && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
}
default:
@@ -10262,6 +10298,45 @@ addressable_p (tree gnu_expr, tree gnu_type, Node_Id gnat_expr)
}
}
+/* Return true if GNU_EXPR may be aliased by an object of GNU_TYPE in the
+ context of by-reference parameter passing. This is the case when the
+ object (ultimately) referenced through GNU_EXPR has a type whose alias
+ set is either effectively 0, or equal to, or a subset of the alias set
+ of GNU_TYPE.
+
+ When the predicate returns true, it is possible to take the address of
+ GNU_EXPR without violating strict aliasing rules. When it does not, no
+ such guarantee holds, so a temporary with GNU_TYPE needs to be created
+ and its address passed instead (provided that this be legal of course). */
+
+static bool
+aliasable_p (tree gnu_expr, tree gnu_type)
+{
+ /* This is the source of the possible violation: taking the address of an
+ object in a type that does not correspond to its declared type. */
+ if (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR)
+ gnu_expr = TREE_OPERAND (gnu_expr, 0);
+
+ /* Work around get_deref_alias_set and alias_set_subset_of being disabled
+ when flag_strict_aliasing is 0. */
+ const bool saved_flag_strict_aliasing = flag_strict_aliasing;
+
+ flag_strict_aliasing = 1;
+
+ /* Call get_deref_alias_set to catch ref-all and void* pointers. */
+ const alias_set_type set1
+ = TREE_CODE (gnu_expr) == INDIRECT_REF
+ ? get_deref_alias_set (TREE_OPERAND (gnu_expr, 0))
+ : get_alias_set (TREE_TYPE (gnu_expr));
+ const alias_set_type set2 = get_alias_set (gnu_type);
+
+ bool ret = set1 == 0 || set1 == set2 || alias_set_subset_of (set1, set2);
+
+ flag_strict_aliasing = saved_flag_strict_aliasing;
+
+ return ret;
+}
+
/* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
If a Freeze node exists for the entity, delay the bulk of the processing.
Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
@@ -1036,9 +1036,9 @@ build_binary_op (enum tree_code op_code, tree result_type,
if (op_code == ARRAY_RANGE_REF
&& TREE_TYPE (operation_type) != TREE_TYPE (left_type))
{
- operation_type
- = build_nonshared_array_type (TREE_TYPE (left_type),
- TYPE_DOMAIN (operation_type));
+ operation_type = copy_type (operation_type);
+ TREE_TYPE (operation_type) = TREE_TYPE (left_type);
+
/* Declare it now since it will never be declared otherwise. This
is necessary to ensure that its subtrees are properly marked. */
create_type_decl (TYPE_NAME (operation_type), operation_type, true,
From: Eric Botcazou <ebotcazou@adacore.com> This fixes another long-standing (implicit) violation of the strict aliasing rules that occurs when the result of a value conversion is directly passed as an actual parameter in a call to a subprogram and the passing mechanism is by reference. In this case, the reference passed to the subprogram may be to a type that is too different from the type of the underlying object, which is the definition of such a violation. The change reworks and strengthens the previous fix as follows: first, the detection of these violations is moved into a dedicated predicate; second, an assertion is added to check that none of them has been missed, which is triggered by either -fchecking or -fstrict-aliasing, as the closely related assertion that is present in relate_alias_sets. The assertion uncovered two internal sources of violations: implementation types for packed array types with peculiar index types and interface types, which are fixed by propagating alias sets in the first case and resorting to universal aliasing in the second case. Finally, an unconditional warning is implemented to inform the user that the temporary is created and to suggest a possible solution to prevent that. gcc/ada/ * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Array_Type>: For a packed type implemented specially, temporarily save the XUA type as equivalent to the entity before processing the implementation type. For this implementation type, if its component type is the same as that of the original type, copy the alias set from the latter. <types>: Resort to universal aliasing for all interface types. * gcc-interface/trans.cc (Call_to_gnu): Add GNU_ACTUAL_TYPE local variable and rename existing one to GNU_UNPADDED_ACTUAL_TYPE. If the formal is passed by reference and the actual is a conversion, call aliasable_p to detect aliasing violations, issue a warning upon finding one and create the temporary in the target type. Add an assertion that no such violation has been missed above. (addressable_p): Revert latest changes. (aliasable_p): New predicate. * gcc-interface/utils2.cc (build_binary_op) <ARRAY_RANGE_REF>: When creating a new array type on the fly, preserve the alias set of the operation type. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/decl.cc | 48 ++++++--- gcc/ada/gcc-interface/trans.cc | 167 +++++++++++++++++++++++--------- gcc/ada/gcc-interface/utils2.cc | 6 +- 3 files changed, 159 insertions(+), 62 deletions(-)