CbC/CbC_gcc: gcc/ada/inline.adb comparison

comparison gcc/ada/inline.adb @ 145:1830386684a0

gcc-9.2.0

author	anatofuz
date	Thu, 13 Feb 2020 11:34:05 +0900
parents	84e7813d76e9
children

comparison

equal deleted inserted replaced

-:84e7813d76e9
+:1830386684a0
 --                                                                          --
 --                               I N L I N E                                --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2019, 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- --
 -- GNAT was originally developed  by the GNAT team at  New York University. --
 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
 --                                                                          --
 ------------------------------------------------------------------------------
+with Alloc;
 with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Sinput;   use Sinput;
 with Snames;   use Snames;
 with Stand;    use Stand;
+with Table;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
 with Uname;    use Uname;
-with Tbuild;   use Tbuild;
+with GNAT.HTable;
 package body Inline is
 Check_Inlining_Restrictions : constant Boolean := True;
 --  In the following cases the frontend rejects inlining because they
 --  List of frontend inlined calls
 Backend_Calls : Elist_Id;
 --  List of inline calls passed to the backend
+Backend_Instances : Elist_Id;
+--  List of instances inlined for 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
+-----------------------------
+--  Pending_Instantiations --
+-----------------------------
+--  We make entries in this table for the pending instantiations of generic
+--  bodies that are created during semantic analysis. After the analysis is
+--  complete, calling Instantiate_Bodies performs the actual instantiations.
+package Pending_Instantiations is new Table.Table (
+Table_Component_Type => Pending_Body_Info,
+Table_Index_Type     => Int,
+Table_Low_Bound      => 0,
+Table_Initial        => Alloc.Pending_Instantiations_Initial,
+Table_Increment      => Alloc.Pending_Instantiations_Increment,
+Table_Name           => "Pending_Instantiations");
+-------------------------------------
+--  Called_Pending_Instantiations  --
+-------------------------------------
+--  With back-end inlining, the pending instantiations that are not in the
+--  main unit or subunit are performed only after a call to the subprogram
+--  instance, or to a subprogram within the package instance, is inlined.
+--  Since such a call can be within a subsequent pending instantiation,
+--  we make entries in this table that stores the index of these "called"
+--  pending instantiations and perform them when the table is populated.
+package Called_Pending_Instantiations is new Table.Table (
+Table_Component_Type => Int,
+Table_Index_Type     => Int,
+Table_Low_Bound      => 0,
+Table_Initial        => Alloc.Pending_Instantiations_Initial,
+Table_Increment      => Alloc.Pending_Instantiations_Increment,
+Table_Name           => "Called_Pending_Instantiations");
+---------------------------------
+--  To_Pending_Instantiations  --
+---------------------------------
+--  With back-end inlining, we also need to have a map from the pending
+--  instantiations to their index in the Pending_Instantiations table.
+Node_Table_Size : constant := 257;
+--  Number of headers in hash table
+subtype Node_Header_Num is Integer range 0 .. Node_Table_Size - 1;
+--  Range of headers in hash table
+function Node_Hash (Id : Node_Id) return Node_Header_Num;
+--  Simple hash function for Node_Ids
+package To_Pending_Instantiations is new GNAT.Htable.Simple_HTable
+(Header_Num => Node_Header_Num,
+Element    => Int,
+No_Element => -1,
+Key        => Node_Id,
+Hash       => Node_Hash,
+Equal      => "=");
+-----------------
+-- Node_Hash --
+-----------------
+function Node_Hash (Id : Node_Id) return Node_Header_Num is
+begin
+return Node_Header_Num (Id mod Node_Table_Size);
+end Node_Hash;
 --------------------
 -- Inlined Bodies --
 --------------------
 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_Instance (E : Entity_Id);
+--  Add instance E to the list of inlined instances for the unit
 procedure Add_Inlined_Subprogram (E : Entity_Id);
---  Add subprogram E to the list of inlined subprogram for the unit
+--  Add subprogram E to the list of inlined subprograms 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.
 end loop;
 return Dont_Inline;
 end Must_Inline;
-Level : Inline_Level_Type;
+Inst      : Entity_Id;
+Inst_Decl : Node_Id;
+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
+--  Skip subprograms that cannot or need not be inlined outside their
+--  unit or parent subprogram.
 if Is_Abstract_Subprogram (E)
 or else Convention (E) = Convention_Protected
+or else In_Main_Unit_Or_Subunit (E)
 or else Is_Nested (E)
 then
 return;
 end if;
 Level := Must_Inline;
 if Level = Dont_Inline then
 return;
 end if;
