diff options
19 files changed, 343 insertions, 145 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5fc0dd3..204f9b9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2015-05-28 Eric Botcazou <ebotcazou@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 Ed Schonberg <schonberg@adacore.com> * sem_ch3.adb (Is_Visible_Component): Component is visible diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index da352c2..f955efc 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -168,7 +168,6 @@ struct value_annotation_hasher : ggc_cache_hasher<tree_int_map *> 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, int); 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_entity, tree gnu_expr, int definition) 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_entity, tree gnu_expr, int definition) /* 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_entity, tree gnu_expr, int definition) /* 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_entity, tree gnu_expr, int definition) 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_entity, tree gnu_expr, int definition) 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_entity, tree gnu_expr, int definition) && 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_entity, tree gnu_expr, int definition) 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_entity, tree gnu_expr, int definition) 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_entity, tree gnu_expr, int definition) 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 gnat_address) 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 *data, int n) 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 diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index b75cc35..65f871b 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -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; +} diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index c3b06c2..0750051 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -4189,9 +4189,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, 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 *gnu_result_type_p, tree gnu_target, && ((!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 *gnu_result_type_p, tree gnu_target, 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 *gnu_result_type_p, tree gnu_target, /* ??? 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) diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index edbcc53..cc2c645 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -923,13 +923,10 @@ build_binary_op (enum tree_code op_code, tree result_type, 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, tree result_type, tree operand) /* 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 *data, int n) && 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 *data, int n) /* 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 *data, int n) /* 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, rewrite_fn func, void *data, int n) 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, rewrite_fn func, void *data, int n) 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, rewrite_fn func, void *data, int n) 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, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1a2b185..282a3be 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,19 @@ +2015-05-28 Eric Botcazou <ebotcazou@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. + 2015-05-28 Richard Biener <rguenther@suse.de> * gcc.dg/vect/slp-reduc-sad.c: New testcase. diff --git a/gcc/testsuite/gnat.dg/varsize_temp.adb b/gcc/testsuite/gnat.dg/varsize1.adb index b7c3a0b..55ee34a 100644 --- a/gcc/testsuite/gnat.dg/varsize_temp.adb +++ b/gcc/testsuite/gnat.dg/varsize1.adb @@ -1,6 +1,6 @@ -- { dg-do compile } -procedure Varsize_Temp (Nbytes : Natural) is +procedure Varsize1 (Nbytes : Natural) is type Message_T (Length : Natural) is record case Length is @@ -25,5 +25,3 @@ procedure Varsize_Temp (Nbytes : Natural) is begin Process (One_Message); end; - - diff --git a/gcc/testsuite/gnat.dg/varsize_copy.adb b/gcc/testsuite/gnat.dg/varsize2.adb index 4fa0ff8..70a5b06 100644 --- a/gcc/testsuite/gnat.dg/varsize_copy.adb +++ b/gcc/testsuite/gnat.dg/varsize2.adb @@ -1,7 +1,7 @@ -- { dg-do compile } -- { dg-options "-O -gnatws" } -package body Varsize_Copy is +package body Varsize2 is type Key_Mapping_Type is record Page : Page_Type; @@ -21,4 +21,4 @@ package body Varsize_Copy is return S.Key_Mappings (Key).Page; end; -end Varsize_Copy; +end Varsize2; diff --git a/gcc/testsuite/gnat.dg/varsize_copy.ads b/gcc/testsuite/gnat.dg/varsize2.ads index 9a088a9..d9ec1cc 100644 --- a/gcc/testsuite/gnat.dg/varsize_copy.ads +++ b/gcc/testsuite/gnat.dg/varsize2.ads @@ -1,4 +1,4 @@ -package Varsize_Copy is +package Varsize2 is type Key_Type is (Nul, Cntrl, Stx, Etx, Eot, Enq, Ack, Spad, Clr, Dc_1, Dc_2, Dc_3, Dc_4); @@ -27,4 +27,4 @@ package Varsize_Copy is function F (Key : Key_Type) return Page_Type; -end Varsize_Copy; +end Varsize2; diff --git a/gcc/testsuite/gnat.dg/varsize3_1.adb b/gcc/testsuite/gnat.dg/varsize3_1.adb new file mode 100644 index 0000000..841f2cf --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize3_1.adb @@ -0,0 +1,5 @@ +-- { dg-do compile } + +package body Varsize3_1 is + +end Varsize3_1; diff --git a/gcc/testsuite/gnat.dg/varsize3_1.ads b/gcc/testsuite/gnat.dg/varsize3_1.ads new file mode 100644 index 0000000..16195c2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize3_1.ads @@ -0,0 +1,9 @@ +with Varsize3_Pkg1; use Varsize3_Pkg1; + +package Varsize3_1 is + + pragma Elaborate_Body; + + Filter : constant Object := True; + +end Varsize3_1; diff --git a/gcc/testsuite/gnat.dg/varsize3_2.adb b/gcc/testsuite/gnat.dg/varsize3_2.adb new file mode 100644 index 0000000..7e565d2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize3_2.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +with Varsize3_Pkg1; use Varsize3_Pkg1; + +procedure Varsize3_2 is + + Filter : constant Object := True; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/varsize3_3.adb b/gcc/testsuite/gnat.dg/varsize3_3.adb new file mode 100644 index 0000000..a08db64 --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize3_3.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +with Varsize3_Pkg1; use Varsize3_Pkg1; + +procedure Varsize3_3 is + + Filter : Object; + +begin + Filter := True; +end; diff --git a/gcc/testsuite/gnat.dg/varsize3_4.adb b/gcc/testsuite/gnat.dg/varsize3_4.adb new file mode 100644 index 0000000..fe19374 --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize3_4.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +with Varsize3_Pkg1; use Varsize3_Pkg1; + +procedure Varsize3_4 is + + Filter : Object renames True; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/varsize3_5.adb b/gcc/testsuite/gnat.dg/varsize3_5.adb new file mode 100644 index 0000000..2fd44c0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize3_5.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +with Varsize3_Pkg1; use Varsize3_Pkg1; + +procedure Varsize3_5 is + + Filter : constant Arr := True.E; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/varsize3_6.adb b/gcc/testsuite/gnat.dg/varsize3_6.adb new file mode 100644 index 0000000..423e508 --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize3_6.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +with Varsize3_Pkg1; use Varsize3_Pkg1; + +procedure Varsize3_6 is + + Filter : Arr renames True.E; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/varsize3_pkg1.ads b/gcc/testsuite/gnat.dg/varsize3_pkg1.ads new file mode 100644 index 0000000..ac12b39 --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize3_pkg1.ads @@ -0,0 +1,12 @@ +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; diff --git a/gcc/testsuite/gnat.dg/varsize3_pkg2.ads b/gcc/testsuite/gnat.dg/varsize3_pkg2.ads new file mode 100644 index 0000000..980c9bd --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize3_pkg2.ads @@ -0,0 +1,5 @@ +package Varsize3_Pkg2 is + + function Last_Index return Positive; + +end Varsize3_Pkg2; diff --git a/gcc/testsuite/gnat.dg/varsize3_pkg3.ads b/gcc/testsuite/gnat.dg/varsize3_pkg3.ads new file mode 100644 index 0000000..0cc80e3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize3_pkg3.ads @@ -0,0 +1,13 @@ +generic + + type T is private; + +package Varsize3_Pkg3 is + + type Object is record + E : T; + end record; + + function True return Object; + +end Varsize3_Pkg3; |