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