+--  If a previous call to the subprogram has been inlined, nothing to do
+if Is_Called (E) then
+return;
+end if;
+--  If the subprogram is an instance, then inline the instance
+if Is_Generic_Instance (E) then
+Add_Inlined_Instance (E);
+end if;
+--  Mark the subprogram as called
+Set_Is_Called (E);
 --  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
 --  where both the spec and body are in the same context, then there is
 --  no need to load any package body since the body of the function is
 --  in the spec.
 if Is_Non_Loading_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
+else
-Set_Is_Called (E);
+pragma Assert (Ekind (Pack) = E_Package);
+--  If the subprogram is within an instance, inline the instance
+if Comes_From_Source (E) then
+Inst := Scope (E);
+while Present (Inst) and then Inst /= Standard_Standard loop
+exit when Is_Generic_Instance (Inst);
+Inst := Scope (Inst);
+end loop;
+if Present (Inst)
+and then Is_Generic_Instance (Inst)
+and then not Is_Called (Inst)
+then
+Inst_Decl := Unit_Declaration_Node (Inst);
+--  Do not inline the instance if the body already exists,
+--  or the instance node is simply missing.
+if Present (Corresponding_Body (Inst_Decl))
+or else (Nkind (Parent (Inst_Decl)) /= N_Compilation_Unit
+and then No (Next (Inst_Decl)))
+then
+Set_Is_Called (Inst);
+else
+Add_Inlined_Instance (Inst);
+end if;
+end if;
+end if;
+--  If the unit containing E is an instance, nothing more to do
 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.
+--  calls if the back end takes care of inlining the call.
---  Note that Level in Inline_Package | Inline_Call here.
+--  Note that Level is in Inline_Call | Inline_Package here.
 elsif ((Level = Inline_Call
 and then Has_Pragma_Inline_Always (E)
 and then Back_End_Inlining)
 or else Level = Inline_Package)
 Inline_Processing_Required := True;
 end;
 end Add_Inlined_Body;
+--------------------------
+-- Add_Inlined_Instance --
+--------------------------
+procedure Add_Inlined_Instance (E : Entity_Id) is
+Decl_Node : constant Node_Id := Unit_Declaration_Node (E);
+Index     : Int;
+begin
+--  This machinery is only used with back-end inlining
+if not Back_End_Inlining then
+return;
+end if;
+--  Register the instance in the list
+Append_New_Elmt (Decl_Node, To => Backend_Instances);
+--  Retrieve the index of its corresponding pending instantiation
+--  and mark this corresponding pending instantiation as needed.
+Index := To_Pending_Instantiations.Get (Decl_Node);
+if Index >= 0 then
+Called_Pending_Instantiations.Append (Index);
+else
+pragma Assert (False);
+null;
+end if;
+Set_Is_Called (E);
+end Add_Inlined_Instance;
 ----------------------------
 -- Add_Inlined_Subprogram --
 ----------------------------
 procedure Add_Inlined_Subprogram (E : Entity_Id) is
 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
+--  We can inline the subprogram if its unit is known to be inlined or is
---  inlined or is an instance whose body will be analyzed anyway or the
+--  an instance whose body will be analyzed anyway or the subprogram was
---  subprogram was generated as a body by the compiler (for example an
+--  generated as a body by the compiler (for example an initialization
---  initialization procedure) or its declaration was provided along with
+--  procedure) or its declaration was provided along with the body (for
---  the body (for example an expression function), and if it is declared
+--  example an expression function) and it does not declare types with
---  at the library level not in the main unit, and if it can be inlined
+--  nontrivial initialization procedures.
---  by the back-end, then insert it in the list of inlined subprograms.
+if (Is_Inlined (Pack)
-if Is_Inlined (E)
+or else Is_Generic_Instance (Pack)
-and then (Is_Inlined (Pack)
+or else Nkind (Decl) = N_Subprogram_Body
-or else Is_Generic_Instance (Pack)
+or else Present (Corresponding_Body (Decl)))
-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
 else
 Register_Backend_Not_Inlined_Subprogram (E);
 end if;
 end Add_Inlined_Subprogram;
+--------------------------------
+--  Add_Pending_Instantiation --
+--------------------------------
+procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is
+Act_Decl_Id : Entity_Id;
+Index       : Int;
+begin
+--  Here is a defense against a ludicrous number of instantiations
+--  caused by a circular set of instantiation attempts.
+if Pending_Instantiations.Last + 1 >= Maximum_Instantiations then
+Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations);
+Error_Msg_N ("too many instantiations, exceeds max of^", Inst);
+Error_Msg_N ("\limit can be changed using -gnateinn switch", Inst);
+raise Unrecoverable_Error;
+end if;
+--  Capture the body of the generic instantiation along with its context
+--  for later processing by Instantiate_Bodies.
+Pending_Instantiations.Append
+((Act_Decl                 => Act_Decl,
+Config_Switches          => Save_Config_Switches,
+Current_Sem_Unit         => Current_Sem_Unit,
+Expander_Status          => Expander_Active,
+Inst_Node                => Inst,
+Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
+Scope_Suppress           => Scope_Suppress,
+Warnings                 => Save_Warnings));
+--  With back-end inlining, also associate the index to the instantiation
+if Back_End_Inlining then
+Act_Decl_Id := Defining_Entity (Act_Decl);
+Index := Pending_Instantiations.Last;
+To_Pending_Instantiations.Set (Act_Decl, Index);
+--  If an instantiation is in the main unit or subunit, or is a nested
+--  subprogram, then its body is needed as per the analysis done in
+--  Analyze_Package_Instantiation & Analyze_Subprogram_Instantiation.
+if In_Main_Unit_Or_Subunit (Act_Decl_Id)
+or else (Is_Subprogram (Act_Decl_Id)
+and then Is_Nested (Act_Decl_Id))
+then
+Called_Pending_Instantiations.Append (Index);
+Set_Is_Called (Act_Decl_Id);
+end if;
+end if;
+end Add_Pending_Instantiation;
 ------------------------
 -- Add_Scope_To_Clean --
 ------------------------
 function Can_Be_Inlined_In_GNATprove_Mode
 (Spec_Id : Entity_Id;
 Body_Id : Entity_Id) return Boolean
 is
