+2012-03-07 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): If the object
+ declaration has an init expression then stop the analysis of the
+ object declaration if the expression which initializes the object
+ is a call to an inlined function which returns an unconstrained
+ and has been expanded into a procedure call.
+ * sem_ch5.adb (Has_Call_Using_Secondary_Stack): Add missing
+ support to handle selected components.
+ * sem_ch6.ads (Cannot_Inline): Adding parameter Is_Serious plus
+ documentation.
+ * sem_ch6.adb (Check_And_Build_Body_To_Inline): New
+ subprogram which implements the checks required by the
+ new rules for frontend inlining and builds the body to inline.
+ (Analyze_Subprogram_Body_Helper): Move code that
+ checks inlining of subprogram that has nested subprogram
+ to Check_And_Build_Body_To_Inline. Replace call to
+ Build_Body_To_Inline by call to the new subprogram
+ Check_And_Build_Body_To_Inline.
+ (Cannot_Inline): New implementation.
+ * sem_ch12.adb (Analyze_Package_Instantiation.Must_Inline_Subp):
+ New subprogram.
+ * sem_util.ad[sb] (Must_Inline): New subprogram.
+ (Returns_Unconstrained_Type): New subprogram.
+ * sem_res.adb (Resolve_Call): Do not create a transient scope
+ for inlined calls.
+ * inline.ads (Analyzing_Inlined_Bodies): Remove unreferenced variable.
+ * inline.adb (Analyze_Inlined_Bodies, Initialize): Remove setting
+ to false the variable Analyzing_Inlined_Bodies. Fix comments.
+ * exp_ch4.adb (Expand_N_Allocator): Fix handling of finalization master.
+ * exp_ch6.ads (List_Inlining_Info): New subprogram.
+ * exp_ch6.adb (Expand_Call.Do_Inline): New subprogram.
+ (Expand_Call.Do_Inline_Always): New subprogram.
+ (In_Unfrozen_Instance): Move the declaration of this subprogram.
+ (Expand_Inlined_Call.Reset_Dispatching_Calls): New subprogram.
+ (Expand_Inlined_Call): Adding new support for inlining functions
+ that return unconstrained types.
+ (List_Inlining_Info): New subprogram.
+ * debug.adb Document flags -gnatd.j and -gnatd.k
+ * gnat1drv.adb Add call to generate the new listing of inlined
+ calls and calls passed to the backend.
+
2012-03-07 Robert Dewar <dewar@adacore.com>
* sem_ch5.adb, s-vaflop.adb, s-taprop-vms.adb, exp_ch6.adb,
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-- d.g Enable conversion of raise into goto
-- d.h
-- d.i Ignore Warnings pragmas
- -- d.j
- -- d.k
+ -- d.j Generate listing of frontend inlined calls
+ -- d.k Enable new support for frontend inlining
-- d.l Use Ada 95 semantics for limited function returns
-- d.m For -gnatl, print full source only for main unit
-- d.n Print source file names
-- be used in particular to disable Warnings (Off) to check if any of
-- these statements are inappropriate.
+ -- d.j Generate listing of frontend inlined calls and inline calls passed
+ -- to the backend. This is useful to locate skipped calls that must be
+ -- inlined by the frontend.
+
+ -- d.k Enable new semantics of frontend inlining. This is useful to test
+ -- this new feature in all the platforms.
+
-- d.l Use Ada 95 semantics for limited function returns. This may be
-- used to work around the incompatibility introduced by AI-318-2.
-- It is useful only in -gnat05 mode.
-- Processing for anonymous access-to-controlled types. These access
-- types receive a special finalization master which appears in the
-- declarations of the enclosing semantic unit. This expansion is done
- -- now to ensure that any additional types generated by this routine
- -- or Expand_Allocator_Expression inherit the proper type attributes.
+ -- now to ensure that any additional types generated by this routine or
+ -- Expand_Allocator_Expression inherit the proper type attributes.
- if Ekind (PtrT) = E_Anonymous_Access_Type
+ if (Ekind (PtrT) = E_Anonymous_Access_Type
+ or else
+ (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
and then Needs_Finalization (Dtyp)
then
-- Anonymous access-to-controlled types allocate on the global pool.
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Output; use Output;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem_SCIL; use Sem_SCIL;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
+with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Targparm; use Targparm;
package body Exp_Ch6 is
+ Inlined_Calls : Elist_Id := No_Elist;
+ Backend_Calls : Elist_Id := No_Elist;
+ -- List of frontend inlined calls and inline calls passed to the backend
+
-----------------------
-- Local Subprograms --
-----------------------
-- expression for the value of the actual, EF is the entity for the
-- extra formal.
+ procedure Do_Inline (Subp : Entity_Id; Orig_Subp : Entity_Id);
+ -- Check and inline the body of Subp. Invoked when compiling with
+ -- optimizations enabled and Subp has pragma inline or inline always.
+ -- If the subprogram is a renaming, or if it is inherited, then Subp
+ -- references the renamed entity and Orig_Subp is the entity of the
+ -- call node N.
+
+ procedure Do_Inline_Always (Subp : Entity_Id; Orig_Subp : Entity_Id);
+ -- Check and inline the body of Subp. Invoked when compiling without
+ -- optimizations and Subp has pragma inline always. If the subprogram is
+ -- a renaming, or if it is inherited, then Subp references the renamed
+ -- entity and Orig_Subp is the entity of the call node N.
+
function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
-- Within an instance, a type derived from a non-tagged formal derived
-- type inherits from the original parent, not from the actual. The
-- convoluted tree traversal before setting the proper subprogram to be
-- called.
+ function In_Unfrozen_Instance (E : Entity_Id) return Boolean;
+ -- Return true if E comes from an instance that is not yet frozen
+
function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean;
-- Determine if Subp denotes a non-dispatching call to a Deep routine
end if;
end Add_Extra_Actual;
+ ----------------
+ -- Do_Inline --
+ ----------------
+
+ procedure Do_Inline (Subp : Entity_Id; Orig_Subp : Entity_Id) is
+ Spec : constant Node_Id := Unit_Declaration_Node (Subp);
+
+ procedure Do_Backend_Inline;
+ -- Check that the call can be safely passed to the backend. If true
+ -- then register the enclosing unit of Subp to Inlined_Bodies so that
+ -- the body of Subp can be retrieved and analyzed by the backend.
+
+ procedure Register_Backend_Call (N : Node_Id);
+ -- Append N to the list Backend_Calls
+
+ -----------------------
+ -- Do_Backend_Inline --
+ -----------------------
+
+ procedure Do_Backend_Inline is
+ begin
+ -- No extra test needed for init subprograms since we know they
+ -- are available to the backend!
+
+ if Is_Init_Proc (Subp) then
+ Add_Inlined_Body (Subp);
+ Register_Backend_Call (Call_Node);
+
+ -- Verify that if the body to inline is located in the current
+ -- unit the inlining does not occur earlier. This avoids
+ -- order-of-elaboration problems in the back end.
+
+ elsif In_Same_Extended_Unit (Call_Node, Subp)
+ and then Nkind (Spec) = N_Subprogram_Declaration
+ and then Earlier_In_Extended_Unit
+ (Loc, Sloc (Body_To_Inline (Spec)))
+ then
+ Error_Msg_NE
+ ("cannot inline& (body not seen yet)?",
+ Call_Node, Subp);
+
+ else
+ declare
+ Backend_Inline : Boolean := True;
+
+ begin
+ -- If we are compiling a package body that is not the
+ -- main unit, it must be for inlining/instantiation
+ -- purposes, in which case we inline the call to insure
+ -- that the same temporaries are generated when compiling
+ -- the body by itself. Otherwise link errors can occur.
+
+ -- If the function being called is itself in the main
+ -- unit, we cannot inline, because there is a risk of
+ -- double elaboration and/or circularity: the inlining
+ -- can make visible a private entity in the body of the
+ -- main unit, that gigi will see before its sees its
+ -- proper definition.
+
+ if not (In_Extended_Main_Code_Unit (Call_Node))
+ and then In_Package_Body
+ then
+ Backend_Inline :=
+ not In_Extended_Main_Source_Unit (Subp);
+ end if;
+
+ if Backend_Inline then
+ Add_Inlined_Body (Subp);
+ Register_Backend_Call (Call_Node);
+ end if;
+ end;
+ end if;
+ end Do_Backend_Inline;
+
+ ---------------------------
+ -- Register_Backend_Call --
+ ---------------------------
+
+ procedure Register_Backend_Call (N : Node_Id) is
+ begin
+ if Backend_Calls = No_Elist then
+ Backend_Calls := New_Elmt_List;
+ end if;
+
+ Append_Elmt (N, To => Backend_Calls);
+ end Register_Backend_Call;
+
+ -- Start of processing for Do_Inline
+
+ begin
+ -- Verify that the body to inline has already been seen
+
+ if No (Spec)
+ or else Nkind (Spec) /= N_Subprogram_Declaration
+ or else No (Body_To_Inline (Spec))
+ then
+ if Comes_From_Source (Subp)
+ and then Must_Inline (Subp)
+ then
+ Cannot_Inline
+ ("cannot inline& (body not seen yet)?", Call_Node, Subp);
+
+ -- Let the back end handle it
+
+ else
+ Do_Backend_Inline;
+ return;
+ end if;
+
+ -- If this an inherited function that returns a private type, do not
+ -- inline if the full view is an unconstrained array, because such
+ -- calls cannot be inlined.
+
+ elsif Present (Orig_Subp)
+ and then Is_Array_Type (Etype (Orig_Subp))
+ and then not Is_Constrained (Etype (Orig_Subp))
+ then
+ Cannot_Inline
+ ("cannot inline& (unconstrained array)?", Call_Node, Subp);
+
+ else
+ Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
+ end if;
+ end Do_Inline;
+
+ ----------------------
+ -- Do_Inline_Always --
+ ----------------------
+
+ procedure Do_Inline_Always (Subp : Entity_Id; Orig_Subp : Entity_Id) is
+ Spec : constant Node_Id := Unit_Declaration_Node (Subp);
+ Body_Id : Entity_Id;
+
+ begin
+ if No (Spec)
+ or else Nkind (Spec) /= N_Subprogram_Declaration
+ or else No (Body_To_Inline (Spec))
+ or else Serious_Errors_Detected /= 0
+ then
+ return;
+ end if;
+
+ Body_Id := Corresponding_Body (Spec);
+
+ -- Verify that the body to inline has already been seen
+
+ if No (Body_Id)
+ or else not Analyzed (Body_Id)
+ then
+ Set_Is_Inlined (Subp, False);
+
+ if Comes_From_Source (Subp) then
+
+ -- Report a warning only if the call is located in the unit of
+ -- the called subprogram; otherwise it is an error.
+
+ if not In_Same_Extended_Unit (Call_Node, Subp) then
+ Cannot_Inline
+ ("cannot inline& (body not seen yet)", Call_Node, Subp,
+ Is_Serious => True);
+
+ elsif In_Open_Scopes (Subp) then
+
+ -- For backward compatibility we generate the same error
+ -- or warning of the previous implementation. This will
+ -- be changed when we definitely incorporate the new
+ -- support ???
+
+ if Front_End_Inlining
+ and then Optimization_Level = 0
+ then
+ Error_Msg_N
+ ("call to recursive subprogram cannot be inlined?",
+ N);
+
+ -- Do not emit error compiling runtime packages
+
+ elsif Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Subp)))
+ then
+ Error_Msg_N
+ ("call to recursive subprogram cannot be inlined?",
+ N);
+
+ else
+ Error_Msg_N
+ ("call to recursive subprogram cannot be inlined",
+ N);
+ end if;
+
+ else
+ Cannot_Inline
+ ("cannot inline& (body not seen yet)?", Call_Node, Subp);
+ end if;
+ end if;
+
+ return;
+
+ -- If this an inherited function that returns a private type, do not
+ -- inline if the full view is an unconstrained array, because such
+ -- calls cannot be inlined.
+
+ elsif Present (Orig_Subp)
+ and then Is_Array_Type (Etype (Orig_Subp))
+ and then not Is_Constrained (Etype (Orig_Subp))
+ then
+ Cannot_Inline
+ ("cannot inline& (unconstrained array)?", Call_Node, Subp);
+
+ -- If the called subprogram comes from an instance in the same
+ -- unit, and the instance is not yet frozen, inlining might
+ -- trigger order-of-elaboration problems.
+
+ elsif In_Unfrozen_Instance (Scope (Subp)) then
+ Cannot_Inline
+ ("cannot inline& (unfrozen instance)?", Call_Node, Subp);
+
+ else
+ Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
+ end if;
+ end Do_Inline_Always;
+
---------------------------
-- Inherited_From_Formal --
---------------------------
raise Program_Error;
end Inherited_From_Formal;
+ --------------------------
+ -- In_Unfrozen_Instance --
+ --------------------------
+
+ function In_Unfrozen_Instance (E : Entity_Id) return Boolean is
+ S : Entity_Id := E;
+
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Is_Generic_Instance (S)
+ and then Present (Freeze_Node (S))
+ and then not Analyzed (Freeze_Node (S))
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Unfrozen_Instance;
+
-------------------------
-- Is_Direct_Deep_Call --
-------------------------
return;
end if;
- if Is_Inlined (Subp) then
+ -- Handle inlining (old semantics)
+
+ if Is_Inlined (Subp) and then not Debug_Flag_Dot_K then
Inlined_Subprogram : declare
Bod : Node_Id;
Must_Inline : Boolean := False;
Spec : constant Node_Id := Unit_Declaration_Node (Subp);
- Scop : constant Entity_Id := Scope (Subp);
-
- function In_Unfrozen_Instance return Boolean;
- -- If the subprogram comes from an instance in the same unit,
- -- and the instance is not yet frozen, inlining might trigger
- -- order-of-elaboration problems in gigi.
-
- --------------------------
- -- In_Unfrozen_Instance --
- --------------------------
-
- function In_Unfrozen_Instance return Boolean is
- S : Entity_Id;
-
- begin
- S := Scop;
- while Present (S)
- and then S /= Standard_Standard
- loop
- if Is_Generic_Instance (S)
- and then Present (Freeze_Node (S))
- and then not Analyzed (Freeze_Node (S))
- then
- return True;
- end if;
-
- S := Scope (S);
- end loop;
-
- return False;
- end In_Unfrozen_Instance;
-
- -- Start of processing for Inlined_Subprogram
begin
-- Verify that the body to inline has already been seen, and
then
Must_Inline := False;
- elsif In_Unfrozen_Instance then
+ elsif In_Unfrozen_Instance (Scope (Subp)) then
Must_Inline := False;
else
end if;
end if;
end Inlined_Subprogram;
+
+ -- Handle inlining (new semantics)
+
+ elsif Is_Inlined (Subp) then
+ declare
+ Spec : constant Node_Id := Unit_Declaration_Node (Subp);
+
+ begin
+ if Optimization_Level > 0 then
+ Do_Inline (Subp, Orig_Subp);
+
+ elsif Must_Inline (Subp) then
+ if In_Extended_Main_Code_Unit (Call_Node)
+ and then In_Same_Extended_Unit (Sloc (Spec), Loc)
+ and then not Has_Completion (Subp)
+ then
+ Cannot_Inline
+ ("cannot inline& (body not seen yet)?",
+ Call_Node, Subp);
+
+ else
+ Do_Inline_Always (Subp, Orig_Subp);
+ end if;
+ end if;
+
+ -- The call may have been inlined or may have been passed to
+ -- the backend. No further action needed if it was inlined.
+
+ if Nkind (N) /= N_Function_Call then
+ return;
+ end if;
+ end;
end if;
end if;
Remove_Side_Effects (N);
end Expand_Ctrl_Function_Call;
- --------------------------
+ -------------------------
-- Expand_Inlined_Call --
- --------------------------
+ -------------------------
procedure Expand_Inlined_Call
(N : Node_Id;
Body_To_Inline (Unit_Declaration_Node (Subp));
Blk : Node_Id;
- Bod : Node_Id;
Decl : Node_Id;
Decls : constant List_Id := New_List;
Exit_Lab : Entity_Id := Empty;
Targ : Node_Id;
-- The target of the call. If context is an assignment statement then
- -- this is the left-hand side of the assignment. else it is a temporary
+ -- 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;
Return_Object : Entity_Id := Empty;
-- Entity in declaration in an extended_return_statement
- Is_Unc : constant Boolean :=
- Is_Array_Type (Etype (Subp))
- and then not Is_Constrained (Etype (Subp));
+ 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.
-- Ada.Tags. If Debug_Generated_Code is true, suppress this change to
-- simplify our own development.
+ 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; in all the found occurrences reset the entity
+ -- associated with Operation.
+
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.
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;
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_Check --
+ --------------
+
+ function Do_Reset (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Procedure_Call_Statement
+ and then Nkind (Name (N)) = N_Selected_Component
+ and then Nkind (Prefix (Name (N))) = N_Identifier
+ and then Is_Formal (Entity (Prefix (Name (N))))
+ and then Is_Dispatching_Operation
+ (Entity (Selector_Name (Name (N))))
+ then
+ Set_Entity (Selector_Name (Name (N)), Empty);
+ end if;
+
+ return OK;
+ end Do_Reset;
+
+ function Do_Reset_Calls is new Traverse_Func (Do_Reset);
+
+ -- Start of processing for Reset_Dispatching_Calls
+
+ Dummy : constant Traverse_Result := Do_Reset_Calls (N);
+ pragma Unreferenced (Dummy);
+ begin
+ null;
+ end Reset_Dispatching_Calls;
+
---------------------------
-- Rewrite_Function_Call --
---------------------------
end;
elsif Nkind (Parent (N)) = N_Object_Declaration then
- Set_Expression (Parent (N), Empty);
- Insert_After (Parent (N), Blk);
- elsif Is_Unc 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 then Debug_Flag_Dot_K 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 Debug_Flag_Dot_K then
Insert_Before (Parent (N), Blk);
end if;
end Rewrite_Function_Call;
-- Start of processing for Expand_Inlined_Call
begin
+ -- Initializations for old/new semantics
+
+ if not Debug_Flag_Dot_K 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
and then
Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod))))
= N_Extended_Return_Statement
+ and then not Debug_Flag_Dot_K
then
return;
end if;
return;
end if;
+ -- Register the call in the list of inlined calls
+
+ if Inlined_Calls = No_Elist then
+ Inlined_Calls := New_Elmt_List;
+ end if;
+
+ Append_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));
- Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
- Blk :=
- Make_Block_Statement (Loc,
- Declarations => Declarations (Bod),
- Handled_Statement_Sequence => Handled_Statement_Sequence (Bod));
+ -- Old semantics
- if No (Declarations (Bod)) then
- Set_Declarations (Blk, New_List);
- end if;
+ if not Debug_Flag_Dot_K 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));
- -- 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 No (Declarations (Bod)) then
+ Set_Declarations (Blk, New_List);
+ end if;
- -- 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.
+ -- 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 Is_Unc then
- if Nkind (Parent (N)) /= N_Assignment_Statement then
- Targ1 := Defining_Identifier (First (Declarations (Blk)));
- else
- Targ1 := Name (Parent (N));
- end if;
+ -- If the context is an assignment statement, as is the case
+ -- for the expansion of an extended return, the left-hand side
+ -- provides bounds even if the return type is unconstrained.
+
+ if Is_Unc then
+ declare
+ First_Decl : Node_Id;
+
+ begin
+ First_Decl := First (Declarations (Blk));
+
+ if Nkind (First_Decl) /= N_Object_Declaration then
+ return;
+ end if;
+
+ if Nkind (Parent (N)) /= N_Assignment_Statement then
+ Targ1 := Defining_Identifier (First_Decl);
+ else
+ Targ1 := Name (Parent (N));
+ end if;
+ end;
+ end if;
+ end;
+
+ -- New semantics
+
+ else
+ declare
+ Bod : Node_Id;
+
+ begin
+ -- General case
+
+ if not Is_Unc then
+ Bod :=
+ Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
+ Blk :=
+ Make_Block_Statement (Loc,
+ Declarations => Declarations (Bod),
+ Handled_Statement_Sequence =>
+ Handled_Statement_Sequence (Bod));
+
+ -- Inline a call to a function that returns an unconstrained type.
+ -- The semantic analyzer checked that frontend-inlined functions
+ -- returning unconstrained types have no declarations and have
+ -- a single extended return statement. As part of its processing
+ -- the function was split in 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) = Sinfo.N_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
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 Debug_Flag_Dot_K
+ 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
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 ...
+ -- begin
+ -- declare
+ -- Result : String (1 .. 4);
+ -- begin
+ -- Proc (Result, ...);
+ -- return Result;
+ -- end;
+ -- end F;
+
+ -- 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_Reference_To (Targ, Loc));
+ end;
+
+ -- Remove the return statement
+
+ pragma Assert
+ (Nkind (Last (Statements (Handled_Statement_Sequence (Blk))))
+ = Sinfo.N_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.
Reset_Slocs (Blk);
end if;
- if Present (Exit_Lab) then
+ if Is_Unc_Decl then
+
+ -- No action needed since the return statement has been already
+ -- removed!
+
+ null;
+
+ elsif Present (Exit_Lab) then
-- If the body was a single expression, the single return statement
-- and the corresponding label are useless.
if Is_Predef then
declare
Style : constant Boolean := Style_Check;
+
begin
Style_Check := False;
+
+ -- Search for dispatching calls that use the Object.Operation
+ -- notation using an Object that is a parameter of the inlined
+ -- function. We reset the decoration of Operation to force
+ -- the reanalysis of the inlined dispatching call because
+ -- the actual object has been inlined.
+
+ Reset_Dispatching_Calls (Blk);
+
Analyze (Blk, Suppress => All_Checks);
Style_Check := Style;
end;
else
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.
- if Is_Unc then
+ elsif Is_Unc then
if Nkind (N) = N_Identifier then
Set_Etype (N, Etype (Entity (N)));
else
-- Alpha/VMS, no-op everywhere else).
-- Comes_From_Source intercepts recursive expansion.
- if Vax_Float (Etype (N))
- and then Nkind (N) = N_Function_Call
+ if Nkind (N) = N_Function_Call
+ and then Vax_Float (Etype (N))
and then Present (Name (N))
and then Present (Entity (Name (N)))
and then Has_Foreign_Convention (Entity (Name (N)))
end if;
end Needs_Result_Accessibility_Level;
+ ------------------------
+ -- List_Inlining_Info --
+ ------------------------
+
+ procedure List_Inlining_Info is
+ Elmt : Elmt_Id;
+ Nod : Node_Id;
+ Count : Nat;
+
+ begin
+ if not Debug_Flag_Dot_J then
+ return;
+ end if;
+
+ -- Generate listing of calls inlined by the frontend
+
+ if Present (Inlined_Calls) then
+ Count := 0;
+ Elmt := First_Elmt (Inlined_Calls);
+ while Present (Elmt) loop
+ Nod := Node (Elmt);
+
+ if In_Extended_Main_Code_Unit (Nod) then
+ Count := Count + 1;
+
+ if Count = 1 then
+ Write_Str ("Listing of frontend inlined calls");
+ Write_Eol;
+ end if;
+
+ Write_Str (" ");
+ Write_Int (Count);
+ Write_Str (":");
+ Write_Location (Sloc (Nod));
+ Write_Str (":");
+ Output.Write_Eol;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ -- Generate listing of calls passed to the backend
+
+ if Present (Backend_Calls) then
+ Count := 0;
+
+ Elmt := First_Elmt (Backend_Calls);
+ while Present (Elmt) loop
+ Nod := Node (Elmt);
+
+ if In_Extended_Main_Code_Unit (Nod) then
+ Count := Count + 1;
+
+ if Count = 1 then
+ Write_Str ("Listing of inlined calls passed to the backend");
+ Write_Eol;
+ end if;
+
+ Write_Str (" ");
+ Write_Int (Count);
+ Write_Str (":");
+ Write_Location (Sloc (Nod));
+ Output.Write_Eol;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+ end List_Inlining_Info;
+
end Exp_Ch6;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-- Predicate to recognize stubbed procedures and null procedures, which
-- can be inlined unconditionally in all cases.
+ procedure List_Inlining_Info;
+ -- Generate listing of calls inlined by the frontend plus listing of
+ -- calls to inline subprograms passed to the backend.
+
procedure Make_Build_In_Place_Call_In_Allocator
(Allocator : Node_Id;
Function_Call : Node_Id);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Elists;
with Errout; use Errout;
with Exp_CG;
+with Exp_Ch6; use Exp_Ch6;
with Fmap;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
List_Rep_Info;
+ List_Inlining_Info;
-- Only write the library if the backend did not generate any error
-- messages. Otherwise signal errors to the driver program so that
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
end if;
end Is_Ancestor_Of_Main;
- -- Start of processing for Analyze_Inlined_Bodies
+ -- Start of processing for Analyze_Inlined_Bodies
begin
- Analyzing_Inlined_Bodies := False;
-
if Serious_Errors_Detected = 0 then
Push_Scope (Standard_Standard);
Comp_Unit := Parent (Comp_Unit);
end loop;
- -- Load the body, unless it the main unit, or is an instance whose
- -- body has already been analyzed.
+ -- Load the body, 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)
procedure Initialize is
begin
- Analyzing_Inlined_Bodies := False;
Pending_Descriptor.Init;
Pending_Instantiations.Init;
Inlined_Bodies.Init;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
Table_Increment => Alloc.Pending_Instantiations_Increment,
Table_Name => "Pending_Descriptor");
- Analyzing_Inlined_Bodies : Boolean;
- -- This flag is set False by the call to Initialize, and then is set
- -- True by the call to Analyze_Inlined_Bodies. It is used to suppress
- -- generation of subprogram descriptors for inlined bodies.
-
-----------------
-- Subprograms --
-----------------
with Aspects; use Aspects;
with Atree; use Atree;
+with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
-- but it is simpler than detecting the need for the body at the point
-- of inlining, when the context of the instance is not available.
+ function Must_Inline_Subp return Boolean;
+ -- If inlining is active and the generic contains inlined subprograms,
+ -- return True if some of the inlined subprograms must be inlined by
+ -- the frontend.
+
-----------------------
-- Delay_Descriptors --
-----------------------
return False;
end Might_Inline_Subp;
+ ----------------------
+ -- Must_Inline_Subp --
+ ----------------------
+
+ function Must_Inline_Subp return Boolean is
+ E : Entity_Id;
+
+ begin
+ if not Inline_Processing_Required then
+ return False;
+
+ else
+ E := First_Entity (Gen_Unit);
+ while Present (E) loop
+ if Is_Subprogram (E)
+ and then Is_Inlined (E)
+ and then Must_Inline (E)
+ then
+ return True;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+
+ return False;
+ end Must_Inline_Subp;
+
-- Local declarations
Vis_Prims_List : Elist_Id := No_Elist;
and then Might_Inline_Subp
and then not Is_Actual_Pack
then
- if Front_End_Inlining
+ if not Debug_Flag_Dot_K
+ and then Front_End_Inlining
+ and then (Is_In_Main_Unit (N)
+ or else In_Main_Context (Current_Scope))
+ and then Nkind (Parent (N)) /= N_Compilation_Unit
+ then
+ Inline_Now := True;
+
+ elsif Debug_Flag_Dot_K
+ and then Must_Inline_Subp
and then (Is_In_Main_Unit (N)
or else In_Main_Context (Current_Scope))
and then Nkind (Parent (N)) /= N_Compilation_Unit
Set_Etype (Id, T);
Resolve (E, T);
+ -- No further action needed if E is a call to an inlined function
+ -- which returns an unconstrained type and it has been expanded into
+ -- a procedure call. In that case N has been replaced by an object
+ -- declaration without initializing expression and it has been
+ -- analyzed (see Expand_Inlined_Call).
+
+ if Debug_Flag_Dot_K
+ and then Expander_Active
+ and then Nkind (E) = N_Function_Call
+ and then Nkind (Name (E)) in N_Has_Entity
+ and then Is_Inlined (Entity (Name (E)))
+ and then not Is_Constrained (Etype (E))
+ and then Analyzed (N)
+ and then No (Expression (N))
+ then
+ return;
+ end if;
+
-- If E is null and has been replaced by an N_Raise_Constraint_Error
-- node (which was marked already-analyzed), we need to set the type
-- to something other than Any_Access in order to keep gigi happy.
if Nkind (Nam) = N_Explicit_Dereference then
Subp := Etype (Nam);
- -- Normal case
+ -- Call using a selected component notation or Ada 2005 object
+ -- operation notation
+
+ elsif Nkind (Nam) = N_Selected_Component then
+ Subp := Entity (Selector_Name (Nam));
+
+ -- Common case
else
Subp := Entity (Nam);
function Can_Override_Operator (Subp : Entity_Id) return Boolean;
-- Returns true if Subp can override a predefined operator.
+ procedure Check_And_Build_Body_To_Inline
+ (N : Node_Id;
+ Spec_Id : Entity_Id;
+ Body_Id : Entity_Id);
+ -- Spec_Id and Body_Id are the entities of the specification and body of
+ -- the subprogram body N. If N can be inlined by the frontend (supported
+ -- cases documented in Check_Body_To_Inline) then build the body-to-inline
+ -- associated with N and attach it to the declaration node of Spec_Id.
+
procedure Check_Conformance
(New_Id : Entity_Id;
Old_Id : Entity_Id;
if Comes_From_Source (Body_Id)
and then Serious_Errors_Detected = 0
+ and then not Debug_Flag_Dot_K
then
P_Ent := Body_Id;
loop
end loop;
end if;
+ -- Look ahead to recognize a pragma inline that appears after the body
+
Check_Inline_Pragma (Spec_Id);
-- Deal with special case of a fully private operation in the body of
if Nkind (N) = N_Subprogram_Body_Stub then
return;
+ end if;
- elsif Present (Spec_Id)
- and then Expander_Active
- and then
- (Has_Pragma_Inline_Always (Spec_Id)
- or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
+ -- Handle frontend inlining. There is no need to prepare us for inlining
+ -- if we will not generate the code.
+
+ -- Old semantics
+
+ if not Debug_Flag_Dot_K then
+ if Present (Spec_Id)
+ and then Expander_Active
+ and then
+ (Has_Pragma_Inline_Always (Spec_Id)
+ or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
+ then
+ Build_Body_To_Inline (N, Spec_Id);
+ end if;
+
+ -- New semantics
+
+ elsif Expander_Active
+ and then Serious_Errors_Detected = 0
+ and then Present (Spec_Id)
+ and then Has_Pragma_Inline (Spec_Id)
then
- Build_Body_To_Inline (N, Spec_Id);
+ Check_And_Build_Body_To_Inline (N, Spec_Id, Body_Id);
end if;
-- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
-- Cannot_Inline --
-------------------
- procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is
+ procedure Cannot_Inline
+ (Msg : String;
+ N : Node_Id;
+ Subp : Entity_Id;
+ Is_Serious : Boolean := False) is
begin
- -- 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.
+ pragma Assert (Msg (Msg'Last) = '?');
- if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
- and then not In_Extended_Main_Source_Unit (Subp)
- then
- null;
+ -- Old semantics
+
+ if not Debug_Flag_Dot_K 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_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
+ and then not In_Extended_Main_Source_Unit (Subp)
+ then
+ null;
+
+ 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, N, Subp);
+ end if;
+
+ return;
+
+ -- New semantics
- elsif Has_Pragma_Inline_Always (Subp) then
+ elsif Is_Serious then
- -- Remove last character (question mark) to make this into an error,
- -- because the Inline_Always pragma cannot be obeyed.
+ -- Remove last character (question mark) to make this into an error.
Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
- elsif Ineffective_Inline_Warnings then
- Error_Msg_NE (Msg, N, Subp);
+ elsif Optimization_Level = 0 then
+
+ -- 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_File_Name (Unit_File_Name (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_File_Name
+ (Unit_File_Name (Get_Source_Unit (Gen_P)))
+ then
+ Set_Is_Inlined (Subp, False);
+ Error_Msg_NE (Msg, 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 pragma Assert (Front_End_Inlining);
+ Set_Is_Inlined (Subp, False);
+
+ -- When inlining cannot take place we must issue an error.
+ -- For backward compatibility we still report a warning.
+
+ if Ineffective_Inline_Warnings then
+ Error_Msg_NE (Msg, N, Subp);
+ end if;
+ end if;
+
+ -- Compiling with optimizations enabled it is too early to report
+ -- problems since the backend may still perform inlining. In order
+ -- to report unhandled inlinings the program must be compiled with
+ -- -Winline and the error is reported by the backend.
+
+ else
+ null;
end if;
end Cannot_Inline;
+ ------------------------------------
+ -- Check_And_Build_Body_To_Inline --
+ ------------------------------------
+
+ procedure Check_And_Build_Body_To_Inline
+ (N : Node_Id;
+ Spec_Id : Entity_Id;
+ Body_Id : Entity_Id)
+ is
+ procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
+ -- Use generic machinery to build an unexpanded body for the subprogram.
+ -- This body is subsequently used for inline expansions at call sites.
+
+ function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
+ -- Return true if the function body N has no local declarations and its
+ -- unique statement is a single extended return statement with a handled
+ -- statements sequence.
+
+ function Check_Body_To_Inline
+ (N : Node_Id;
+ Subp : Entity_Id) return Boolean;
+ -- N is the N_Subprogram_Body of Subp. Return true if Subp can be
+ -- inlined by the frontend. These are the rules:
+ -- * At -O0 use fe inlining when inline_always is specified except if
+ -- the function returns a controlled type.
+ -- * At other optimization levels use the fe inlining for both inline
+ -- and inline_always in the following cases:
+ -- - function returning a known at compile time constant
+ -- - function returning a call to an intrinsic function
+ -- - function returning an unconstrained type (see Can_Split
+ -- Unconstrained_Function).
+ -- - function returning a call to a frontend-inlined function
+ -- Use the back-end mechanism otherwise
+ --
+ -- In addition, in the following cases the function cannot be inlined by
+ -- the frontend:
+ -- - functions that uses the secondary stack
+ -- - functions that have declarations of:
+ -- - Concurrent types
+ -- - Packages
+ -- - Instantiations
+ -- - Subprograms
+ -- - functions that have some of the following statements:
+ -- - abort
+ -- - asynchronous-select
+ -- - conditional-entry-call
+ -- - delay-relative
+ -- - delay-until
+ -- - selective-accept
+ -- - timed-entry-call
+ -- - functions that have exception handlers
+ -- - functions that have some enclosing body containing instantiations
+ -- that appear before the corresponding generic body.
+
+ procedure Generate_Body_To_Inline
+ (N : Node_Id;
+ Body_To_Inline : out Node_Id);
+ -- Generate a parameterless duplicate of subprogram body N. Occurrences
+ -- of pragmas referencing the formals are removed since they have no
+ -- meaning when the body is inlined and the formals are rewritten (the
+ -- analysis of the non-inlined body will handle these pragmas properly).
+ -- A new internal name is associated with Body_To_Inline.
+
+ procedure Preanalyze (N : Node_Id);
+ -- Performs a pre-analysis of node N. During pre-analysis no expansion
+ -- is carried out for N or its children. For more info on pre-analysis
+ -- read the spec of Sem.
+
+ 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 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
+ Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
+ Original_Body : Node_Id;
+ Body_To_Analyze : Node_Id;
+
+ begin
+ pragma Assert (Current_Scope = Spec_Id);
+
+ -- Within an instance, the body to inline must be treated as a nested
+ -- generic, so that the proper global references are preserved. We
+ -- do not do this at the library level, because it is not needed, and
+ -- furthermore this causes trouble if front end inlining is activated
+ -- (-gnatN).
+
+ if In_Instance
+ and then Scope (Current_Scope) /= Standard_Standard
+ then
+ Save_Env (Scope (Current_Scope), Scope (Current_Scope));
+ end if;
+
+ -- 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.
+
+ Generate_Body_To_Inline (N, Original_Body);
+ Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
+
+ -- Set return type of function, which is also global and does not
+ -- need to be resolved.
+
+ if Ekind (Spec_Id) = E_Function then
+ Set_Result_Definition (Specification (Body_To_Analyze),
+ New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
+ end if;
+
+ if No (Declarations (N)) then
+ Set_Declarations (N, New_List (Body_To_Analyze));
+ else
+ Append_To (Declarations (N), Body_To_Analyze);
+ end if;
+
+ Preanalyze (Body_To_Analyze);
+
+ Push_Scope (Defining_Entity (Body_To_Analyze));
+ Save_Global_References (Original_Body);
+ End_Scope;
+ Remove (Body_To_Analyze);
+
+ -- Restore environment if previously saved
+
+ if In_Instance
+ and then Scope (Current_Scope) /= Standard_Standard
+ then
+ Restore_Env;
+ end if;
+
+ pragma Assert (No (Body_To_Inline (Decl)));
+ Set_Body_To_Inline (Decl, Original_Body);
+ Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
+ end Build_Body_To_Inline;
+
+ --------------------------
+ -- Check_Body_To_Inline --
+ --------------------------
+
+ function Check_Body_To_Inline
+ (N : Node_Id;
+ Subp : Entity_Id) return Boolean
+ is
+ Max_Size : constant := 10;
+ Stat_Count : Integer := 0;
+
+ function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
+ -- Check for declarations that make inlining not worthwhile
+
+ function Has_Excluded_Statement (Stats : List_Id) return Boolean;
+ -- Check for statements that make inlining not worthwhile: any
+ -- tasking statement, nested at any level. Keep track of total
+ -- number of elementary statements, as a measure of acceptable size.
+
+ function Has_Pending_Instantiation return Boolean;
+ -- Return True if some enclosing body contains instantiations that
+ -- appear before the corresponding generic body.
+
+ function Returns_Compile_Time_Constant (N : Node_Id) return Boolean;
+ -- Return True if all the return statements of the function body N
+ -- are simple return statements and return a compile time constant
+
+ function Returns_Intrinsic_Function_Call (N : Node_Id) return Boolean;
+ -- Return True if all the return statements of the function body N
+ -- are simple return statements and return an intrinsic function call
+
+ function Uses_Secondary_Stack (N : 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_Excluded_Declaration --
+ ------------------------------
+
+ function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
+ D : Node_Id;
+
+ function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
+ -- Nested subprograms make a given body ineligible for inlining,
+ -- but we make an exception for instantiations of unchecked
+ -- conversion. The body has not been analyzed yet, so check the
+ -- name, and verify that the visible entity with that name is the
+ -- predefined unit.
+
+ -----------------------------
+ -- Is_Unchecked_Conversion --
+ -----------------------------
+
+ function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
+ Id : constant Node_Id := Name (D);
+ Conv : Entity_Id;
+
+ begin
+ if Nkind (Id) = N_Identifier
+ and then Chars (Id) = Name_Unchecked_Conversion
+ then
+ Conv := Current_Entity (Id);
+
+ elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
+ and then Chars (Selector_Name (Id))
+ = Name_Unchecked_Conversion
+ then
+ Conv := Current_Entity (Selector_Name (Id));
+ else
+ return False;
+ end if;
+
+ return Present (Conv)
+ and then Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Conv)))
+ and then Is_Intrinsic_Subprogram (Conv);
+ end Is_Unchecked_Conversion;
+
+ -- Start of processing for Has_Excluded_Declaration
+
+ begin
+ D := First (Decls);
+ while Present (D) loop
+ if (Nkind (D) = N_Function_Instantiation
+ and then not Is_Unchecked_Conversion (D))
+ or else Nkind_In (D, N_Protected_Type_Declaration,
+ N_Package_Declaration,
+ N_Package_Instantiation,
+ N_Subprogram_Body,
+ N_Procedure_Instantiation,
+ N_Task_Type_Declaration)
+ then
+ Cannot_Inline
+ ("cannot inline & (non-allowed declaration)?", D, Subp);
+
+ return True;
+ end if;
+
+ Next (D);
+ end loop;
+
+ return False;
+ end Has_Excluded_Declaration;
+
+ ----------------------------
+ -- Has_Excluded_Statement --
+ ----------------------------
+
+ function Has_Excluded_Statement (Stats : List_Id) return Boolean is
+ S : Node_Id;
+ E : Node_Id;
+
+ begin
+ S := First (Stats);
+ while Present (S) loop
+ Stat_Count := Stat_Count + 1;
+
+ if Nkind_In (S, N_Abort_Statement,
+ N_Asynchronous_Select,
+ N_Conditional_Entry_Call,
+ N_Delay_Relative_Statement,
+ N_Delay_Until_Statement,
+ N_Selective_Accept,
+ N_Timed_Entry_Call)
+ then
+ Cannot_Inline
+ ("cannot inline & (non-allowed statement)?", S, Subp);
+ return True;
+
+ elsif Nkind (S) = N_Block_Statement then
+ if Present (Declarations (S))
+ and then Has_Excluded_Declaration (Declarations (S))
+ then
+ return True;
+
+ elsif Present (Handled_Statement_Sequence (S)) then
+ if Present
+ (Exception_Handlers (Handled_Statement_Sequence (S)))
+ then
+ Cannot_Inline
+ ("cannot inline& (exception handler)?",
+ First (Exception_Handlers
+ (Handled_Statement_Sequence (S))),
+ Subp);
+ return True;
+
+ elsif Has_Excluded_Statement
+ (Statements (Handled_Statement_Sequence (S)))
+ then
+ return True;
+ end if;
+ end if;
+
+ elsif Nkind (S) = N_Case_Statement then
+ E := First (Alternatives (S));
+ while Present (E) loop
+ if Has_Excluded_Statement (Statements (E)) then
+ return True;
+ end if;
+
+ Next (E);
+ end loop;
+
+ elsif Nkind (S) = N_If_Statement then
+ if Has_Excluded_Statement (Then_Statements (S)) then
+ return True;
+ end if;
+
+ if Present (Elsif_Parts (S)) then
+ E := First (Elsif_Parts (S));
+ while Present (E) loop
+ if Has_Excluded_Statement (Then_Statements (E)) then
+ return True;
+ end if;
+ Next (E);
+ end loop;
+ end if;
+
+ if Present (Else_Statements (S))
+ and then Has_Excluded_Statement (Else_Statements (S))
+ then
+ return True;
+ end if;
+
+ elsif Nkind (S) = N_Loop_Statement
+ and then Has_Excluded_Statement (Statements (S))
+ then
+ return True;
+
+ elsif Nkind (S) = N_Extended_Return_Statement then
+ if Present (Handled_Statement_Sequence (S))
+ and then
+ Has_Excluded_Statement
+ (Statements (Handled_Statement_Sequence (S)))
+ then
+ return True;
+
+ elsif Present (Handled_Statement_Sequence (S))
+ and then
+ Present (Exception_Handlers
+ (Handled_Statement_Sequence (S)))
+ then
+ Cannot_Inline
+ ("cannot inline& (exception handler)?",
+ First (Exception_Handlers
+ (Handled_Statement_Sequence (S))),
+ Subp);
+ return True;
+ end if;
+ end if;
+
+ Next (S);
+ end loop;
+
+ return False;
+ end Has_Excluded_Statement;
+
+ -------------------------------
+ -- Has_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;
+
+ ------------------------------------
+ -- Returns_Compile_Time_Constant --
+ ------------------------------------
+
+ function Returns_Compile_Time_Constant (N : Node_Id) return Boolean is
+
+ function Check_Return (N : Node_Id) return Traverse_Result;
+
+ ------------------
+ -- Check_Return --
+ ------------------
+
+ function Check_Return (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Extended_Return_Statement then
+ return Abandon;
+
+ elsif Nkind (N) = N_Simple_Return_Statement then
+ if Present (Expression (N)) then
+ declare
+ Orig_Expr : constant Node_Id :=
+ Original_Node (Expression (N));
+
+ begin
+ if Nkind_In (Orig_Expr, N_Integer_Literal,
+ N_Real_Literal,
+ N_Character_Literal)
+ then
+ return OK;
+
+ elsif Is_Entity_Name (Orig_Expr)
+ and then Ekind (Entity (Orig_Expr)) = E_Constant
+ and then Is_Static_Expression (Orig_Expr)
+ then
+ return OK;
+ else
+ return Abandon;
+ end if;
+ end;
+
+ -- Expression has wrong form
+
+ else
+ return Abandon;
+ end if;
+
+ -- Continue analyzing statements
+
+ else
+ return OK;
+ end if;
+ end Check_Return;
+
+ function Check_All_Returns is new Traverse_Func (Check_Return);
+
+ -- Start of processing for Returns_Compile_Time_Constant
+
+ begin
+ return Check_All_Returns (N) = OK;
+ end Returns_Compile_Time_Constant;
+
+ --------------------------------------
+ -- Returns_Intrinsic_Function_Call --
+ --------------------------------------
+
+ function Returns_Intrinsic_Function_Call
+ (N : Node_Id) return Boolean
+ is
+ function Check_Return (N : Node_Id) return Traverse_Result;
+
+ ------------------
+ -- Check_Return --
+ ------------------
+
+ function Check_Return (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Extended_Return_Statement then
+ return Abandon;
+
+ elsif Nkind (N) = N_Simple_Return_Statement then
+ if Present (Expression (N)) then
+ declare
+ Orig_Expr : constant Node_Id :=
+ Original_Node (Expression (N));
+
+ begin
+ if Nkind (Orig_Expr) in N_Op
+ and then Is_Intrinsic_Subprogram (Entity (Orig_Expr))
+ then
+ return OK;
+
+ elsif Nkind (Orig_Expr) in N_Has_Entity
+ and then Present (Entity (Orig_Expr))
+ and then Ekind (Entity (Orig_Expr)) = E_Function
+ and then Is_Inlined (Entity (Orig_Expr))
+ then
+ return OK;
+
+ elsif Nkind (Orig_Expr) in N_Has_Entity
+ and then Present (Entity (Orig_Expr))
+ and then Is_Intrinsic_Subprogram (Entity (Orig_Expr))
+ then
+ return OK;
+
+ else
+ return Abandon;
+ end if;
+ end;
+
+ -- Expression has wrong form
+
+ else
+ return Abandon;
+ end if;
+
+ -- Continue analyzing statements
+
+ else
+ return OK;
+ end if;
+ end Check_Return;
+
+ function Check_All_Returns is new Traverse_Func (Check_Return);
+
+ -- Start of processing for Returns_Intrinsic_Function_Call
+
+ begin
+ return Check_All_Returns (N) = OK;
+ end Returns_Intrinsic_Function_Call;
+
+ --------------------------
+ -- Uses_Secondary_Stack --
+ --------------------------
+
+ function Uses_Secondary_Stack (N : 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, Subp);
+
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Check_Call;
+
+ function Check_Calls is new Traverse_Func (Check_Call);
+
+ -- Start of processing for Uses_Secondary_Stack
+
+ begin
+ return Check_Calls (N) = Abandon;
+ end Uses_Secondary_Stack;
+
+ -- Local variables
+
+ Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
+ May_Inline : constant Boolean :=
+ Has_Pragma_Inline_Always (Spec_Id)
+ or else (Has_Pragma_Inline (Spec_Id)
+ and then ((Optimization_Level > 0
+ and then Ekind (Spec_Id)
+ = E_Function)
+ or else Front_End_Inlining));
+ Body_To_Analyze : Node_Id;
+
+ -- Start of processing for Check_Body_To_Inline
+
+ begin
+ -- No action needed in stubs since the attribute Body_To_Inline
+ -- is not available
+
+ if Nkind (Decl) = N_Subprogram_Body_Stub then
+ return False;
+
+ -- 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 False;
+
+ -- No action needed if the subprogram does not fulfill the minimum
+ -- conditions to be inlined by the frontend
+
+ elsif not May_Inline then
+ return False;
+ end if;
+
+ -- Check excluded declarations
+
+ if Present (Declarations (N))
+ and then Has_Excluded_Declaration (Declarations (N))
+ then
+ return False;
+ end if;
+
+ -- Check excluded statements
+
+ 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))),
+ Subp);
+
+ return False;
+
+ elsif Has_Excluded_Statement
+ (Statements (Handled_Statement_Sequence (N)))
+ then
+ return False;
+ end if;
+ end if;
+
+ -- For backward compatibility, compiling under -gnatN we do not
+ -- inline a subprogram that is too large, unless it is marked
+ -- Inline_Always. This pragma does not suppress the other checks
+ -- on inlining (forbidden declarations, handlers, etc).
+
+ if Front_End_Inlining
+ and then not Has_Pragma_Inline_Always (Subp)
+ and then Stat_Count > Max_Size
+ then
+ Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
+ return False;
+ end if;
+
+ -- 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.
+
+ if Has_Pending_Instantiation then
+ Cannot_Inline
+ ("cannot inline& (forward instance within enclosing body)?",
+ N, Subp);
+
+ return False;
+ end if;
+
+ -- Generate and preanalyze the body to inline (needed to perform
+ -- the rest of the checks)
+
+ Generate_Body_To_Inline (N, Body_To_Analyze);
+
+ if Ekind (Subp) = E_Function then
+ Set_Result_Definition (Specification (Body_To_Analyze),
+ New_Occurrence_Of (Etype (Subp), Sloc (N)));
+ end if;
+
+ -- Nest the body to analyze within the real one
+
+ 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);
+ Remove (Body_To_Analyze);
+
+ -- Keep separate checks needed when compiling without optimizations
+
+ if Optimization_Level = 0 then
+
+ -- Cannot inline functions whose body has a call that returns an
+ -- unconstrained type since the secondary stack is involved, and
+ -- it is not worth inlining.
+
+ if Uses_Secondary_Stack (Body_To_Analyze) then
+ return False;
+
+ -- Cannot inline functions that return controlled types since
+ -- controlled actions interfere in complex ways with inlining.
+
+ elsif Ekind (Subp) = E_Function
+ and then Needs_Finalization (Etype (Subp))
+ then
+ Cannot_Inline
+ ("cannot inline & (controlled return type)?", N, Subp);
+ return False;
+
+ elsif Returns_Unconstrained_Type (Subp) then
+ Cannot_Inline
+ ("cannot inline & (unconstrained return type)?", N, Subp);
+ return False;
+ end if;
+
+ -- Compiling with optimizations enabled
+
+ else
+ -- Procedures are never frontend inlined in this case!
+
+ if Ekind (Subp) /= E_Function then
+ return False;
+
+ -- Functions returning unconstrained types are tested
+ -- separately (see Can_Split_Unconstrained_Function).
+
+ elsif Returns_Unconstrained_Type (Subp) then
+ null;
+
+ -- Check supported cases
+
+ elsif not Returns_Compile_Time_Constant (Body_To_Analyze)
+ and then Convention (Subp) /= Convention_Intrinsic
+ and then not Returns_Intrinsic_Function_Call (Body_To_Analyze)
+ then
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end Check_Body_To_Inline;
+
+ --------------------------------------
+ -- Can_Split_Unconstrained_Function --
+ --------------------------------------
+
+ function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean
+ is
+ Ret_Node : constant Node_Id :=
+ First (Statements (Handled_Statement_Sequence (N)));
+ D : Node_Id;
+
+ begin
+ -- No user defined declarations allowed in the function except inside
+ -- the unique return statement; implicit labels are the only allowed
+ -- declarations.
+
+ if not Is_Empty_List (Declarations (N)) then
+ D := First (Declarations (N));
+ while Present (D) loop
+ if Nkind (D) /= N_Implicit_Label_Declaration then
+ return False;
+ end if;
+
+ Next (D);
+ end loop;
+ end if;
+
+ return Present (Ret_Node)
+ and then Nkind (Ret_Node) = N_Extended_Return_Statement
+ and then No (Next (Ret_Node))
+ and then Present (Handled_Statement_Sequence (Ret_Node));
+ end Can_Split_Unconstrained_Function;
+
+ -----------------------------
+ -- Generate_Body_To_Inline --
+ -----------------------------
+
+ procedure Generate_Body_To_Inline
+ (N : Node_Id;
+ Body_To_Inline : out Node_Id)
+ is
+ procedure Remove_Pragmas (N : Node_Id);
+ -- Remove occurrences of pragmas that may reference the formals of
+ -- N. The analysis of the non-inlined body will handle these pragmas
+ -- properly.
+
+ --------------------
+ -- Remove_Pragmas --
+ --------------------
+
+ procedure Remove_Pragmas (N : Node_Id) is
+ Decl : Node_Id;
+ Nxt : Node_Id;
+
+ begin
+ Decl := First (Declarations (N));
+ while Present (Decl) loop
+ Nxt := Next (Decl);
+
+ if Nkind (Decl) = N_Pragma
+ and then (Pragma_Name (Decl) = Name_Unreferenced
+ or else
+ Pragma_Name (Decl) = Name_Unmodified)
+ then
+ Remove (Decl);
+ end if;
+
+ Decl := Nxt;
+ end loop;
+ end Remove_Pragmas;
+
+ -- Start of processing for Generate_Body_To_Inline
+
+ begin
+ -- Within an instance, the body to inline must be treated as a nested
+ -- generic, so that the proper global references are preserved.
+
+ -- Note that we do not do this at the library level, because it
+ -- is not needed, and furthermore this causes trouble if front
+ -- end inlining is activated (-gnatN).
+
+ if In_Instance
+ and then Scope (Current_Scope) /= Standard_Standard
+ then
+ Body_To_Inline := Copy_Generic_Node (N, Empty, True);
+ else
+ Body_To_Inline := Copy_Separate_Tree (N);
+ end if;
+
+ -- A pragma Unreferenced or pragma Unmodified that mentions a formal
+ -- parameter has no meaning when the body is inlined and the formals
+ -- are rewritten. Remove it from body to inline. The analysis of the
+ -- non-inlined body will handle the pragma properly.
+
+ Remove_Pragmas (Body_To_Inline);
+
+ -- We need to capture references to the formals in order
+ -- to substitute the actuals at the point of inlining, i.e.
+ -- instantiation. To treat the formals as globals to the body to
+ -- inline, we nest it within a dummy parameterless subprogram,
+ -- declared within the real one.
+
+ Set_Parameter_Specifications
+ (Specification (Body_To_Inline), No_List);
+
+ -- A new internal name is associated with Body_To_Inline to avoid
+ -- conflicts when the non-inlined body N is analyzed.
+
+ Set_Defining_Unit_Name (Specification (Body_To_Inline),
+ Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P')));
+ Set_Corresponding_Spec (Body_To_Inline, Empty);
+ end Generate_Body_To_Inline;
+
+ ----------------
+ -- Preanalyze --
+ ----------------
+
+ procedure Preanalyze (N : Node_Id) is
+ Save_Full_Analysis : constant Boolean := Full_Analysis;
+
+ begin
+ Full_Analysis := False;
+ Expander_Mode_Save_And_Set (False);
+
+ Analyze (N);
+
+ Expander_Mode_Restore;
+ Full_Analysis := Save_Full_Analysis;
+ end Preanalyze;
+
+ ----------------------------------
+ -- Split_Unconstrained_Function --
+ ----------------------------------
+
+ procedure Split_Unconstrained_Function
+ (N : Node_Id;
+ Spec_Id : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Ret_Node : constant Node_Id :=
+ First (Statements (Handled_Statement_Sequence (N)));
+ Ret_Obj : constant Node_Id :=
+ First (Return_Object_Declarations (Ret_Node));
+
+ procedure Build_Procedure
+ (Proc_Id : out Entity_Id;
+ Decl_List : out List_Id);
+ -- Build a procedure containing the statements found in the extended
+ -- return statement of the unconstrained function body N.
+
+ procedure Build_Procedure
+ (Proc_Id : out Entity_Id;
+ Decl_List : out List_Id)
+ is
+ Formal : Entity_Id;
+ Formal_List : constant List_Id := New_List;
+ Proc_Spec : Node_Id;
+ Proc_Body : Node_Id;
+ Subp_Name : constant Name_Id := New_Internal_Name ('F');
+ Body_Decl_List : List_Id := No_List;
+ Param_Type : Node_Id;
+
+ begin
+ if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then
+ Param_Type := New_Copy (Object_Definition (Ret_Obj));
+ else
+ Param_Type :=
+ New_Copy (Subtype_Mark (Object_Definition (Ret_Obj)));
+ end if;
+
+ Append_To (Formal_List,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Ret_Obj))),
+ In_Present => False,
+ Out_Present => True,
+ Null_Exclusion_Present => False,
+ Parameter_Type => Param_Type));
+
+ Formal := First_Formal (Spec_Id);
+ while Present (Formal) loop
+ Append_To (Formal_List,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Sloc (Formal),
+ Chars => Chars (Formal)),
+ In_Present => In_Present (Parent (Formal)),
+ Out_Present => Out_Present (Parent (Formal)),
+ Null_Exclusion_Present =>
+ Null_Exclusion_Present (Parent (Formal)),
+ Parameter_Type =>
+ New_Reference_To (Etype (Formal), Loc),
+ Expression =>
+ Copy_Separate_Tree (Expression (Parent (Formal)))));
+
+ Next_Formal (Formal);
+ end loop;
+
+ Proc_Id :=
+ Make_Defining_Identifier (Loc, Chars => Subp_Name);
+
+ Proc_Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
+ Parameter_Specifications => Formal_List);
+
+ Decl_List := New_List;
+
+ Append_To (Decl_List,
+ Make_Subprogram_Declaration (Loc, Proc_Spec));
+
+ -- Can_Convert_Unconstrained_Function checked that the function
+ -- has no local declarations except implicit label declarations.
+ -- Copy these declarations to the built procedure.
+
+ if Present (Declarations (N)) then
+ Body_Decl_List := New_List;
+
+ declare
+ D : Node_Id;
+ New_D : Node_Id;
+
+ begin
+ D := First (Declarations (N));
+ while Present (D) loop
+ pragma Assert (Nkind (D) = N_Implicit_Label_Declaration);
+
+ New_D :=
+ Make_Implicit_Label_Declaration (Loc,
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (D))),
+ Label_Construct => Empty);
+ Append_To (Body_Decl_List, New_D);
+
+ Next (D);
+ end loop;
+ end;
+ end if;
+
+ pragma Assert (Present (Handled_Statement_Sequence (Ret_Node)));
+
+ Proc_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification => Copy_Separate_Tree (Proc_Spec),
+ Declarations => Body_Decl_List,
+ Handled_Statement_Sequence =>
+ Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node)));
+
+ Set_Defining_Unit_Name (Specification (Proc_Body),
+ Make_Defining_Identifier (Loc, Subp_Name));
+
+ Append_To (Decl_List, Proc_Body);
+ end Build_Procedure;
+
+ -- Local variables
+
+ New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj);
+ Blk_Stmt : Node_Id;
+ Proc_Id : Entity_Id;
+ Proc_Call : Node_Id;
+
+ -- Start of processing for Split_Unconstrained_Function
+
+ begin
+ -- Build the associated procedure, analyze it and insert it before
+ -- the function body N
+
+ declare
+ Scope : constant Entity_Id := Current_Scope;
+ Decl_List : List_Id;
+ begin
+ Pop_Scope;
+ Build_Procedure (Proc_Id, Decl_List);
+ Insert_Actions (N, Decl_List);
+ 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_Reference_To (Defining_Identifier (New_Obj), Loc));
+
+ Formal := First_Formal (Spec_Id);
+ while Present (Formal) loop
+ Append_To (Actual_List, New_Reference_To (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_Reference_To (Proc_Id, Loc),
+ Parameter_Associations => Actual_List);
+ end;
+
+ -- Generate
+
+ -- declare
+ -- New_Obj : ...
+ -- begin
+ -- main_1__F1b (New_Obj, ...);
+ -- return Obj;
+ -- end B10b;
+
+ 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_Reference_To
+ (Defining_Identifier (New_Obj), Loc)))));
+
+ Rewrite (Ret_Node, Blk_Stmt);
+ end Split_Unconstrained_Function;
+
+ -- Start of processing for Check_And_Build_Body_To_Inline
+
+ begin
+ -- Do not inline any subprogram that contains nested subprograms, since
+ -- the backend inlining circuit seems to generate uninitialized
+ -- references in this case. We know this happens in the case of front
+ -- end ZCX support, but it also appears it can happen in other cases as
+ -- well. The backend often rejects attempts to inline in the case of
+ -- nested procedures anyway, so little if anything is lost by this.
+ -- Note that this is test is for the benefit of the back-end. There is
+ -- a separate test for front-end inlining that also rejects nested
+ -- subprograms.
+
+ -- Do not do this test if errors have been detected, because in some
+ -- error cases, this code blows up, and we don't need it anyway if
+ -- there have been errors, since we won't get to the linker anyway.
+
+ if Comes_From_Source (Body_Id)
+ and then (Has_Pragma_Inline_Always (Spec_Id)
+ or else Optimization_Level > 0)
+ and then Serious_Errors_Detected = 0
+ then
+ declare
+ P_Ent : Node_Id;
+
+ begin
+ P_Ent := Body_Id;
+ loop
+ P_Ent := Scope (P_Ent);
+ exit when No (P_Ent) or else P_Ent = Standard_Standard;
+
+ if Is_Subprogram (P_Ent) then
+ Set_Is_Inlined (P_Ent, False);
+
+ if Comes_From_Source (P_Ent)
+ and then Has_Pragma_Inline (P_Ent)
+ then
+ Cannot_Inline
+ ("cannot inline& (nested subprogram)?", N, P_Ent,
+ Is_Serious => True);
+ end if;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ -- Build the body to inline only if really needed!
+
+ if Check_Body_To_Inline (N, Spec_Id)
+ and then Serious_Errors_Detected = 0
+ then
+ if Returns_Unconstrained_Type (Spec_Id) then
+ 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;
+ else
+ Build_Body_To_Inline (N, Spec_Id);
+ Set_Is_Inlined (Spec_Id);
+ end if;
+ end if;
+ end Check_And_Build_Body_To_Inline;
+
-----------------------
-- Check_Conformance --
-----------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-- and body declarations. Returns the defining entity for the
-- specification N.
- procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id);
+ procedure Cannot_Inline
+ (Msg : String;
+ N : Node_Id;
+ Subp : Entity_Id;
+ Is_Serious : Boolean := False);
-- This procedure is called if the node N, an instance of a call to
-- subprogram Subp, cannot be inlined. Msg is the message to be issued,
- -- and has a ? as the last character. If Subp has a pragma Always_Inlined,
- -- then an error message is issued (by removing the last character of Msg).
- -- If Subp is not Always_Inlined, then a warning is issued if the flag
- -- Ineffective_Inline_Warnings is set, and if not, the call has no effect.
+ -- and has a ? as the last character. Temporarily the behavior of this
+ -- routine depends on the value of -gnatd.k:
+ -- * If -gnatd.k is not set (ie. old inlining model) then if Subp has
+ -- a pragma Always_Inlined, then an error message is issued (by
+ -- removing the last character of Msg). If Subp is not Always_Inlined,
+ -- then a warning is issued if the flag Ineffective_Inline_Warnings
+ -- is set, and if not, the call has no effect.
+ -- * If -gnatd.k is set (ie. new inlining model) then:
+ -- - If Is_Serious is true, then an error is reported (by removing the
+ -- last character of Msg);
+ -- - otherwise:
+ -- * Compiling without optimizations if Subp has a pragma
+ -- Always_Inlined, then an error message is issued; if Subp is
+ -- not Always_Inlined, then a warning is issued if the flag
+ -- Ineffective_Inline_Warnings is set, and if not, the call
+ -- has no effect.
+ -- * Compiling with optimizations then a warning is issued if
+ -- the flag Ineffective_Inline_Warnings is set; otherwise the
+ -- call has no effect since inlining may be performed by the
+ -- backend.
procedure Check_Conventions (Typ : Entity_Id);
-- Ada 2005 (AI-430): Check that the conventions of all inherited and
and then Has_Pragma_Inline_Always (Nam)
and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
and then Present (Body_To_Inline (Unit_Declaration_Node (Nam)))
+ and then not Debug_Flag_Dot_K
+ then
+ null;
+
+ elsif Is_Inlined (Nam)
+ and then Has_Pragma_Inline (Nam)
+ and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
+ and then Present (Body_To_Inline (Unit_Declaration_Node (Nam)))
+ and then Debug_Flag_Dot_K
then
null;
Mark_Allocators (Root_Nod);
end Mark_Coextensions;
+ -----------------
+ -- Must_Inline --
+ -----------------
+
+ function Must_Inline (Subp : Entity_Id) return Boolean is
+ begin
+ return Optimization_Level = 0
+ and then Has_Pragma_Inline (Subp)
+ and then (Has_Pragma_Inline_Always (Subp)
+ or else Front_End_Inlining);
+ end Must_Inline;
+
----------------------
-- Needs_One_Actual --
----------------------
Reset_Analyzed (N);
end Reset_Analyzed_Flags;
+ --------------------------------
+ -- Returns_Unconstrained_Type --
+ --------------------------------
+
+ function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
+ begin
+ return Ekind (Subp) = E_Function
+ and then not Is_Scalar_Type (Etype (Subp))
+ and then not Is_Access_Type (Etype (Subp))
+ and then not Is_Constrained (Etype (Subp));
+ end Returns_Unconstrained_Type;
+
---------------------------
-- Safe_To_Capture_Value --
---------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-- to guarantee this in all cases. Note that it is more possible to give
-- correct answer if the tree is fully analyzed.
+ function Must_Inline (Subp : Entity_Id) return Boolean;
+ -- Return true if Subp must be inlined by the frontend
+
function Needs_One_Actual (E : Entity_Id) return Boolean;
-- Returns True if a function has defaults for all but its first
-- formal. Used in Ada 2005 mode to solve the syntactic ambiguity that
procedure Reset_Analyzed_Flags (N : Node_Id);
-- Reset the Analyzed flags in all nodes of the tree whose root is N
+ function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean;
+ -- Return true if Subp is a function that returns an unconstrained type
+
function Safe_To_Capture_Value
(N : Node_Id;
Ent : Entity_Id;
projects / platform / upstream / linaro-gcc.git / commitdiff