From ced572837c918c138eee3e901d4b11a9996d7f07 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 9 Apr 2010 10:10:25 +0000 Subject: [PATCH] gigi.h (gnat_mark_addressable): Rename parameter. * gcc-interface/gigi.h (gnat_mark_addressable): Rename parameter. * gcc-interface/decl.c (maybe_variable): Do not set TREE_STATIC on _REF node. Use the type of the operand to set TREE_READONLY. * gcc-interface/trans.c (Identifier_to_gnu): Do not set TREE_STATIC on _REF node. Do not overwrite TREE_READONLY. (call_to_gnu): Rename local variable and fix various nits. In the copy-in/copy-out case, build the SAVE_EXPR manually. (convert_with_check): Call protect_multiple_eval in lieu of save_expr and fold the computations. (protect_multiple_eval): Always save entire fat pointers. (maybe_stabilize_reference): Minor tweaks. (gnat_stabilize_reference_1): Likewise. Do not deal with tcc_constant, tcc_type and tcc_statement. * gcc-interface/utils.c (convert_to_fat_pointer): Call protect_multiple_eval in lieu of save_expr. (convert): Minor tweaks. (maybe_unconstrained_array): Do not set TREE_STATIC on _REF node. (builtin_type_for_size): Call gnat_type_for_size directly. * gcc-interface/utils2.c (contains_save_expr_p): Delete. (contains_null_expr): Likewise (gnat_build_constructor): Do not call it. (compare_arrays): Deal with all side-effects, use protect_multiple_eval instead of gnat_stabilize_reference to protect the operands. (nonbinary_modular_operation): Call protect_multiple_eval in lieu of save_expr. (maybe_wrap_malloc): Likewise. (build_allocator): Likewise. (build_unary_op) : Do not set TREE_STATIC on _REF node. (gnat_mark_addressable): Rename parameter. From-SVN: r158156 --- gcc/ada/ChangeLog | 32 +++++ gcc/ada/gcc-interface/decl.c | 4 +- gcc/ada/gcc-interface/gigi.h | 6 +- gcc/ada/gcc-interface/trans.c | 274 ++++++++++++++++++++--------------------- gcc/ada/gcc-interface/utils.c | 12 +- gcc/ada/gcc-interface/utils2.c | 178 +++++++------------------- 6 files changed, 223 insertions(+), 283 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e43a534..8cd43c6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2010-04-09 Eric Botcazou + + * gcc-interface/gigi.h (gnat_mark_addressable): Rename parameter. + * gcc-interface/decl.c (maybe_variable): Do not set TREE_STATIC on _REF + node. Use the type of the operand to set TREE_READONLY. + * gcc-interface/trans.c (Identifier_to_gnu): Do not set TREE_STATIC on + _REF node. Do not overwrite TREE_READONLY. + (call_to_gnu): Rename local variable and fix various nits. In the + copy-in/copy-out case, build the SAVE_EXPR manually. + (convert_with_check): Call protect_multiple_eval in lieu of save_expr + and fold the computations. + (protect_multiple_eval): Always save entire fat pointers. + (maybe_stabilize_reference): Minor tweaks. + (gnat_stabilize_reference_1): Likewise. Do not deal with tcc_constant, + tcc_type and tcc_statement. + * gcc-interface/utils.c (convert_to_fat_pointer): Call + protect_multiple_eval in lieu of save_expr. + (convert): Minor tweaks. + (maybe_unconstrained_array): Do not set TREE_STATIC on _REF node. + (builtin_type_for_size): Call gnat_type_for_size directly. + * gcc-interface/utils2.c (contains_save_expr_p): Delete. + (contains_null_expr): Likewise + (gnat_build_constructor): Do not call it. + (compare_arrays): Deal with all side-effects, use protect_multiple_eval + instead of gnat_stabilize_reference to protect the operands. + (nonbinary_modular_operation): Call protect_multiple_eval in lieu of + save_expr. + (maybe_wrap_malloc): Likewise. + (build_allocator): Likewise. + (build_unary_op) : Do not set TREE_STATIC on _REF node. + (gnat_mark_addressable): Rename parameter. + 2010-04-08 Eric Botcazou * gcc-interface/ada-tree.h (TYPE_RETURNS_UNCONSTRAINED_P): Rename into. diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 25b4c07..03938d1 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -5743,9 +5743,7 @@ maybe_variable (tree gnu_operand) tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand), variable_size (TREE_OPERAND (gnu_operand, 0))); - - TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) - = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand))); + TREE_READONLY (gnu_result) = TYPE_READONLY (TREE_TYPE (gnu_operand)); return gnu_result; } diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index e9956b0..97c5ca0 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -871,9 +871,9 @@ extern tree build_allocator (tree type, tree init, tree result_type, extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual); -/* Indicate that we need to make the address of EXPR_NODE and it therefore - should not be allocated in a register. Return true if successful. */ -extern bool gnat_mark_addressable (tree expr_node); +/* Indicate that we need to take the address of T and that it therefore + should not be allocated in a register. Returns true if successful. */ +extern bool gnat_mark_addressable (tree t); /* Implementation of the builtin_function langhook. */ extern tree gnat_builtin_function (tree decl); diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 049c201..438799c 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -914,7 +914,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) || (TREE_CODE (gnu_result) == PARM_DECL && DECL_BY_COMPONENT_PTR_P (gnu_result)))) { - bool ro = DECL_POINTS_TO_READONLY_P (gnu_result); + const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result); tree renamed_obj; if (TREE_CODE (gnu_result) == PARM_DECL @@ -928,8 +928,8 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) we can reference the renamed object directly, since the renamed expression has been protected against multiple evaluations. */ else if (TREE_CODE (gnu_result) == VAR_DECL - && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0 - && (! DECL_RENAMING_GLOBAL_P (gnu_result) + && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) + && (!DECL_RENAMING_GLOBAL_P (gnu_result) || global_bindings_p ())) gnu_result = renamed_obj; @@ -942,7 +942,8 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) else gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); - TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro; + if (read_only) + TREE_READONLY (gnu_result) = 1; } /* The GNAT tree has the type of a function as the type of its result. Also @@ -2404,75 +2405,68 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) static tree call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) { - tree gnu_result; /* The GCC node corresponding to the GNAT subprogram name. This can either be a FUNCTION_DECL node if we are dealing with a standard subprogram call, or an indirect reference expression (an INDIRECT_REF node) pointing to a subprogram. */ - tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node)); + tree gnu_subprog = gnat_to_gnu (Name (gnat_node)); /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ - tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node); - tree gnu_subprog_addr - = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog_node); + tree gnu_subprog_type = TREE_TYPE (gnu_subprog); + tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog); Entity_Id gnat_formal; Node_Id gnat_actual; tree gnu_actual_list = NULL_TREE; tree gnu_name_list = NULL_TREE; tree gnu_before_list = NULL_TREE; tree gnu_after_list = NULL_TREE; - tree gnu_subprog_call; + tree gnu_call; gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE); - /* If we are calling a stubbed function, make this into a raise of - Program_Error. Elaborate all our args first. */ - if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL - && DECL_STUBBED_P (gnu_subprog_node)) + /* If we are calling a stubbed function, raise Program_Error, but Elaborate + all our args first. */ + if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog)) { + tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called, + gnat_node, N_Raise_Program_Error); + for (gnat_actual = First_Actual (gnat_node); Present (gnat_actual); gnat_actual = Next_Actual (gnat_actual)) add_stmt (gnat_to_gnu (gnat_actual)); - { - tree call_expr - = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node, - N_Raise_Program_Error); + if (Nkind (gnat_node) == N_Function_Call && !gnu_target) + { + *gnu_result_type_p = TREE_TYPE (gnu_subprog_type); + return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr); + } - if (Nkind (gnat_node) == N_Function_Call && !gnu_target) - { - *gnu_result_type_p = TREE_TYPE (gnu_subprog_type); - return build1 (NULL_EXPR, *gnu_result_type_p, call_expr); - } - else - return call_expr; - } + return call_expr; } /* The only way we can be making a call via an access type is if Name is an explicit dereference. In that case, get the list of formal args from the - type the access type is pointing to. Otherwise, get the formals from + type the access type is pointing to. Otherwise, get the formals from the entity being called. */ if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); else if (Nkind (Name (gnat_node)) == N_Attribute_Reference) /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ - gnat_formal = 0; + gnat_formal = Empty; else gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); - /* Create the list of the actual parameters as GCC expects it, namely a chain - of TREE_LIST nodes in which the TREE_VALUE field of each node is a - parameter-expression and the TREE_PURPOSE field is null. Skip Out - parameters not passed by reference and don't need to be copied in. */ + /* Create the list of the actual parameters as GCC expects it, namely a + chain of TREE_LIST nodes in which the TREE_VALUE field of each node + is an expression and the TREE_PURPOSE field is null. But skip Out + parameters not passed by reference and that need not be copied in. */ for (gnat_actual = First_Actual (gnat_node); Present (gnat_actual); gnat_formal = Next_Formal_With_Extras (gnat_formal), gnat_actual = Next_Actual (gnat_actual)) { - tree gnu_formal - = (present_gnu_tree (gnat_formal) - ? get_gnu_tree (gnat_formal) : NULL_TREE); + tree gnu_formal = present_gnu_tree (gnat_formal) + ? get_gnu_tree (gnat_formal) : NULL_TREE; tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal)); /* We must suppress conversions that can cause the creation of a temporary in the Out or In Out case because we need the real @@ -2487,13 +2481,13 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) && Ekind (gnat_formal) != E_In_Parameter) || (Nkind (gnat_actual) == N_Type_Conversion && Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))); - Node_Id gnat_name = (suppress_type_conversion - ? Expression (gnat_actual) : gnat_actual); + Node_Id gnat_name = suppress_type_conversion + ? Expression (gnat_actual) : gnat_actual; tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type; tree gnu_actual; /* 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 + that any side-effects are handled via SAVE_EXPRs; likewise if we need to force side-effects before the call. ??? This is more conservative than we need since we don't need to do this for pass-by-ref with no conversion. */ @@ -2518,13 +2512,12 @@ 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); - /* For users of Starlet we issue a warning because the - interface apparently assumes that by-ref parameters - outlive the procedure invocation. The code still - will not work as intended, but we cannot do much - better since other low-level parts of the back-end - would allocate temporaries at will because of the - misalignment if we did not do so here. */ + /* For users of Starlet we issue a warning because the interface + apparently assumes that by-ref parameters outlive the procedure + invocation. The code still will not work as intended, but we + cannot do much better since low-level parts of the back-end + would allocate temporaries at will because of the misalignment + if we did not do so here. */ else if (Is_Valued_Procedure (Entity (Name (gnat_node)))) { post_error @@ -2563,13 +2556,13 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnu_name = convert (gnu_name_type, gnu_name); /* Make a SAVE_EXPR to both properly account for potential side - effects and handle the creation of a temporary copy. Special - code in gnat_gimplify_expr ensures that the same temporary is - used as the object and copied back after the call if needed. */ + effects and handle the creation of a temporary. Special code + in gnat_gimplify_expr ensures that the same temporary is used + as the object and copied back after the call if needed. */ gnu_name = build1 (SAVE_EXPR, TREE_TYPE (gnu_name), gnu_name); TREE_SIDE_EFFECTS (gnu_name) = 1; - /* Set up to move the copy back to the original. */ + /* Set up to move the copy back to the original if needed. */ if (Ekind (gnat_formal) != E_In_Parameter) { tree stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy, @@ -2618,9 +2611,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) /* We may have suppressed a conversion to the Etype of the actual since the parent is a procedure call. So put it back here. ??? We use the reverse order compared to the case above because - of an awkward interaction with the check and actually don't put - back the conversion at all if a check is emitted. This is also - done for the conversion to the formal's type just below. */ + of an awkward interaction with the check. */ if (TREE_CODE (gnu_actual) != SAVE_EXPR) gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual); @@ -2639,9 +2630,8 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnu_name); /* If we have not saved a GCC object for the formal, it means it is an - Out parameter not passed by reference and that does not need to be - copied in. Otherwise, look at the PARM_DECL to see if it is passed by - reference. */ + Out parameter not passed by reference and that need not be copied in. + Otherwise, first see if the PARM_DECL is passed by reference. */ if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL && DECL_BY_REF_P (gnu_formal)) @@ -2707,12 +2697,12 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) && TREE_CODE (gnu_formal) == PARM_DECL && DECL_BY_DESCRIPTOR_P (gnu_formal)) { - /* If arg is 'Null_Parameter, pass zero descriptor. */ + /* If this is 'Null_Parameter, pass a zero descriptor. */ if ((TREE_CODE (gnu_actual) == INDIRECT_REF || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF) && TREE_PRIVATE (gnu_actual)) - gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), - integer_zero_node); + gnu_actual + = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node); else gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE, fill_vms_descriptor (gnu_actual, @@ -2721,26 +2711,25 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) } else { - tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual)); + tree gnu_size; if (Ekind (gnat_formal) != E_In_Parameter) gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list); - if (!gnu_formal || TREE_CODE (gnu_formal) != PARM_DECL) + if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL)) continue; /* If this is 'Null_Parameter, pass a zero even though we are dereferencing it. */ - else if (TREE_CODE (gnu_actual) == INDIRECT_REF - && TREE_PRIVATE (gnu_actual) - && host_integerp (gnu_actual_size, 1) - && 0 >= compare_tree_int (gnu_actual_size, - BITS_PER_WORD)) + if (TREE_CODE (gnu_actual) == INDIRECT_REF + && TREE_PRIVATE (gnu_actual) + && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual))) + && TREE_CODE (gnu_size) == INTEGER_CST + && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0) gnu_actual = unchecked_convert (DECL_ARG_TYPE (gnu_formal), convert (gnat_type_for_size - (tree_low_cst (gnu_actual_size, 1), - 1), + (TREE_INT_CST_LOW (gnu_size), 1), integer_zero_node), false); else @@ -2750,17 +2739,16 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list); } - gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type), - gnu_subprog_addr, - nreverse (gnu_actual_list)); - set_expr_location_from_node (gnu_subprog_call, gnat_node); + gnu_call = build_call_list (TREE_TYPE (gnu_subprog_type), gnu_subprog_addr, + nreverse (gnu_actual_list)); + set_expr_location_from_node (gnu_call, gnat_node); /* If it's a function call, the result is the call expression unless a target is specified, in which case we copy the result into the target and return the assignment statement. */ if (Nkind (gnat_node) == N_Function_Call) { - gnu_result = gnu_subprog_call; + tree gnu_result = gnu_call; enum tree_code op_code; /* If the function returns an unconstrained array or by direct reference, @@ -2802,12 +2790,16 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) { tree gnu_name; - gnu_subprog_call = save_expr (gnu_subprog_call); + /* The call sequence must contain one and only one call, even though + the function is const or pure. So force a SAVE_EXPR. */ + gnu_call = build1 (SAVE_EXPR, TREE_TYPE (gnu_call), gnu_call); + TREE_SIDE_EFFECTS (gnu_call) = 1; gnu_name_list = nreverse (gnu_name_list); /* If any of the names had side-effects, ensure they are all evaluated before the call. */ - for (gnu_name = gnu_name_list; gnu_name; + for (gnu_name = gnu_name_list; + gnu_name; gnu_name = TREE_CHAIN (gnu_name)) if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name))) append_to_statement_list (TREE_VALUE (gnu_name), @@ -2838,8 +2830,9 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) either the result of the function if there is only a single such parameter or the appropriate field from the record returned. */ tree gnu_result - = length == 1 ? gnu_subprog_call - : build_component_ref (gnu_subprog_call, NULL_TREE, + = length == 1 + ? gnu_call + : build_component_ref (gnu_call, NULL_TREE, TREE_PURPOSE (scalar_return_list), false); @@ -2851,9 +2844,9 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) /* If the result is a padded type, remove the padding. */ if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) - gnu_result = convert (TREE_TYPE (TYPE_FIELDS - (TREE_TYPE (gnu_result))), - gnu_result); + gnu_result + = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), + gnu_result); /* If the actual is a type conversion, the real target object is denoted by the inner Expression and we need to convert the @@ -2907,11 +2900,12 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) scalar_return_list = TREE_CHAIN (scalar_return_list); gnu_name_list = TREE_CHAIN (gnu_name_list); } - } + } else - append_to_statement_list (gnu_subprog_call, &gnu_before_list); + append_to_statement_list (gnu_call, &gnu_before_list); append_to_statement_list (gnu_after_list, &gnu_before_list); + return gnu_before_list; } @@ -6695,7 +6689,7 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, && !truncatep) { REAL_VALUE_TYPE half_minus_pred_half, pred_half; - tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type; + tree gnu_conv, gnu_zero, gnu_comp, calc_type; tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half; const struct real_format *fmt; @@ -6718,14 +6712,14 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, gnu_pred_half = build_real (calc_type, pred_half); /* If the input is strictly negative, subtract this value - and otherwise add it from the input. For 0.5, the result + and otherwise add it from the input. For 0.5, the result is exactly between 1.0 and the machine number preceding 1.0 - (for calc_type). Since the last bit of 1.0 is even, this 0.5 + (for calc_type). Since the last bit of 1.0 is even, this 0.5 will round to 1.0, while all other number with an absolute - value less than 0.5 round to 0.0. For larger numbers exactly + value less than 0.5 round to 0.0. For larger numbers exactly halfway between integers, rounding will always be correct as the true mathematical result will be closer to the higher - integer compared to the lower one. So, this constant works + integer compared to the lower one. So, this constant works for all floating-point numbers. The reason to use the same constant with subtract/add instead @@ -6734,16 +6728,16 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, conversion of the input to the calc_type (if necessary). */ gnu_zero = convert (gnu_in_basetype, integer_zero_node); - gnu_saved_result = save_expr (gnu_result); - gnu_conv = convert (calc_type, gnu_saved_result); - gnu_comp = build2 (GE_EXPR, integer_type_node, - gnu_saved_result, gnu_zero); + gnu_result = protect_multiple_eval (gnu_result); + gnu_conv = convert (calc_type, gnu_result); + gnu_comp + = fold_build2 (GE_EXPR, integer_type_node, gnu_result, gnu_zero); gnu_add_pred_half - = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half); + = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half); gnu_subtract_pred_half - = build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half); - gnu_result = build3 (COND_EXPR, calc_type, gnu_comp, - gnu_add_pred_half, gnu_subtract_pred_half); + = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half); + gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp, + gnu_add_pred_half, gnu_subtract_pred_half); } if (TREE_CODE (gnu_base_type) == INTEGER_TYPE @@ -6753,10 +6747,8 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, else gnu_result = convert (gnu_base_type, gnu_result); - /* Finally, do the range check if requested. Note that if the - result type is a modular type, the range check is actually - an overflow check. */ - + /* Finally, do the range check if requested. Note that if the result type + is a modular type, the range check is actually an overflow check. */ if (rangep || (TREE_CODE (gnu_base_type) == INTEGER_TYPE && TYPE_MODULAR_P (gnu_base_type) && overflowp)) @@ -7205,6 +7197,7 @@ tree protect_multiple_eval (tree exp) { tree type = TREE_TYPE (exp); + enum tree_code code = TREE_CODE (exp); /* If EXP has no side effects, we theoritically don't need to do anything. However, we may be recursively passed more and more complex expressions @@ -7221,13 +7214,20 @@ protect_multiple_eval (tree exp) Similarly, if we're indirectly referencing something, we only need to protect the address since the data itself can't change in these situations. */ - if (TREE_CODE (exp) == NON_LVALUE_EXPR - || CONVERT_EXPR_P (exp) - || TREE_CODE (exp) == VIEW_CONVERT_EXPR - || TREE_CODE (exp) == INDIRECT_REF - || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF) - return build1 (TREE_CODE (exp), type, - protect_multiple_eval (TREE_OPERAND (exp, 0))); + if (code == NON_LVALUE_EXPR + || CONVERT_EXPR_CODE_P (code) + || code == VIEW_CONVERT_EXPR + || code == INDIRECT_REF + || code == UNCONSTRAINED_ARRAY_REF) + return build1 (code, type, protect_multiple_eval (TREE_OPERAND (exp, 0))); + + /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer. + This may be more efficient, but will also allow us to more easily find + the match for the PLACEHOLDER_EXPR. */ + if (code == COMPONENT_REF + && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0)))) + return build3 (code, type, protect_multiple_eval (TREE_OPERAND (exp, 0)), + TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2)); /* If this is a fat pointer or something that can be placed in a register, just make a SAVE_EXPR. Likewise for a CALL_EXPR as large objects are @@ -7235,7 +7235,7 @@ protect_multiple_eval (tree exp) directly be filled by the callee. */ if (TYPE_IS_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode - || TREE_CODE (exp) == CALL_EXPR) + || code == CALL_EXPR) return save_expr (exp); /* Otherwise reference, protect the address and dereference. */ @@ -7354,26 +7354,23 @@ maybe_stabilize_reference (tree ref, bool force, bool *success) return ref; } - TREE_READONLY (result) = TREE_READONLY (ref); - - /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial - expression may not be sustained across some paths, such as the way via - build1 for INDIRECT_REF. We re-populate those flags here for the general - case, which is consistent with the GCC version of this routine. + /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression + may not be sustained across some paths, such as the way via build1 for + INDIRECT_REF. We reset those flags here in the general case, which is + consistent with the GCC version of this routine. Special care should be taken regarding TREE_SIDE_EFFECTS, because some - paths introduce side effects where there was none initially (e.g. calls - to save_expr), and we also want to keep track of that. */ - - TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref); + paths introduce side-effects where there was none initially (e.g. if a + SAVE_EXPR is built) and we also want to keep track of that. */ + TREE_READONLY (result) = TREE_READONLY (ref); TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref); + TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref); return result; } -/* Wrapper around maybe_stabilize_reference, for common uses without - lvalue restrictions and without need to examine the success - indication. */ +/* Wrapper around maybe_stabilize_reference, for common uses without lvalue + restrictions and without the need to examine the success indication. */ static tree gnat_stabilize_reference (tree ref, bool force) @@ -7396,17 +7393,14 @@ gnat_stabilize_reference_1 (tree e, bool force) to a const array but whose index contains side-effects. But we can ignore things that are actual constant or that already have been handled by this function. */ - if (TREE_CONSTANT (e) || code == SAVE_EXPR) return e; switch (TREE_CODE_CLASS (code)) { case tcc_exceptional: - case tcc_type: case tcc_declaration: case tcc_comparison: - case tcc_statement: case tcc_expression: case tcc_reference: case tcc_vl_exp: @@ -7415,44 +7409,44 @@ gnat_stabilize_reference_1 (tree e, bool force) us to more easily find the match for the PLACEHOLDER_EXPR. */ if (code == COMPONENT_REF && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0)))) - result = build3 (COMPONENT_REF, type, - gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), - force), - TREE_OPERAND (e, 1), TREE_OPERAND (e, 2)); + result + = build3 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), + 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. */ + /* The tcc_reference and tcc_comparison classes could be handled as + below, but it is generally faster to only evaluate them once. */ else if (TREE_SIDE_EFFECTS (e) || force) return save_expr (e); else return e; break; - case tcc_constant: - /* Constants need no processing. In fact, we should never reach - here. */ - return e; - case tcc_binary: /* Recursively stabilize each operand. */ - result = build2 (code, type, - gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), - gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), - force)); + result + = build2 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), + gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force)); break; case tcc_unary: /* Recursively stabilize each operand. */ - result = build1 (code, type, - gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), - force)); + result + = build1 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force)); break; default: gcc_unreachable (); } + /* See similar handling in maybe_stabilize_reference. */ TREE_READONLY (result) = TREE_READONLY (e); - - TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e); TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e); + TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e); + return result; } diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 412aa3a..f35e9c7 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -3587,7 +3587,7 @@ convert_to_fat_pointer (tree type, tree expr) { tree fields = TYPE_FIELDS (TREE_TYPE (etype)); - expr = save_expr (expr); + expr = protect_multiple_eval (expr); if (TREE_CODE (expr) == ADDR_EXPR) expr = TREE_OPERAND (expr, 0); else @@ -3881,7 +3881,8 @@ convert (tree type, tree expr) /* If packing has made this field a bitfield and the input value couldn't be emitted statically any more, we need to clear TREE_CONSTANT on our output. */ - if (!clear_constant && TREE_CONSTANT (expr) + if (!clear_constant + && TREE_CONSTANT (expr) && !CONSTRUCTOR_BITFIELD_P (efield) && CONSTRUCTOR_BITFIELD_P (field) && !initializer_constant_valid_for_bitfield_p (value)) @@ -3900,7 +3901,7 @@ convert (tree type, tree expr) TREE_TYPE (expr) = type; CONSTRUCTOR_ELTS (expr) = v; if (clear_constant) - TREE_CONSTANT (expr) = TREE_STATIC (expr) = false; + TREE_CONSTANT (expr) = TREE_STATIC (expr) = 0; return expr; } } @@ -4251,8 +4252,7 @@ maybe_unconstrained_array (tree exp) build_component_ref (TREE_OPERAND (exp, 0), get_identifier ("P_ARRAY"), NULL_TREE, false)); - TREE_READONLY (new_exp) = TREE_STATIC (new_exp) - = TREE_READONLY (exp); + TREE_READONLY (new_exp) = TREE_READONLY (exp); return new_exp; } @@ -4735,7 +4735,7 @@ build_void_list_node (void) static tree builtin_type_for_size (int size, bool unsignedp) { - tree type = lang_hooks.types.type_for_size (size, unsignedp); + tree type = gnat_type_for_size (size, unsignedp); return type ? type : error_mark_node; } diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index e3b3ec9..5db38c5 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -49,8 +49,6 @@ #include "gigi.h" static tree find_common_type (tree, tree); -static bool contains_save_expr_p (tree); -static tree contains_null_expr (tree); static tree compare_arrays (tree, tree, tree); static tree nonbinary_modular_operation (enum tree_code, tree, tree, tree); static tree build_simple_component_ref (tree, tree, tree, bool); @@ -233,100 +231,13 @@ find_common_type (tree t1, tree t2) return NULL_TREE; } -/* See if EXP contains a SAVE_EXPR in a position where we would - normally put it. +/* Return an expression tree representing an equality comparison of A1 and A2, + two objects of type ARRAY_TYPE. The result should be of type RESULT_TYPE. - ??? This is a real kludge, but is probably the best approach short - of some very general solution. */ - -static bool -contains_save_expr_p (tree exp) -{ - switch (TREE_CODE (exp)) - { - case SAVE_EXPR: - return true; - - case ADDR_EXPR: case INDIRECT_REF: - case COMPONENT_REF: - CASE_CONVERT: case VIEW_CONVERT_EXPR: - return contains_save_expr_p (TREE_OPERAND (exp, 0)); - - case CONSTRUCTOR: - { - tree value; - unsigned HOST_WIDE_INT ix; - - FOR_EACH_CONSTRUCTOR_VALUE (CONSTRUCTOR_ELTS (exp), ix, value) - if (contains_save_expr_p (value)) - return true; - return false; - } - - default: - return false; - } -} - -/* See if EXP contains a NULL_EXPR in an expression we use for sizes. Return - it if so. This is used to detect types whose sizes involve computations - that are known to raise Constraint_Error. */ - -static tree -contains_null_expr (tree exp) -{ - tree tem; - - if (TREE_CODE (exp) == NULL_EXPR) - return exp; - - switch (TREE_CODE_CLASS (TREE_CODE (exp))) - { - case tcc_unary: - return contains_null_expr (TREE_OPERAND (exp, 0)); - - case tcc_comparison: - case tcc_binary: - tem = contains_null_expr (TREE_OPERAND (exp, 0)); - if (tem) - return tem; - - return contains_null_expr (TREE_OPERAND (exp, 1)); - - case tcc_expression: - switch (TREE_CODE (exp)) - { - case SAVE_EXPR: - return contains_null_expr (TREE_OPERAND (exp, 0)); - - case COND_EXPR: - tem = contains_null_expr (TREE_OPERAND (exp, 0)); - if (tem) - return tem; - - tem = contains_null_expr (TREE_OPERAND (exp, 1)); - if (tem) - return tem; - - return contains_null_expr (TREE_OPERAND (exp, 2)); - - default: - return 0; - } - - default: - return 0; - } -} - -/* Return an expression tree representing an equality comparison of - A1 and A2, two objects of ARRAY_TYPE. The returned expression should - be of type RESULT_TYPE - - Two arrays are equal in one of two ways: (1) if both have zero length - in some dimension (not necessarily the same dimension) or (2) if the - lengths in each dimension are equal and the data is equal. We perform the - length tests in as efficient a manner as possible. */ + Two arrays are equal in one of two ways: (1) if both have zero length in + some dimension (not necessarily the same dimension) or (2) if the lengths + in each dimension are equal and the data is equal. We perform the length + tests in as efficient a manner as possible. */ static tree compare_arrays (tree result_type, tree a1, tree a2) @@ -336,8 +247,18 @@ compare_arrays (tree result_type, tree a1, tree a2) tree result = convert (result_type, integer_one_node); tree a1_is_null = convert (result_type, integer_zero_node); tree a2_is_null = convert (result_type, integer_zero_node); + bool a1_side_effects_p = TREE_SIDE_EFFECTS (a1); + bool a2_side_effects_p = TREE_SIDE_EFFECTS (a2); bool length_zero_p = false; + /* If either operand has side-effects, they have to be evaluated only once + in spite of the multiple references to the operand in the comparison. */ + if (a1_side_effects_p) + a1 = protect_multiple_eval (a1); + + if (a2_side_effects_p) + a2 = protect_multiple_eval (a2); + /* Process each dimension separately and compare the lengths. If any dimension has a size known to be zero, set SIZE_ZERO_P to 1 to suppress the comparison of the data. */ @@ -350,9 +271,9 @@ compare_arrays (tree result_type, tree a1, tree a2) tree bt = get_base_type (TREE_TYPE (lb1)); tree length1 = fold_build2 (MINUS_EXPR, bt, ub1, lb1); tree length2 = fold_build2 (MINUS_EXPR, bt, ub2, lb2); - tree nbt; - tree tem; tree comparison, this_a1_is_null, this_a2_is_null; + tree nbt, tem; + bool btem; /* If the length of the first array is a constant, swap our operands unless the length of the second array is the constant zero. @@ -367,6 +288,8 @@ compare_arrays (tree result_type, tree a1, tree a2) tem = ub1, ub1 = ub2, ub2 = tem; tem = length1, length1 = length2, length2 = tem; tem = a1_is_null, a1_is_null = a2_is_null, a2_is_null = tem; + btem = a1_side_effects_p, a1_side_effects_p = a2_side_effects_p, + a2_side_effects_p = btem; } /* If the length of this dimension in the second array is the constant @@ -449,11 +372,13 @@ compare_arrays (tree result_type, tree a1, tree a2) tree type = find_common_type (TREE_TYPE (a1), TREE_TYPE (a2)); if (type) - a1 = convert (type, a1), a2 = convert (type, a2); + { + a1 = convert (type, a1), + a2 = convert (type, a2); + } result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result, fold_build2 (EQ_EXPR, result_type, a1, a2)); - } /* The result is also true if both sizes are zero. */ @@ -462,14 +387,13 @@ compare_arrays (tree result_type, tree a1, tree a2) a1_is_null, a2_is_null), result); - /* If either operand contains SAVE_EXPRs, they have to be evaluated before - starting the comparison above since the place it would be otherwise - evaluated would be wrong. */ - - if (contains_save_expr_p (a1)) + /* If either operand has side-effects, they have to be evaluated before + starting the comparison above since the place they would be otherwise + evaluated could be wrong. */ + if (a1_side_effects_p) result = build2 (COMPOUND_EXPR, result_type, a1, result); - if (contains_save_expr_p (a2)) + if (a2_side_effects_p) result = build2 (COMPOUND_EXPR, result_type, a2, result); return result; @@ -547,7 +471,7 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs, /* For subtraction, add the modulus back if we are negative. */ else if (op_code == MINUS_EXPR) { - result = save_expr (result); + result = protect_multiple_eval (result); result = fold_build3 (COND_EXPR, op_type, fold_build2 (LT_EXPR, integer_type_node, result, convert (op_type, integer_zero_node)), @@ -558,7 +482,7 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs, /* For the other operations, subtract the modulus if we are >= it. */ else { - result = save_expr (result); + result = protect_multiple_eval (result); result = fold_build3 (COND_EXPR, op_type, fold_build2 (GE_EXPR, integer_type_node, result, modulus), @@ -1241,7 +1165,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) { result = build1 (UNCONSTRAINED_ARRAY_REF, TYPE_UNCONSTRAINED_ARRAY (type), operand); - TREE_READONLY (result) = TREE_STATIC (result) + TREE_READONLY (result) = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type)); } else if (TREE_CODE (operand) == ADDR_EXPR) @@ -1590,13 +1514,6 @@ gnat_build_constructor (tree type, tree list) if (TREE_SIDE_EFFECTS (val)) side_effects = true; - - /* Propagate an NULL_EXPR from the size of the type. We won't ever - be executing the code we generate here in that case, but handle it - specially to avoid the compiler blowing up. */ - if (TREE_CODE (type) == RECORD_TYPE - && (result = contains_null_expr (DECL_SIZE (obj))) != NULL_TREE) - return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0)); } /* For record types with constant components only, sort field list @@ -1883,7 +1800,7 @@ maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node) { /* Latch malloc's return value and get a pointer to the aligning field first. */ - tree storage_ptr = save_expr (malloc_ptr); + tree storage_ptr = protect_multiple_eval (malloc_ptr); tree aligning_record_addr = convert (build_pointer_type (aligning_type), storage_ptr); @@ -2118,12 +2035,11 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, gnat_proc, gnat_pool, gnat_node)); - /* If we have an initial value, put the new address into a SAVE_EXPR, assign - the value, and return the address. Do this with a COMPOUND_EXPR. */ - + /* If we have an initial value, protect the new address, assign the value + and return the address with a COMPOUND_EXPR. */ if (init) { - result = save_expr (result); + result = protect_multiple_eval (result); result = build2 (COMPOUND_EXPR, TREE_TYPE (result), build_binary_op @@ -2188,14 +2104,14 @@ fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual) return gnat_build_constructor (record_type, nreverse (const_list)); } -/* Indicate that we need to make the address of EXPR_NODE and it therefore +/* Indicate that we need to take the address of T and that it therefore should not be allocated in a register. Returns true if successful. */ bool -gnat_mark_addressable (tree expr_node) +gnat_mark_addressable (tree t) { - while (1) - switch (TREE_CODE (expr_node)) + while (true) + switch (TREE_CODE (t)) { case ADDR_EXPR: case COMPONENT_REF: @@ -2206,27 +2122,27 @@ gnat_mark_addressable (tree expr_node) case VIEW_CONVERT_EXPR: case NON_LVALUE_EXPR: CASE_CONVERT: - expr_node = TREE_OPERAND (expr_node, 0); + t = TREE_OPERAND (t, 0); break; case CONSTRUCTOR: - TREE_ADDRESSABLE (expr_node) = 1; + TREE_ADDRESSABLE (t) = 1; return true; case VAR_DECL: case PARM_DECL: case RESULT_DECL: - TREE_ADDRESSABLE (expr_node) = 1; + TREE_ADDRESSABLE (t) = 1; return true; case FUNCTION_DECL: - TREE_ADDRESSABLE (expr_node) = 1; + TREE_ADDRESSABLE (t) = 1; return true; case CONST_DECL: - return (DECL_CONST_CORRESPONDING_VAR (expr_node) - && (gnat_mark_addressable - (DECL_CONST_CORRESPONDING_VAR (expr_node)))); + return DECL_CONST_CORRESPONDING_VAR (t) + && gnat_mark_addressable (DECL_CONST_CORRESPONDING_VAR (t)); + default: return true; } -- 2.7.4