+function Has_Formal_Or_Result_Of_Deep_Type
+(Id : Entity_Id) return Boolean;
+--  Returns true if the subprogram has at least one formal parameter or
+--  a return type of a deep type: either an access type or a composite
+--  type containing an access type.
 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.
 --  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.
+function Maybe_Traversal_Function (Id : Entity_Id) return Boolean;
+--  Return True if subprogram Id could be a traversal function, as
+--  defined in SPARK RM 3.10. This is only a safe approximation, as the
+--  knowledge of the SPARK boundary is needed to determine exactly
+--  traversal functions.
+---------------------------------------
+-- Has_Formal_Or_Result_Of_Deep_Type --
+---------------------------------------
+function Has_Formal_Or_Result_Of_Deep_Type
+(Id : Entity_Id) return Boolean
+is
+function Is_Deep (Typ : Entity_Id) return Boolean;
+--  Return True if Typ is deep: either an access type or a composite
+--  type containing an access type.
+-------------
+-- Is_Deep --
+-------------
+function Is_Deep (Typ : Entity_Id) return Boolean is
+begin
+case Type_Kind'(Ekind (Typ)) is
+when Access_Kind =>
+return True;
+when E_Array_Type
+| E_Array_Subtype
+=>
+return Is_Deep (Component_Type (Typ));
+when Record_Kind =>
+declare
+Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
+begin
+while Present (Comp) loop
+if Is_Deep (Etype (Comp)) then
+return True;
+end if;
+Next_Component_Or_Discriminant (Comp);
+end loop;
+end;
+return False;
+when Scalar_Kind
+| E_String_Literal_Subtype
+| Concurrent_Kind
+| Incomplete_Kind
+| E_Exception_Type
+| E_Subprogram_Type
+=>
+return False;
+when E_Private_Type
+| E_Private_Subtype
+| E_Limited_Private_Type
+| E_Limited_Private_Subtype
+=>
+--  Conservatively consider that the type might be deep if
+--  its completion has not been seen yet.
+if No (Underlying_Type (Typ)) then
+return True;
+--  Do not peek under a private type if its completion has
+--  SPARK_Mode Off. In such a case, a deep type is considered
+--  by GNATprove to be not deep.
+elsif Present (Full_View (Typ))
+and then Present (SPARK_Pragma (Full_View (Typ)))
+and then Get_SPARK_Mode_From_Annotation
+(SPARK_Pragma (Full_View (Typ))) = Off
+then
+return False;
+--  Otherwise peek under the private type.
+else
+return Is_Deep (Underlying_Type (Typ));
+end if;
+end case;
+end Is_Deep;
+--  Local variables
+Subp_Id    : constant Entity_Id := Ultimate_Alias (Id);
+Formal     : Entity_Id;
+Formal_Typ : Entity_Id;
+--  Start of processing for Has_Formal_Or_Result_Of_Deep_Type
+begin
+--  Inspect all parameters of the subprogram looking for a formal
+--  of a deep type.
+Formal := First_Formal (Subp_Id);
+while Present (Formal) loop
+Formal_Typ := Etype (Formal);
+if Is_Deep (Formal_Typ) then
+return True;
+end if;
+Next_Formal (Formal);
+end loop;
+--  Check whether this is a function whose return type is deep
+if Ekind (Subp_Id) = E_Function
+and then Is_Deep (Etype (Subp_Id))
+then
+return True;
+end if;
+return False;
+end Has_Formal_Or_Result_Of_Deep_Type;
 ---------------------------------------------------
 -- Has_Formal_With_Discriminant_Dependent_Fields --
 ---------------------------------------------------
 end if;
 return Nkind (Parent (Decl)) = N_Compilation_Unit;
 end Is_Unit_Subprogram;
