diff options
Diffstat (limited to 'gcc/ada/gcc-interface/trans.c')
| -rw-r--r-- | gcc/ada/gcc-interface/trans.c | 344 |
1 files changed, 231 insertions, 113 deletions
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index f159836..3156e77 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -165,6 +165,10 @@ static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack; some functions. See processing for N_Subprogram_Body. */ static GTY(()) VEC(tree,gc) *gnu_return_label_stack; +/* Stack of variable for the return value of a function with copy-in/copy-out + parameters. See processing for N_Subprogram_Body. */ +static GTY(()) VEC(tree,gc) *gnu_return_var_stack; + /* Stack of LOOP_STMT nodes. */ static GTY(()) VEC(tree,gc) *gnu_loop_label_stack; @@ -2445,9 +2449,12 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) tree gnu_subprog_decl; /* Its RESULT_DECL node. */ tree gnu_result_decl; - /* The FUNCTION_TYPE node corresponding to the subprogram spec. */ + /* Its FUNCTION_TYPE node. */ tree gnu_subprog_type; + /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */ tree gnu_cico_list; + /* The entry in the CI_CO_LIST that represents a function return, if any. */ + tree gnu_return_var_elmt = NULL_TREE; tree gnu_result; VEC(parm_attr,gc) *cache; @@ -2470,10 +2477,14 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) && !present_gnu_tree (gnat_subprog_id)); gnu_result_decl = DECL_RESULT (gnu_subprog_decl); gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); + gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); + if (gnu_cico_list) + gnu_return_var_elmt = value_member (void_type_node, gnu_cico_list); /* If the function returns by invisible reference, make it explicit in the - function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */ - if (TREE_ADDRESSABLE (gnu_subprog_type)) + function body. See gnat_to_gnu_entity, E_Subprogram_Type case. + Handle the explicit case here and the copy-in/copy-out case below. */ + if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt) { TREE_TYPE (gnu_result_decl) = build_reference_type (TREE_TYPE (gnu_result_decl)); @@ -2499,15 +2510,38 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) /* If there are In Out or Out parameters, we need to ensure that the return statement properly copies them out. We do this by making a new block and converting any return into a goto to a label at the end of the block. */ - gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); if (gnu_cico_list) { + tree gnu_return_var = NULL_TREE; + VEC_safe_push (tree, gc, gnu_return_label_stack, create_artificial_label (input_location)); start_stmt_group (); gnat_pushlevel (); + /* If this is a function with In Out or Out parameters, we also need a + variable for the return value to be placed. */ + if (gnu_return_var_elmt) + { + tree gnu_return_type + = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt)); + + /* If the function returns by invisible reference, make it + explicit in the function body. See gnat_to_gnu_entity, + E_Subprogram_Type case. */ + if (TREE_ADDRESSABLE (gnu_subprog_type)) + gnu_return_type = build_reference_type (gnu_return_type); + + gnu_return_var + = create_var_decl (get_identifier ("RETVAL"), NULL_TREE, + gnu_return_type, NULL_TREE, false, false, + false, false, NULL, gnat_subprog_id); + TREE_VALUE (gnu_return_var_elmt) = gnu_return_var; + } + + VEC_safe_push (tree, gc, gnu_return_var_stack, gnu_return_var); + /* See whether there are parameters for which we don't have a GCC tree yet. These must be Out parameters. Make a VAR_DECL for them and put it into TYPE_CI_CO_LIST, which must contain an empty entry too. @@ -2649,9 +2683,33 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) if (DECL_FUNCTION_STUB (gnu_subprog_decl)) build_function_stub (gnu_subprog_decl, gnat_subprog_id); + if (gnu_return_var_elmt) + TREE_VALUE (gnu_return_var_elmt) = void_type_node; + mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node))); } + +/* Create a temporary variable with PREFIX and initialize it with GNU_INIT. + Put the initialization statement into GNU_INIT_STMT and annotate it with + the SLOC of GNAT_NODE. Return the temporary variable. */ + +static tree +create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt, + Node_Id gnat_node) +{ + tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE, + TREE_TYPE (gnu_init), NULL_TREE, false, + false, false, false, NULL, Empty); + DECL_ARTIFICIAL (gnu_temp) = 1; + DECL_IGNORED_P (gnu_temp) = 1; + + *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init); + set_expr_location_from_node (*gnu_init_stmt, gnat_node); + + return gnu_temp; +} + /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call or an N_Procedure_Call_Statement, to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where we should place the result type. @@ -2675,7 +2733,9 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) tree gnu_name_list = NULL_TREE; tree gnu_before_list = NULL_TREE; tree gnu_after_list = NULL_TREE; - tree gnu_call; + tree gnu_call, gnu_result; + bool returning_value = (Nkind (gnat_node) == N_Function_Call && !gnu_target); + bool pushed_binding_level = false; bool went_into_elab_proc = false; gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE); @@ -2692,7 +2752,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnat_actual = Next_Actual (gnat_actual)) add_stmt (gnat_to_gnu (gnat_actual)); - if (Nkind (gnat_node) == N_Function_Call && !gnu_target) + if (returning_value) { *gnu_result_type_p = TREE_TYPE (gnu_subprog_type); return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr); @@ -2713,17 +2773,23 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) else gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); - /* If we are translating a statement, open a new nesting level that will - surround it to declare the temporaries created for the call. */ - if (Nkind (gnat_node) == N_Procedure_Call_Statement || gnu_target) + /* If we are translating a statement, push a new binding level that will + surround it to declare the temporaries created for the call. Likewise + if we'll be returning a value and also have copy-in/copy-out parameters, + as we need to create statements to fetch their value after the call. + + ??? We could do that unconditionally, but the middle-end doesn't seem + to be prepared to handle the construct in nested contexts. */ + if (!returning_value || TYPE_CI_CO_LIST (gnu_subprog_type)) { start_stmt_group (); gnat_pushlevel (); + pushed_binding_level = true; } /* The lifetime of the temporaries created for the call ends with the call so we can give them the scope of the elaboration routine at top level. */ - else if (!current_function_decl) + if (!current_function_decl) { current_function_decl = get_elaboration_procedure (); went_into_elab_proc = true; @@ -2778,6 +2844,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name))) && !addressable_p (gnu_name, gnu_name_type)) { + bool in_param = (Ekind (gnat_formal) == E_In_Parameter); tree gnu_orig = gnu_name, gnu_temp, gnu_stmt; /* Do not issue warnings for CONSTRUCTORs since this is not a copy @@ -2837,26 +2904,28 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) TREE_TYPE (gnu_name)))) gnu_name = convert (gnu_name_type, gnu_name); + /* If we haven't pushed a binding level and this is an In Out or Out + parameter, push a new one. This is needed to wrap the copy-back + statements we'll be making below. */ + if (!pushed_binding_level && !in_param) + { + start_stmt_group (); + gnat_pushlevel (); + pushed_binding_level = true; + } + /* Create an explicit temporary holding the copy. This ensures that its lifetime is as narrow as possible around a statement. */ - gnu_temp = create_var_decl (create_tmp_var_name ("A"), NULL_TREE, - TREE_TYPE (gnu_name), NULL_TREE, - false, false, false, false, NULL, Empty); - DECL_ARTIFICIAL (gnu_temp) = 1; - DECL_IGNORED_P (gnu_temp) = 1; + gnu_temp + = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual); /* But initialize it on the fly like for an implicit temporary as we aren't necessarily dealing with a statement. */ - gnu_stmt - = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_name); - set_expr_location_from_node (gnu_stmt, gnat_actual); - - /* From now on, the real object is the temporary. */ gnu_name = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_name), gnu_stmt, gnu_temp); /* Set up to move the copy back to the original if needed. */ - if (Ekind (gnat_formal) != E_In_Parameter) + if (!in_param) { gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp); @@ -3034,62 +3103,10 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnu_actual_vec); 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) - { - tree gnu_result = gnu_call; - - /* If the function returns an unconstrained array or by direct reference, - we have to dereference the pointer. */ - if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type) - || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)) - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); - - if (gnu_target) - { - Node_Id gnat_parent = Parent (gnat_node); - tree gnu_result_type = TREE_TYPE (gnu_subprog_type); - enum tree_code op_code; - - /* If range check is needed, emit code to generate it. */ - if (Do_Range_Check (gnat_node)) - gnu_result - = emit_range_check (gnu_result, Etype (Name (gnat_parent)), - gnat_parent); - - /* ??? If the return type has non-constant size, then force the - return slot optimization as we would not be able to generate - a temporary. Likewise if it was unconstrained as we would - copy too much data. That's what has been done historically. */ - if (!TREE_CONSTANT (TYPE_SIZE (gnu_result_type)) - || (TYPE_IS_PADDING_P (gnu_result_type) - && CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type)))))) - op_code = INIT_EXPR; - else - op_code = MODIFY_EXPR; - - gnu_result - = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_result); - add_stmt_with_node (gnu_result, gnat_parent); - gnat_poplevel (); - gnu_result = end_stmt_group (); - } - else - { - if (went_into_elab_proc) - current_function_decl = NULL_TREE; - *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); - } - - return gnu_result; - } - - /* If this is the case where the GNAT tree contains a procedure call but the - Ada procedure has copy-in/copy-out parameters, then the special parameter - passing mechanism must be used. */ + /* If this is a subprogram with copy-in/copy-out parameters, we need to + unpack the valued returned from the function into the In Out or Out + parameters. We deal with the function return (if this is an Ada + function) below. */ if (TYPE_CI_CO_LIST (gnu_subprog_type)) { /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/ @@ -3097,29 +3114,23 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); const int length = list_length (gnu_cico_list); + /* The call sequence must contain one and only one call, even though the + function is pure. Save the result into a temporary if needed. */ if (length > 1) { - tree gnu_temp, gnu_stmt; - - /* The call sequence must contain one and only one call, even though - the function is pure. Save the result into a temporary. */ - gnu_temp = create_var_decl (create_tmp_var_name ("R"), NULL_TREE, - TREE_TYPE (gnu_call), NULL_TREE, false, - false, false, false, NULL, Empty); - DECL_ARTIFICIAL (gnu_temp) = 1; - DECL_IGNORED_P (gnu_temp) = 1; - - gnu_stmt - = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_call); - set_expr_location_from_node (gnu_stmt, gnat_node); - - /* Add the call statement to the list and start from its result. */ + tree gnu_stmt; + gnu_call + = create_init_temporary ("R", gnu_call, &gnu_stmt, gnat_node); append_to_statement_list (gnu_stmt, &gnu_before_list); - gnu_call = gnu_temp; gnu_name_list = nreverse (gnu_name_list); } + /* The first entry is for the actual return value if this is a + function, so skip it. */ + if (TREE_VALUE (gnu_cico_list) == void_type_node) + gnu_cico_list = TREE_CHAIN (gnu_cico_list); + if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); else @@ -3129,7 +3140,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) Present (gnat_actual); gnat_formal = Next_Formal_With_Extras (gnat_formal), gnat_actual = Next_Actual (gnat_actual)) - /* If we are dealing with a copy in copy out parameter, we must + /* If we are dealing with a copy-in/copy-out parameter, we must retrieve its value from the record returned in the call. */ if (!(present_gnu_tree (gnat_formal) && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL @@ -3208,14 +3219,109 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnu_name_list = TREE_CHAIN (gnu_name_list); } } - else + + /* If this is 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) + { + tree gnu_result_type = TREE_TYPE (gnu_subprog_type); + + /* If this is a function with copy-in/copy-out parameters, extract the + return value from it and update the return type. */ + if (TYPE_CI_CO_LIST (gnu_subprog_type)) + { + tree gnu_elmt = value_member (void_type_node, + TYPE_CI_CO_LIST (gnu_subprog_type)); + gnu_call = build_component_ref (gnu_call, NULL_TREE, + TREE_PURPOSE (gnu_elmt), false); + gnu_result_type = TREE_TYPE (gnu_call); + } + + /* If the function returns an unconstrained array or by direct reference, + we have to dereference the pointer. */ + if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type) + || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)) + gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call); + + if (gnu_target) + { + Node_Id gnat_parent = Parent (gnat_node); + enum tree_code op_code; + + /* If range check is needed, emit code to generate it. */ + if (Do_Range_Check (gnat_node)) + gnu_call + = emit_range_check (gnu_call, Etype (Name (gnat_parent)), + gnat_parent); + + /* ??? If the return type has non-constant size, then force the + return slot optimization as we would not be able to generate + a temporary. Likewise if it was unconstrained as we would + copy too much data. That's what has been done historically. */ + if (!TREE_CONSTANT (TYPE_SIZE (gnu_result_type)) + || (TYPE_IS_PADDING_P (gnu_result_type) + && CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type)))))) + op_code = INIT_EXPR; + else + op_code = MODIFY_EXPR; + + gnu_call + = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call); + set_expr_location_from_node (gnu_call, gnat_parent); + append_to_statement_list (gnu_call, &gnu_before_list); + } + else + *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); + } + + /* Otherwise, if this is a procedure call statement without copy-in/copy-out + parameters, the result is just the call statement. */ + else if (!TYPE_CI_CO_LIST (gnu_subprog_type)) append_to_statement_list (gnu_call, &gnu_before_list); - append_to_statement_list (gnu_after_list, &gnu_before_list); + if (went_into_elab_proc) + current_function_decl = NULL_TREE; - add_stmt (gnu_before_list); - gnat_poplevel (); - return end_stmt_group (); + /* If we have pushed a binding level, the result is the statement group. + Otherwise it's just the call expression. */ + if (pushed_binding_level) + { + /* If we need a value and haven't created the call statement, do so. */ + if (returning_value && !TYPE_CI_CO_LIST (gnu_subprog_type)) + { + tree gnu_stmt; + gnu_call + = create_init_temporary ("R", gnu_call, &gnu_stmt, gnat_node); + append_to_statement_list (gnu_stmt, &gnu_before_list); + } + append_to_statement_list (gnu_after_list, &gnu_before_list); + add_stmt (gnu_before_list); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + else + return gnu_call; + + /* If we need a value, make a COMPOUND_EXPR to return it; otherwise, + return the result. Deal specially with UNCONSTRAINED_ARRAY_REF. */ + if (returning_value) + { + if (TREE_CODE (gnu_call) == UNCONSTRAINED_ARRAY_REF + || TREE_CODE (gnu_call) == INDIRECT_REF) + gnu_result = build1 (TREE_CODE (gnu_call), TREE_TYPE (gnu_call), + fold_build2 (COMPOUND_EXPR, + TREE_TYPE (TREE_OPERAND (gnu_call, + 0)), + gnu_result, + TREE_OPERAND (gnu_call, 0))); + else + gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_call), + gnu_result, gnu_call); + } + + return gnu_result; } /* Subroutine of gnat_to_gnu to translate gnat_node, an @@ -4958,25 +5064,22 @@ gnat_to_gnu (Node_Id gnat_node) { tree gnu_ret_val, gnu_ret_obj; - /* If we have a return label defined, convert this into a branch to - that label. The return proper will be handled elsewhere. */ - if (VEC_last (tree, gnu_return_label_stack)) - { - gnu_result = build1 (GOTO_EXPR, void_type_node, - VEC_last (tree, gnu_return_label_stack)); - /* When not optimizing, make sure the return is preserved. */ - if (!optimize && Comes_From_Source (gnat_node)) - DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0; - break; - } - /* If the subprogram is a function, we must return the expression. */ if (Present (Expression (gnat_node))) { tree gnu_subprog_type = TREE_TYPE (current_function_decl); + tree gnu_ret_type = TREE_TYPE (gnu_subprog_type); tree gnu_result_decl = DECL_RESULT (current_function_decl); gnu_ret_val = gnat_to_gnu (Expression (gnat_node)); + /* If this function has copy-in/copy-out parameters, get the real + variable and type for the return. See Subprogram_to_gnu. */ + if (TYPE_CI_CO_LIST (gnu_subprog_type)) + { + gnu_result_decl = VEC_last (tree, gnu_return_var_stack); + gnu_ret_type = TREE_TYPE (gnu_result_decl); + } + /* 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 @@ -4998,8 +5101,7 @@ gnat_to_gnu (Node_Id gnat_node) { gnu_ret_val = maybe_unconstrained_array (gnu_ret_val); gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val), - gnu_ret_val, - TREE_TYPE (gnu_subprog_type), + gnu_ret_val, gnu_ret_type, Procedure_To_Call (gnat_node), Storage_Pool (gnat_node), gnat_node, false); @@ -5032,6 +5134,22 @@ gnat_to_gnu (Node_Id gnat_node) gnu_ret_obj = NULL_TREE; } + /* If we have a return label defined, convert this into a branch to + that label. The return proper will be handled elsewhere. */ + if (VEC_last (tree, gnu_return_label_stack)) + { + if (gnu_ret_obj) + add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj, + gnu_ret_val)); + + gnu_result = build1 (GOTO_EXPR, void_type_node, + VEC_last (tree, gnu_return_label_stack)); + /* When not optimizing, make sure the return is preserved. */ + if (!optimize && Comes_From_Source (gnat_node)) + DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0; + break; + } + gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val); } break; |