-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, 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- --
-- --
------------------------------------------------------------------------------
+with Alloc;
with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
-with Uname; use Uname;
+with Table;
with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Uname; use Uname;
+
+with GNAT.HTable;
package body Inline is
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 --
--------------------
-- 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 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
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.
+ -- However, we can handle such functions if all return statements return
+ -- a local variable that is the first 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
-- Inline_Package means that the call is considered for inlining and
-- its package compiled and scanned for more inlining opportunities.
+ function Is_Non_Loading_Expression_Function
+ (Id : Entity_Id) return Boolean;
+ -- Determine whether arbitrary entity Id denotes a subprogram which is
+ -- either
+ --
+ -- * An expression function
+ --
+ -- * A function completed by an expression function where both the
+ -- spec and body are in the same context.
+
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.
+ ----------------------------------------
+ -- Is_Non_Loading_Expression_Function --
+ ----------------------------------------
+
+ function Is_Non_Loading_Expression_Function
+ (Id : Entity_Id) return Boolean
+ is
+ Body_Decl : Node_Id;
+ Body_Id : Entity_Id;
+ Spec_Decl : Node_Id;
+
+ begin
+ -- A stand-alone expression function is transformed into a spec-body
+ -- pair in-place. Since both the spec and body are in the same list,
+ -- the inlining of such an expression function does not need to load
+ -- anything extra.
+
+ if Is_Expression_Function (Id) then
+ return True;
+
+ -- A function may be completed by an expression function
+
+ elsif Ekind (Id) = E_Function then
+ Spec_Decl := Unit_Declaration_Node (Id);
+
+ if Nkind (Spec_Decl) = N_Subprogram_Declaration then
+ Body_Id := Corresponding_Body (Spec_Decl);
+
+ if Present (Body_Id) then
+ Body_Decl := Unit_Declaration_Node (Body_Id);
+
+ -- The inlining of a completing expression function does
+ -- not need to load anything extra when both the spec and
+ -- body are in the same context.
+
+ return
+ Was_Expression_Function (Body_Decl)
+ and then Parent (Spec_Decl) = Parent (Body_Decl);
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Is_Non_Loading_Expression_Function;
+
-----------------
-- Must_Inline --
-----------------
return Dont_Inline;
end Must_Inline;
- Level : Inline_Level_Type;
+ Inst : Entity_Id;
+ Inst_Decl : Node_Id;
+ Inst_Node : 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;
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
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 the subprogram is an expression function, or is completed by one
+ -- 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_Expression_Function (E) then
- Set_Is_Called (E);
+ if Is_Non_Loading_Expression_Function (E) then
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.
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);
+ else
+ 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
+ -- Do not add a pending instantiation if the body exits
+ -- already, or if the instance is a compilation unit, or
+ -- the instance node is missing.
+
+ Inst_Decl := Unit_Declaration_Node (Inst);
+ if Present (Corresponding_Body (Inst_Decl))
+ or else Nkind (Parent (Inst_Decl)) = N_Compilation_Unit
+ or else No (Next (Inst_Decl))
+ then
+ Set_Is_Called (Inst);
+
+ else
+ -- If the inlined call itself appears within an instance,
+ -- ensure that the enclosing instance body is available.
+ -- This is necessary because Sem_Ch12.Might_Inline_Subp
+ -- does not recurse into nested instantiations.
+
+ if not Is_Inlined (Inst) and then In_Instance then
+ Set_Is_Inlined (Inst);
+
+ -- The instantiation node usually follows the package
+ -- declaration for the instance. If the generic unit
+ -- has aspect specifications, they are transformed
+ -- into pragmas in the instance, and the instance node
+ -- appears after them.
+
+ Inst_Node := Next (Inst_Decl);
+
+ while Nkind (Inst_Node) /= N_Package_Instantiation loop
+ Inst_Node := Next (Inst_Node);
+ end loop;
+
+ Add_Pending_Instantiation (Inst_Node, Inst_Decl);
+ end if;
+
+ Add_Inlined_Instance (Inst);
+ end if;
+ end if;
+ end if;
+
+ -- If the unit containing E is an instance, then the instance body
+ -- will be analyzed in any case, see Sem_Ch12.Might_Inline_Subp.
if Is_Generic_Instance (Pack) then
null;
-- 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.
+ -- Note that Level is in Inline_Call | Inline_Packag here.
elsif ((Level = Inline_Call
and then Has_Pragma_Inline_Always (E)
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 --
----------------------------
-- 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)
+ -- We can inline the subprogram 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 it does not declare types with
+ -- nontrivial initialization procedures.
+
+ if (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 Has_Initialized_Type (E)
then
Register_Backend_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 >= 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 either a compilation unit or is in the main
+ -- unit or subunit or is a nested subprogram, then its body is needed
+ -- as per the analysis already done in Analyze_Package_Instantiation
+ -- and Analyze_Subprogram_Instantiation.
+
+ if Nkind (Parent (Inst)) = N_Compilation_Unit
+ or else 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 --
------------------------
Body_To_Analyze : Node_Id;
Max_Size : constant := 10;
+ function Has_Extended_Return return Boolean;
+ -- This function returns True if the subprogram has an extended return
+ -- statement.
+
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
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.
+ -- unconstrained type, the secondary stack is involved, and it is
+ -- not worth inlining.
+
+ -------------------------
+ -- Has_Extended_Return --
+ -------------------------
+
+ function Has_Extended_Return return Boolean is
+ Body_To_Inline : constant Node_Id := N;
+
+ function Check_Return (N : Node_Id) return Traverse_Result;
+ -- Returns OK on node N if this is not an extended return statement
+
+ ------------------
+ -- Check_Return --
+ ------------------
+
+ function Check_Return (N : Node_Id) return Traverse_Result is
+ begin
+ case Nkind (N) is
+ when N_Extended_Return_Statement =>
+ return Abandon;
+
+ -- 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_Extended_Return
+
+ begin
+ return Check_All_Returns (N) /= OK;
+ end Has_Extended_Return;
-------------------------------
-- Has_Pending_Instantiation --
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.
+ -- Functions that return controlled types cannot currently be inlined
+ -- because they require secondary stack handling; controlled actions
+ -- may also interfere in complex ways with inlining.
elsif Ekind (Spec_Id) = E_Function
and then Needs_Finalization (Etype (Spec_Id))
-- 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
+ -- 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, True);
+ Original_Body := Copy_Generic_Node (N, Empty, Instantiating => True);
else
Original_Body := Copy_Separate_Tree (N);
end if;
Remove_Aspects_And_Pragmas (Original_Body);
- Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
+ 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.
Append (Body_To_Analyze, Declarations (N));
end if;
- -- The body to inline is pre-analyzed. In GNATprove mode we must disable
+ -- The body to inline is preanalyzed. In GNATprove mode we must disable
-- full analysis as well so that light expansion does not take place
-- either, and name resolution is unaffected.
Restore_Env;
end if;
+ -- 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. We had to delay this check until
+ -- the body of the function is analyzed since Has_Single_Return()
+ -- requires a minimum decoration.
+
+ if 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 (Body_To_Analyze)
+
+ -- Skip inlining if the function returns an unconstrained type
+ -- using an extended return statement, since this part of the
+ -- new inlining model is not yet supported by the current
+ -- implementation. ???
+
+ or else (Returns_Unconstrained_Type (Spec_Id)
+ and then Has_Extended_Return)
+ then
+ Cannot_Inline
+ ("cannot inline & (unconstrained return type)?", N, Spec_Id);
+ return;
+ 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
+ elsif Uses_Secondary_Stack (Body_To_Analyze) then
return;
end if;
-- types.
function Has_Some_Contract (Id : Entity_Id) return Boolean;
- -- Returns True if subprogram Id has any contract (Pre, Post, Global,
- -- Depends, etc.)
+ -- 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;
- -- Returns True if subprogram Id defines a compilation unit
+ -- Return True if subprogram Id defines a compilation unit
-- Shouldn't this be in Sem_Aux???
- function In_Package_Visible_Spec (Id : Node_Id) return Boolean;
- -- Returns True if subprogram Id is defined in the visible part of a
- -- package specification.
+ 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
-
+ (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.
+ -- Determine whether unconstrained record type Typ has at least one
+ -- component that depends on a discriminant.
------------------------------------------
-- Has_Discriminant_Dependent_Component --
Comp : Entity_Id;
begin
- -- Inspect all components of the record type looking for one
- -- that depends on a discriminant.
+ -- Inspect all components of the record type looking for one that
+ -- depends on a discriminant.
Comp := First_Component (Typ);
while Present (Comp) loop
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
return False;
end Has_Some_Contract;
- -----------------------------
- -- In_Package_Visible_Spec --
- -----------------------------
+ ---------------------
+ -- In_Package_Spec --
+ ---------------------
- function In_Package_Visible_Spec (Id : Node_Id) return Boolean is
- Decl : Node_Id := Parent (Parent (Id));
- P : Node_Id;
+ 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
- if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
- Decl := Parent (Decl);
- end if;
-
- P := Parent (Decl);
-
- return Nkind (P) = N_Package_Specification
- and then List_Containing (Decl) = Visible_Declarations (P);
- end In_Package_Visible_Spec;
+ return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
+ end In_Package_Spec;
------------------------
-- Is_Unit_Subprogram --
if Is_Unit_Subprogram (Id) then
return False;
- -- Do not inline subprograms declared in the visible part of a package
+ -- 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_Visible_Spec (Id) then
+ elsif In_Package_Spec (Id) then
return False;
-- Do not inline subprograms declared in other units. This is important
return False;
-- Do not inline subprograms that have a contract on the spec or the
- -- body. Use the contract(s) instead in GNATprove.
+ -- 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
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
pragma Assert (Msg (Msg'Last) = '?');
- -- Legacy front end inlining model
+ -- Legacy front-end inlining model
if not Back_End_Inlining then
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.
+ -- In GNATprove mode, issue a warning when -gnatd_f is set, 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);
+
+ if Debug_Flag_Underscore_F then
+ Error_Msg_NE (Msg, N, Subp);
+ end if;
elsif Has_Pragma_Inline_Always (Subp) then
Error_Msg_NE (Msg & "p?", N, Subp);
end if;
- -- New semantics relying on back end inlining
+ -- New semantics relying on back-end inlining
elsif Is_Serious then
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.
+ -- In GNATprove mode, issue a warning when -gnatd_f is set, 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);
+
+ if Debug_Flag_Underscore_F then
+ Error_Msg_NE (Msg, N, Subp);
+ end if;
else
-- 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 Generate_Subprogram_Body
- (N : Node_Id;
- Body_To_Inline : out Node_Id);
- -- Generate a parameterless duplicate of subprogram body N. 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 properly).
- -- A new internal name is associated with Body_To_Inline.
+ 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;
-- 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 return a value;
+ -- 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.
--------------------------
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_Subprogram_Body --
+ ------------------------------
+
+ 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
+ -- ??? 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
+
+ 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;
+ -- 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
-- do not do this at the library level, because it is not needed, and
- -- furthermore this causes trouble if front end inlining is activated
+ -- furthermore this causes trouble if front-end inlining is activated
-- (-gnatN).
if In_Instance
Save_Env (Scope (Current_Scope), Scope (Current_Scope));
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.
+ -- 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, False);
+ 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.
Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
end Build_Body_To_Inline;
+ --------------------------------
+ -- Build_Return_Object_Formal --
+ --------------------------------
+
+ procedure Build_Return_Object_Formal
+ (Loc : Source_Ptr;
+ Obj_Decl : Node_Id;
+ Formals : List_Id)
+ is
+ Obj_Def : constant Node_Id := Object_Definition (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
+ Typ_Def : Node_Id;
+
+ begin
+ -- Build the type definition of the formal parameter. The use of
+ -- New_Copy_Tree ensures that global references preserved in the
+ -- case of generics.
+
+ if Is_Entity_Name (Obj_Def) then
+ Typ_Def := New_Copy_Tree (Obj_Def);
+ else
+ Typ_Def := New_Copy_Tree (Subtype_Mark (Obj_Def));
+ end if;
+
+ -- Generate:
+ --
+ -- Obj_Id : [out] Typ_Def
+
+ -- Mode OUT should not be used when the return object is declared as
+ -- a constant. Check the definition of the object declaration because
+ -- the object has not been analyzed yet.
+
+ Append_To (Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars (Obj_Id)),
+ In_Present => False,
+ Out_Present => not Constant_Present (Obj_Decl),
+ Null_Exclusion_Present => False,
+ Parameter_Type => Typ_Def));
+ end Build_Return_Object_Formal;
+
--------------------------------------
-- Can_Split_Unconstrained_Function --
--------------------------------------
- function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean
- is
- Ret_Node : constant Node_Id :=
- First (Statements (Handled_Statement_Sequence (N)));
- D : Node_Id;
+ function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is
+ Stmt : constant Node_Id :=
+ First (Statements (Handled_Statement_Sequence (N)));
+ Decl : Node_Id;
begin
-- No user defined declarations allowed in the function except inside
-- the unique return statement; implicit labels are the only allowed
-- declarations.
- if not Is_Empty_List (Declarations (N)) then
- D := First (Declarations (N));
- while Present (D) loop
- if Nkind (D) /= N_Implicit_Label_Declaration then
- return False;
- end if;
+ Decl := First (Declarations (N));
+ while Present (Decl) loop
+ if Nkind (Decl) /= N_Implicit_Label_Declaration then
+ return False;
+ end if;
- Next (D);
- end loop;
- end if;
+ Next (Decl);
+ end loop;
-- We only split the inlined function when we are generating the code
-- of its body; otherwise we leave duplicated split subprograms in
-- time.
return In_Extended_Main_Code_Unit (N)
- and then Present (Ret_Node)
- and then Nkind (Ret_Node) = N_Extended_Return_Statement
- and then No (Next (Ret_Node))
- and then Present (Handled_Statement_Sequence (Ret_Node));
+ and then Present (Stmt)
+ and then Nkind (Stmt) = N_Extended_Return_Statement
+ and then No (Next (Stmt))
+ and then Present (Handled_Statement_Sequence (Stmt));
end Can_Split_Unconstrained_Function;
- -----------------------------
- -- Generate_Body_To_Inline --
- -----------------------------
+ ------------------
+ -- Copy_Formals --
+ ------------------
- procedure Generate_Subprogram_Body
- (N : Node_Id;
- Body_To_Inline : out Node_Id)
+ procedure Copy_Formals
+ (Loc : Source_Ptr;
+ Subp_Id : Entity_Id;
+ Formals : List_Id)
is
- begin
- -- 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).
+ Formal : Entity_Id;
+ Spec : Node_Id;
- if In_Instance
- and then Scope (Current_Scope) /= Standard_Standard
- then
- Body_To_Inline := Copy_Generic_Node (N, Empty, True);
- else
- Body_To_Inline := Copy_Separate_Tree (N);
- end if;
+ begin
+ Formal := First_Formal (Subp_Id);
+ while Present (Formal) loop
+ Spec := Parent (Formal);
- -- Remove all aspects/pragmas that have no meaning in an inlined body
+ -- Create an exact copy of the formal parameter. The use of
+ -- New_Copy_Tree ensures that global references are preserved
+ -- in case of generics.
- Remove_Aspects_And_Pragmas (Body_To_Inline);
+ 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))));
- -- 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.
+ Next_Formal (Formal);
+ end loop;
+ end Copy_Formals;
- Set_Parameter_Specifications
- (Specification (Body_To_Inline), No_List);
+ ------------------------
+ -- Copy_Return_Object --
+ ------------------------
- -- A new internal name is associated with Body_To_Inline to avoid
- -- conflicts when the non-inlined body N is analyzed.
+ function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id is
+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
- 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;
+ 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 --
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;
(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;
+ Formals : constant List_Id := New_List;
+ Subp_Name : constant Name_Id := New_Internal_Name ('F');
- 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));
+ Body_Decls : List_Id := No_List;
+ Decl : Node_Id;
+ Proc_Body : Node_Id;
+ Proc_Spec : Node_Id;
- Formal := First_Formal (Spec_Id);
+ begin
+ -- Create formal parameters for the return object and all formals
+ -- of the unconstrained function in order to pass their values to
+ -- the procedure.
- -- 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.
+ Build_Return_Object_Formal
+ (Loc => Loc,
+ Obj_Decl => Ret_Obj,
+ Formals => Formals);
- 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;
+ Copy_Formals
+ (Loc => Loc,
+ Subp_Id => Spec_Id,
+ Formals => Formals);
Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name);
Proc_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
- Parameter_Specifications => Formal_List);
+ Parameter_Specifications => Formals);
Decl_List := New_List;
-- Copy these declarations to the built procedure.
if Present (Declarations (N)) then
- Body_Decl_List := New_List;
+ Body_Decls := New_List;
- declare
- D : Node_Id;
- New_D : Node_Id;
+ Decl := First (Declarations (N));
+ while Present (Decl) loop
+ pragma Assert (Nkind (Decl) = N_Implicit_Label_Declaration);
- begin
- D := First (Declarations (N));
- while Present (D) loop
- pragma Assert (Nkind (D) = N_Implicit_Label_Declaration);
-
- New_D :=
- Make_Implicit_Label_Declaration (Loc,
- Make_Defining_Identifier (Loc,
- Chars => Chars (Defining_Identifier (D))),
- Label_Construct => Empty);
- Append_To (Body_Decl_List, New_D);
-
- Next (D);
- end loop;
- end;
+ Append_To (Body_Decls,
+ Make_Implicit_Label_Declaration (Loc,
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Decl))),
+ Label_Construct => Empty));
+
+ Next (Decl);
+ end loop;
end if;
- pragma Assert (Present (Handled_Statement_Sequence (Ret_Node)));
+ pragma Assert (Present (Handled_Statement_Sequence (Ret_Stmt)));
Proc_Body :=
Make_Subprogram_Body (Loc,
- Specification => Copy_Separate_Tree (Proc_Spec),
- Declarations => Body_Decl_List,
+ Specification => Copy_Subprogram_Spec (Proc_Spec),
+ Declarations => Body_Decls,
Handled_Statement_Sequence =>
- Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node)));
+ New_Copy_Tree (Handled_Statement_Sequence (Ret_Stmt)));
Set_Defining_Unit_Name (Specification (Proc_Body),
Make_Defining_Identifier (Loc, Subp_Name));
-- Local variables
- New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj);
+ New_Obj : constant Node_Id := Copy_Return_Object (Ret_Obj);
Blk_Stmt : Node_Id;
- Proc_Id : Entity_Id;
Proc_Call : Node_Id;
+ Proc_Id : Entity_Id;
-- Start of processing for Split_Unconstrained_Function
Pop_Scope;
Build_Procedure (Proc_Id, Decl_List);
Insert_Actions (N, Decl_List);
+ Set_Is_Inlined (Proc_Id);
Push_Scope (Scope);
end;
Parameter_Associations => Actual_List);
end;
- -- Generate
+ -- Generate:
-- declare
-- New_Obj : ...
-- begin
- -- main_1__F1b (New_Obj, ...);
- -- return Obj;
- -- end B10b;
+ -- Proc (New_Obj, ...);
+ -- return New_Obj;
+ -- end;
Blk_Stmt :=
Make_Block_Statement (Loc,
New_Occurrence_Of
(Defining_Identifier (New_Obj), Loc)))));
- Rewrite (Ret_Node, Blk_Stmt);
+ Rewrite (Ret_Stmt, Blk_Stmt);
end Split_Unconstrained_Function;
-- Local variables
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))
Subp : Entity_Id;
Orig_Subp : Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (N);
- Is_Predef : constant Boolean :=
+ Decls : constant List_Id := New_List;
+ Is_Predef : constant Boolean :=
Is_Predefined_Unit (Get_Source_Unit (Subp));
- Orig_Bod : constant Node_Id :=
+ Loc : constant Source_Ptr := Sloc (N);
+ Orig_Bod : constant Node_Id :=
Body_To_Inline (Unit_Declaration_Node (Subp));
+ Uses_Back_End : constant Boolean :=
+ Back_End_Inlining and then Optimization_Level > 0;
+ -- The back-end expansion is used if the target supports back-end
+ -- inlining and some level of optimixation is required; otherwise
+ -- the inlining takes place fully as a tree expansion.
+
Blk : Node_Id;
Decl : Node_Id;
- Decls : constant List_Id := New_List;
- Exit_Lab : Entity_Id := Empty;
+ Exit_Lab : Entity_Id := Empty;
F : Entity_Id;
A : Node_Id;
- Lab_Decl : Node_Id;
+ Lab_Decl : Node_Id := Empty;
Lab_Id : Node_Id;
New_A : Node_Id;
- Num_Ret : Nat := 0;
+ 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.
+ Return_Object : Entity_Id := Empty;
+ -- Entity in declaration in an extended_return_statement
+
+ Targ : Node_Id := Empty;
+ -- 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
+
procedure Declare_Postconditions_Result;
-- When generating C code, declare _Result, which may be used in the
-- inlined _Postconditions procedure to verify the return value.
-- 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
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 --
---------------------
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
+ -- expression and the context may be different, so place
+ -- a type 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)
+ -- legal argument of a conversion. Ditto for numeric, character
+ -- and string 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_Character_Literal,
+ N_Null,
+ N_String_Literal)
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
+
+ -- Use an unchecked type conversion between access types, for
+ -- which a type conversion would not always be valid, as no
+ -- check may result from the conversion.
+
+ elsif Is_Access_Type (Ret_Type) then
Ret :=
Unchecked_Convert_To
(Ret_Type, Relocate_Node (Expression (N)));
+
+ -- Otherwise use a type conversion, which may trigger a check
+
+ else
+ Ret :=
+ Make_Type_Conversion (Sloc (N),
+ Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
+ Expression => Relocate_Node (Expression (N)));
end if;
if Nkind (Targ) = N_Defining_Identifier then
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 --
------------------
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.
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
begin
-- Initializations for old/new semantics
- if not Back_End_Inlining then
+ if not Uses_Back_End then
Is_Unc := Is_Array_Type (Etype (Subp))
and then not Is_Constrained (Etype (Subp));
Is_Unc_Decl := False;
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
-- Old semantics
- if not Back_End_Inlining then
+ if not Uses_Back_End then
declare
Bod : Node_Id;
begin
First_Decl := First (Declarations (Blk));
+ -- If the body is a single extended return statement,the
+ -- resulting block is a nested block.
+
+ if No (First_Decl) then
+ First_Decl :=
+ First (Statements (Handled_Statement_Sequence (Blk)));
+
+ if Nkind (First_Decl) = N_Block_Statement then
+ First_Decl := First (Declarations (First_Decl));
+ end if;
+ end if;
+
+ -- No front-end inlining possible
+
if Nkind (First_Decl) /= N_Object_Declaration then
return;
end if;
-- 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 in two subprograms: a procedure P and
- -- a function F that has a block with a call to procedure P (see
+ -- 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
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))));
+ pragma Assert (not Is_By_Reference_Type (Etype (A)));
+ pragma Assert (not Is_Limited_Type (Etype (A)));
Append_To (Decls,
Make_Object_Declaration (Loc,
-- of the result of a call to an inlined function that returns
-- an unconstrained type
- elsif Back_End_Inlining
+ elsif Uses_Back_End
and then Nkind (Parent (N)) = N_Object_Declaration
and then Is_Unc
then
-- avoid generating undesired extra calls and goto statements.
-- Given:
- -- function Func (...) return ...
+ -- function Func (...) return String is
-- begin
-- declare
-- Result : String (1 .. 4);
-- Proc (Result, ...);
-- return Result;
-- end;
- -- end F;
+ -- end Func;
-- Result : String := Func (...);
-- Attach block to tree before analysis and rewriting.
Replace_Formals (Blk);
+ Replace_Formals_In_Aspects (Blk);
Set_Parent (Blk, N);
if GNATprove_Mode then
return True;
end if;
- -- Then declarations excluded only for front end inlining
+ -- Then declarations excluded only for front-end inlining
if Back_End_Inlining then
null;
if Present (Expression (N))
and then Is_Entity_Name (Expression (N))
then
+ pragma Assert (Present (Entity (Expression (N))));
+
if No (Return_Statement) then
Return_Statement := N;
return OK;
- elsif Chars (Expression (N)) =
- Chars (Expression (Return_Statement))
- then
- return OK;
-
else
- return Abandon;
+ pragma Assert
+ (Present (Entity (Expression (Return_Statement))));
+
+ if Entity (Expression (N)) =
+ Entity (Expression (Return_Statement))
+ then
+ return OK;
+ else
+ return Abandon;
+ end if;
end if;
- -- A return statement within an extended return is a noop
- -- after inlining.
+ -- 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
+ and then Nkind (Parent (Parent (N))) =
+ N_Extended_Return_Statement
then
return OK;
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))));
+ return
+ Present (Declarations (N))
+ and then Present (First (Declarations (N)))
+ and then Entity (Expression (Return_Statement)) =
+ Defining_Identifier (First (Declarations (N)));
end if;
end Has_Single_Return;
procedure Initialize is
begin
- Pending_Descriptor.Init;
Pending_Instantiations.Init;
Inlined_Bodies.Init;
Successors.Init;
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;
-- 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;
+
+ 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);
-- 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
- 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;
+ if Back_End_Inlining then
+ while J <= Called_Pending_Instantiations.Last
+ and then Serious_Errors_Detected = 0
+ loop
+ K := Called_Pending_Instantiations.Table (J);
+ Info := Pending_Instantiations.Table (K);
+ Instantiate_Body (Info);
- elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
- Instantiate_Package_Body (Info);
- Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
+ J := J + 1;
+ end loop;
- else
- Instantiate_Subprogram_Body (Info);
- end if;
+ else
+ while J <= Pending_Instantiations.Last
+ and then Serious_Errors_Detected = 0
+ loop
+ Info := Pending_Instantiations.Table (J);
+ Instantiate_Body (Info);
- J := J + 1;
- end loop;
+ J := J + 1;
+ 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
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
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
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
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
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
- ("List of inlined subprograms passed to the backend");
- Write_Eol;
- end if;
+ 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;
+ Write_Str (" ");
+ Write_Int (Count);
+ Write_Str (":");
+ Write_Name (Chars (Nod));
+ Write_Str (" (");
+ Write_Location (Sloc (Nod));
+ Write_Str (")");
+ Output.Write_Eol;
+ end if;
Next_Elmt (Elmt);
end loop;
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
- ("List of subprograms that cannot be inlined by the backend");
- Write_Eol;
- end if;
+ if Count = 1 then
+ Write_Str
+ ("List of subprograms that cannot be inlined by 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;
+ Write_Str (" ");
+ Write_Int (Count);
+ Write_Str (":");
+ Write_Name (Chars (Nod));
+ Write_Str (" (");
+ Write_Location (Sloc (Nod));
+ Write_Str (")");
+ Output.Write_Eol;
+ end if;
Next_Elmt (Elmt);
end loop;
projects / platform / upstream / gcc.git / blobdiff