+------------------------------
+-- Maybe_Traversal_Function --
+------------------------------
+function Maybe_Traversal_Function (Id : Entity_Id) return Boolean is
+begin
+return Ekind (Id) = E_Function
+--  Only traversal functions return an anonymous access-to-object
+--  type in SPARK.
+and then Is_Anonymous_Access_Type (Etype (Id));
+end Maybe_Traversal_Function;
 --  Local declarations
 Id : Entity_Id;
 --  Procedure or function entity for the subprogram
 --  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 dispatching operations, as only their static calls
+--  can be analyzed in context, and not their dispatching calls.
+elsif Is_Dispatching_Operation (Id) then
 return False;
 --  Do not inline subprograms marked No_Return, possibly used for
 --  signaling errors, which GNATprove handles specially.
 --  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;
+--  Do not inline subprograms with a formal parameter or return type of
+--  a deep type, as in that case inlining might generate code that
+--  violates borrow-checking rules of SPARK 3.10 even if the original
+--  code did not.
+elsif Has_Formal_Or_Result_Of_Deep_Type (Id) then
+return False;
+--  Do not inline subprograms which may be traversal functions. Such
+--  inlining introduces temporary variables of named access type for
+--  which assignments are move instead of borrow/observe, possibly
+--  leading to spurious errors when checking SPARK rules related to
+--  pointer usage.
+elsif Maybe_Traversal_Function (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.
 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.
+procedure Build_Return_Object_Formal
+(Loc      : Source_Ptr;
+Obj_Decl : Node_Id;
+Formals  : List_Id);
+--  Create a formal parameter for return object declaration Obj_Decl of
+--  an extended return statement and add it to list Formals.
 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
 --  Return true if we generate code for the function body N, the function
 --  body N has no local declarations and its unique statement is a single
 --  extended return statement with a handled statements sequence.
+procedure Copy_Formals
+(Loc     : Source_Ptr;
+Subp_Id : Entity_Id;
+Formals : List_Id);
+--  Create new formal parameters from the formal parameters of subprogram
+--  Subp_Id and add them to list Formals.
+function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id;
+--  Create a copy of return object declaration Obj_Decl of an extended
+--  return statement.
 procedure Split_Unconstrained_Function
 (N       : Node_Id;
 Spec_Id : Entity_Id);
 --  N is an inlined function body that returns an unconstrained type and
 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.
+--  pragmas). A new internal name is associated with Body_To_Inline.
 ------------------------------
 -- Generate_Subprogram_Body --
 ------------------------------
 and then Scope (Current_Scope) /= Standard_Standard
 then
 Body_To_Inline :=
 Copy_Generic_Node (N, Empty, Instantiating => True);
 else
+--  ??? Shouldn't this use New_Copy_Tree? What about global
+--  references captured in the body to inline?
 Body_To_Inline := Copy_Separate_Tree (N);
 end if;
 --  Remove aspects/pragmas that have no meaning in an inlined body
 Decl            : constant Node_Id := Unit_Declaration_Node (Spec_Id);
 Original_Body   : Node_Id;
 Body_To_Analyze : Node_Id;
+--  Start of processing for Build_Body_To_Inline
 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
 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;
+--------------------------------
+-- Build_Return_Object_Formal --
+--------------------------------
+procedure Build_Return_Object_Formal
+(Loc      : Source_Ptr;
+Obj_Decl : Node_Id;
+Formals  : List_Id)
+is
+Obj_Def : constant Node_Id   := Object_Definition (Obj_Decl);
+Obj_Id  : constant Entity_Id := Defining_Entity   (Obj_Decl);
+Typ_Def : Node_Id;
+begin
+--  Build the type definition of the formal parameter. The use of
+--  New_Copy_Tree ensures that global references preserved in the
+--  case of generics.
+if Is_Entity_Name (Obj_Def) then
+Typ_Def := New_Copy_Tree (Obj_Def);
+else
+Typ_Def := New_Copy_Tree (Subtype_Mark (Obj_Def));
+end if;
+--  Generate:
+--
+--    Obj_Id : [out] Typ_Def
+--  Mode OUT should not be used when the return object is declared as
+--  a constant. Check the definition of the object declaration because
+--  the object has not been analyzed yet.
+Append_To (Formals,
+Make_Parameter_Specification (Loc,
+Defining_Identifier    =>
+Make_Defining_Identifier (Loc, Chars (Obj_Id)),
+In_Present             => False,
+Out_Present            => not Constant_Present (Obj_Decl),
+Null_Exclusion_Present => False,
+Parameter_Type         => Typ_Def));
+end Build_Return_Object_Formal;
 --------------------------------------
 -- Can_Split_Unconstrained_Function --
 --------------------------------------
 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is
