Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/inline.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/inline.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,4210 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N L I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Expander; use Expander; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Lib; use Lib; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Output; use Output; +with Sem_Aux; use Sem_Aux; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch10; use Sem_Ch10; +with Sem_Ch12; use Sem_Ch12; +with Sem_Prag; use Sem_Prag; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Uname; use Uname; +with Tbuild; use Tbuild; + +package body Inline is + + Check_Inlining_Restrictions : constant Boolean := True; + -- In the following cases the frontend rejects inlining because they + -- are not handled well by the backend. This variable facilitates + -- disabling these restrictions to evaluate future versions of the + -- GCC backend in which some of the restrictions may be supported. + -- + -- - subprograms that have: + -- - nested subprograms + -- - instantiations + -- - package declarations + -- - task or protected object declarations + -- - some of the following statements: + -- - abort + -- - asynchronous-select + -- - conditional-entry-call + -- - delay-relative + -- - delay-until + -- - selective-accept + -- - timed-entry-call + + Inlined_Calls : Elist_Id; + -- List of frontend inlined calls + + Backend_Calls : Elist_Id; + -- List of inline calls passed to the backend + + Backend_Inlined_Subps : Elist_Id; + -- List of subprograms inlined by the backend + + Backend_Not_Inlined_Subps : Elist_Id; + -- List of subprograms that cannot be inlined by the backend + + -------------------- + -- Inlined Bodies -- + -------------------- + + -- Inlined functions are actually placed in line by the backend if the + -- corresponding bodies are available (i.e. compiled). Whenever we find + -- a call to an inlined subprogram, we add the name of the enclosing + -- compilation unit to a worklist. After all compilation, and after + -- expansion of generic bodies, we traverse the list of pending bodies + -- and compile them as well. + + package Inlined_Bodies is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Inlined_Bodies_Initial, + Table_Increment => Alloc.Inlined_Bodies_Increment, + Table_Name => "Inlined_Bodies"); + + ----------------------- + -- Inline Processing -- + ----------------------- + + -- For each call to an inlined subprogram, we make entries in a table + -- that stores caller and callee, and indicates the call direction from + -- one to the other. We also record the compilation unit that contains + -- the callee. After analyzing the bodies of all such compilation units, + -- we compute the transitive closure of inlined subprograms called from + -- the main compilation unit and make it available to the code generator + -- in no particular order, thus allowing cycles in the call graph. + + Last_Inlined : Entity_Id := Empty; + + -- For each entry in the table we keep a list of successors in topological + -- order, i.e. callers of the current subprogram. + + type Subp_Index is new Nat; + No_Subp : constant Subp_Index := 0; + + -- The subprogram entities are hashed into the Inlined table + + Num_Hash_Headers : constant := 512; + + Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1) + of Subp_Index; + + type Succ_Index is new Nat; + No_Succ : constant Succ_Index := 0; + + type Succ_Info is record + Subp : Subp_Index; + Next : Succ_Index; + end record; + + -- The following table stores list elements for the successor lists. These + -- lists cannot be chained directly through entries in the Inlined table, + -- because a given subprogram can appear in several such lists. + + package Successors is new Table.Table ( + Table_Component_Type => Succ_Info, + Table_Index_Type => Succ_Index, + Table_Low_Bound => 1, + Table_Initial => Alloc.Successors_Initial, + Table_Increment => Alloc.Successors_Increment, + Table_Name => "Successors"); + + type Subp_Info is record + Name : Entity_Id := Empty; + Next : Subp_Index := No_Subp; + First_Succ : Succ_Index := No_Succ; + Main_Call : Boolean := False; + Processed : Boolean := False; + end record; + + package Inlined is new Table.Table ( + Table_Component_Type => Subp_Info, + Table_Index_Type => Subp_Index, + Table_Low_Bound => 1, + Table_Initial => Alloc.Inlined_Initial, + Table_Increment => Alloc.Inlined_Increment, + Table_Name => "Inlined"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty); + -- Make two entries in Inlined table, for an inlined subprogram being + -- called, and for the inlined subprogram that contains the call. If + -- the call is in the main compilation unit, Caller is Empty. + + procedure Add_Inlined_Subprogram (E : Entity_Id); + -- Add subprogram E to the list of inlined subprogram for the unit + + function Add_Subp (E : Entity_Id) return Subp_Index; + -- Make entry in Inlined table for subprogram E, or return table index + -- that already holds E. + + function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id; + pragma Inline (Get_Code_Unit_Entity); + -- Return the entity node for the unit containing E. Always return the spec + -- for a package. + + function Has_Initialized_Type (E : Entity_Id) return Boolean; + -- If a candidate for inlining contains type declarations for types with + -- nontrivial initialization procedures, they are not worth inlining. + + function Has_Single_Return (N : Node_Id) return Boolean; + -- In general we cannot inline functions that return unconstrained type. + -- However, we can handle such functions if all return statements return a + -- local variable that is the only declaration in the body of the function. + -- In that case the call can be replaced by that local variable as is done + -- for other inlined calls. + + function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean; + -- Return True if E is in the main unit or its spec or in a subunit + + function Is_Nested (E : Entity_Id) return Boolean; + -- If the function is nested inside some other function, it will always + -- be compiled if that function is, so don't add it to the inline list. + -- We cannot compile a nested function outside the scope of the containing + -- function anyway. This is also the case if the function is defined in a + -- task body or within an entry (for example, an initialization procedure). + + procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id); + -- Remove all aspects and/or pragmas that have no meaning in inlined body + -- Body_Decl. The analysis of these items is performed on the non-inlined + -- body. The items currently removed are: + -- Contract_Cases + -- Global + -- Depends + -- Postcondition + -- Precondition + -- Refined_Global + -- Refined_Depends + -- Refined_Post + -- Test_Case + -- Unmodified + -- Unreferenced + + ------------------------------ + -- Deferred Cleanup Actions -- + ------------------------------ + + -- The cleanup actions for scopes that contain instantiations is delayed + -- until after expansion of those instantiations, because they may contain + -- finalizable objects or tasks that affect the cleanup code. A scope + -- that contains instantiations only needs to be finalized once, even + -- if it contains more than one instance. We keep a list of scopes + -- that must still be finalized, and call cleanup_actions after all + -- the instantiations have been completed. + + To_Clean : Elist_Id; + + procedure Add_Scope_To_Clean (Inst : Entity_Id); + -- Build set of scopes on which cleanup actions must be performed + + procedure Cleanup_Scopes; + -- Complete cleanup actions on scopes that need it + + -------------- + -- Add_Call -- + -------------- + + procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is + P1 : constant Subp_Index := Add_Subp (Called); + P2 : Subp_Index; + J : Succ_Index; + + begin + if Present (Caller) then + P2 := Add_Subp (Caller); + + -- Add P1 to the list of successors of P2, if not already there. + -- Note that P2 may contain more than one call to P1, and only + -- one needs to be recorded. + + J := Inlined.Table (P2).First_Succ; + while J /= No_Succ loop + if Successors.Table (J).Subp = P1 then + return; + end if; + + J := Successors.Table (J).Next; + end loop; + + -- On exit, make a successor entry for P1 + + Successors.Increment_Last; + Successors.Table (Successors.Last).Subp := P1; + Successors.Table (Successors.Last).Next := + Inlined.Table (P2).First_Succ; + Inlined.Table (P2).First_Succ := Successors.Last; + else + Inlined.Table (P1).Main_Call := True; + end if; + end Add_Call; + + ---------------------- + -- Add_Inlined_Body -- + ---------------------- + + procedure Add_Inlined_Body (E : Entity_Id; N : Node_Id) is + + type Inline_Level_Type is (Dont_Inline, Inline_Call, Inline_Package); + -- Level of inlining for the call: Dont_Inline means no inlining, + -- Inline_Call means that only the call is considered for inlining, + -- Inline_Package means that the call is considered for inlining and + -- its package compiled and scanned for more inlining opportunities. + + function Must_Inline return Inline_Level_Type; + -- Inlining is only done if the call statement N is in the main unit, + -- or within the body of another inlined subprogram. + + ----------------- + -- Must_Inline -- + ----------------- + + function Must_Inline return Inline_Level_Type is + Scop : Entity_Id; + Comp : Node_Id; + + begin + -- Check if call is in main unit + + Scop := Current_Scope; + + -- Do not try to inline if scope is standard. This could happen, for + -- example, for a call to Add_Global_Declaration, and it causes + -- trouble to try to inline at this level. + + if Scop = Standard_Standard then + return Dont_Inline; + end if; + + -- Otherwise lookup scope stack to outer scope + + while Scope (Scop) /= Standard_Standard + and then not Is_Child_Unit (Scop) + loop + Scop := Scope (Scop); + end loop; + + Comp := Parent (Scop); + while Nkind (Comp) /= N_Compilation_Unit loop + Comp := Parent (Comp); + end loop; + + -- If the call is in the main unit, inline the call and compile the + -- package of the subprogram to find more calls to be inlined. + + if Comp = Cunit (Main_Unit) + or else Comp = Library_Unit (Cunit (Main_Unit)) + then + Add_Call (E); + return Inline_Package; + end if; + + -- The call is not in the main unit. See if it is in some subprogram + -- that can be inlined outside its unit. If so, inline the call and, + -- if the inlining level is set to 1, stop there; otherwise also + -- compile the package as above. + + Scop := Current_Scope; + while Scope (Scop) /= Standard_Standard + and then not Is_Child_Unit (Scop) + loop + if Is_Overloadable (Scop) + and then Is_Inlined (Scop) + and then not Is_Nested (Scop) + then + Add_Call (E, Scop); + + if Inline_Level = 1 then + return Inline_Call; + else + return Inline_Package; + end if; + end if; + + Scop := Scope (Scop); + end loop; + + return Dont_Inline; + end Must_Inline; + + Level : Inline_Level_Type; + + -- Start of processing for Add_Inlined_Body + + begin + Append_New_Elmt (N, To => Backend_Calls); + + -- Skip subprograms that cannot be inlined outside their unit + + if Is_Abstract_Subprogram (E) + or else Convention (E) = Convention_Protected + or else Is_Nested (E) + then + return; + end if; + + -- Find out whether the call must be inlined. Unless the result is + -- Dont_Inline, Must_Inline also creates an edge for the call in the + -- callgraph; however, it will not be activated until after Is_Called + -- is set on the subprogram. + + Level := Must_Inline; + + if Level = Dont_Inline then + return; + end if; + + -- If the call was generated by the compiler and is to a subprogram in + -- a run-time unit, we need to suppress debugging information for it, + -- so that the code that is eventually inlined will not affect the + -- debugging of the program. We do not do it if the call comes from + -- source because, even if the call is inlined, the user may expect it + -- to be present in the debugging information. + + if not Comes_From_Source (N) + and then In_Extended_Main_Source_Unit (N) + and then Is_Predefined_Unit (Get_Source_Unit (E)) + then + Set_Needs_Debug_Info (E, False); + end if; + + -- If the subprogram is an expression function, then there is no need to + -- load any package body since the body of the function is in the spec. + + if Is_Expression_Function (E) then + Set_Is_Called (E); + return; + end if; + + -- Find unit containing E, and add to list of inlined bodies if needed. + -- If the body is already present, no need to load any other unit. This + -- is the case for an initialization procedure, which appears in the + -- package declaration that contains the type. It is also the case if + -- the body has already been analyzed. Finally, if the unit enclosing + -- E is an instance, the instance body will be analyzed in any case, + -- and there is no need to add the enclosing unit (whose body might not + -- be available). + + -- Library-level functions must be handled specially, because there is + -- no enclosing package to retrieve. In this case, it is the body of + -- the function that will have to be loaded. + + declare + Pack : constant Entity_Id := Get_Code_Unit_Entity (E); + + begin + if Pack = E then + Set_Is_Called (E); + Inlined_Bodies.Increment_Last; + Inlined_Bodies.Table (Inlined_Bodies.Last) := E; + + elsif Ekind (Pack) = E_Package then + Set_Is_Called (E); + + if Is_Generic_Instance (Pack) then + null; + + -- Do not inline the package if the subprogram is an init proc + -- or other internally generated subprogram, because in that + -- case the subprogram body appears in the same unit that + -- declares the type, and that body is visible to the back end. + -- Do not inline it either if it is in the main unit. + -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always + -- calls if the back-end takes care of inlining the call. + -- Note that Level in Inline_Package | Inline_Call here. + + elsif ((Level = Inline_Call + and then Has_Pragma_Inline_Always (E) + and then Back_End_Inlining) + or else Level = Inline_Package) + and then not Is_Inlined (Pack) + and then not Is_Internal (E) + and then not In_Main_Unit_Or_Subunit (Pack) + then + Set_Is_Inlined (Pack); + Inlined_Bodies.Increment_Last; + Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack; + end if; + end if; + + -- Ensure that Analyze_Inlined_Bodies will be invoked after + -- completing the analysis of the current unit. + + Inline_Processing_Required := True; + end; + end Add_Inlined_Body; + + ---------------------------- + -- Add_Inlined_Subprogram -- + ---------------------------- + + procedure Add_Inlined_Subprogram (E : Entity_Id) is + Decl : constant Node_Id := Parent (Declaration_Node (E)); + Pack : constant Entity_Id := Get_Code_Unit_Entity (E); + + procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id); + -- Append Subp to the list of subprograms inlined by the backend + + procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id); + -- Append Subp to the list of subprograms that cannot be inlined by + -- the backend. + + ----------------------------------------- + -- Register_Backend_Inlined_Subprogram -- + ----------------------------------------- + + procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is + begin + Append_New_Elmt (Subp, To => Backend_Inlined_Subps); + end Register_Backend_Inlined_Subprogram; + + --------------------------------------------- + -- Register_Backend_Not_Inlined_Subprogram -- + --------------------------------------------- + + procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is + begin + Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps); + end Register_Backend_Not_Inlined_Subprogram; + + -- Start of processing for Add_Inlined_Subprogram + + begin + -- If the subprogram is to be inlined, and if its unit is known to be + -- inlined or is an instance whose body will be analyzed anyway or the + -- subprogram was generated as a body by the compiler (for example an + -- initialization procedure) or its declaration was provided along with + -- the body (for example an expression function), and if it is declared + -- at the library level not in the main unit, and if it can be inlined + -- by the back-end, then insert it in the list of inlined subprograms. + + if Is_Inlined (E) + and then (Is_Inlined (Pack) + or else Is_Generic_Instance (Pack) + or else Nkind (Decl) = N_Subprogram_Body + or else Present (Corresponding_Body (Decl))) + and then not In_Main_Unit_Or_Subunit (E) + and then not Is_Nested (E) + and then not Has_Initialized_Type (E) + then + Register_Backend_Inlined_Subprogram (E); + + if No (Last_Inlined) then + Set_First_Inlined_Subprogram (Cunit (Main_Unit), E); + else + Set_Next_Inlined_Subprogram (Last_Inlined, E); + end if; + + Last_Inlined := E; + + else + Register_Backend_Not_Inlined_Subprogram (E); + end if; + end Add_Inlined_Subprogram; + + ------------------------ + -- Add_Scope_To_Clean -- + ------------------------ + + procedure Add_Scope_To_Clean (Inst : Entity_Id) is + Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst); + Elmt : Elmt_Id; + + begin + -- If the instance appears in a library-level package declaration, + -- all finalization is global, and nothing needs doing here. + + if Scop = Standard_Standard then + return; + end if; + + -- If the instance is within a generic unit, no finalization code + -- can be generated. Note that at this point all bodies have been + -- analyzed, and the scope stack itself is not present, and the flag + -- Inside_A_Generic is not set. + + declare + S : Entity_Id; + + begin + S := Scope (Inst); + while Present (S) and then S /= Standard_Standard loop + if Is_Generic_Unit (S) then + return; + end if; + + S := Scope (S); + end loop; + end; + + Elmt := First_Elmt (To_Clean); + while Present (Elmt) loop + if Node (Elmt) = Scop then + return; + end if; + + Elmt := Next_Elmt (Elmt); + end loop; + + Append_Elmt (Scop, To_Clean); + end Add_Scope_To_Clean; + + -------------- + -- Add_Subp -- + -------------- + + function Add_Subp (E : Entity_Id) return Subp_Index is + Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers; + J : Subp_Index; + + procedure New_Entry; + -- Initialize entry in Inlined table + + procedure New_Entry is + begin + Inlined.Increment_Last; + Inlined.Table (Inlined.Last).Name := E; + Inlined.Table (Inlined.Last).Next := No_Subp; + Inlined.Table (Inlined.Last).First_Succ := No_Succ; + Inlined.Table (Inlined.Last).Main_Call := False; + Inlined.Table (Inlined.Last).Processed := False; + end New_Entry; + + -- Start of processing for Add_Subp + + begin + if Hash_Headers (Index) = No_Subp then + New_Entry; + Hash_Headers (Index) := Inlined.Last; + return Inlined.Last; + + else + J := Hash_Headers (Index); + while J /= No_Subp loop + if Inlined.Table (J).Name = E then + return J; + else + Index := J; + J := Inlined.Table (J).Next; + end if; + end loop; + + -- On exit, subprogram was not found. Enter in table. Index is + -- the current last entry on the hash chain. + + New_Entry; + Inlined.Table (Index).Next := Inlined.Last; + return Inlined.Last; + end if; + end Add_Subp; + + ---------------------------- + -- Analyze_Inlined_Bodies -- + ---------------------------- + + procedure Analyze_Inlined_Bodies is + Comp_Unit : Node_Id; + J : Int; + Pack : Entity_Id; + Subp : Subp_Index; + S : Succ_Index; + + type Pending_Index is new Nat; + + package Pending_Inlined is new Table.Table ( + Table_Component_Type => Subp_Index, + Table_Index_Type => Pending_Index, + Table_Low_Bound => 1, + Table_Initial => Alloc.Inlined_Initial, + Table_Increment => Alloc.Inlined_Increment, + Table_Name => "Pending_Inlined"); + -- The workpile used to compute the transitive closure + + -- Start of processing for Analyze_Inlined_Bodies + + begin + if Serious_Errors_Detected = 0 then + Push_Scope (Standard_Standard); + + J := 0; + while J <= Inlined_Bodies.Last + and then Serious_Errors_Detected = 0 + loop + Pack := Inlined_Bodies.Table (J); + while Present (Pack) + and then Scope (Pack) /= Standard_Standard + and then not Is_Child_Unit (Pack) + loop + Pack := Scope (Pack); + end loop; + + Comp_Unit := Parent (Pack); + while Present (Comp_Unit) + and then Nkind (Comp_Unit) /= N_Compilation_Unit + loop + Comp_Unit := Parent (Comp_Unit); + end loop; + + -- Load the body if it exists and contains inlineable entities, + -- unless it is the main unit, or is an instance whose body has + -- already been analyzed. + + if Present (Comp_Unit) + and then Comp_Unit /= Cunit (Main_Unit) + and then Body_Required (Comp_Unit) + and then + (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration + or else + (No (Corresponding_Body (Unit (Comp_Unit))) + and then Body_Needed_For_Inlining + (Defining_Entity (Unit (Comp_Unit))))) + then + declare + Bname : constant Unit_Name_Type := + Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); + + OK : Boolean; + + begin + if not Is_Loaded (Bname) then + Style_Check := False; + Load_Needed_Body (Comp_Unit, OK); + + if not OK then + + -- Warn that a body was not available for inlining + -- by the back-end. + + Error_Msg_Unit_1 := Bname; + Error_Msg_N + ("one or more inlined subprograms accessed in $!??", + Comp_Unit); + Error_Msg_File_1 := + Get_File_Name (Bname, Subunit => False); + Error_Msg_N ("\but file{ was not found!??", Comp_Unit); + end if; + end if; + end; + end if; + + J := J + 1; + + if J > Inlined_Bodies.Last then + + -- The analysis of required bodies may have produced additional + -- generic instantiations. To obtain further inlining, we need + -- to perform another round of generic body instantiations. + + Instantiate_Bodies; + + -- Symmetrically, the instantiation of required generic bodies + -- may have caused additional bodies to be inlined. To obtain + -- further inlining, we keep looping over the inlined bodies. + end if; + end loop; + + -- The list of inlined subprograms is an overestimate, because it + -- includes inlined functions called from functions that are compiled + -- as part of an inlined package, but are not themselves called. An + -- accurate computation of just those subprograms that are needed + -- requires that we perform a transitive closure over the call graph, + -- starting from calls in the main compilation unit. + + for Index in Inlined.First .. Inlined.Last loop + if not Is_Called (Inlined.Table (Index).Name) then + + -- This means that Add_Inlined_Body added the subprogram to the + -- table but wasn't able to handle its code unit. Do nothing. + + Inlined.Table (Index).Processed := True; + + elsif Inlined.Table (Index).Main_Call then + Pending_Inlined.Increment_Last; + Pending_Inlined.Table (Pending_Inlined.Last) := Index; + Inlined.Table (Index).Processed := True; + + else + Set_Is_Called (Inlined.Table (Index).Name, False); + end if; + end loop; + + -- Iterate over the workpile until it is emptied, propagating the + -- Is_Called flag to the successors of the processed subprogram. + + while Pending_Inlined.Last >= Pending_Inlined.First loop + Subp := Pending_Inlined.Table (Pending_Inlined.Last); + Pending_Inlined.Decrement_Last; + + S := Inlined.Table (Subp).First_Succ; + + while S /= No_Succ loop + Subp := Successors.Table (S).Subp; + + if not Inlined.Table (Subp).Processed then + Set_Is_Called (Inlined.Table (Subp).Name); + Pending_Inlined.Increment_Last; + Pending_Inlined.Table (Pending_Inlined.Last) := Subp; + Inlined.Table (Subp).Processed := True; + end if; + + S := Successors.Table (S).Next; + end loop; + end loop; + + -- Finally add the called subprograms to the list of inlined + -- subprograms for the unit. + + for Index in Inlined.First .. Inlined.Last loop + if Is_Called (Inlined.Table (Index).Name) then + Add_Inlined_Subprogram (Inlined.Table (Index).Name); + end if; + end loop; + + Pop_Scope; + end if; + end Analyze_Inlined_Bodies; + + -------------------------- + -- Build_Body_To_Inline -- + -------------------------- + + procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is + Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); + Analysis_Status : constant Boolean := Full_Analysis; + Original_Body : Node_Id; + Body_To_Analyze : Node_Id; + Max_Size : constant := 10; + + function Has_Pending_Instantiation return Boolean; + -- If some enclosing body contains instantiations that appear before + -- the corresponding generic body, the enclosing body has a freeze node + -- so that it can be elaborated after the generic itself. This might + -- conflict with subsequent inlinings, so that it is unsafe to try to + -- inline in such a case. + + function Has_Single_Return_In_GNATprove_Mode return Boolean; + -- This function is called only in GNATprove mode, and it returns + -- True if the subprogram has no return statement or a single return + -- statement as last statement. It returns False for subprogram with + -- a single return as last statement inside one or more blocks, as + -- inlining would generate gotos in that case as well (although the + -- goto is useless in that case). + + function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; + -- If the body of the subprogram includes a call that returns an + -- unconstrained type, the secondary stack is involved, and it + -- is not worth inlining. + + ------------------------------- + -- Has_Pending_Instantiation -- + ------------------------------- + + function Has_Pending_Instantiation return Boolean is + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) loop + if Is_Compilation_Unit (S) + or else Is_Child_Unit (S) + then + return False; + + elsif Ekind (S) = E_Package + and then Has_Forward_Instantiation (S) + then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end Has_Pending_Instantiation; + + ----------------------------------------- + -- Has_Single_Return_In_GNATprove_Mode -- + ----------------------------------------- + + function Has_Single_Return_In_GNATprove_Mode return Boolean is + Body_To_Inline : constant Node_Id := N; + Last_Statement : Node_Id := Empty; + + function Check_Return (N : Node_Id) return Traverse_Result; + -- Returns OK on node N if this is not a return statement different + -- from the last statement in the subprogram. + + ------------------ + -- Check_Return -- + ------------------ + + function Check_Return (N : Node_Id) return Traverse_Result is + begin + case Nkind (N) is + when N_Extended_Return_Statement + | N_Simple_Return_Statement + => + if N = Last_Statement then + return OK; + else + return Abandon; + end if; + + -- Skip locally declared subprogram bodies inside the body to + -- inline, as the return statements inside those do not count. + + when N_Subprogram_Body => + if N = Body_To_Inline then + return OK; + else + return Skip; + end if; + + when others => + return OK; + end case; + end Check_Return; + + function Check_All_Returns is new Traverse_Func (Check_Return); + + -- Start of processing for Has_Single_Return_In_GNATprove_Mode + + begin + -- Retrieve the last statement + + Last_Statement := Last (Statements (Handled_Statement_Sequence (N))); + + -- Check that the last statement is the only possible return + -- statement in the subprogram. + + return Check_All_Returns (N) = OK; + end Has_Single_Return_In_GNATprove_Mode; + + -------------------------- + -- Uses_Secondary_Stack -- + -------------------------- + + function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is + function Check_Call (N : Node_Id) return Traverse_Result; + -- Look for function calls that return an unconstrained type + + ---------------- + -- Check_Call -- + ---------------- + + function Check_Call (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Function_Call + and then Is_Entity_Name (Name (N)) + and then Is_Composite_Type (Etype (Entity (Name (N)))) + and then not Is_Constrained (Etype (Entity (Name (N)))) + then + Cannot_Inline + ("cannot inline & (call returns unconstrained type)?", + N, Spec_Id); + return Abandon; + else + return OK; + end if; + end Check_Call; + + function Check_Calls is new Traverse_Func (Check_Call); + + begin + return Check_Calls (Bod) = Abandon; + end Uses_Secondary_Stack; + + -- Start of processing for Build_Body_To_Inline + + begin + -- Return immediately if done already + + if Nkind (Decl) = N_Subprogram_Declaration + and then Present (Body_To_Inline (Decl)) + then + return; + + -- Subprograms that have return statements in the middle of the body are + -- inlined with gotos. GNATprove does not currently support gotos, so + -- we prevent such inlining. + + elsif GNATprove_Mode + and then not Has_Single_Return_In_GNATprove_Mode + then + Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id); + return; + + -- Functions that return unconstrained composite types require + -- secondary stack handling, and cannot currently be inlined, unless + -- all return statements return a local variable that is the first + -- local declaration in the body. + + elsif Ekind (Spec_Id) = E_Function + and then not Is_Scalar_Type (Etype (Spec_Id)) + and then not Is_Access_Type (Etype (Spec_Id)) + and then not Is_Constrained (Etype (Spec_Id)) + then + if not Has_Single_Return (N) then + Cannot_Inline + ("cannot inline & (unconstrained return type)?", N, Spec_Id); + return; + end if; + + -- Ditto for functions that return controlled types, where controlled + -- actions interfere in complex ways with inlining. + + elsif Ekind (Spec_Id) = E_Function + and then Needs_Finalization (Etype (Spec_Id)) + then + Cannot_Inline + ("cannot inline & (controlled return type)?", N, Spec_Id); + return; + end if; + + if Present (Declarations (N)) + and then Has_Excluded_Declaration (Spec_Id, Declarations (N)) + then + return; + end if; + + if Present (Handled_Statement_Sequence (N)) then + if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then + Cannot_Inline + ("cannot inline& (exception handler)?", + First (Exception_Handlers (Handled_Statement_Sequence (N))), + Spec_Id); + return; + + elsif Has_Excluded_Statement + (Spec_Id, Statements (Handled_Statement_Sequence (N))) + then + return; + end if; + end if; + + -- We do not inline a subprogram that is too large, unless it is marked + -- Inline_Always or we are in GNATprove mode. This pragma does not + -- suppress the other checks on inlining (forbidden declarations, + -- handlers, etc). + + if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode) + and then List_Length + (Statements (Handled_Statement_Sequence (N))) > Max_Size + then + Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id); + return; + end if; + + if Has_Pending_Instantiation then + Cannot_Inline + ("cannot inline& (forward instance within enclosing body)?", + N, Spec_Id); + return; + end if; + + -- Within an instance, the body to inline must be treated as a nested + -- generic, so that the proper global references are preserved. + + -- Note that we do not do this at the library level, because it is not + -- needed, and furthermore this causes trouble if front-end inlining + -- is activated (-gnatN). + + if In_Instance and then Scope (Current_Scope) /= Standard_Standard then + Save_Env (Scope (Current_Scope), Scope (Current_Scope)); + Original_Body := Copy_Generic_Node (N, Empty, Instantiating => True); + else + Original_Body := Copy_Separate_Tree (N); + end if; + + -- We need to capture references to the formals in order to substitute + -- the actuals at the point of inlining, i.e. instantiation. To treat + -- the formals as globals to the body to inline, we nest it within a + -- dummy parameterless subprogram, declared within the real one. To + -- avoid generating an internal name (which is never public, and which + -- affects serial numbers of other generated names), we use an internal + -- symbol that cannot conflict with user declarations. + + Set_Parameter_Specifications (Specification (Original_Body), No_List); + Set_Defining_Unit_Name + (Specification (Original_Body), + Make_Defining_Identifier (Sloc (N), Name_uParent)); + Set_Corresponding_Spec (Original_Body, Empty); + + -- Remove all aspects/pragmas that have no meaning in an inlined body + + Remove_Aspects_And_Pragmas (Original_Body); + + Body_To_Analyze := + Copy_Generic_Node (Original_Body, Empty, Instantiating => False); + + -- Set return type of function, which is also global and does not need + -- to be resolved. + + if Ekind (Spec_Id) = E_Function then + Set_Result_Definition + (Specification (Body_To_Analyze), + New_Occurrence_Of (Etype (Spec_Id), Sloc (N))); + end if; + + if No (Declarations (N)) then + Set_Declarations (N, New_List (Body_To_Analyze)); + else + Append (Body_To_Analyze, Declarations (N)); + end if; + + -- The body to inline is pre-analyzed. In GNATprove mode we must disable + -- full analysis as well so that light expansion does not take place + -- either, and name resolution is unaffected. + + Expander_Mode_Save_And_Set (False); + Full_Analysis := False; + + Analyze (Body_To_Analyze); + Push_Scope (Defining_Entity (Body_To_Analyze)); + Save_Global_References (Original_Body); + End_Scope; + Remove (Body_To_Analyze); + + Expander_Mode_Restore; + Full_Analysis := Analysis_Status; + + -- Restore environment if previously saved + + if In_Instance and then Scope (Current_Scope) /= Standard_Standard then + Restore_Env; + end if; + + -- If secondary stack is used, there is no point in inlining. We have + -- already issued the warning in this case, so nothing to do. + + if Uses_Secondary_Stack (Body_To_Analyze) then + return; + end if; + + Set_Body_To_Inline (Decl, Original_Body); + Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id)); + Set_Is_Inlined (Spec_Id); + end Build_Body_To_Inline; + + ------------------------------------------- + -- Call_Can_Be_Inlined_In_GNATprove_Mode -- + ------------------------------------------- + + function Call_Can_Be_Inlined_In_GNATprove_Mode + (N : Node_Id; + Subp : Entity_Id) return Boolean + is + F : Entity_Id; + A : Node_Id; + + begin + F := First_Formal (Subp); + A := First_Actual (N); + while Present (F) loop + if Ekind (F) /= E_Out_Parameter + and then not Same_Type (Etype (F), Etype (A)) + and then + (Is_By_Reference_Type (Etype (A)) + or else Is_Limited_Type (Etype (A))) + then + return False; + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + + return True; + end Call_Can_Be_Inlined_In_GNATprove_Mode; + + -------------------------------------- + -- Can_Be_Inlined_In_GNATprove_Mode -- + -------------------------------------- + + function Can_Be_Inlined_In_GNATprove_Mode + (Spec_Id : Entity_Id; + Body_Id : Entity_Id) return Boolean + is + function Has_Formal_With_Discriminant_Dependent_Fields + (Id : Entity_Id) return Boolean; + -- Returns true if the subprogram has at least one formal parameter of + -- an unconstrained record type with per-object constraints on component + -- types. + + function Has_Some_Contract (Id : Entity_Id) return Boolean; + -- Return True if subprogram Id has any contract. The presence of + -- Extensions_Visible or Volatile_Function is also considered as a + -- contract here. + + function Is_Unit_Subprogram (Id : Entity_Id) return Boolean; + -- Return True if subprogram Id defines a compilation unit + -- Shouldn't this be in Sem_Aux??? + + function In_Package_Spec (Id : Entity_Id) return Boolean; + -- Return True if subprogram Id is defined in the package specification, + -- either its visible or private part. + + --------------------------------------------------- + -- Has_Formal_With_Discriminant_Dependent_Fields -- + --------------------------------------------------- + + function Has_Formal_With_Discriminant_Dependent_Fields + (Id : Entity_Id) return Boolean + is + function Has_Discriminant_Dependent_Component + (Typ : Entity_Id) return Boolean; + -- Determine whether unconstrained record type Typ has at least one + -- component that depends on a discriminant. + + ------------------------------------------ + -- Has_Discriminant_Dependent_Component -- + ------------------------------------------ + + function Has_Discriminant_Dependent_Component + (Typ : Entity_Id) return Boolean + is + Comp : Entity_Id; + + begin + -- Inspect all components of the record type looking for one that + -- depends on a discriminant. + + Comp := First_Component (Typ); + while Present (Comp) loop + if Has_Discriminant_Dependent_Constraint (Comp) then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + end Has_Discriminant_Dependent_Component; + + -- Local variables + + Subp_Id : constant Entity_Id := Ultimate_Alias (Id); + Formal : Entity_Id; + Formal_Typ : Entity_Id; + + -- Start of processing for + -- Has_Formal_With_Discriminant_Dependent_Fields + + begin + -- Inspect all parameters of the subprogram looking for a formal + -- of an unconstrained record type with at least one discriminant + -- dependent component. + + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + Formal_Typ := Etype (Formal); + + if Is_Record_Type (Formal_Typ) + and then not Is_Constrained (Formal_Typ) + and then Has_Discriminant_Dependent_Component (Formal_Typ) + then + return True; + end if; + + Next_Formal (Formal); + end loop; + + return False; + end Has_Formal_With_Discriminant_Dependent_Fields; + + ----------------------- + -- Has_Some_Contract -- + ----------------------- + + function Has_Some_Contract (Id : Entity_Id) return Boolean is + Items : Node_Id; + + begin + -- A call to an expression function may precede the actual body which + -- is inserted at the end of the enclosing declarations. Ensure that + -- the related entity is decorated before inspecting the contract. + + if Is_Subprogram_Or_Generic_Subprogram (Id) then + Items := Contract (Id); + + -- Note that Classifications is not Empty when Extensions_Visible + -- or Volatile_Function is present, which causes such subprograms + -- to be considered to have a contract here. This is fine as we + -- want to avoid inlining these too. + + return Present (Items) + and then (Present (Pre_Post_Conditions (Items)) or else + Present (Contract_Test_Cases (Items)) or else + Present (Classifications (Items))); + end if; + + return False; + end Has_Some_Contract; + + --------------------- + -- In_Package_Spec -- + --------------------- + + function In_Package_Spec (Id : Entity_Id) return Boolean is + P : constant Node_Id := Parent (Subprogram_Spec (Id)); + -- Parent of the subprogram's declaration + + begin + return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration; + end In_Package_Spec; + + ------------------------ + -- Is_Unit_Subprogram -- + ------------------------ + + function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is + Decl : Node_Id := Parent (Parent (Id)); + begin + if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then + Decl := Parent (Decl); + end if; + + return Nkind (Parent (Decl)) = N_Compilation_Unit; + end Is_Unit_Subprogram; + + -- Local declarations + + Id : Entity_Id; + -- Procedure or function entity for the subprogram + + -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode + + begin + pragma Assert (Present (Spec_Id) or else Present (Body_Id)); + + if Present (Spec_Id) then + Id := Spec_Id; + else + Id := Body_Id; + end if; + + -- Only local subprograms without contracts are inlined in GNATprove + -- mode, as these are the subprograms which a user is not interested in + -- analyzing in isolation, but rather in the context of their call. This + -- is a convenient convention, that could be changed for an explicit + -- pragma/aspect one day. + + -- In a number of special cases, inlining is not desirable or not + -- possible, see below. + + -- Do not inline unit-level subprograms + + if Is_Unit_Subprogram (Id) then + return False; + + -- Do not inline subprograms declared in package specs, because they are + -- not local, i.e. can be called either from anywhere (if declared in + -- visible part) or from the child units (if declared in private part). + + elsif In_Package_Spec (Id) then + return False; + + -- Do not inline subprograms declared in other units. This is important + -- in particular for subprograms defined in the private part of a + -- package spec, when analyzing one of its child packages, as otherwise + -- we issue spurious messages about the impossibility to inline such + -- calls. + + elsif not In_Extended_Main_Code_Unit (Id) then + return False; + + -- Do not inline subprograms marked No_Return, possibly used for + -- signaling errors, which GNATprove handles specially. + + elsif No_Return (Id) then + return False; + + -- Do not inline subprograms that have a contract on the spec or the + -- body. Use the contract(s) instead in GNATprove. This also prevents + -- inlining of subprograms with Extensions_Visible or Volatile_Function. + + elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id)) + or else + (Present (Body_Id) and then Has_Some_Contract (Body_Id)) + then + return False; + + -- Do not inline expression functions, which are directly inlined at the + -- prover level. + + elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id)) + or else + (Present (Body_Id) and then Is_Expression_Function (Body_Id)) + then + return False; + + -- Do not inline generic subprogram instances. The visibility rules of + -- generic instances plays badly with inlining. + + elsif Is_Generic_Instance (Spec_Id) then + return False; + + -- Only inline subprograms whose spec is marked SPARK_Mode On. For + -- the subprogram body, a similar check is performed after the body + -- is analyzed, as this is where a pragma SPARK_Mode might be inserted. + + elsif Present (Spec_Id) + and then + (No (SPARK_Pragma (Spec_Id)) + or else + Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On) + then + return False; + + -- Subprograms in generic instances are currently not inlined, to avoid + -- problems with inlining of standard library subprograms. + + elsif Instantiation_Location (Sloc (Id)) /= No_Location then + return False; + + -- Do not inline subprograms and entries defined inside protected types, + -- which typically are not helper subprograms, which also avoids getting + -- spurious messages on calls that cannot be inlined. + + elsif Within_Protected_Type (Id) then + return False; + + -- Do not inline predicate functions (treated specially by GNATprove) + + elsif Is_Predicate_Function (Id) then + return False; + + -- Do not inline subprograms with a parameter of an unconstrained + -- record type if it has discrimiant dependent fields. Indeed, with + -- such parameters, the frontend cannot always ensure type compliance + -- in record component accesses (in particular with records containing + -- packed arrays). + + elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then + return False; + + -- Otherwise, this is a subprogram declared inside the private part of a + -- package, or inside a package body, or locally in a subprogram, and it + -- does not have any contract. Inline it. + + else + return True; + end if; + end Can_Be_Inlined_In_GNATprove_Mode; + + ------------------- + -- Cannot_Inline -- + ------------------- + + procedure Cannot_Inline + (Msg : String; + N : Node_Id; + Subp : Entity_Id; + Is_Serious : Boolean := False) + is + begin + -- In GNATprove mode, inlining is the technical means by which the + -- higher-level goal of contextual analysis is reached, so issue + -- messages about failure to apply contextual analysis to a + -- subprogram, rather than failure to inline it. + + if GNATprove_Mode + and then Msg (Msg'First .. Msg'First + 12) = "cannot inline" + then + declare + Len1 : constant Positive := + String (String'("cannot inline"))'Length; + Len2 : constant Positive := + String (String'("info: no contextual analysis of"))'Length; + + New_Msg : String (1 .. Msg'Length + Len2 - Len1); + + begin + New_Msg (1 .. Len2) := "info: no contextual analysis of"; + New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) := + Msg (Msg'First + Len1 .. Msg'Last); + Cannot_Inline (New_Msg, N, Subp, Is_Serious); + return; + end; + end if; + + pragma Assert (Msg (Msg'Last) = '?'); + + -- Legacy front-end inlining model + + if not Back_End_Inlining then + + -- Do not emit warning if this is a predefined unit which is not + -- the main unit. With validity checks enabled, some predefined + -- subprograms may contain nested subprograms and become ineligible + -- for inlining. + + if Is_Predefined_Unit (Get_Source_Unit (Subp)) + and then not In_Extended_Main_Source_Unit (Subp) + then + null; + + -- In GNATprove mode, issue a warning, and indicate that the + -- subprogram is not always inlined by setting flag Is_Inlined_Always + -- to False. + + elsif GNATprove_Mode then + Set_Is_Inlined_Always (Subp, False); + Error_Msg_NE (Msg & "p?", N, Subp); + + elsif Has_Pragma_Inline_Always (Subp) then + + -- Remove last character (question mark) to make this into an + -- error, because the Inline_Always pragma cannot be obeyed. + + Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); + + elsif Ineffective_Inline_Warnings then + Error_Msg_NE (Msg & "p?", N, Subp); + end if; + + -- New semantics relying on back-end inlining + + elsif Is_Serious then + + -- Remove last character (question mark) to make this into an error. + + Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); + + -- In GNATprove mode, issue a warning, and indicate that the subprogram + -- is not always inlined by setting flag Is_Inlined_Always to False. + + elsif GNATprove_Mode then + Set_Is_Inlined_Always (Subp, False); + Error_Msg_NE (Msg & "p?", N, Subp); + + else + + -- Do not emit warning if this is a predefined unit which is not + -- the main unit. This behavior is currently provided for backward + -- compatibility but it will be removed when we enforce the + -- strictness of the new rules. + + if Is_Predefined_Unit (Get_Source_Unit (Subp)) + and then not In_Extended_Main_Source_Unit (Subp) + then + null; + + elsif Has_Pragma_Inline_Always (Subp) then + + -- Emit a warning if this is a call to a runtime subprogram + -- which is located inside a generic. Previously this call + -- was silently skipped. + + if Is_Generic_Instance (Subp) then + declare + Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp)); + begin + if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then + Set_Is_Inlined (Subp, False); + Error_Msg_NE (Msg & "p?", N, Subp); + return; + end if; + end; + end if; + + -- Remove last character (question mark) to make this into an + -- error, because the Inline_Always pragma cannot be obeyed. + + Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); + + else + Set_Is_Inlined (Subp, False); + + if Ineffective_Inline_Warnings then + Error_Msg_NE (Msg & "p?", N, Subp); + end if; + end if; + end if; + end Cannot_Inline; + + -------------------------------------------- + -- Check_And_Split_Unconstrained_Function -- + -------------------------------------------- + + procedure Check_And_Split_Unconstrained_Function + (N : Node_Id; + Spec_Id : Entity_Id; + Body_Id : Entity_Id) + is + procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id); + -- Use generic machinery to build an unexpanded body for the subprogram. + -- This body is subsequently used for inline expansions at call sites. + + 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 Split_Unconstrained_Function + (N : Node_Id; + Spec_Id : Entity_Id); + -- N is an inlined function body that returns an unconstrained type and + -- has a single extended return statement. Split N in two subprograms: + -- a procedure P' and a function F'. The formals of P' duplicate the + -- formals of N plus an extra formal which is used to return a value; + -- its body is composed by the declarations and list of statements + -- of the extended return statement of N. + + -------------------------- + -- Build_Body_To_Inline -- + -------------------------- + + procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is + procedure Generate_Subprogram_Body + (N : Node_Id; + Body_To_Inline : out Node_Id); + -- Generate a parameterless duplicate of subprogram body N. Note that + -- occurrences of pragmas referencing the formals are removed since + -- they have no meaning when the body is inlined and the formals are + -- rewritten (the analysis of the non-inlined body will handle these + -- pragmas). A new internal name is associated with Body_To_Inline. + + ----------------------------- + -- Generate_Body_To_Inline -- + ----------------------------- + + procedure Generate_Subprogram_Body + (N : Node_Id; + Body_To_Inline : out Node_Id) + is + begin + -- Within an instance, the body to inline must be treated as a + -- nested generic so that proper global references are preserved. + + -- Note that we do not do this at the library level, because it + -- is not needed, and furthermore this causes trouble if front + -- end inlining is activated (-gnatN). + + if In_Instance + and then Scope (Current_Scope) /= Standard_Standard + then + Body_To_Inline := + Copy_Generic_Node (N, Empty, Instantiating => True); + else + Body_To_Inline := Copy_Separate_Tree (N); + end if; + + -- Remove aspects/pragmas that have no meaning in an inlined body + + Remove_Aspects_And_Pragmas (Body_To_Inline); + + -- We need to capture references to the formals in order + -- to substitute the actuals at the point of inlining, i.e. + -- instantiation. To treat the formals as globals to the body to + -- inline, we nest it within a dummy parameterless subprogram, + -- declared within the real one. + + Set_Parameter_Specifications + (Specification (Body_To_Inline), No_List); + + -- A new internal name is associated with Body_To_Inline to avoid + -- conflicts when the non-inlined body N is analyzed. + + Set_Defining_Unit_Name (Specification (Body_To_Inline), + Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P'))); + Set_Corresponding_Spec (Body_To_Inline, Empty); + end Generate_Subprogram_Body; + + -- Local variables + + Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); + Original_Body : Node_Id; + Body_To_Analyze : Node_Id; + + begin + pragma Assert (Current_Scope = Spec_Id); + + -- Within an instance, the body to inline must be treated as a nested + -- generic, so that the proper global references are preserved. We + -- do not do this at the library level, because it is not needed, and + -- furthermore this causes trouble if front-end inlining is activated + -- (-gnatN). + + if In_Instance + and then Scope (Current_Scope) /= Standard_Standard + then + Save_Env (Scope (Current_Scope), Scope (Current_Scope)); + end if; + + -- Capture references to formals in order to substitute the actuals + -- at the point of inlining or instantiation. To treat the formals + -- as globals to the body to inline, nest the body within a dummy + -- parameterless subprogram, declared within the real one. + + Generate_Subprogram_Body (N, Original_Body); + Body_To_Analyze := + Copy_Generic_Node (Original_Body, Empty, Instantiating => False); + + -- Set return type of function, which is also global and does not + -- need to be resolved. + + if Ekind (Spec_Id) = E_Function then + Set_Result_Definition (Specification (Body_To_Analyze), + New_Occurrence_Of (Etype (Spec_Id), Sloc (N))); + end if; + + if No (Declarations (N)) then + Set_Declarations (N, New_List (Body_To_Analyze)); + else + Append_To (Declarations (N), Body_To_Analyze); + end if; + + Preanalyze (Body_To_Analyze); + + Push_Scope (Defining_Entity (Body_To_Analyze)); + Save_Global_References (Original_Body); + End_Scope; + Remove (Body_To_Analyze); + + -- Restore environment if previously saved + + if In_Instance + and then Scope (Current_Scope) /= Standard_Standard + then + Restore_Env; + end if; + + pragma Assert (No (Body_To_Inline (Decl))); + Set_Body_To_Inline (Decl, Original_Body); + Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id)); + end Build_Body_To_Inline; + + -------------------------------------- + -- 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; + + 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; + + Next (D); + end loop; + end if; + + -- We only split the inlined function when we are generating the code + -- of its body; otherwise we leave duplicated split subprograms in + -- the tree which (if referenced) generate wrong references at link + -- 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)); + end Can_Split_Unconstrained_Function; + + ---------------------------------- + -- Split_Unconstrained_Function -- + ---------------------------------- + + procedure Split_Unconstrained_Function + (N : Node_Id; + Spec_Id : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Ret_Node : constant Node_Id := + First (Statements (Handled_Statement_Sequence (N))); + Ret_Obj : constant Node_Id := + First (Return_Object_Declarations (Ret_Node)); + + procedure Build_Procedure + (Proc_Id : out Entity_Id; + Decl_List : out List_Id); + -- Build a procedure containing the statements found in the extended + -- return statement of the unconstrained function body N. + + --------------------- + -- Build_Procedure -- + --------------------- + + procedure Build_Procedure + (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; + + 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; + + 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. + + 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))))); + + Next_Formal (Formal); + end loop; + + Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name); + + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => Formal_List); + + Decl_List := New_List; + + Append_To (Decl_List, + Make_Subprogram_Declaration (Loc, Proc_Spec)); + + -- Can_Convert_Unconstrained_Function checked that the function + -- has no local declarations except implicit label declarations. + -- Copy these declarations to the built procedure. + + if Present (Declarations (N)) then + Body_Decl_List := New_List; + + declare + D : Node_Id; + New_D : Node_Id; + + 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; + end if; + + pragma Assert (Present (Handled_Statement_Sequence (Ret_Node))); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => Copy_Separate_Tree (Proc_Spec), + Declarations => Body_Decl_List, + Handled_Statement_Sequence => + Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node))); + + Set_Defining_Unit_Name (Specification (Proc_Body), + Make_Defining_Identifier (Loc, Subp_Name)); + + Append_To (Decl_List, Proc_Body); + end Build_Procedure; + + -- Local variables + + New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj); + Blk_Stmt : Node_Id; + Proc_Id : Entity_Id; + Proc_Call : Node_Id; + + -- Start of processing for Split_Unconstrained_Function + + begin + -- Build the associated procedure, analyze it and insert it before + -- the function body N. + + declare + Scope : constant Entity_Id := Current_Scope; + Decl_List : List_Id; + begin + Pop_Scope; + Build_Procedure (Proc_Id, Decl_List); + Insert_Actions (N, Decl_List); + Set_Is_Inlined (Proc_Id); + Push_Scope (Scope); + end; + + -- Build the call to the generated procedure + + declare + Actual_List : constant List_Id := New_List; + Formal : Entity_Id; + + begin + Append_To (Actual_List, + New_Occurrence_Of (Defining_Identifier (New_Obj), Loc)); + + Formal := First_Formal (Spec_Id); + while Present (Formal) loop + Append_To (Actual_List, New_Occurrence_Of (Formal, Loc)); + + -- Avoid spurious warning on unreferenced formals + + Set_Referenced (Formal); + Next_Formal (Formal); + end loop; + + Proc_Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc_Id, Loc), + Parameter_Associations => Actual_List); + end; + + -- Generate: + + -- declare + -- New_Obj : ... + -- begin + -- Proc (New_Obj, ...); + -- return New_Obj; + -- end; + + Blk_Stmt := + Make_Block_Statement (Loc, + Declarations => New_List (New_Obj), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + + Proc_Call, + + Make_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of + (Defining_Identifier (New_Obj), Loc))))); + + Rewrite (Ret_Node, Blk_Stmt); + end Split_Unconstrained_Function; + + -- Local variables + + Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); + + -- Start of processing for Check_And_Split_Unconstrained_Function + + begin + pragma Assert (Back_End_Inlining + and then Ekind (Spec_Id) = E_Function + and then Returns_Unconstrained_Type (Spec_Id) + and then Comes_From_Source (Body_Id) + and then (Has_Pragma_Inline_Always (Spec_Id) + or else Optimization_Level > 0)); + + -- This routine must not be used in GNATprove mode since GNATprove + -- relies on frontend inlining + + pragma Assert (not GNATprove_Mode); + + -- No need to split the function if we cannot generate the code + + if Serious_Errors_Detected /= 0 then + return; + end if; + + -- No action needed in stubs since the attribute Body_To_Inline + -- is not available + + if Nkind (Decl) = N_Subprogram_Body_Stub then + return; + + -- Cannot build the body to inline if the attribute is already set. + -- This attribute may have been set if this is a subprogram renaming + -- declarations (see Freeze.Build_Renamed_Body). + + elsif Present (Body_To_Inline (Decl)) then + return; + + -- Check excluded declarations + + elsif Present (Declarations (N)) + and then Has_Excluded_Declaration (Spec_Id, Declarations (N)) + then + return; + + -- Check excluded statements. There is no need to protect us against + -- exception handlers since they are supported by the GCC backend. + + elsif Present (Handled_Statement_Sequence (N)) + and then Has_Excluded_Statement + (Spec_Id, Statements (Handled_Statement_Sequence (N))) + then + return; + end if; + + -- Build the body to inline only if really needed + + if Can_Split_Unconstrained_Function (N) then + Split_Unconstrained_Function (N, Spec_Id); + Build_Body_To_Inline (N, Spec_Id); + Set_Is_Inlined (Spec_Id); + end if; + end Check_And_Split_Unconstrained_Function; + + ------------------------------------- + -- Check_Package_Body_For_Inlining -- + ------------------------------------- + + procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is + Bname : Unit_Name_Type; + E : Entity_Id; + OK : Boolean; + + begin + -- Legacy implementation (relying on frontend inlining) + + if not Back_End_Inlining + and then Is_Compilation_Unit (P) + and then not Is_Generic_Instance (P) + then + Bname := Get_Body_Name (Get_Unit_Name (Unit (N))); + + E := First_Entity (P); + while Present (E) loop + if Has_Pragma_Inline_Always (E) + or else (Has_Pragma_Inline (E) and Front_End_Inlining) + then + if not Is_Loaded (Bname) then + Load_Needed_Body (N, OK); + + if OK then + + -- Check we are not trying to inline a parent whose body + -- depends on a child, when we are compiling the body of + -- the child. Otherwise we have a potential elaboration + -- circularity with inlined subprograms and with + -- Taft-Amendment types. + + declare + Comp : Node_Id; -- Body just compiled + Child_Spec : Entity_Id; -- Spec of main unit + Ent : Entity_Id; -- For iteration + With_Clause : Node_Id; -- Context of body. + + begin + if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body + and then Present (Body_Entity (P)) + then + Child_Spec := + Defining_Entity + ((Unit (Library_Unit (Cunit (Main_Unit))))); + + Comp := + Parent (Unit_Declaration_Node (Body_Entity (P))); + + -- Check whether the context of the body just + -- compiled includes a child of itself, and that + -- child is the spec of the main compilation. + + With_Clause := First (Context_Items (Comp)); + while Present (With_Clause) loop + if Nkind (With_Clause) = N_With_Clause + and then + Scope (Entity (Name (With_Clause))) = P + and then + Entity (Name (With_Clause)) = Child_Spec + then + Error_Msg_Node_2 := Child_Spec; + Error_Msg_NE + ("body of & depends on child unit&??", + With_Clause, P); + Error_Msg_N + ("\subprograms in body cannot be inlined??", + With_Clause); + + -- Disable further inlining from this unit, + -- and keep Taft-amendment types incomplete. + + Ent := First_Entity (P); + while Present (Ent) loop + if Is_Type (Ent) + and then Has_Completion_In_Body (Ent) + then + Set_Full_View (Ent, Empty); + + elsif Is_Subprogram (Ent) then + Set_Is_Inlined (Ent, False); + end if; + + Next_Entity (Ent); + end loop; + + return; + end if; + + Next (With_Clause); + end loop; + end if; + end; + + elsif Ineffective_Inline_Warnings then + Error_Msg_Unit_1 := Bname; + Error_Msg_N + ("unable to inline subprograms defined in $??", P); + Error_Msg_N ("\body not found??", P); + return; + end if; + end if; + + return; + end if; + + Next_Entity (E); + end loop; + end if; + end Check_Package_Body_For_Inlining; + + -------------------- + -- Cleanup_Scopes -- + -------------------- + + procedure Cleanup_Scopes is + Elmt : Elmt_Id; + Decl : Node_Id; + Scop : Entity_Id; + + begin + Elmt := First_Elmt (To_Clean); + while Present (Elmt) loop + Scop := Node (Elmt); + + if Ekind (Scop) = E_Entry then + Scop := Protected_Body_Subprogram (Scop); + + elsif Is_Subprogram (Scop) + and then Is_Protected_Type (Scope (Scop)) + and then Present (Protected_Body_Subprogram (Scop)) + then + -- If a protected operation contains an instance, its cleanup + -- operations have been delayed, and the subprogram has been + -- rewritten in the expansion of the enclosing protected body. It + -- is the corresponding subprogram that may require the cleanup + -- operations, so propagate the information that triggers cleanup + -- activity. + + Set_Uses_Sec_Stack + (Protected_Body_Subprogram (Scop), + Uses_Sec_Stack (Scop)); + + Scop := Protected_Body_Subprogram (Scop); + end if; + + if Ekind (Scop) = E_Block then + Decl := Parent (Block_Node (Scop)); + + else + Decl := Unit_Declaration_Node (Scop); + + if Nkind_In (Decl, N_Subprogram_Declaration, + N_Task_Type_Declaration, + N_Subprogram_Body_Stub) + then + Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); + end if; + end if; + + Push_Scope (Scop); + Expand_Cleanup_Actions (Decl); + End_Scope; + + Elmt := Next_Elmt (Elmt); + end loop; + end Cleanup_Scopes; + + ------------------------- + -- Expand_Inlined_Call -- + ------------------------- + + procedure Expand_Inlined_Call + (N : Node_Id; + Subp : Entity_Id; + Orig_Subp : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Is_Predef : constant Boolean := + Is_Predefined_Unit (Get_Source_Unit (Subp)); + Orig_Bod : constant Node_Id := + Body_To_Inline (Unit_Declaration_Node (Subp)); + + Blk : Node_Id; + Decl : Node_Id; + Decls : constant List_Id := New_List; + Exit_Lab : Entity_Id := Empty; + F : Entity_Id; + A : Node_Id; + Lab_Decl : Node_Id; + Lab_Id : Node_Id; + New_A : Node_Id; + Num_Ret : Nat := 0; + Ret_Type : Entity_Id; + + Targ : Node_Id; + -- The target of the call. If context is an assignment statement then + -- this is the left-hand side of the assignment, else it is a temporary + -- to which the return value is assigned prior to rewriting the call. + + Targ1 : Node_Id := Empty; + -- A separate target used when the return type is unconstrained + + Temp : Entity_Id; + Temp_Typ : Entity_Id; + + Return_Object : Entity_Id := Empty; + -- Entity in declaration in an extended_return_statement + + Is_Unc : Boolean; + Is_Unc_Decl : Boolean; + -- If the type returned by the function is unconstrained and the call + -- can be inlined, special processing is required. + + procedure Declare_Postconditions_Result; + -- When generating C code, declare _Result, which may be used in the + -- inlined _Postconditions procedure to verify the return value. + + procedure Make_Exit_Label; + -- Build declaration for exit label to be used in Return statements, + -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit + -- declaration). Does nothing if Exit_Lab already set. + + function Process_Formals (N : Node_Id) return Traverse_Result; + -- Replace occurrence of a formal with the corresponding actual, or the + -- thunk generated for it. Replace a return statement with an assignment + -- to the target of the call, with appropriate conversions if needed. + + function Process_Sloc (Nod : Node_Id) return Traverse_Result; + -- If the call being expanded is that of an internal subprogram, set the + -- sloc of the generated block to that of the call itself, so that the + -- expansion is skipped by the "next" command in gdb. Same processing + -- for a subprogram in a predefined file, e.g. Ada.Tags. If + -- Debug_Generated_Code is true, suppress this change to simplify our + -- own development. Same in GNATprove mode, to ensure that warnings and + -- diagnostics point to the proper location. + + procedure Reset_Dispatching_Calls (N : Node_Id); + -- In subtree N search for occurrences of dispatching calls that use the + -- Ada 2005 Object.Operation notation and the object is a formal of the + -- inlined subprogram. Reset the entity associated with Operation in all + -- the found occurrences. + + procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); + -- If the function body is a single expression, replace call with + -- expression, else insert block appropriately. + + procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); + -- If procedure body has no local variables, inline body without + -- creating block, otherwise rewrite call with block. + + function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; + -- Determine whether a formal parameter is used only once in Orig_Bod + + ----------------------------------- + -- Declare_Postconditions_Result -- + ----------------------------------- + + procedure Declare_Postconditions_Result is + Enclosing_Subp : constant Entity_Id := Scope (Subp); + + begin + pragma Assert + (Modify_Tree_For_C + and then Is_Subprogram (Enclosing_Subp) + and then Present (Postconditions_Proc (Enclosing_Subp))); + + if Ekind (Enclosing_Subp) = E_Function then + if Nkind (First (Parameter_Associations (N))) in + N_Numeric_Or_String_Literal + then + Append_To (Declarations (Blk), + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uResult), + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Etype (Enclosing_Subp), Loc), + Expression => + New_Copy_Tree (First (Parameter_Associations (N))))); + else + Append_To (Declarations (Blk), + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uResult), + Subtype_Mark => + New_Occurrence_Of (Etype (Enclosing_Subp), Loc), + Name => + New_Copy_Tree (First (Parameter_Associations (N))))); + end if; + end if; + end Declare_Postconditions_Result; + + --------------------- + -- Make_Exit_Label -- + --------------------- + + procedure Make_Exit_Label is + Lab_Ent : Entity_Id; + begin + if No (Exit_Lab) then + Lab_Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Occurrence_Of (Lab_Ent, Loc); + Exit_Lab := Make_Label (Loc, Lab_Id); + Lab_Decl := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Lab_Ent, + Label_Construct => Exit_Lab); + end if; + end Make_Exit_Label; + + --------------------- + -- Process_Formals -- + --------------------- + + function Process_Formals (N : Node_Id) return Traverse_Result is + A : Entity_Id; + E : Entity_Id; + Ret : Node_Id; + + begin + if Is_Entity_Name (N) and then Present (Entity (N)) then + E := Entity (N); + + if Is_Formal (E) and then Scope (E) = Subp then + A := Renamed_Object (E); + + -- Rewrite the occurrence of the formal into an occurrence of + -- the actual. Also establish visibility on the proper view of + -- the actual's subtype for the body's context (if the actual's + -- subtype is private at the call point but its full view is + -- visible to the body, then the inlined tree here must be + -- analyzed with the full view). + + if Is_Entity_Name (A) then + Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N))); + Check_Private_View (N); + + elsif Nkind (A) = N_Defining_Identifier then + Rewrite (N, New_Occurrence_Of (A, Sloc (N))); + Check_Private_View (N); + + -- Numeric literal + + else + Rewrite (N, New_Copy (A)); + end if; + end if; + + return Skip; + + elsif Is_Entity_Name (N) + and then Present (Return_Object) + and then Chars (N) = Chars (Return_Object) + then + -- Occurrence within an extended return statement. The return + -- object is local to the body been inlined, and thus the generic + -- copy is not analyzed yet, so we match by name, and replace it + -- with target of call. + + if Nkind (Targ) = N_Defining_Identifier then + Rewrite (N, New_Occurrence_Of (Targ, Loc)); + else + Rewrite (N, New_Copy_Tree (Targ)); + end if; + + return Skip; + + elsif Nkind (N) = N_Simple_Return_Statement then + if No (Expression (N)) then + Num_Ret := Num_Ret + 1; + Make_Exit_Label; + Rewrite (N, + Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); + + else + if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (Parent (N))) = N_Subprogram_Body + then + -- Function body is a single expression. No need for + -- exit label. + + null; + + else + Num_Ret := Num_Ret + 1; + Make_Exit_Label; + end if; + + -- Because of the presence of private types, the views of the + -- expression and the context may be different, so place an + -- unchecked conversion to the context type to avoid spurious + -- errors, e.g. when the expression is a numeric literal and + -- the context is private. If the expression is an aggregate, + -- use a qualified expression, because an aggregate is not a + -- legal argument of a conversion. Ditto for numeric literals + -- and attributes that yield a universal type, because those + -- must be resolved to a specific type. + + if Nkind_In (Expression (N), N_Aggregate, N_Null) + or else Yields_Universal_Type (Expression (N)) + then + Ret := + Make_Qualified_Expression (Sloc (N), + Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), + Expression => Relocate_Node (Expression (N))); + else + Ret := + Unchecked_Convert_To + (Ret_Type, Relocate_Node (Expression (N))); + end if; + + if Nkind (Targ) = N_Defining_Identifier then + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Targ, Loc), + Expression => Ret)); + else + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => New_Copy (Targ), + Expression => Ret)); + end if; + + Set_Assignment_OK (Name (N)); + + if Present (Exit_Lab) then + Insert_After (N, + Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); + end if; + end if; + + return OK; + + -- An extended return becomes a block whose first statement is the + -- assignment of the initial expression of the return object to the + -- target of the call itself. + + elsif Nkind (N) = N_Extended_Return_Statement then + declare + Return_Decl : constant Entity_Id := + First (Return_Object_Declarations (N)); + Assign : Node_Id; + + begin + Return_Object := Defining_Identifier (Return_Decl); + + if Present (Expression (Return_Decl)) then + if Nkind (Targ) = N_Defining_Identifier then + Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Targ, Loc), + Expression => Expression (Return_Decl)); + else + Assign := + Make_Assignment_Statement (Loc, + Name => New_Copy (Targ), + Expression => Expression (Return_Decl)); + end if; + + Set_Assignment_OK (Name (Assign)); + + if No (Handled_Statement_Sequence (N)) then + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List)); + end if; + + Prepend (Assign, + Statements (Handled_Statement_Sequence (N))); + end if; + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Handled_Statement_Sequence (N))); + + return OK; + end; + + -- Remove pragma Unreferenced since it may refer to formals that + -- are not visible in the inlined body, and in any case we will + -- not be posting warnings on the inlined body so it is unneeded. + + elsif Nkind (N) = N_Pragma + and then Pragma_Name (N) = Name_Unreferenced + then + Rewrite (N, Make_Null_Statement (Sloc (N))); + return OK; + + else + return OK; + end if; + end Process_Formals; + + procedure Replace_Formals is new Traverse_Proc (Process_Formals); + + ------------------ + -- Process_Sloc -- + ------------------ + + function Process_Sloc (Nod : Node_Id) return Traverse_Result is + begin + if not Debug_Generated_Code then + Set_Sloc (Nod, Sloc (N)); + Set_Comes_From_Source (Nod, False); + end if; + + return OK; + end Process_Sloc; + + procedure Reset_Slocs is new Traverse_Proc (Process_Sloc); + + ------------------------------ + -- Reset_Dispatching_Calls -- + ------------------------------ + + procedure Reset_Dispatching_Calls (N : Node_Id) is + + function Do_Reset (N : Node_Id) return Traverse_Result; + -- Comment required ??? + + -------------- + -- Do_Reset -- + -------------- + + function Do_Reset (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Procedure_Call_Statement + and then Nkind (Name (N)) = N_Selected_Component + and then Nkind (Prefix (Name (N))) = N_Identifier + and then Is_Formal (Entity (Prefix (Name (N)))) + and then Is_Dispatching_Operation + (Entity (Selector_Name (Name (N)))) + then + Set_Entity (Selector_Name (Name (N)), Empty); + end if; + + return OK; + end Do_Reset; + + function Do_Reset_Calls is new Traverse_Func (Do_Reset); + + -- Local variables + + Dummy : constant Traverse_Result := Do_Reset_Calls (N); + pragma Unreferenced (Dummy); + + -- Start of processing for Reset_Dispatching_Calls + + begin + null; + end Reset_Dispatching_Calls; + + --------------------------- + -- Rewrite_Function_Call -- + --------------------------- + + procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is + HSS : constant Node_Id := Handled_Statement_Sequence (Blk); + Fst : constant Node_Id := First (Statements (HSS)); + + begin + -- Optimize simple case: function body is a single return statement, + -- which has been expanded into an assignment. + + if Is_Empty_List (Declarations (Blk)) + and then Nkind (Fst) = N_Assignment_Statement + and then No (Next (Fst)) + then + -- The function call may have been rewritten as the temporary + -- that holds the result of the call, in which case remove the + -- now useless declaration. + + if Nkind (N) = N_Identifier + and then Nkind (Parent (Entity (N))) = N_Object_Declaration + then + Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); + end if; + + Rewrite (N, Expression (Fst)); + + elsif Nkind (N) = N_Identifier + and then Nkind (Parent (Entity (N))) = N_Object_Declaration + then + -- The block assigns the result of the call to the temporary + + Insert_After (Parent (Entity (N)), Blk); + + -- If the context is an assignment, and the left-hand side is free of + -- side-effects, the replacement is also safe. + -- Can this be generalized further??? + + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then + (Is_Entity_Name (Name (Parent (N))) + or else + (Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N))))) + + or else + (Nkind (Name (Parent (N))) = N_Selected_Component + and then Is_Entity_Name (Prefix (Name (Parent (N)))))) + then + -- Replace assignment with the block + + declare + Original_Assignment : constant Node_Id := Parent (N); + + begin + -- Preserve the original assignment node to keep the complete + -- assignment subtree consistent enough for Analyze_Assignment + -- to proceed (specifically, the original Lhs node must still + -- have an assignment statement as its parent). + + -- We cannot rely on Original_Node to go back from the block + -- node to the assignment node, because the assignment might + -- already be a rewrite substitution. + + Discard_Node (Relocate_Node (Original_Assignment)); + Rewrite (Original_Assignment, Blk); + end; + + elsif Nkind (Parent (N)) = N_Object_Declaration then + + -- A call to a function which returns an unconstrained type + -- found in the expression initializing an object-declaration is + -- expanded into a procedure call which must be added after the + -- object declaration. + + if Is_Unc_Decl and Back_End_Inlining then + Insert_Action_After (Parent (N), Blk); + else + Set_Expression (Parent (N), Empty); + Insert_After (Parent (N), Blk); + end if; + + elsif Is_Unc and then not Back_End_Inlining then + Insert_Before (Parent (N), Blk); + end if; + end Rewrite_Function_Call; + + ---------------------------- + -- Rewrite_Procedure_Call -- + ---------------------------- + + procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is + HSS : constant Node_Id := Handled_Statement_Sequence (Blk); + + begin + -- If there is a transient scope for N, this will be the scope of the + -- actions for N, and the statements in Blk need to be within this + -- scope. For example, they need to have visibility on the constant + -- declarations created for the formals. + + -- If N needs no transient scope, and if there are no declarations in + -- the inlined body, we can do a little optimization and insert the + -- statements for the body directly after N, and rewrite N to a + -- null statement, instead of rewriting N into a full-blown block + -- statement. + + if not Scope_Is_Transient + and then Is_Empty_List (Declarations (Blk)) + then + Insert_List_After (N, Statements (HSS)); + Rewrite (N, Make_Null_Statement (Loc)); + else + Rewrite (N, Blk); + end if; + end Rewrite_Procedure_Call; + + ------------------------- + -- Formal_Is_Used_Once -- + ------------------------- + + function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is + Use_Counter : Int := 0; + + function Count_Uses (N : Node_Id) return Traverse_Result; + -- Traverse the tree and count the uses of the formal parameter. + -- In this case, for optimization purposes, we do not need to + -- continue the traversal once more than one use is encountered. + + ---------------- + -- Count_Uses -- + ---------------- + + function Count_Uses (N : Node_Id) return Traverse_Result is + begin + -- The original node is an identifier + + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + + -- Original node's entity points to the one in the copied body + + and then Nkind (Entity (N)) = N_Identifier + and then Present (Entity (Entity (N))) + + -- The entity of the copied node is the formal parameter + + and then Entity (Entity (N)) = Formal + then + Use_Counter := Use_Counter + 1; + + if Use_Counter > 1 then + + -- Denote more than one use and abandon the traversal + + Use_Counter := 2; + return Abandon; + + end if; + end if; + + return OK; + end Count_Uses; + + procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses); + + -- Start of processing for Formal_Is_Used_Once + + begin + Count_Formal_Uses (Orig_Bod); + return Use_Counter = 1; + end Formal_Is_Used_Once; + + -- Start of processing for Expand_Inlined_Call + + begin + -- Initializations for old/new semantics + + if not Back_End_Inlining then + Is_Unc := Is_Array_Type (Etype (Subp)) + and then not Is_Constrained (Etype (Subp)); + Is_Unc_Decl := False; + else + Is_Unc := Returns_Unconstrained_Type (Subp) + and then Optimization_Level > 0; + Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration + and then Is_Unc; + end if; + + -- Check for an illegal attempt to inline a recursive procedure. If the + -- subprogram has parameters this is detected when trying to supply a + -- binding for parameters that already have one. For parameterless + -- subprograms this must be done explicitly. + + if In_Open_Scopes (Subp) then + Cannot_Inline + ("cannot inline call to recursive subprogram?", N, Subp); + Set_Is_Inlined (Subp, False); + return; + + -- Skip inlining if this is not a true inlining since the attribute + -- Body_To_Inline is also set for renamings (see sinfo.ads). For a + -- true inlining, Orig_Bod has code rather than being an entity. + + elsif Nkind (Orig_Bod) in N_Entity then + return; + + -- Skip inlining if the function returns an unconstrained type using + -- an extended return statement since this part of the new inlining + -- model which is not yet supported by the current implementation. ??? + + elsif Is_Unc + and then + Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) = + N_Extended_Return_Statement + and then not Back_End_Inlining + then + return; + end if; + + if Nkind (Orig_Bod) = N_Defining_Identifier + or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol + then + -- Subprogram is renaming_as_body. Calls occurring after the renaming + -- can be replaced with calls to the renamed entity directly, because + -- the subprograms are subtype conformant. If the renamed subprogram + -- is an inherited operation, we must redo the expansion because + -- implicit conversions may be needed. Similarly, if the renamed + -- entity is inlined, expand the call for further optimizations. + + Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); + + if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then + Expand_Call (N); + end if; + + return; + end if; + + -- Register the call in the list of inlined calls + + Append_New_Elmt (N, To => Inlined_Calls); + + -- Use generic machinery to copy body of inlined subprogram, as if it + -- were an instantiation, resetting source locations appropriately, so + -- that nested inlined calls appear in the main unit. + + Save_Env (Subp, Empty); + Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod)); + + -- Old semantics + + if not Back_End_Inlining then + declare + Bod : Node_Id; + + begin + Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); + Blk := + Make_Block_Statement (Loc, + Declarations => Declarations (Bod), + Handled_Statement_Sequence => + Handled_Statement_Sequence (Bod)); + + if No (Declarations (Bod)) then + Set_Declarations (Blk, New_List); + end if; + + -- When generating C code, declare _Result, which may be used to + -- verify the return value. + + if Modify_Tree_For_C + and then Nkind (N) = N_Procedure_Call_Statement + and then Chars (Name (N)) = Name_uPostconditions + then + Declare_Postconditions_Result; + end if; + + -- For the unconstrained case, capture the name of the local + -- variable that holds the result. This must be the first + -- declaration in the block, because its bounds cannot depend + -- on local variables. Otherwise there is no way to declare the + -- result outside of the block. Needless to say, in general the + -- bounds will depend on the actuals in the call. + + -- If the context is an assignment statement, as is the case + -- for the expansion of an extended return, the left-hand side + -- provides bounds even if the return type is unconstrained. + + if Is_Unc then + declare + First_Decl : Node_Id; + + begin + First_Decl := First (Declarations (Blk)); + + if Nkind (First_Decl) /= N_Object_Declaration then + return; + end if; + + if Nkind (Parent (N)) /= N_Assignment_Statement then + Targ1 := Defining_Identifier (First_Decl); + else + Targ1 := Name (Parent (N)); + end if; + end; + end if; + end; + + -- New semantics + + else + declare + Bod : Node_Id; + + begin + -- General case + + if not Is_Unc then + Bod := + Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); + Blk := + Make_Block_Statement (Loc, + Declarations => Declarations (Bod), + Handled_Statement_Sequence => + Handled_Statement_Sequence (Bod)); + + -- Inline a call to a function that returns an unconstrained type. + -- The semantic analyzer checked that frontend-inlined functions + -- returning unconstrained types have no declarations and have + -- a single extended return statement. As part of its processing + -- the function was split into two subprograms: a procedure P' and + -- a function F' that has a block with a call to procedure P' (see + -- Split_Unconstrained_Function). + + else + pragma Assert + (Nkind + (First + (Statements (Handled_Statement_Sequence (Orig_Bod)))) = + N_Block_Statement); + + declare + Blk_Stmt : constant Node_Id := + First (Statements (Handled_Statement_Sequence (Orig_Bod))); + First_Stmt : constant Node_Id := + First (Statements (Handled_Statement_Sequence (Blk_Stmt))); + Second_Stmt : constant Node_Id := Next (First_Stmt); + + begin + pragma Assert + (Nkind (First_Stmt) = N_Procedure_Call_Statement + and then Nkind (Second_Stmt) = N_Simple_Return_Statement + and then No (Next (Second_Stmt))); + + Bod := + Copy_Generic_Node + (First + (Statements (Handled_Statement_Sequence (Orig_Bod))), + Empty, Instantiating => True); + Blk := Bod; + + -- Capture the name of the local variable that holds the + -- result. This must be the first declaration in the block, + -- because its bounds cannot depend on local variables. + -- Otherwise there is no way to declare the result outside + -- of the block. Needless to say, in general the bounds will + -- depend on the actuals in the call. + + if Nkind (Parent (N)) /= N_Assignment_Statement then + Targ1 := Defining_Identifier (First (Declarations (Blk))); + + -- If the context is an assignment statement, as is the case + -- for the expansion of an extended return, the left-hand + -- side provides bounds even if the return type is + -- unconstrained. + + else + Targ1 := Name (Parent (N)); + end if; + end; + end if; + + if No (Declarations (Bod)) then + Set_Declarations (Blk, New_List); + end if; + end; + end if; + + -- If this is a derived function, establish the proper return type + + if Present (Orig_Subp) and then Orig_Subp /= Subp then + Ret_Type := Etype (Orig_Subp); + else + Ret_Type := Etype (Subp); + end if; + + -- Create temporaries for the actuals that are expressions, or that are + -- scalars and require copying to preserve semantics. + + F := First_Formal (Subp); + A := First_Actual (N); + while Present (F) loop + if Present (Renamed_Object (F)) then + + -- If expander is active, it is an error to try to inline a + -- recursive program. In GNATprove mode, just indicate that the + -- inlining will not happen, and mark the subprogram as not always + -- inlined. + + if GNATprove_Mode then + Cannot_Inline + ("cannot inline call to recursive subprogram?", N, Subp); + Set_Is_Inlined_Always (Subp, False); + else + Error_Msg_N + ("cannot inline call to recursive subprogram", N); + end if; + + return; + end if; + + -- Reset Last_Assignment for any parameters of mode out or in out, to + -- prevent spurious warnings about overwriting for assignments to the + -- formal in the inlined code. + + if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then + Set_Last_Assignment (Entity (A), Empty); + end if; + + -- If the argument may be a controlling argument in a call within + -- the inlined body, we must preserve its classwide nature to insure + -- that dynamic dispatching take place subsequently. If the formal + -- has a constraint it must be preserved to retain the semantics of + -- the body. + + if Is_Class_Wide_Type (Etype (F)) + or else (Is_Access_Type (Etype (F)) + and then Is_Class_Wide_Type (Designated_Type (Etype (F)))) + then + Temp_Typ := Etype (F); + + elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) + and then Etype (F) /= Base_Type (Etype (F)) + and then Is_Constrained (Etype (F)) + then + Temp_Typ := Etype (F); + + else + Temp_Typ := Etype (A); + end if; + + -- If the actual is a simple name or a literal, no need to + -- create a temporary, object can be used directly. + + -- If the actual is a literal and the formal has its address taken, + -- we cannot pass the literal itself as an argument, so its value + -- must be captured in a temporary. Skip this optimization in + -- GNATprove mode, to make sure any check on a type conversion + -- will be issued. + + if (Is_Entity_Name (A) + and then + (not Is_Scalar_Type (Etype (A)) + or else Ekind (Entity (A)) = E_Enumeration_Literal) + and then not GNATprove_Mode) + + -- When the actual is an identifier and the corresponding formal is + -- used only once in the original body, the formal can be substituted + -- directly with the actual parameter. Skip this optimization in + -- GNATprove mode, to make sure any check on a type conversion + -- will be issued. + + or else + (Nkind (A) = N_Identifier + and then Formal_Is_Used_Once (F) + and then not GNATprove_Mode) + + or else + (Nkind_In (A, N_Real_Literal, + N_Integer_Literal, + N_Character_Literal) + and then not Address_Taken (F)) + then + if Etype (F) /= Etype (A) then + Set_Renamed_Object + (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); + else + Set_Renamed_Object (F, A); + end if; + + else + Temp := Make_Temporary (Loc, 'C'); + + -- If the actual for an in/in-out parameter is a view conversion, + -- make it into an unchecked conversion, given that an untagged + -- type conversion is not a proper object for a renaming. + + -- In-out conversions that involve real conversions have already + -- been transformed in Expand_Actuals. + + if Nkind (A) = N_Type_Conversion + and then Ekind (F) /= E_In_Parameter + then + New_A := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Etype (F), Loc), + Expression => Relocate_Node (Expression (A))); + + -- In GNATprove mode, keep the most precise type of the actual for + -- the temporary variable, when the formal type is unconstrained. + -- Otherwise, the AST may contain unexpected assignment statements + -- to a temporary variable of unconstrained type renaming a local + -- variable of constrained type, which is not expected by + -- GNATprove. + + elsif Etype (F) /= Etype (A) + and then (not GNATprove_Mode or else Is_Constrained (Etype (F))) + then + New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A)); + Temp_Typ := Etype (F); + + else + New_A := Relocate_Node (A); + end if; + + Set_Sloc (New_A, Sloc (N)); + + -- If the actual has a by-reference type, it cannot be copied, + -- so its value is captured in a renaming declaration. Otherwise + -- declare a local constant initialized with the actual. + + -- We also use a renaming declaration for expressions of an array + -- type that is not bit-packed, both for efficiency reasons and to + -- respect the semantics of the call: in most cases the original + -- call will pass the parameter by reference, and thus the inlined + -- code will have the same semantics. + + -- Finally, we need a renaming declaration in the case of limited + -- types for which initialization cannot be by copy either. + + if Ekind (F) = E_In_Parameter + and then not Is_By_Reference_Type (Etype (A)) + and then not Is_Limited_Type (Etype (A)) + and then + (not Is_Array_Type (Etype (A)) + or else not Is_Object_Reference (A) + or else Is_Bit_Packed_Array (Etype (A))) + then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), + Expression => New_A); + + else + -- In GNATprove mode, make an explicit copy of input + -- parameters when formal and actual types differ, to make + -- sure any check on the type conversion will be issued. + -- The legality of the copy is ensured by calling first + -- Call_Can_Be_Inlined_In_GNATprove_Mode. + + if GNATprove_Mode + and then Ekind (F) /= E_Out_Parameter + and then not Same_Type (Etype (F), Etype (A)) + then + pragma Assert (not (Is_By_Reference_Type (Etype (A)))); + pragma Assert (not (Is_Limited_Type (Etype (A)))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'C'), + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), + Expression => New_Copy_Tree (New_A))); + end if; + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp, + Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), + Name => New_A); + end if; + + Append (Decl, Decls); + Set_Renamed_Object (F, Temp); + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + + -- Establish target of function call. If context is not assignment or + -- declaration, create a temporary as a target. The declaration for the + -- temporary may be subsequently optimized away if the body is a single + -- expression, or if the left-hand side of the assignment is simple + -- enough, i.e. an entity or an explicit dereference of one. + + if Ekind (Subp) = E_Function then + if Nkind (Parent (N)) = N_Assignment_Statement + and then Is_Entity_Name (Name (Parent (N))) + then + Targ := Name (Parent (N)); + + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N)))) + then + Targ := Name (Parent (N)); + + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then Nkind (Name (Parent (N))) = N_Selected_Component + and then Is_Entity_Name (Prefix (Name (Parent (N)))) + then + Targ := New_Copy_Tree (Name (Parent (N))); + + elsif Nkind (Parent (N)) = N_Object_Declaration + and then Is_Limited_Type (Etype (Subp)) + then + Targ := Defining_Identifier (Parent (N)); + + -- New semantics: In an object declaration avoid an extra copy + -- of the result of a call to an inlined function that returns + -- an unconstrained type + + elsif Back_End_Inlining + and then Nkind (Parent (N)) = N_Object_Declaration + and then Is_Unc + then + Targ := Defining_Identifier (Parent (N)); + + else + -- Replace call with temporary and create its declaration + + Temp := Make_Temporary (Loc, 'C'); + Set_Is_Internal (Temp); + + -- For the unconstrained case, the generated temporary has the + -- same constrained declaration as the result variable. It may + -- eventually be possible to remove that temporary and use the + -- result variable directly. + + if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement + then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Copy_Tree (Object_Definition (Parent (Targ1)))); + + Replace_Formals (Decl); + + else + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Ret_Type, Loc)); + + Set_Etype (Temp, Ret_Type); + end if; + + Set_No_Initialization (Decl); + Append (Decl, Decls); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + Targ := Temp; + end if; + end if; + + Insert_Actions (N, Decls); + + if Is_Unc_Decl then + + -- Special management for inlining a call to a function that returns + -- an unconstrained type and initializes an object declaration: we + -- avoid generating undesired extra calls and goto statements. + + -- Given: + -- function Func (...) return String is + -- begin + -- declare + -- Result : String (1 .. 4); + -- begin + -- Proc (Result, ...); + -- return Result; + -- end; + -- end Func; + + -- Result : String := Func (...); + + -- Replace this object declaration by: + + -- Result : String (1 .. 4); + -- Proc (Result, ...); + + Remove_Homonym (Targ); + + Decl := + Make_Object_Declaration + (Loc, + Defining_Identifier => Targ, + Object_Definition => + New_Copy_Tree (Object_Definition (Parent (Targ1)))); + Replace_Formals (Decl); + Rewrite (Parent (N), Decl); + Analyze (Parent (N)); + + -- Avoid spurious warnings since we know that this declaration is + -- referenced by the procedure call. + + Set_Never_Set_In_Source (Targ, False); + + -- Remove the local declaration of the extended return stmt from the + -- inlined code + + Remove (Parent (Targ1)); + + -- Update the reference to the result (since we have rewriten the + -- object declaration) + + declare + Blk_Call_Stmt : Node_Id; + + begin + -- Capture the call to the procedure + + Blk_Call_Stmt := + First (Statements (Handled_Statement_Sequence (Blk))); + pragma Assert + (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement); + + Remove (First (Parameter_Associations (Blk_Call_Stmt))); + Prepend_To (Parameter_Associations (Blk_Call_Stmt), + New_Occurrence_Of (Targ, Loc)); + end; + + -- Remove the return statement + + pragma Assert + (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = + N_Simple_Return_Statement); + + Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); + end if; + + -- Traverse the tree and replace formals with actuals or their thunks. + -- Attach block to tree before analysis and rewriting. + + Replace_Formals (Blk); + Set_Parent (Blk, N); + + if GNATprove_Mode then + null; + + elsif not Comes_From_Source (Subp) or else Is_Predef then + Reset_Slocs (Blk); + end if; + + if Is_Unc_Decl then + + -- No action needed since return statement has been already removed + + null; + + elsif Present (Exit_Lab) then + + -- If there's a single return statement at the end of the subprogram, + -- the corresponding goto statement and the corresponding label are + -- useless. + + if Num_Ret = 1 + and then + Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = + N_Goto_Statement + then + Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); + else + Append (Lab_Decl, (Declarations (Blk))); + Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); + end if; + end if; + + -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors + -- on conflicting private views that Gigi would ignore. If this is a + -- predefined unit, analyze with checks off, as is done in the non- + -- inlined run-time units. + + declare + I_Flag : constant Boolean := In_Inlined_Body; + + begin + In_Inlined_Body := True; + + if Is_Predef then + declare + Style : constant Boolean := Style_Check; + + begin + Style_Check := False; + + -- Search for dispatching calls that use the Object.Operation + -- notation using an Object that is a parameter of the inlined + -- function. We reset the decoration of Operation to force + -- the reanalysis of the inlined dispatching call because + -- the actual object has been inlined. + + Reset_Dispatching_Calls (Blk); + + Analyze (Blk, Suppress => All_Checks); + Style_Check := Style; + end; + + else + Analyze (Blk); + end if; + + In_Inlined_Body := I_Flag; + end; + + if Ekind (Subp) = E_Procedure then + Rewrite_Procedure_Call (N, Blk); + + else + Rewrite_Function_Call (N, Blk); + + if Is_Unc_Decl then + null; + + -- For the unconstrained case, the replacement of the call has been + -- made prior to the complete analysis of the generated declarations. + -- Propagate the proper type now. + + elsif Is_Unc then + if Nkind (N) = N_Identifier then + Set_Etype (N, Etype (Entity (N))); + else + Set_Etype (N, Etype (Targ1)); + end if; + end if; + end if; + + Restore_Env; + + -- Cleanup mapping between formals and actuals for other expansions + + F := First_Formal (Subp); + while Present (F) loop + Set_Renamed_Object (F, Empty); + Next_Formal (F); + end loop; + end Expand_Inlined_Call; + + -------------------------- + -- Get_Code_Unit_Entity -- + -------------------------- + + function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is + Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E)); + + begin + if Ekind (Unit) = E_Package_Body then + Unit := Spec_Entity (Unit); + end if; + + return Unit; + end Get_Code_Unit_Entity; + + ------------------------------ + -- Has_Excluded_Declaration -- + ------------------------------ + + function Has_Excluded_Declaration + (Subp : Entity_Id; + Decls : List_Id) return Boolean + is + D : Node_Id; + + function Is_Unchecked_Conversion (D : Node_Id) return Boolean; + -- Nested subprograms make a given body ineligible for inlining, but + -- we make an exception for instantiations of unchecked conversion. + -- The body has not been analyzed yet, so check the name, and verify + -- that the visible entity with that name is the predefined unit. + + ----------------------------- + -- Is_Unchecked_Conversion -- + ----------------------------- + + function Is_Unchecked_Conversion (D : Node_Id) return Boolean is + Id : constant Node_Id := Name (D); + Conv : Entity_Id; + + begin + if Nkind (Id) = N_Identifier + and then Chars (Id) = Name_Unchecked_Conversion + then + Conv := Current_Entity (Id); + + elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name) + and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion + then + Conv := Current_Entity (Selector_Name (Id)); + else + return False; + end if; + + return Present (Conv) + and then Is_Predefined_Unit (Get_Source_Unit (Conv)) + and then Is_Intrinsic_Subprogram (Conv); + end Is_Unchecked_Conversion; + + -- Start of processing for Has_Excluded_Declaration + + begin + -- No action needed if the check is not needed + + if not Check_Inlining_Restrictions then + return False; + end if; + + D := First (Decls); + while Present (D) loop + + -- First declarations universally excluded + + if Nkind (D) = N_Package_Declaration then + Cannot_Inline + ("cannot inline & (nested package declaration)?", D, Subp); + return True; + + elsif Nkind (D) = N_Package_Instantiation then + Cannot_Inline + ("cannot inline & (nested package instantiation)?", D, Subp); + return True; + end if; + + -- Then declarations excluded only for front-end inlining + + if Back_End_Inlining then + null; + + elsif Nkind (D) = N_Task_Type_Declaration + or else Nkind (D) = N_Single_Task_Declaration + then + Cannot_Inline + ("cannot inline & (nested task type declaration)?", D, Subp); + return True; + + elsif Nkind (D) = N_Protected_Type_Declaration + or else Nkind (D) = N_Single_Protected_Declaration + then + Cannot_Inline + ("cannot inline & (nested protected type declaration)?", + D, Subp); + return True; + + elsif Nkind (D) = N_Subprogram_Body then + Cannot_Inline + ("cannot inline & (nested subprogram)?", D, Subp); + return True; + + elsif Nkind (D) = N_Function_Instantiation + and then not Is_Unchecked_Conversion (D) + then + Cannot_Inline + ("cannot inline & (nested function instantiation)?", D, Subp); + return True; + + elsif Nkind (D) = N_Procedure_Instantiation then + Cannot_Inline + ("cannot inline & (nested procedure instantiation)?", D, Subp); + return True; + + -- Subtype declarations with predicates will generate predicate + -- functions, i.e. nested subprogram bodies, so inlining is not + -- possible. + + elsif Nkind (D) = N_Subtype_Declaration + and then Present (Aspect_Specifications (D)) + then + declare + A : Node_Id; + A_Id : Aspect_Id; + + begin + A := First (Aspect_Specifications (D)); + while Present (A) loop + A_Id := Get_Aspect_Id (Chars (Identifier (A))); + + if A_Id = Aspect_Predicate + or else A_Id = Aspect_Static_Predicate + or else A_Id = Aspect_Dynamic_Predicate + then + Cannot_Inline + ("cannot inline & (subtype declaration with " + & "predicate)?", D, Subp); + return True; + end if; + + Next (A); + end loop; + end; + end if; + + Next (D); + end loop; + + return False; + end Has_Excluded_Declaration; + + ---------------------------- + -- Has_Excluded_Statement -- + ---------------------------- + + function Has_Excluded_Statement + (Subp : Entity_Id; + Stats : List_Id) return Boolean + is + S : Node_Id; + E : Node_Id; + + begin + -- No action needed if the check is not needed + + if not Check_Inlining_Restrictions then + return False; + end if; + + S := First (Stats); + while Present (S) loop + if Nkind_In (S, N_Abort_Statement, + N_Asynchronous_Select, + N_Conditional_Entry_Call, + N_Delay_Relative_Statement, + N_Delay_Until_Statement, + N_Selective_Accept, + N_Timed_Entry_Call) + then + Cannot_Inline + ("cannot inline & (non-allowed statement)?", S, Subp); + return True; + + elsif Nkind (S) = N_Block_Statement then + if Present (Declarations (S)) + and then Has_Excluded_Declaration (Subp, Declarations (S)) + then + return True; + + elsif Present (Handled_Statement_Sequence (S)) then + if not Back_End_Inlining + and then + Present + (Exception_Handlers (Handled_Statement_Sequence (S))) + then + Cannot_Inline + ("cannot inline& (exception handler)?", + First (Exception_Handlers + (Handled_Statement_Sequence (S))), + Subp); + return True; + + elsif Has_Excluded_Statement + (Subp, Statements (Handled_Statement_Sequence (S))) + then + return True; + end if; + end if; + + elsif Nkind (S) = N_Case_Statement then + E := First (Alternatives (S)); + while Present (E) loop + if Has_Excluded_Statement (Subp, Statements (E)) then + return True; + end if; + + Next (E); + end loop; + + elsif Nkind (S) = N_If_Statement then + if Has_Excluded_Statement (Subp, Then_Statements (S)) then + return True; + end if; + + if Present (Elsif_Parts (S)) then + E := First (Elsif_Parts (S)); + while Present (E) loop + if Has_Excluded_Statement (Subp, Then_Statements (E)) then + return True; + end if; + + Next (E); + end loop; + end if; + + if Present (Else_Statements (S)) + and then Has_Excluded_Statement (Subp, Else_Statements (S)) + then + return True; + end if; + + elsif Nkind (S) = N_Loop_Statement + and then Has_Excluded_Statement (Subp, Statements (S)) + then + return True; + + elsif Nkind (S) = N_Extended_Return_Statement then + if Present (Handled_Statement_Sequence (S)) + and then + Has_Excluded_Statement + (Subp, Statements (Handled_Statement_Sequence (S))) + then + return True; + + elsif not Back_End_Inlining + and then Present (Handled_Statement_Sequence (S)) + and then + Present (Exception_Handlers + (Handled_Statement_Sequence (S))) + then + Cannot_Inline + ("cannot inline& (exception handler)?", + First (Exception_Handlers (Handled_Statement_Sequence (S))), + Subp); + return True; + end if; + end if; + + Next (S); + end loop; + + return False; + end Has_Excluded_Statement; + + -------------------------- + -- Has_Initialized_Type -- + -------------------------- + + function Has_Initialized_Type (E : Entity_Id) return Boolean is + E_Body : constant Node_Id := Subprogram_Body (E); + Decl : Node_Id; + + begin + if No (E_Body) then -- imported subprogram + return False; + + else + Decl := First (Declarations (E_Body)); + while Present (Decl) loop + if Nkind (Decl) = N_Full_Type_Declaration + and then Present (Init_Proc (Defining_Identifier (Decl))) + then + return True; + end if; + + Next (Decl); + end loop; + end if; + + return False; + end Has_Initialized_Type; + + ----------------------- + -- Has_Single_Return -- + ----------------------- + + function Has_Single_Return (N : Node_Id) return Boolean is + Return_Statement : Node_Id := Empty; + + function Check_Return (N : Node_Id) return Traverse_Result; + + ------------------ + -- Check_Return -- + ------------------ + + function Check_Return (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Simple_Return_Statement then + if Present (Expression (N)) + and then Is_Entity_Name (Expression (N)) + then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + elsif Chars (Expression (N)) = + Chars (Expression (Return_Statement)) + then + return OK; + + else + return Abandon; + end if; + + -- A return statement within an extended return is a noop + -- after inlining. + + elsif No (Expression (N)) + and then + Nkind (Parent (Parent (N))) = N_Extended_Return_Statement + then + return OK; + + else + -- Expression has wrong form + + return Abandon; + end if; + + -- We can only inline a build-in-place function if it has a single + -- extended return. + + elsif Nkind (N) = N_Extended_Return_Statement then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + else + return Abandon; + end if; + + else + return OK; + end if; + end Check_Return; + + function Check_All_Returns is new Traverse_Func (Check_Return); + + -- Start of processing for Has_Single_Return + + begin + if Check_All_Returns (N) /= OK then + return False; + + elsif Nkind (Return_Statement) = N_Extended_Return_Statement then + return True; + + else + return Present (Declarations (N)) + and then Present (First (Declarations (N))) + and then Chars (Expression (Return_Statement)) = + Chars (Defining_Identifier (First (Declarations (N)))); + end if; + end Has_Single_Return; + + ----------------------------- + -- In_Main_Unit_Or_Subunit -- + ----------------------------- + + function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is + Comp : Node_Id := Cunit (Get_Code_Unit (E)); + + begin + -- Check whether the subprogram or package to inline is within the main + -- unit or its spec or within a subunit. In either case there are no + -- additional bodies to process. If the subprogram appears in a parent + -- of the current unit, the check on whether inlining is possible is + -- done in Analyze_Inlined_Bodies. + + while Nkind (Unit (Comp)) = N_Subunit loop + Comp := Library_Unit (Comp); + end loop; + + return Comp = Cunit (Main_Unit) + or else Comp = Library_Unit (Cunit (Main_Unit)); + end In_Main_Unit_Or_Subunit; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Pending_Descriptor.Init; + Pending_Instantiations.Init; + Inlined_Bodies.Init; + Successors.Init; + Inlined.Init; + + for J in Hash_Headers'Range loop + Hash_Headers (J) := No_Subp; + end loop; + + Inlined_Calls := No_Elist; + Backend_Calls := No_Elist; + Backend_Inlined_Subps := No_Elist; + Backend_Not_Inlined_Subps := No_Elist; + end Initialize; + + ------------------------ + -- Instantiate_Bodies -- + ------------------------ + + -- Generic bodies contain all the non-local references, so an + -- instantiation does not need any more context than Standard + -- itself, even if the instantiation appears in an inner scope. + -- Generic associations have verified that the contract model is + -- satisfied, so that any error that may occur in the analysis of + -- the body is an internal error. + + procedure Instantiate_Bodies is + J : Nat; + Info : Pending_Body_Info; + + begin + if Serious_Errors_Detected = 0 then + Expander_Active := (Operating_Mode = Opt.Generate_Code); + Push_Scope (Standard_Standard); + To_Clean := New_Elmt_List; + + if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then + Start_Generic; + end if; + + -- A body instantiation may generate additional instantiations, so + -- the following loop must scan to the end of a possibly expanding + -- set (that's why we can't simply use a FOR loop here). + + J := 0; + while J <= Pending_Instantiations.Last + and then Serious_Errors_Detected = 0 + loop + Info := Pending_Instantiations.Table (J); + + -- If the instantiation node is absent, it has been removed + -- as part of unreachable code. + + if No (Info.Inst_Node) then + null; + + elsif Nkind (Info.Act_Decl) = N_Package_Declaration then + Instantiate_Package_Body (Info); + Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl)); + + else + Instantiate_Subprogram_Body (Info); + end if; + + J := J + 1; + end loop; + + -- Reset the table of instantiations. Additional instantiations + -- may be added through inlining, when additional bodies are + -- analyzed. + + Pending_Instantiations.Init; + + -- We can now complete the cleanup actions of scopes that contain + -- pending instantiations (skipped for generic units, since we + -- never need any cleanups in generic units). + + if Expander_Active + and then not Is_Generic_Unit (Main_Unit_Entity) + then + Cleanup_Scopes; + elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then + End_Generic; + end if; + + Pop_Scope; + end if; + end Instantiate_Bodies; + + --------------- + -- Is_Nested -- + --------------- + + function Is_Nested (E : Entity_Id) return Boolean is + Scop : Entity_Id; + + begin + Scop := Scope (E); + while Scop /= Standard_Standard loop + if Ekind (Scop) in Subprogram_Kind then + return True; + + elsif Ekind (Scop) = E_Task_Type + or else Ekind (Scop) = E_Entry + or else Ekind (Scop) = E_Entry_Family + then + return True; + end if; + + Scop := Scope (Scop); + end loop; + + return False; + end Is_Nested; + + ------------------------ + -- List_Inlining_Info -- + ------------------------ + + procedure List_Inlining_Info is + Elmt : Elmt_Id; + Nod : Node_Id; + Count : Nat; + + begin + if not Debug_Flag_Dot_J then + return; + end if; + + -- Generate listing of calls inlined by the frontend + + if Present (Inlined_Calls) then + Count := 0; + Elmt := First_Elmt (Inlined_Calls); + while Present (Elmt) loop + Nod := Node (Elmt); + + if In_Extended_Main_Code_Unit (Nod) then + Count := Count + 1; + + if Count = 1 then + Write_Str ("List of calls inlined by the frontend"); + Write_Eol; + end if; + + Write_Str (" "); + Write_Int (Count); + Write_Str (":"); + Write_Location (Sloc (Nod)); + Write_Str (":"); + Output.Write_Eol; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- Generate listing of calls passed to the backend + + if Present (Backend_Calls) then + Count := 0; + + Elmt := First_Elmt (Backend_Calls); + while Present (Elmt) loop + Nod := Node (Elmt); + + if In_Extended_Main_Code_Unit (Nod) then + Count := Count + 1; + + if Count = 1 then + Write_Str ("List of inlined calls passed to the backend"); + Write_Eol; + end if; + + Write_Str (" "); + Write_Int (Count); + Write_Str (":"); + Write_Location (Sloc (Nod)); + Output.Write_Eol; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- Generate listing of subprograms passed to the backend + + if Present (Backend_Inlined_Subps) and then Back_End_Inlining then + Count := 0; + + Elmt := First_Elmt (Backend_Inlined_Subps); + while Present (Elmt) loop + Nod := Node (Elmt); + + Count := Count + 1; + + if Count = 1 then + Write_Str + ("List of inlined subprograms passed to the backend"); + Write_Eol; + end if; + + Write_Str (" "); + Write_Int (Count); + Write_Str (":"); + Write_Name (Chars (Nod)); + Write_Str (" ("); + Write_Location (Sloc (Nod)); + Write_Str (")"); + Output.Write_Eol; + + Next_Elmt (Elmt); + end loop; + end if; + + -- Generate listing of subprograms that cannot be inlined by the backend + + if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining then + Count := 0; + + Elmt := First_Elmt (Backend_Not_Inlined_Subps); + while Present (Elmt) loop + Nod := Node (Elmt); + + Count := Count + 1; + + if Count = 1 then + Write_Str + ("List of subprograms that cannot be inlined by the backend"); + Write_Eol; + end if; + + Write_Str (" "); + Write_Int (Count); + Write_Str (":"); + Write_Name (Chars (Nod)); + Write_Str (" ("); + Write_Location (Sloc (Nod)); + Write_Str (")"); + Output.Write_Eol; + + Next_Elmt (Elmt); + end loop; + end if; + end List_Inlining_Info; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Pending_Instantiations.Release; + Pending_Instantiations.Locked := True; + Inlined_Bodies.Release; + Inlined_Bodies.Locked := True; + Successors.Release; + Successors.Locked := True; + Inlined.Release; + Inlined.Locked := True; + end Lock; + + -------------------------------- + -- Remove_Aspects_And_Pragmas -- + -------------------------------- + + procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id) is + procedure Remove_Items (List : List_Id); + -- Remove all useless aspects/pragmas from a particular list + + ------------------ + -- Remove_Items -- + ------------------ + + procedure Remove_Items (List : List_Id) is + Item : Node_Id; + Item_Id : Node_Id; + Next_Item : Node_Id; + + begin + -- Traverse the list looking for an aspect specification or a pragma + + Item := First (List); + while Present (Item) loop + Next_Item := Next (Item); + + if Nkind (Item) = N_Aspect_Specification then + Item_Id := Identifier (Item); + elsif Nkind (Item) = N_Pragma then + Item_Id := Pragma_Identifier (Item); + else + Item_Id := Empty; + end if; + + if Present (Item_Id) + and then Nam_In (Chars (Item_Id), Name_Contract_Cases, + Name_Global, + Name_Depends, + Name_Postcondition, + Name_Precondition, + Name_Refined_Global, + Name_Refined_Depends, + Name_Refined_Post, + Name_Test_Case, + Name_Unmodified, + Name_Unreferenced, + Name_Unused) + then + Remove (Item); + end if; + + Item := Next_Item; + end loop; + end Remove_Items; + + -- Start of processing for Remove_Aspects_And_Pragmas + + begin + Remove_Items (Aspect_Specifications (Body_Decl)); + Remove_Items (Declarations (Body_Decl)); + + -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear + -- in the body of the subprogram. + + Remove_Items (Statements (Handled_Statement_Sequence (Body_Decl))); + end Remove_Aspects_And_Pragmas; + + -------------------------- + -- Remove_Dead_Instance -- + -------------------------- + + procedure Remove_Dead_Instance (N : Node_Id) is + J : Int; + + begin + J := 0; + while J <= Pending_Instantiations.Last loop + if Pending_Instantiations.Table (J).Inst_Node = N then + Pending_Instantiations.Table (J).Inst_Node := Empty; + return; + end if; + + J := J + 1; + end loop; + end Remove_Dead_Instance; + +end Inline;