From: Eric Botcazou Date: Wed, 5 Nov 2014 19:17:00 +0000 (+0000) Subject: trans.c (Subprogram_Body_to_gnu): For a function with copy-in/copy-out parameters... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=2374257aff7c2f88a7b1fa8c1466176b7d42f99c;p=gcc.git trans.c (Subprogram_Body_to_gnu): For a function with copy-in/copy-out parameters and which returns by invisible... * gcc-interface/trans.c (Subprogram_Body_to_gnu): For a function with copy-in/copy-out parameters and which returns by invisible reference, do not create the variable for the return value; instead, manually generate the indirect copy out statements on exit. (gnat_to_gnu) : Adjust accordingly and build a simple indirect assignment for the return value. From-SVN: r217155 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 72c0313afd3..c4b86401533 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2014-11-05 Eric Botcazou + + * gcc-interface/trans.c (Subprogram_Body_to_gnu): For a function with + copy-in/copy-out parameters and which returns by invisible reference, + do not create the variable for the return value; instead, manually + generate the indirect copy out statements on exit. + (gnat_to_gnu) : Adjust accordingly and build + a simple indirect assignment for the return value. + 2014-11-05 Eric Botcazou * gcc-interface/decl.c (gnat_to_gnu_entity) : For a diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 05b81ef75fb..01c9234e166 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -3547,13 +3547,12 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) 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 (gnu_cico_list && TREE_VALUE (gnu_cico_list) == void_type_node) + gnu_return_var_elmt = 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. - Handle the explicit case here and the copy-in/copy-out case below. */ - if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt) + function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */ + if (TREE_ADDRESSABLE (gnu_subprog_type)) { TREE_TYPE (gnu_result_decl) = build_reference_type (TREE_TYPE (gnu_result_decl)); @@ -3573,9 +3572,10 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) begin_subprog_body (gnu_subprog_decl); - /* 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. */ + /* If there are copy-in/copy-out parameters, we need to ensure that they are + properly copied out by the return statement. We do this by making a new + block and converting any return into a goto to a label at the end of the + block. */ if (gnu_cico_list) { tree gnu_return_var = NULL_TREE; @@ -3586,19 +3586,14 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) 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) + /* If this is a function with copy-in/copy-out parameters and which does + not return by invisible reference, we also need a variable for the + return value to be placed. */ + if (gnu_return_var_elmt && !TREE_ADDRESSABLE (gnu_subprog_type)) { 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, @@ -3693,7 +3688,8 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) the label and copy statement. */ if (gnu_cico_list) { - tree gnu_retval; + const Node_Id gnat_end_label + = End_Label (Handled_Statement_Sequence (gnat_node)); gnu_return_var_stack->pop (); @@ -3701,14 +3697,45 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_return_label_stack->last ())); - if (list_length (gnu_cico_list) == 1) - gnu_retval = TREE_VALUE (gnu_cico_list); + /* If this is a function which returns by invisible reference, the + return value has already been dealt with at the return statements, + so we only need to indirectly copy out the parameters. */ + if (TREE_ADDRESSABLE (gnu_subprog_type)) + { + tree gnu_ret_deref + = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result_decl); + tree t; + + gcc_assert (TREE_VALUE (gnu_cico_list) == void_type_node); + + for (t = TREE_CHAIN (gnu_cico_list); t; t = TREE_CHAIN (t)) + { + tree gnu_field_deref + = build_component_ref (gnu_ret_deref, NULL_TREE, + TREE_PURPOSE (t), true); + gnu_result = build2 (MODIFY_EXPR, void_type_node, + gnu_field_deref, TREE_VALUE (t)); + add_stmt_with_node (gnu_result, gnat_end_label); + } + } + + /* Otherwise, if this is a procedure or a function which does not return + by invisible reference, we can do a direct block-copy out. */ else - gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type), - gnu_cico_list); + { + tree gnu_retval; + + if (list_length (gnu_cico_list) == 1) + gnu_retval = TREE_VALUE (gnu_cico_list); + else + gnu_retval + = build_constructor_from_list (TREE_TYPE (gnu_subprog_type), + gnu_cico_list); + + gnu_result = build_return_expr (gnu_result_decl, gnu_retval); + add_stmt_with_node (gnu_result, gnat_end_label); + } - add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval), - End_Label (Handled_Statement_Sequence (gnat_node))); gnat_poplevel (); gnu_result = end_stmt_group (); } @@ -6539,9 +6566,11 @@ gnat_to_gnu (Node_Id gnat_node) { tree gnu_subprog_type = TREE_TYPE (current_function_decl); - /* If this function has copy-in/copy-out parameters, get the real - object for the return. See Subprogram_to_gnu. */ - if (TYPE_CI_CO_LIST (gnu_subprog_type)) + /* If this function has copy-in/copy-out parameters parameters and + doesn't return by invisible reference, get the real object for + the return. See Subprogram_Body_to_gnu. */ + if (TYPE_CI_CO_LIST (gnu_subprog_type) + && !TREE_ADDRESSABLE (gnu_subprog_type)) gnu_ret_obj = gnu_return_var_stack->last (); else gnu_ret_obj = DECL_RESULT (current_function_decl); @@ -6615,8 +6644,8 @@ gnat_to_gnu (Node_Id gnat_node) tree gnu_ret_deref = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val), gnu_ret_obj); - gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, - gnu_ret_deref, gnu_ret_val); + gnu_result = build2 (MODIFY_EXPR, void_type_node, + gnu_ret_deref, gnu_ret_val); add_stmt_with_node (gnu_result, gnat_node); gnu_ret_val = NULL_TREE; } @@ -6629,7 +6658,7 @@ gnat_to_gnu (Node_Id gnat_node) that label. The return proper will be handled elsewhere. */ if (gnu_return_label_stack->last ()) { - if (gnu_ret_obj) + if (gnu_ret_val) add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj, gnu_ret_val)); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 913b5c72766..c699ce31b4f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2014-11-05 Eric Botcazou + + * gnat.dg/discr42.adb: New test. + * gnat.dg/discr42_pkg.ad[sb]: New helper. + 2014-11-05 Eric Botcazou * gnat.dg/specs/private2.ads: New test. diff --git a/gcc/testsuite/gnat.dg/discr42.adb b/gcc/testsuite/gnat.dg/discr42.adb new file mode 100644 index 00000000000..e3380b889ba --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr42.adb @@ -0,0 +1,22 @@ +-- { dg-do run } + +with Discr42_Pkg; use Discr42_Pkg; + +procedure Discr42 is + + R : Rec; + Pos : Natural := 1; + +begin + + R := F (Pos); + + if Pos /= 2 then + raise Program_Error; + end if; + + if R /= (D => True, N => 4) then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/discr42_pkg.adb b/gcc/testsuite/gnat.dg/discr42_pkg.adb new file mode 100644 index 00000000000..8ec584c8ca3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr42_pkg.adb @@ -0,0 +1,13 @@ +package body Discr42_Pkg is + + function F (Pos : in out Natural) return Rec is + begin + Pos := Pos + 1; + if Pos > 1 then + return (D => True, N => Pos * 2); + else + return (D => False); + end if; + end; + +end Discr42_Pkg; diff --git a/gcc/testsuite/gnat.dg/discr42_pkg.ads b/gcc/testsuite/gnat.dg/discr42_pkg.ads new file mode 100644 index 00000000000..b9bef43037c --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr42_pkg.ads @@ -0,0 +1,12 @@ +package Discr42_Pkg is + + type Rec (D : Boolean := False) is record + case D is + when True => N : Natural; + when False => null; + end case; + end record; + + function F (Pos : in out Natural) return Rec; + +end Discr42_Pkg;