-Ret_Node : constant Node_Id :=
+Stmt : constant Node_Id :=
 First (Statements (Handled_Statement_Sequence (N)));
-D : Node_Id;
+Decl : Node_Id;
 begin
 --  No user defined declarations allowed in the function except inside
 --  the unique return statement; implicit labels are the only allowed
 --  declarations.
-if not Is_Empty_List (Declarations (N)) then
+Decl := First (Declarations (N));
-D := First (Declarations (N));
+while Present (Decl) loop
-while Present (D) loop
+if Nkind (Decl) /= N_Implicit_Label_Declaration then
-if Nkind (D) /= N_Implicit_Label_Declaration then
+return False;
-return False;
+end if;
-end if;
+Next (Decl);
-Next (D);
+end loop;
-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 Present (Stmt)
-and then Nkind (Ret_Node) = N_Extended_Return_Statement
+and then Nkind (Stmt) = N_Extended_Return_Statement
-and then No (Next (Ret_Node))
+and then No (Next (Stmt))
-and then Present (Handled_Statement_Sequence (Ret_Node));
+and then Present (Handled_Statement_Sequence (Stmt));
 end Can_Split_Unconstrained_Function;
+------------------
+-- Copy_Formals --
+------------------
+procedure Copy_Formals
+(Loc     : Source_Ptr;
+Subp_Id : Entity_Id;
+Formals : List_Id)
+is
+Formal : Entity_Id;
+Spec   : Node_Id;
+begin
+Formal := First_Formal (Subp_Id);
+while Present (Formal) loop
+Spec := Parent (Formal);
+--  Create an exact copy of the formal parameter. The use of
+--  New_Copy_Tree ensures that global references are preserved
+--  in case of generics.
+Append_To (Formals,
+Make_Parameter_Specification (Loc,
+Defining_Identifier    =>
+Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
+In_Present             => In_Present  (Spec),
+Out_Present            => Out_Present (Spec),
+Null_Exclusion_Present => Null_Exclusion_Present (Spec),
+Parameter_Type         =>
+New_Copy_Tree (Parameter_Type (Spec)),
+Expression             => New_Copy_Tree (Expression (Spec))));
+Next_Formal (Formal);
+end loop;
+end Copy_Formals;
+------------------------
+-- Copy_Return_Object --
+------------------------
+function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id is
+Obj_Id  : constant Entity_Id := Defining_Entity (Obj_Decl);
+begin
+--  The use of New_Copy_Tree ensures that global references are
+--  preserved in case of generics.
+return
+Make_Object_Declaration (Sloc (Obj_Decl),
+Defining_Identifier    =>
+Make_Defining_Identifier (Sloc (Obj_Id), Chars (Obj_Id)),
+Aliased_Present        => Aliased_Present  (Obj_Decl),
+Constant_Present       => Constant_Present (Obj_Decl),
+Null_Exclusion_Present => Null_Exclusion_Present (Obj_Decl),
+Object_Definition      =>
+New_Copy_Tree (Object_Definition (Obj_Decl)),
+Expression             => New_Copy_Tree (Expression (Obj_Decl)));
+end Copy_Return_Object;
 ----------------------------------
 -- Split_Unconstrained_Function --
 ----------------------------------
 procedure Split_Unconstrained_Function
 (N        : Node_Id;
 Spec_Id  : Entity_Id)
 is
 Loc      : constant Source_Ptr := Sloc (N);
-Ret_Node : constant Node_Id :=
+Ret_Stmt : constant Node_Id :=
 First (Statements (Handled_Statement_Sequence (N)));
 Ret_Obj  : constant Node_Id :=
-First (Return_Object_Declarations (Ret_Node));
+First (Return_Object_Declarations (Ret_Stmt));
 procedure Build_Procedure
 (Proc_Id   : out Entity_Id;
 Decl_List : out List_Id);
 --  Build a procedure containing the statements found in the extended
 procedure Build_Procedure
 (Proc_Id   : out Entity_Id;
 Decl_List : out List_Id)
 is
-Formal         : Entity_Id;
+Formals   : constant List_Id   := New_List;
-Formal_List    : constant List_Id := New_List;
+Subp_Name : constant Name_Id   := New_Internal_Name ('F');
-Proc_Spec      : Node_Id;
-Proc_Body      : Node_Id;
+Body_Decls : List_Id := No_List;
-Subp_Name      : constant Name_Id := New_Internal_Name ('F');
+Decl       : Node_Id;
-Body_Decl_List : List_Id := No_List;
+Proc_Body  : Node_Id;
-Param_Type     : Node_Id;
+Proc_Spec  : Node_Id;
 begin
