From abc856cf227c4a97ddb4697bb51ab0da8dba4d94 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Wed, 3 Jul 2019 08:15:54 +0000 Subject: [PATCH] [Ada] Spurious visibility error in inlined function This patch corrects the use of tree replication when inlining a function that returns an unconstrained result, and its sole statement is an extended return statement. The use of New_Copy_Tree ensires that global references saved in a generic template are properly carried over when the function is instantiated and inlined. 2019-07-03 Hristian Kirtchev gcc/ada/ * inline.adb (Build_Return_Object_Formal): New routine. (Can_Split_Unconstrained_Function): Code clean up. (Copy_Formals,Copy_Return_Object): New routines. (Split_Unconstrained_Function): Code clean up and refactoring. gcc/testsuite/ * gnat.dg/inline15.adb, gnat.dg/inline15_gen.adb, gnat.dg/inline15_gen.ads, gnat.dg/inline15_types.ads: New testcase. From-SVN: r272980 --- gcc/ada/ChangeLog | 7 + gcc/ada/inline.adb | 267 +++++++++++++++-------- gcc/testsuite/ChangeLog | 6 + gcc/testsuite/gnat.dg/inline15.adb | 11 + gcc/testsuite/gnat.dg/inline15_gen.adb | 27 +++ gcc/testsuite/gnat.dg/inline15_gen.ads | 11 + gcc/testsuite/gnat.dg/inline15_types.ads | 17 ++ 7 files changed, 255 insertions(+), 91 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/inline15.adb create mode 100644 gcc/testsuite/gnat.dg/inline15_gen.adb create mode 100644 gcc/testsuite/gnat.dg/inline15_gen.ads create mode 100644 gcc/testsuite/gnat.dg/inline15_types.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d2566c8897f..d25fcbe47ca 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2019-07-03 Hristian Kirtchev + + * inline.adb (Build_Return_Object_Formal): New routine. + (Can_Split_Unconstrained_Function): Code clean up. + (Copy_Formals,Copy_Return_Object): New routines. + (Split_Unconstrained_Function): Code clean up and refactoring. + 2019-07-03 Gary Dismukes * bindo-augmentors.adb, bindo-augmentors.ads, diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 8672105f1e9..653908a7144 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1706,11 +1706,29 @@ package body Inline is -- Use generic machinery to build an unexpanded body for the subprogram. -- This body is subsequently used for inline expansions at call sites. + procedure Build_Return_Object_Formal + (Loc : Source_Ptr; + Obj_Decl : Node_Id; + Formals : List_Id); + -- Create a formal parameter for return object declaration Obj_Decl of + -- an extended return statement and add it to list Formals. + function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean; -- Return true if we generate code for the function body N, the function -- body N has no local declarations and its unique statement is a single -- extended return statement with a handled statements sequence. + procedure Copy_Formals + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Formals : List_Id); + -- Create new formal parameters from the formal parameters of subprogram + -- Subp_Id and add them to list Formals. + + function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id; + -- Create a copy of return object declaration Obj_Decl of an extended + -- return statement. + procedure Split_Unconstrained_Function (N : Node_Id; Spec_Id : Entity_Id); @@ -1757,6 +1775,9 @@ package body Inline is Body_To_Inline := Copy_Generic_Node (N, Empty, Instantiating => True); else + -- ??? Shouldn't this use New_Copy_Tree? What about global + -- references captured in the body to inline? + Body_To_Inline := Copy_Separate_Tree (N); end if; @@ -1845,30 +1866,70 @@ package body Inline is Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id)); end Build_Body_To_Inline; + -------------------------------- + -- Build_Return_Object_Formal -- + -------------------------------- + + procedure Build_Return_Object_Formal + (Loc : Source_Ptr; + Obj_Decl : Node_Id; + Formals : List_Id) + is + Obj_Def : constant Node_Id := Object_Definition (Obj_Decl); + Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); + Typ_Def : Node_Id; + + begin + -- Build the type definition of the formal parameter. The use of + -- New_Copy_Tree ensures that global references preserved in the + -- case of generics. + + if Is_Entity_Name (Obj_Def) then + Typ_Def := New_Copy_Tree (Obj_Def); + else + Typ_Def := New_Copy_Tree (Subtype_Mark (Obj_Def)); + end if; + + -- Generate: + -- + -- Obj_Id : [out] Typ_Def + + -- Mode OUT should not be used when the return object is declared as + -- a constant. Check the definition of the object declaration because + -- the object has not been analyzed yet. + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Obj_Id)), + In_Present => False, + Out_Present => not Constant_Present (Obj_Decl), + Null_Exclusion_Present => False, + Parameter_Type => Typ_Def)); + end Build_Return_Object_Formal; + -------------------------------------- -- Can_Split_Unconstrained_Function -- -------------------------------------- function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is - Ret_Node : constant Node_Id := - First (Statements (Handled_Statement_Sequence (N))); - D : Node_Id; + Stmt : constant Node_Id := + First (Statements (Handled_Statement_Sequence (N))); + Decl : Node_Id; begin -- No user defined declarations allowed in the function except inside -- the unique return statement; implicit labels are the only allowed -- declarations. - if not Is_Empty_List (Declarations (N)) then - D := First (Declarations (N)); - while Present (D) loop - if Nkind (D) /= N_Implicit_Label_Declaration then - return False; - end if; + Decl := First (Declarations (N)); + while Present (Decl) loop + if Nkind (Decl) /= N_Implicit_Label_Declaration then + return False; + end if; - Next (D); - end loop; - end if; + Next (Decl); + end loop; -- We only split the inlined function when we are generating the code -- of its body; otherwise we leave duplicated split subprograms in @@ -1876,12 +1937,71 @@ package body Inline is -- time. return In_Extended_Main_Code_Unit (N) - and then Present (Ret_Node) - and then Nkind (Ret_Node) = N_Extended_Return_Statement - and then No (Next (Ret_Node)) - and then Present (Handled_Statement_Sequence (Ret_Node)); + and then Present (Stmt) + and then Nkind (Stmt) = N_Extended_Return_Statement + and then No (Next (Stmt)) + and then Present (Handled_Statement_Sequence (Stmt)); end Can_Split_Unconstrained_Function; + ------------------ + -- Copy_Formals -- + ------------------ + + procedure Copy_Formals + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Formals : List_Id) + is + Formal : Entity_Id; + Spec : Node_Id; + + begin + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + Spec := Parent (Formal); + + -- Create an exact copy of the formal parameter. The use of + -- New_Copy_Tree ensures that global references are preserved + -- in case of generics. + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), + In_Present => In_Present (Spec), + Out_Present => Out_Present (Spec), + Null_Exclusion_Present => Null_Exclusion_Present (Spec), + Parameter_Type => + New_Copy_Tree (Parameter_Type (Spec)), + Expression => New_Copy_Tree (Expression (Spec)))); + + Next_Formal (Formal); + end loop; + end Copy_Formals; + + ------------------------ + -- Copy_Return_Object -- + ------------------------ + + function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id is + Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); + + begin + -- The use of New_Copy_Tree ensures that global references are + -- preserved in case of generics. + + return + Make_Object_Declaration (Sloc (Obj_Decl), + Defining_Identifier => + Make_Defining_Identifier (Sloc (Obj_Id), Chars (Obj_Id)), + Aliased_Present => Aliased_Present (Obj_Decl), + Constant_Present => Constant_Present (Obj_Decl), + Null_Exclusion_Present => Null_Exclusion_Present (Obj_Decl), + Object_Definition => + New_Copy_Tree (Object_Definition (Obj_Decl)), + Expression => New_Copy_Tree (Expression (Obj_Decl))); + end Copy_Return_Object; + ---------------------------------- -- Split_Unconstrained_Function -- ---------------------------------- @@ -1891,10 +2011,10 @@ package body Inline is Spec_Id : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); - Ret_Node : constant Node_Id := + Ret_Stmt : constant Node_Id := First (Statements (Handled_Statement_Sequence (N))); Ret_Obj : constant Node_Id := - First (Return_Object_Declarations (Ret_Node)); + First (Return_Object_Declarations (Ret_Stmt)); procedure Build_Procedure (Proc_Id : out Entity_Id; @@ -1910,63 +2030,35 @@ package body Inline is (Proc_Id : out Entity_Id; Decl_List : out List_Id) is - Formal : Entity_Id; - Formal_List : constant List_Id := New_List; - Proc_Spec : Node_Id; - Proc_Body : Node_Id; - Subp_Name : constant Name_Id := New_Internal_Name ('F'); - Body_Decl_List : List_Id := No_List; - Param_Type : Node_Id; + Formals : constant List_Id := New_List; + Subp_Name : constant Name_Id := New_Internal_Name ('F'); - begin - if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then - Param_Type := - New_Copy (Object_Definition (Ret_Obj)); - else - Param_Type := - New_Copy (Subtype_Mark (Object_Definition (Ret_Obj))); - end if; + Body_Decls : List_Id := No_List; + Decl : Node_Id; + Proc_Body : Node_Id; + Proc_Spec : Node_Id; - Append_To (Formal_List, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (Ret_Obj))), - In_Present => False, - Out_Present => True, - Null_Exclusion_Present => False, - Parameter_Type => Param_Type)); - - Formal := First_Formal (Spec_Id); - - -- Note that we copy the parameter type rather than creating - -- a reference to it, because it may be a class-wide entity - -- that will not be retrieved by name. + begin + -- Create formal parameters for the return object and all formals + -- of the unconstrained function in order to pass their values to + -- the procedure. - while Present (Formal) loop - Append_To (Formal_List, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Sloc (Formal), - Chars => Chars (Formal)), - In_Present => In_Present (Parent (Formal)), - Out_Present => Out_Present (Parent (Formal)), - Null_Exclusion_Present => - Null_Exclusion_Present (Parent (Formal)), - Parameter_Type => - New_Copy_Tree (Parameter_Type (Parent (Formal))), - Expression => - Copy_Separate_Tree (Expression (Parent (Formal))))); + Build_Return_Object_Formal + (Loc => Loc, + Obj_Decl => Ret_Obj, + Formals => Formals); - Next_Formal (Formal); - end loop; + Copy_Formals + (Loc => Loc, + Subp_Id => Spec_Id, + Formals => Formals); Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name); Proc_Spec := Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc_Id, - Parameter_Specifications => Formal_List); + Parameter_Specifications => Formals); Decl_List := New_List; @@ -1978,37 +2070,30 @@ package body Inline is -- Copy these declarations to the built procedure. if Present (Declarations (N)) then - Body_Decl_List := New_List; + Body_Decls := New_List; - declare - D : Node_Id; - New_D : Node_Id; + Decl := First (Declarations (N)); + while Present (Decl) loop + pragma Assert (Nkind (Decl) = N_Implicit_Label_Declaration); - begin - D := First (Declarations (N)); - while Present (D) loop - pragma Assert (Nkind (D) = N_Implicit_Label_Declaration); - - New_D := - Make_Implicit_Label_Declaration (Loc, - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (D))), - Label_Construct => Empty); - Append_To (Body_Decl_List, New_D); - - Next (D); - end loop; - end; + Append_To (Body_Decls, + Make_Implicit_Label_Declaration (Loc, + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Decl))), + Label_Construct => Empty)); + + Next (Decl); + end loop; end if; - pragma Assert (Present (Handled_Statement_Sequence (Ret_Node))); + pragma Assert (Present (Handled_Statement_Sequence (Ret_Stmt))); Proc_Body := Make_Subprogram_Body (Loc, - Specification => Copy_Separate_Tree (Proc_Spec), - Declarations => Body_Decl_List, + Specification => Copy_Subprogram_Spec (Proc_Spec), + Declarations => Body_Decls, Handled_Statement_Sequence => - Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node))); + New_Copy_Tree (Handled_Statement_Sequence (Ret_Stmt))); Set_Defining_Unit_Name (Specification (Proc_Body), Make_Defining_Identifier (Loc, Subp_Name)); @@ -2018,10 +2103,10 @@ package body Inline is -- Local variables - New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj); + New_Obj : constant Node_Id := Copy_Return_Object (Ret_Obj); Blk_Stmt : Node_Id; - Proc_Id : Entity_Id; Proc_Call : Node_Id; + Proc_Id : Entity_Id; -- Start of processing for Split_Unconstrained_Function @@ -2089,7 +2174,7 @@ package body Inline is New_Occurrence_Of (Defining_Identifier (New_Obj), Loc))))); - Rewrite (Ret_Node, Blk_Stmt); + Rewrite (Ret_Stmt, Blk_Stmt); end Split_Unconstrained_Function; -- Local variables diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c9f0bc6a0bb..91168935178 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2019-07-03 Hristian Kirtchev + + * gnat.dg/inline15.adb, gnat.dg/inline15_gen.adb, + gnat.dg/inline15_gen.ads, gnat.dg/inline15_types.ads: New + testcase. + 2019-07-03 Bob Duff * gnat.dg/warn20.adb, gnat.dg/warn20_pkg.adb, diff --git a/gcc/testsuite/gnat.dg/inline15.adb b/gcc/testsuite/gnat.dg/inline15.adb new file mode 100644 index 00000000000..953e72e44c0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline15.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +with Inline15_Gen; + +procedure Inline15 is + package Inst is new Inline15_Gen; + +begin + Inst.Call_Func; +end Inline15; diff --git a/gcc/testsuite/gnat.dg/inline15_gen.adb b/gcc/testsuite/gnat.dg/inline15_gen.adb new file mode 100644 index 00000000000..f2b17f8af30 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline15_gen.adb @@ -0,0 +1,27 @@ +package body Inline15_Gen is + function Initialize (Val : Inline15_Types.Enum) return Inline15_Types.Rec; + procedure Print (Val : Inline15_Types.Rec); + + procedure Call_Func is + Result : constant Inline15_Types.Rec := Func (Inline15_Types.Two); + begin + null; + end Call_Func; + + function Func (Val : Inline15_Types.Enum) return Inline15_Types.Rec is + begin + return Result : constant Inline15_Types.Rec := Initialize (Val) do + Print (Result); + end return; + end Func; + + function Initialize (Val : Inline15_Types.Enum) return Inline15_Types.Rec is + pragma Warnings (Off); + Result : Inline15_Types.Rec (Val); + pragma Warnings (On); + begin + return Result; + end Initialize; + + procedure Print (Val : Inline15_Types.Rec) is begin null; end Print; +end Inline15_Gen; diff --git a/gcc/testsuite/gnat.dg/inline15_gen.ads b/gcc/testsuite/gnat.dg/inline15_gen.ads new file mode 100644 index 00000000000..42856e8cd0f --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline15_gen.ads @@ -0,0 +1,11 @@ + +-- gen.ads + +with Inline15_Types; + +generic +package Inline15_Gen is + function Func (Val : Inline15_Types.Enum) return Inline15_Types.Rec with Inline; + + procedure Call_Func with Inline; +end Inline15_Gen; diff --git a/gcc/testsuite/gnat.dg/inline15_types.ads b/gcc/testsuite/gnat.dg/inline15_types.ads new file mode 100644 index 00000000000..5aaa2d64bf1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline15_types.ads @@ -0,0 +1,17 @@ +package Inline15_Types is + type Enum is (One, Two, Three, Four); + + type Rec (Discr : Enum) is record + Comp_1 : Integer; + + case Discr is + when One => + Comp_2 : Float; + when Two => + Comp_3 : Boolean; + Comp_4 : Long_Float; + when others => + null; + end case; + end record; +end Inline15_Types; -- 2.30.2