This fixes various cases of a common pattern that would result in an ICE in
the gimplifier because it is trying to create a temporary of variable size.
Tested on x86_64-suse-linux, applied on the mainline.
2015-05-28 Eric Botcazou <ebotca...@adacore.com>
* gcc-interface/gigi.h (gnat_stabilize_reference): Adjust.
(rewrite_fn): Remove third parameter.
(type_is_padding_self_referential): New inline predicate.
(return_type_with_variable_size_p): Likewise.
* gcc-interface/decl.c (allocatable_size_p): More around.
(cannot_be_superflat_p): Rename into...
(cannot_be_superflat ): ...this.
(initial_value_needs_conversion): New predicate.
(gnat_to_gnu_entity): Invoke type_is_padding_self_referential,
initial_value_needs_conversion and adjust to above renaming.
For a renaming, force the materialization if the inner expression
is compound. Adjust calls to elaborate_reference and build a
compound expression if needed.
(struct er_dat): Add N field.
(elaborate_reference_1): Remove N parameter and adjust.
(elaborate_reference): Add INIT parameter and pass it in the call to
gnat_rewrite_reference. Adjust initial expression.
* gcc-interface/trans.c (Call_to_gnu): Treat renamings the same way as
regular object declarations when it comes to creating a temporary.
Adjust call to gnat_stabilize_reference and build a compound expression
if needed. Invoke return_type_with_variable_size_p.
(gnat_to_gnu): Invoke type_is_padding_self_referential. In case #4,
return a call to a function unmodified if it returns with variable size
and is also the initial expression in an object declaration.
* gcc-interface/utils2.c (build_binary_op) <INIT_EXPR>: Use the RHS'
type if it is a call to a function that returns with variable size.
(build_unary_op): Invoke type_is_padding_self_referential.
(gnat_stabilize_reference_1): Remove N parameter and adjust.
(gnat_stabilize_reference): Add INIT parameter and pass it in the call
to gnat_rewrite_reference.
(gnat_rewrite_reference): Remove N, add INIT parameter and adjust.
<COMPOUND_EXPR>: New case.
2015-05-28 Eric Botcazou <ebotca...@adacore.com>
* gnat.dg/varsize_temp.adb: Rename into...
* gnat.dg/varsize1.adb: ...this.
* gnat.dg/varsize_copy.ad[sb]: Rename into...
* gnat.dg/varsize2.ad[sb]: ...this.
* gnat.dg/varsize3_1.adb: New test.
* gnat.dg/varsize3_2.adb: Likewise.
* gnat.dg/varsize3_3.adb: Likewise.
* gnat.dg/varsize3_4.adb: Likewise.
* gnat.dg/varsize3_5.adb: Likewise.
* gnat.dg/varsize3_6.adb: Likewise.
* gnat.dg/varsize3_pkg1.ads: New helper.
* gnat.dg/varsize3_pkg2.ads: Likewise.
* gnat.dg/varsize3_pkg3.ads: Likewise.
--
Eric BotcazouIndex: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c (revision 223768)
+++ gcc-interface/decl.c (working copy)
@@ -168,7 +168,6 @@ struct value_annotation_hasher : ggc_cac
static GTY ((cache)) hash_table<value_annotation_hasher> *annotate_value_cache;
-static bool allocatable_size_p (tree, bool);
static void prepend_one_attribute (struct attrib **,
enum attr_type, tree, tree, Node_Id);
static void prepend_one_attribute_pragma (struct attrib **, Node_Id);
@@ -179,7 +178,7 @@ static bool type_has_variable_size (tree
static tree elaborate_expression_1 (tree, Entity_Id, const char *, bool, bool);
static tree elaborate_expression_2 (tree, Entity_Id, const char *, bool, bool,
unsigned int);
-static tree elaborate_reference (tree, Entity_Id, bool);
+static tree elaborate_reference (tree, Entity_Id, bool, tree *);
static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
bool *);
@@ -189,8 +188,10 @@ static tree change_qualified_type (tree,
static bool same_discriminant_p (Entity_Id, Entity_Id);
static bool array_type_has_nonaliased_component (tree, Entity_Id);
static bool compile_time_known_address_p (Node_Id);
-static bool cannot_be_superflat_p (Node_Id);
+static bool cannot_be_superflat (Node_Id);
static bool constructor_address_p (tree);
+static bool allocatable_size_p (tree, bool);
+static bool initial_value_needs_conversion (tree, tree);
static int compare_field_bitpos (const PTR, const PTR);
static bool components_to_record (tree, Node_Id, tree, int, bool, bool, bool,
bool, bool, bool, bool, bool, tree, tree *);
@@ -957,8 +958,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
to make it more likely to rename the underlying object. */
if (Present (Renamed_Object (gnat_entity)))
{
- /* If the renamed object had padding, strip off the reference
- to the inner object and reset our type. */
+ /* If the renamed object had padding, strip off the reference to
+ the inner object and reset our type. */
if ((TREE_CODE (gnu_expr) == COMPONENT_REF
&& TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
/* Strip useless conversions around the object. */
@@ -970,10 +971,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
/* Or else, if the renamed object has an unconstrained type with
default discriminant, use the padded type. */
- else if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_expr))
- && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_expr)))
- == gnu_type
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
+ else if (type_is_padding_self_referential (TREE_TYPE (gnu_expr)))
gnu_type = TREE_TYPE (gnu_expr);
/* Case 1: if this is a constant renaming stemming from a function
@@ -1001,12 +999,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
/* Case 2: if the renaming entity need not be materialized, use
the elaborated renamed expression for the renaming. But this
means that the caller is responsible for evaluating the address
- of the renaming at the correct spot in the definition case to
+ of the renaming in the correct place for the definition case to
instantiate the SAVE_EXPRs. */
- else if (!Materialize_Entity (gnat_entity))
+ else if (TREE_CODE (inner) != COMPOUND_EXPR
+ && !Materialize_Entity (gnat_entity))
{
+ tree init = NULL_TREE;
+
gnu_decl
- = elaborate_reference (gnu_expr, gnat_entity, definition);
+ = elaborate_reference (gnu_expr, gnat_entity, definition,
+ &init);
+
+ /* We cannot evaluate the first arm of a COMPOUND_EXPR in the
+ correct place for this case, hence the above test. */
+ gcc_assert (init == NULL_TREE);
/* No DECL_EXPR will be created so the expression needs to be
marked manually because it will likely be shared. */
@@ -1039,6 +1045,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
volatility of the renamed object through the indirection. */
else
{
+ tree init = NULL_TREE;
+
if (TREE_THIS_VOLATILE (gnu_expr) && !TYPE_VOLATILE (gnu_type))
gnu_type
= change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
@@ -1050,7 +1058,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
gnu_size = NULL_TREE;
renamed_obj
- = elaborate_reference (gnu_expr, gnat_entity, definition);
+ = elaborate_reference (gnu_expr, gnat_entity, definition,
+ &init);
/* If we are not defining the entity, the expression will not
be attached through DECL_INITIAL so it needs to be marked
@@ -1064,8 +1073,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
&& TREE_CODE (renamed_obj) == ERROR_MARK)
gnu_expr = NULL_TREE;
else
- gnu_expr
- = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj);
+ {
+ gnu_expr
+ = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj);
+ if (init)
+ gnu_expr
+ = build_compound_expr (TREE_TYPE (gnu_expr), init,
+ gnu_expr);
+ }
}
}
@@ -1115,24 +1130,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
gnu_expr = gnat_build_constructor (gnu_type, v);
}
- /* Convert the expression to the type of the object except in the
- case where the object's type is unconstrained or the object's type
- is a padded record whose field is of self-referential size. In
- the former case, converting will generate unnecessary evaluations
- of the CONSTRUCTOR to compute the size and in the latter case, we
- want to only copy the actual data. Also don't convert to a record
- type with a variant part from a record type without one, to keep
- the object simpler. */
- if (gnu_expr
- && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
- && !(TYPE_IS_PADDING_P (gnu_type)
- && CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
- && !(TREE_CODE (gnu_type) == RECORD_TYPE
- && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
- && get_variant_part (gnu_type) != NULL_TREE
- && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
+ /* Convert the expression to the type of the object if need be. */
+ if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
gnu_expr = convert (gnu_type, gnu_expr);
/* If this is a pointer that doesn't have an initializing expression,
@@ -1380,24 +1379,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
if (const_flag)
gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
- /* Convert the expression to the type of the object except in the
- case where the object's type is unconstrained or the object's type
- is a padded record whose field is of self-referential size. In
- the former case, converting will generate unnecessary evaluations
- of the CONSTRUCTOR to compute the size and in the latter case, we
- want to only copy the actual data. Also don't convert to a record
- type with a variant part from a record type without one, to keep
- the object simpler. */
- if (gnu_expr
- && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
- && !(TYPE_IS_PADDING_P (gnu_type)
- && CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
- && !(TREE_CODE (gnu_type) == RECORD_TYPE
- && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
- && get_variant_part (gnu_type) != NULL_TREE
- && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
+ /* Convert the expression to the type of the object if need be. */
+ if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
gnu_expr = convert (gnu_type, gnu_expr);
/* If this name is external or a name was specified, use it, but don't
@@ -2334,7 +2317,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
this. If we can prove that the array can never be superflat,
we can just use the high bound of the index type. */
else if ((Nkind (gnat_index) == N_Range
- && cannot_be_superflat_p (gnat_index))
+ && cannot_be_superflat (gnat_index))
/* Bit-Packed Array Impl. Types are never superflat. */
|| (Is_Packed_Array_Impl_Type (gnat_entity)
&& Is_Bit_Packed_Array
@@ -5821,7 +5804,7 @@ compile_time_known_address_p (Node_Id gn
inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
static bool
-cannot_be_superflat_p (Node_Id gnat_range)
+cannot_be_superflat (Node_Id gnat_range)
{
Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
Node_Id scalar_range;
@@ -5877,6 +5860,57 @@ constructor_address_p (tree gnu_expr)
return (TREE_CODE (gnu_expr) == ADDR_EXPR
&& TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
}
+
+/* Return true if the size in units represented by GNU_SIZE can be handled by
+ an allocation. If STATIC_P is true, consider only what can be done with a
+ static allocation. */
+
+static bool
+allocatable_size_p (tree gnu_size, bool static_p)
+{
+ /* We can allocate a fixed size if it is a valid for the middle-end. */
+ if (TREE_CODE (gnu_size) == INTEGER_CST)
+ return valid_constant_size_p (gnu_size);
+
+ /* We can allocate a variable size if this isn't a static allocation. */
+ else
+ return !static_p;
+}
+
+/* Return true if GNU_EXPR needs a conversion to GNU_TYPE when used as the
+ initial value of an object of GNU_TYPE. */
+
+static bool
+initial_value_needs_conversion (tree gnu_type, tree gnu_expr)
+{
+ /* Do not convert if the object's type is unconstrained because this would
+ generate useless evaluations of the CONSTRUCTOR to compute the size. */
+ if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
+ || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
+ return false;
+
+ /* Do not convert if the object's type is a padding record whose field is of
+ self-referential size because we want to copy only the actual data. */
+ if (type_is_padding_self_referential (gnu_type))
+ return false;
+
+ /* Do not convert a call to a function that returns with variable size since
+ we want to use the return slot optimization in this case. */
+ if (TREE_CODE (gnu_expr) == CALL_EXPR
+ && return_type_with_variable_size_p (TREE_TYPE (gnu_expr)))
+ return false;
+
+ /* Do not convert to a record type with a variant part from a record type
+ without one, to keep the object simpler. */
+ if (TREE_CODE (gnu_type) == RECORD_TYPE
+ && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
+ && get_variant_part (gnu_type) != NULL_TREE
+ && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE)
+ return false;
+
+ /* In all the other cases, convert the expression to the object's type. */
+ return true;
+}
/* Given GNAT_ENTITY, elaborate all expressions that are required to
be elaborated at the point of its definition, but do nothing else. */
@@ -5935,22 +5969,6 @@ elaborate_entity (Entity_Id gnat_entity)
}
}
-/* Return true if the size in units represented by GNU_SIZE can be handled by
- an allocation. If STATIC_P is true, consider only what can be done with a
- static allocation. */
-
-static bool
-allocatable_size_p (tree gnu_size, bool static_p)
-{
- /* We can allocate a fixed size if it is a valid for the middle-end. */
- if (TREE_CODE (gnu_size) == INTEGER_CST)
- return valid_constant_size_p (gnu_size);
-
- /* We can allocate a variable size if this isn't a static allocation. */
- else
- return !static_p;
-}
-
/* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
NAME, ARGS and ERROR_POINT. */
@@ -6224,12 +6242,13 @@ struct er_data
{
Entity_Id entity;
bool definition;
+ unsigned int n;
};
/* Wrapper function around elaborate_expression_1 for elaborate_reference. */
static tree
-elaborate_reference_1 (tree ref, void *data, int n)
+elaborate_reference_1 (tree ref, void *data)
{
struct er_data *er = (struct er_data *)data;
char suffix[16];
@@ -6244,22 +6263,24 @@ elaborate_reference_1 (tree ref, void *d
if (TREE_CODE (ref) == COMPONENT_REF
&& TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (ref, 0))))
return build3 (COMPONENT_REF, TREE_TYPE (ref),
- elaborate_reference_1 (TREE_OPERAND (ref, 0), data, n),
+ elaborate_reference_1 (TREE_OPERAND (ref, 0), data),
TREE_OPERAND (ref, 1), TREE_OPERAND (ref, 2));
- sprintf (suffix, "EXP%d", n);
+ sprintf (suffix, "EXP%d", ++er->n);
return
elaborate_expression_1 (ref, er->entity, suffix, er->definition, false);
}
/* Elaborate the reference REF to be used as renamed object for GNAT_ENTITY.
- DEFINITION is true if this is done for a definition of GNAT_ENTITY. */
+ DEFINITION is true if this is done for a definition of GNAT_ENTITY and
+ INIT is set to the first arm of a COMPOUND_EXPR present in REF, if any. */
static tree
-elaborate_reference (tree ref, Entity_Id gnat_entity, bool definition)
+elaborate_reference (tree ref, Entity_Id gnat_entity, bool definition,
+ tree *init)
{
- struct er_data er = { gnat_entity, definition };
- return gnat_rewrite_reference (ref, elaborate_reference_1, &er);
+ struct er_data er = { gnat_entity, definition, 0 };
+ return gnat_rewrite_reference (ref, elaborate_reference_1, &er, init);
}
/* Given a GNU tree and a GNAT list of choices, generate an expression to test
Index: gcc-interface/utils2.c
===================================================================
--- gcc-interface/utils2.c (revision 223768)
+++ gcc-interface/utils2.c (working copy)
@@ -923,13 +923,10 @@ build_binary_op (enum tree_code op_code,
operation_type = left_type;
}
- /* If we have a call to a function that returns an unconstrained type
- with default discriminant on the RHS, use the RHS type (which is
- padded) as we cannot compute the size of the actual assignment. */
+ /* If we have a call to a function that returns with variable size, use
+ the RHS type in case we want to use the return slot optimization. */
else if (TREE_CODE (right_operand) == CALL_EXPR
- && TYPE_IS_PADDING_P (right_type)
- && CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (right_type)))))
+ && return_type_with_variable_size_p (right_type))
operation_type = right_type;
/* Find the best type to use for copying between aggregate types. */
@@ -1420,10 +1417,7 @@ build_unary_op (enum tree_code op_code,
/* If INNER is a padding type whose field has a self-referential
size, convert to that inner type. We know the offset is zero
and we need to have that type visible. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (inner))
- && CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
- (TREE_TYPE (inner))))))
+ if (type_is_padding_self_referential (TREE_TYPE (inner)))
inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))),
inner);
@@ -2663,7 +2657,7 @@ gnat_protect_expr (tree exp)
argument to force evaluation of everything. */
static tree
-gnat_stabilize_reference_1 (tree e, void *data, int n)
+gnat_stabilize_reference_1 (tree e, void *data)
{
const bool force = *(bool *)data;
enum tree_code code = TREE_CODE (e);
@@ -2688,7 +2682,7 @@ gnat_stabilize_reference_1 (tree e, void
&& TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
result
= build3 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), data, n),
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), data),
TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
/* If the expression has side-effects, then encase it in a SAVE_EXPR
so that it will only be evaluated once. */
@@ -2704,15 +2698,15 @@ gnat_stabilize_reference_1 (tree e, void
/* Recursively stabilize each operand. */
result
= build2 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), data, n),
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), data, n));
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), data),
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), data));
break;
case tcc_unary:
/* Recursively stabilize each operand. */
result
= build1 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), data, n));
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), data));
break;
default:
@@ -2728,21 +2722,22 @@ gnat_stabilize_reference_1 (tree e, void
/* This is equivalent to stabilize_reference in tree.c but we know how to
handle our own nodes and we take extra arguments. FORCE says whether to
- force evaluation of everything. */
+ force evaluation of everything in REF. INIT is set to the first arm of
+ a COMPOUND_EXPR present in REF, if any. */
tree
-gnat_stabilize_reference (tree ref, bool force)
+gnat_stabilize_reference (tree ref, bool force, tree *init)
{
- return gnat_rewrite_reference (ref, gnat_stabilize_reference_1, &force);
+ return
+ gnat_rewrite_reference (ref, gnat_stabilize_reference_1, &force, init);
}
/* Rewrite reference REF and call FUNC on each expression within REF in the
- process. DATA is passed unmodified to FUNC and N is bumped each time it
- is passed to FUNC, so FUNC is guaranteed to see a given N only once per
- reference to be rewritten. */
+ process. DATA is passed unmodified to FUNC. INIT is set to the first
+ arm of a COMPOUND_EXPR present in REF, if any. */
tree
-gnat_rewrite_reference (tree ref, rewrite_fn func, void *data, int n)
+gnat_rewrite_reference (tree ref, rewrite_fn func, void *data, tree *init)
{
tree type = TREE_TYPE (ref);
enum tree_code code = TREE_CODE (ref);
@@ -2764,25 +2759,25 @@ gnat_rewrite_reference (tree ref, rewrit
result
= build1 (code, type,
gnat_rewrite_reference (TREE_OPERAND (ref, 0), func, data,
- n));
+ init));
break;
case INDIRECT_REF:
case UNCONSTRAINED_ARRAY_REF:
- result = build1 (code, type, func (TREE_OPERAND (ref, 0), data, n));
+ result = build1 (code, type, func (TREE_OPERAND (ref, 0), data));
break;
case COMPONENT_REF:
result = build3 (COMPONENT_REF, type,
gnat_rewrite_reference (TREE_OPERAND (ref, 0), func,
- data, n),
+ data, init),
TREE_OPERAND (ref, 1), NULL_TREE);
break;
case BIT_FIELD_REF:
result = build3 (BIT_FIELD_REF, type,
gnat_rewrite_reference (TREE_OPERAND (ref, 0), func,
- data, n),
+ data, init),
TREE_OPERAND (ref, 1), TREE_OPERAND (ref, 2));
break;
@@ -2791,11 +2786,18 @@ gnat_rewrite_reference (tree ref, rewrit
result
= build4 (code, type,
gnat_rewrite_reference (TREE_OPERAND (ref, 0), func, data,
- n + 1),
- func (TREE_OPERAND (ref, 1), data, n),
+ init),
+ func (TREE_OPERAND (ref, 1), data),
TREE_OPERAND (ref, 2), TREE_OPERAND (ref, 3));
break;
+ case COMPOUND_EXPR:
+ gcc_assert (*init == NULL_TREE);
+ *init = TREE_OPERAND (ref, 0);
+ /* We expect only the pattern built in Call_to_gnu. */
+ gcc_assert (DECL_P (TREE_OPERAND (ref, 1)));
+ return TREE_OPERAND (ref, 1);
+
case CALL_EXPR:
{
/* This can only be an atomic load. */
@@ -2808,9 +2810,9 @@ gnat_rewrite_reference (tree ref, rewrit
if (TREE_CODE (t) == ADDR_EXPR)
t = build1 (ADDR_EXPR, TREE_TYPE (t),
gnat_rewrite_reference (TREE_OPERAND (t, 0), func, data,
- n));
+ init));
else
- t = func (t, data, n);
+ t = func (t, data);
t = fold_convert (TREE_TYPE (CALL_EXPR_ARG (ref, 0)), t);
result = build_call_expr (TREE_OPERAND (CALL_EXPR_FN (ref), 0), 2,
Index: gcc-interface/gigi.h
===================================================================
--- gcc-interface/gigi.h (revision 223768)
+++ gcc-interface/gigi.h (working copy)
@@ -959,16 +959,16 @@ extern tree gnat_protect_expr (tree exp)
/* This is equivalent to stabilize_reference in tree.c but we know how to
handle our own nodes and we take extra arguments. FORCE says whether to
- force evaluation of everything. */
-extern tree gnat_stabilize_reference (tree ref, bool force);
+ force evaluation of everything in REF. INIT is set to the first arm of
+ a COMPOUND_EXPR present in REF, if any. */
+extern tree gnat_stabilize_reference (tree ref, bool force, tree *init);
/* Rewrite reference REF and call FUNC on each expression within REF in the
- process. DATA is passed unmodified to FUNC and N is bumped each time it
- is passed to FUNC, so FUNC is guaranteed to see a given N only once per
- reference to be rewritten. */
-typedef tree (*rewrite_fn) (tree, void *, int);
+ process. DATA is passed unmodified to FUNC. INIT is set to the first
+ arm of a COMPOUND_EXPR present in REF, if any. */
+typedef tree (*rewrite_fn) (tree, void *);
extern tree gnat_rewrite_reference (tree ref, rewrite_fn func, void *data,
- int n = 1);
+ tree *init);
/* This is equivalent to get_inner_reference in expr.c but it returns the
ultimate containing object only if the reference (lvalue) is constant,
@@ -1085,3 +1085,30 @@ call_is_atomic_load (tree exp)
enum built_in_function code = DECL_FUNCTION_CODE (fndecl);
return BUILT_IN_ATOMIC_LOAD_N <= code && code <= BUILT_IN_ATOMIC_LOAD_16;
}
+
+/* Return true if TYPE is padding a self-referential type. */
+
+static inline bool
+type_is_padding_self_referential (tree type)
+{
+ if (!TYPE_IS_PADDING_P (type))
+ return false;
+
+ return CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type)));
+}
+
+/* Return true if a function returning TYPE doesn't return a fixed size. */
+
+static inline bool
+return_type_with_variable_size_p (tree type)
+{
+ if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
+ return true;
+
+ /* Return true for an unconstrained type with default discriminant, see
+ the E_Subprogram_Type case of gnat_to_gnu_entity. */
+ if (type_is_padding_self_referential (type))
+ return true;
+
+ return false;
+}
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c (revision 223772)
+++ gcc-interface/trans.c (working copy)
@@ -4189,9 +4189,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gn
because we need to preserve the return value before copying back the
parameters.
- 2. There is no target and this is not an object declaration, and the
- return type has variable size, because in these cases the gimplifier
- cannot create the temporary.
+ 2. There is no target and this is neither an object nor a renaming
+ declaration, and the return type has variable size, because in
+ these cases the gimplifier cannot create the temporary.
3. There is a target and it is a slice or an array with fixed size,
and the return type has variable size, because the gimplifier
@@ -4203,6 +4203,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gn
&& ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
|| (!gnu_target
&& Nkind (Parent (gnat_node)) != N_Object_Declaration
+ && Nkind (Parent (gnat_node)) != N_Object_Renaming_Declaration
&& TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
|| (gnu_target
&& (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
@@ -4258,7 +4259,13 @@ Call_to_gnu (Node_Id gnat_node, tree *gn
if (Ekind (gnat_formal) != E_In_Parameter
&& !is_by_ref_formal_parm
&& TREE_CODE (gnu_name) != NULL_EXPR)
- gnu_name = gnat_stabilize_reference (gnu_name, true);
+ {
+ tree init = NULL_TREE;
+ gnu_name = gnat_stabilize_reference (gnu_name, true, &init);
+ if (init)
+ gnu_name
+ = build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name);
+ }
/* If we are passing a non-addressable parameter by reference, pass the
address of a copy. In the Out or In Out case, set up to copy back
@@ -4724,12 +4731,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gn
/* ??? If the return type has variable size, then force the return
slot optimization as we would not be able to create a temporary.
- Likewise if it was unconstrained as we would copy too much data.
That's what has been done historically. */
- if (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
- || (TYPE_IS_PADDING_P (gnu_result_type)
- && CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type))))))
+ if (return_type_with_variable_size_p (gnu_result_type))
op_code = INIT_EXPR;
else
op_code = MODIFY_EXPR;
@@ -6802,10 +6805,8 @@ gnat_to_gnu (Node_Id gnat_node)
/* Do not remove the padding from GNU_RET_VAL if the inner type is
self-referential since we want to allocate the fixed size. */
if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
- && TYPE_IS_PADDING_P
- (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
- && CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
+ && type_is_padding_self_referential
+ (TREE_OPERAND (gnu_ret_val, 0)))
gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
/* If the function returns by direct reference, return a pointer
@@ -7486,7 +7487,7 @@ gnat_to_gnu (Node_Id gnat_node)
actual returned object. We must do this before any conversions. */
if (TREE_SIDE_EFFECTS (gnu_result)
&& !(TREE_CODE (gnu_result) == CALL_EXPR
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
+ && type_is_padding_self_referential (TREE_TYPE (gnu_result)))
&& (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
|| CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
gnu_result = gnat_protect_expr (gnu_result);
@@ -7512,9 +7513,10 @@ gnat_to_gnu (Node_Id gnat_node)
3. If the type is void or if we have no result, return error_mark_node
to show we have no result.
- 4. If this a call to a function that returns an unconstrained type with
- default discriminant, return the call expression unmodified since we
- cannot compute the size of the actual returned object.
+ 4. If this is a call to a function that returns with variable size and
+ the call is used as the expression in either an object or a renaming
+ declaration, return the result unmodified because we want to use the
+ return slot optimization in this case.
5. Finally, if the type of the result is already correct. */
@@ -7543,9 +7545,7 @@ gnat_to_gnu (Node_Id gnat_node)
size: in that case it must be an object of unconstrained type
with a default discriminant and we want to avoid copying too
much data. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
- (TREE_TYPE (gnu_result))))))
+ if (type_is_padding_self_referential (TREE_TYPE (gnu_result)))
gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
gnu_result);
}
@@ -7567,11 +7567,11 @@ gnat_to_gnu (Node_Id gnat_node)
else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
gnu_result = error_mark_node;
- else if (TREE_CODE (gnu_result) == CALL_EXPR
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
- && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result)))
- == gnu_result_type
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
+ else if (Present (Parent (gnat_node))
+ && (Nkind (Parent (gnat_node)) == N_Object_Declaration
+ || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration)
+ && TREE_CODE (gnu_result) == CALL_EXPR
+ && return_type_with_variable_size_p (TREE_TYPE (gnu_result)))
;
else if (TREE_TYPE (gnu_result) != gnu_result_type)
-- { dg-do compile }
package body Varsize3_1 is
end Varsize3_1;
with Varsize3_Pkg1; use Varsize3_Pkg1;
package Varsize3_1 is
pragma Elaborate_Body;
Filter : constant Object := True;
end Varsize3_1;
-- { dg-do compile }
with Varsize3_Pkg1; use Varsize3_Pkg1;
procedure Varsize3_2 is
Filter : constant Object := True;
begin
null;
end;
-- { dg-do compile }
with Varsize3_Pkg1; use Varsize3_Pkg1;
procedure Varsize3_5 is
Filter : constant Arr := True.E;
begin
null;
end;
-- { dg-do compile }
with Varsize3_Pkg1; use Varsize3_Pkg1;
procedure Varsize3_3 is
Filter : Object;
begin
Filter := True;
end;
-- { dg-do compile }
with Varsize3_Pkg1; use Varsize3_Pkg1;
procedure Varsize3_6 is
Filter : Arr renames True.E;
begin
null;
end;
-- { dg-do compile }
with Varsize3_Pkg1; use Varsize3_Pkg1;
procedure Varsize3_4 is
Filter : Object renames True;
begin
null;
end;
with Varsize3_Pkg2;
with Varsize3_Pkg3;
package Varsize3_Pkg1 is
type Arr is array (Positive range 1 .. Varsize3_Pkg2.Last_Index) of Boolean;
package My_G is new Varsize3_Pkg3 (Arr);
type Object is new My_G.Object;
end Varsize3_Pkg1;
package Varsize3_Pkg2 is
function Last_Index return Positive;
end Varsize3_Pkg2;
generic
type T is private;
package Varsize3_Pkg3 is
type Object is record
E : T;
end record;
function True return Object;
end Varsize3_Pkg3;