-if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then
+--  Create formal parameters for the return object and all formals
-Param_Type :=
+--  of the unconstrained function in order to pass their values to
-New_Copy (Object_Definition (Ret_Obj));
+--  the procedure.
-else
-Param_Type :=
+Build_Return_Object_Formal
-New_Copy (Subtype_Mark (Object_Definition (Ret_Obj)));
+(Loc      => Loc,
-end if;
+Obj_Decl => Ret_Obj,
+Formals  => Formals);
-Append_To (Formal_List,
-Make_Parameter_Specification (Loc,
+Copy_Formals
-Defining_Identifier    =>
+(Loc     => Loc,
-Make_Defining_Identifier (Loc,
+Subp_Id => Spec_Id,
-Chars => Chars (Defining_Identifier (Ret_Obj))),
+Formals => Formals);
-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);
+Parameter_Specifications => Formals);
 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;
+Body_Decls := New_List;
-declare
+Decl := First (Declarations (N));
-D     : Node_Id;
+while Present (Decl) loop
-New_D : Node_Id;
+pragma Assert (Nkind (Decl) = N_Implicit_Label_Declaration);
-begin
+Append_To (Body_Decls,
-D := First (Declarations (N));
+Make_Implicit_Label_Declaration (Loc,
-while Present (D) loop
+Make_Defining_Identifier (Loc,
-pragma Assert (Nkind (D) = N_Implicit_Label_Declaration);
+Chars => Chars (Defining_Identifier (Decl))),
+Label_Construct => Empty));
-New_D :=
-Make_Implicit_Label_Declaration (Loc,
+Next (Decl);
-Make_Defining_Identifier (Loc,
+end loop;
-Chars => Chars (Defining_Identifier (D))),
+end if;
-Label_Construct => Empty);
-Append_To (Body_Decl_List, New_D);
+pragma Assert (Present (Handled_Statement_Sequence (Ret_Stmt)));
-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),
+Specification              => Copy_Subprogram_Spec (Proc_Spec),
-Declarations  => Body_Decl_List,
+Declarations               => Body_Decls,
 Handled_Statement_Sequence =>
-Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node)));
+New_Copy_Tree (Handled_Statement_Sequence (Ret_Stmt)));
 Set_Defining_Unit_Name (Specification (Proc_Body),
 Make_Defining_Identifier (Loc, Subp_Name));
 Append_To (Decl_List, Proc_Body);
 end Build_Procedure;
 --  Local variables
-New_Obj   : constant Node_Id := Copy_Separate_Tree (Ret_Obj);
+New_Obj   : constant Node_Id := Copy_Return_Object (Ret_Obj);
 Blk_Stmt  : Node_Id;
+Proc_Call : 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
 Make_Simple_Return_Statement (Loc,
 Expression =>
 New_Occurrence_Of
 (Defining_Identifier (New_Obj), Loc)))));
-Rewrite (Ret_Node, Blk_Stmt);
+Rewrite (Ret_Stmt, Blk_Stmt);
 end Split_Unconstrained_Function;
 --  Local variables
 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
 --  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;
+--  Do not generate a body to inline for protected functions, because the
+--  transformation generates a call to a protected procedure, causing
+--  spurious errors. We don't inline protected operations anyway, so
+--  this is no loss. We might as well ignore intrinsics and foreign
+--  conventions as well -- just allow Ada conventions.
+elsif not (Convention (Spec_Id) = Convention_Ada
+or else Convention (Spec_Id) = Convention_Ada_Pass_By_Copy
+or else Convention (Spec_Id) = Convention_Ada_Pass_By_Reference)
+then
 return;
 --  Check excluded declarations
 elsif Present (Declarations (N))
 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.
+procedure Make_Loop_Labels_Unique (HSS : Node_Id);
+--  When compiling for CCG and performing front-end inlining, replace
+--  loop names and references to them so that they do not conflict with
+--  homographs in the current subprogram.
 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_Formals_In_Aspects (N : Node_Id) return Traverse_Result;
+--  Because aspects are linked indirectly to the rest of the tree,
+--  replacement of formals appearing in aspect specifications must
+--  be performed in a separate pass, using an instantiation of the
+--  previous subprogram over aspect specifications reachable from N.
 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
 Defining_Identifier => Lab_Ent,
 Label_Construct     => Exit_Lab);
 end if;
 end Make_Exit_Label;
+-----------------------------
+-- Make_Loop_Labels_Unique --
+-----------------------------
+procedure Make_Loop_Labels_Unique (HSS : Node_Id) is
+function Process_Loop (N : Node_Id) return Traverse_Result;
+------------------
+-- Process_Loop --
+------------------
+function Process_Loop (N : Node_Id) return Traverse_Result is
+Id  : Entity_Id;
+begin
+if Nkind (N) = N_Loop_Statement
+and then Present (Identifier (N))
+then
+--  Create new external name for loop and update the
+--  corresponding entity.
+Id := Entity (Identifier (N));
+Set_Chars (Id, New_External_Name (Chars (Id), 'L', -1));
+Set_Chars (Identifier (N), Chars (Id));
+elsif Nkind (N) = N_Exit_Statement
+and then Present (Name (N))
+then
+--  The exit statement must name an enclosing loop, whose name
+--  has already been updated.
+Set_Chars (Name (N), Chars (Entity (Name (N))));
+end if;
+return OK;
+end Process_Loop;
+procedure Update_Loop_Names is new Traverse_Proc (Process_Loop);
+--  Local variables
+Stmt : Node_Id;
+--  Start of processing for Make_Loop_Labels_Unique
+begin
+if Modify_Tree_For_C then
+Stmt := First (Statements (HSS));
+while Present (Stmt) loop
+Update_Loop_Names (Stmt);
+Next (Stmt);
+end loop;
+end if;
+end Make_Loop_Labels_Unique;
 ---------------------
 -- Process_Formals --
 ---------------------
 function Process_Formals (N : Node_Id) return Traverse_Result is
 end if;
 end Process_Formals;
 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
+--------------------------------
+-- Process_Formals_In_Aspects --
+--------------------------------
+function Process_Formals_In_Aspects
+(N : Node_Id) return Traverse_Result
+is
+A : Node_Id;
+begin
+if Has_Aspects (N) then
+A := First (Aspect_Specifications (N));
+while Present (A) loop
+Replace_Formals (Expression (A));
+Next (A);
+end loop;
+end if;
+return OK;
+end Process_Formals_In_Aspects;
+procedure Replace_Formals_In_Aspects is
+new Traverse_Proc (Process_Formals_In_Aspects);
 ------------------
 -- Process_Sloc --
 ------------------
 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
 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
+Make_Loop_Labels_Unique (HSS);
 --  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
 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
 HSS  : constant Node_Id := Handled_Statement_Sequence (Blk);
 begin
+Make_Loop_Labels_Unique (HSS);
 --  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.
 --  Traverse the tree and replace formals with actuals or their thunks.
 --  Attach block to tree before analysis and rewriting.
 Replace_Formals (Blk);
+Replace_Formals_In_Aspects (Blk);
 Set_Parent (Blk, N);
 if GNATprove_Mode then
 null;
 -- Initialize --
 ----------------
 procedure Initialize is
 begin
-Pending_Descriptor.Init;
 Pending_Instantiations.Init;
+Called_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_Instances := No_Elist;
 Backend_Inlined_Subps := No_Elist;
 Backend_Not_Inlined_Subps := No_Elist;
 end Initialize;
 ------------------------
 --  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;
+procedure Instantiate_Body (Info : Pending_Body_Info);
+--  Instantiate a pending body
+------------------------
+--  Instantiate_Body  --
+------------------------
+procedure Instantiate_Body (Info : Pending_Body_Info) is
+begin
+--  If the instantiation node is absent, it has been removed as part
+--  of unreachable code.
+if No (Info.Inst_Node) then
+null;
+--  If the instantiation node is a package body, this means that the
+--  instance is a compilation unit and the instantiation has already
+--  been performed by Build_Instance_Compilation_Unit_Nodes.
+elsif Nkind (Info.Inst_Node) = N_Package_Body 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;
+end Instantiate_Body;
+J, K  : Nat;
 Info : Pending_Body_Info;
+--  Start of processing for Instantiate_Bodies
 begin
 if Serious_Errors_Detected = 0 then
 Expander_Active := (Operating_Mode = Opt.Generate_Code);
 Push_Scope (Standard_Standard);
 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).
+--  set (that's why we cannot simply use a FOR loop here). We must
+--  also capture the element lest the set be entirely reallocated.
 J := 0;
-while J <= Pending_Instantiations.Last
+if Back_End_Inlining then
-and then Serious_Errors_Detected = 0
+while J <= Called_Pending_Instantiations.Last
-loop
+and then Serious_Errors_Detected = 0
-Info := Pending_Instantiations.Table (J);
+loop
+K := Called_Pending_Instantiations.Table (J);
---  If the instantiation node is absent, it has been removed
+Info := Pending_Instantiations.Table (K);
---  as part of unreachable code.
+Instantiate_Body (Info);
-if No (Info.Inst_Node) then
+J := J + 1;
-null;
+end loop;
-elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
+else
-Instantiate_Package_Body (Info);
+while J <= Pending_Instantiations.Last
-Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
+and then Serious_Errors_Detected = 0
+loop
-else
+Info := Pending_Instantiations.Table (J);
-Instantiate_Subprogram_Body (Info);
+Instantiate_Body (Info);
-end if;
+J := J + 1;
-J := J + 1;
+end loop;
-end loop;
+end if;
 --  Reset the table of instantiations. Additional instantiations
 --  may be added through inlining, when additional bodies are
 --  analyzed.
-Pending_Instantiations.Init;
+if Back_End_Inlining then
+Called_Pending_Instantiations.Init;
+else
+Pending_Instantiations.Init;
+end if;
 --  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).
 Scop : Entity_Id;
 begin
 Scop := Scope (E);
 while Scop /= Standard_Standard loop
-if Ekind (Scop) in Subprogram_Kind then
+if Is_Subprogram (Scop) then
 return True;
 elsif Ekind (Scop) = E_Task_Type
 or else Ekind (Scop) = E_Entry
 or else Ekind (Scop) = E_Entry_Family
 Count := 0;
 Elmt  := First_Elmt (Inlined_Calls);
 while Present (Elmt) loop
 Nod := Node (Elmt);
-if In_Extended_Main_Code_Unit (Nod) then
+if not In_Internal_Unit (Nod) then
 Count := Count + 1;
 if Count = 1 then
 Write_Str ("List of calls inlined by the frontend");
 Write_Eol;
 Elmt := First_Elmt (Backend_Calls);
 while Present (Elmt) loop
 Nod := Node (Elmt);
-if In_Extended_Main_Code_Unit (Nod) then
+if not In_Internal_Unit (Nod) then
 Count := Count + 1;
 if Count = 1 then
 Write_Str ("List of inlined calls passed to the backend");
 Write_Eol;
 Next_Elmt (Elmt);
 end loop;
 end if;
+--  Generate listing of instances inlined for the backend
+if Present (Backend_Instances) then
+Count := 0;
+Elmt := First_Elmt (Backend_Instances);
+while Present (Elmt) loop
+Nod := Node (Elmt);
+if not In_Internal_Unit (Nod) then
+Count := Count + 1;
+if Count = 1 then
+Write_Str ("List of instances inlined for 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 not In_Internal_Unit (Nod) then
+Count := Count + 1;
-if Count = 1 then
-Write_Str
+if Count = 1 then
-("List of inlined subprograms passed to the backend");
+Write_Str
-Write_Eol;
+("List of inlined subprograms passed to the backend");
-end if;
+Write_Eol;
+end if;
-Write_Str ("  ");
-Write_Int (Count);
+Write_Str ("  ");
-Write_Str (":");
+Write_Int (Count);
-Write_Name (Chars (Nod));
+Write_Str (":");
-Write_Str (" (");
+Write_Name (Chars (Nod));
-Write_Location (Sloc (Nod));
+Write_Str (" (");
-Write_Str (")");
+Write_Location (Sloc (Nod));
-Output.Write_Eol;
+Write_Str (")");
+Output.Write_Eol;
+end if;
 Next_Elmt (Elmt);
 end loop;
 end if;
 Elmt := First_Elmt (Backend_Not_Inlined_Subps);
 while Present (Elmt) loop
 Nod := Node (Elmt);
-Count := Count + 1;
+if not In_Internal_Unit (Nod) then
+Count := Count + 1;
-if Count = 1 then
-Write_Str
+if Count = 1 then
-("List of subprograms that cannot be inlined by the backend");
+Write_Str
-Write_Eol;
+("List of subprograms that cannot be inlined by backend");
-end if;
+Write_Eol;
+end if;
-Write_Str ("  ");
-Write_Int (Count);
+Write_Str ("  ");
-Write_Str (":");
+Write_Int (Count);
-Write_Name (Chars (Nod));
+Write_Str (":");
-Write_Str (" (");
+Write_Name (Chars (Nod));
-Write_Location (Sloc (Nod));
+Write_Str (" (");
-Write_Str (")");
+Write_Location (Sloc (Nod));
-Output.Write_Eol;
+Write_Str (")");
+Output.Write_Eol;
+end if;
 Next_Elmt (Elmt);
 end loop;
 end if;
 end List_Inlining_Info;
 procedure Lock is
 begin
 Pending_Instantiations.Release;
 Pending_Instantiations.Locked := True;
+Called_Pending_Instantiations.Release;
+Called_Pending_Instantiations.Locked := True;
 Inlined_Bodies.Release;
 Inlined_Bodies.Locked := True;
 Successors.Release;
 Successors.Locked := True;
 Inlined.Release;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/inline.adb @ 145:1830386684a0