sem_ch3.adb (Analyze_Object_Declaration): If the object declaration has an init expression then stop the analysis of the...
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. From-SVN: r185055
This commit is contained in:
parent
844ec03891
commit
84f4072a8e
|
@ -1,3 +1,45 @@
|
|||
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,
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -100,8 +100,8 @@ package body Debug is
|
|||
-- 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
|
||||
|
@ -533,6 +533,13 @@ package body Debug is
|
|||
-- 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.
|
||||
|
|
|
@ -3525,10 +3525,12 @@ package body Exp_Ch4 is
|
|||
-- 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.
|
||||
|
|
|
@ -51,6 +51,7 @@ with Namet; use Namet;
|
|||
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;
|
||||
|
@ -69,6 +70,7 @@ with Sem_Res; use Sem_Res;
|
|||
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;
|
||||
|
@ -78,6 +80,10 @@ with Validsw; use Validsw;
|
|||
|
||||
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 --
|
||||
-----------------------
|
||||
|
@ -1859,6 +1865,19 @@ package body Exp_Ch6 is
|
|||
-- 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
|
||||
|
@ -1868,6 +1887,9 @@ package body Exp_Ch6 is
|
|||
-- 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
|
||||
|
||||
|
@ -1942,6 +1964,228 @@ package body Exp_Ch6 is
|
|||
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 --
|
||||
---------------------------
|
||||
|
@ -2041,6 +2285,30 @@ package body Exp_Ch6 is
|
|||
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 --
|
||||
-------------------------
|
||||
|
@ -3431,45 +3699,14 @@ package body Exp_Ch6 is
|
|||
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
|
||||
|
@ -3495,7 +3732,7 @@ package body Exp_Ch6 is
|
|||
then
|
||||
Must_Inline := False;
|
||||
|
||||
elsif In_Unfrozen_Instance then
|
||||
elsif In_Unfrozen_Instance (Scope (Subp)) then
|
||||
Must_Inline := False;
|
||||
|
||||
else
|
||||
|
@ -3549,6 +3786,38 @@ package body Exp_Ch6 is
|
|||
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;
|
||||
|
||||
|
@ -3779,9 +4048,9 @@ package body Exp_Ch6 is
|
|||
Remove_Side_Effects (N);
|
||||
end Expand_Ctrl_Function_Call;
|
||||
|
||||
--------------------------
|
||||
-------------------------
|
||||
-- Expand_Inlined_Call --
|
||||
--------------------------
|
||||
-------------------------
|
||||
|
||||
procedure Expand_Inlined_Call
|
||||
(N : Node_Id;
|
||||
|
@ -3796,7 +4065,6 @@ package body Exp_Ch6 is
|
|||
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;
|
||||
|
@ -3810,7 +4078,7 @@ package body Exp_Ch6 is
|
|||
|
||||
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;
|
||||
|
@ -3822,9 +4090,8 @@ package body Exp_Ch6 is
|
|||
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.
|
||||
|
||||
|
@ -3845,6 +4112,12 @@ package body Exp_Ch6 is
|
|||
-- 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.
|
||||
|
@ -4023,6 +4296,13 @@ package body Exp_Ch6 is
|
|||
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;
|
||||
|
@ -4068,6 +4348,43 @@ package body Exp_Ch6 is
|
|||
|
||||
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 --
|
||||
---------------------------
|
||||
|
@ -4138,10 +4455,20 @@ package body Exp_Ch6 is
|
|||
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;
|
||||
|
@ -4234,6 +4561,19 @@ package body Exp_Ch6 is
|
|||
-- 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
|
||||
|
@ -4258,6 +4598,7 @@ package body Exp_Ch6 is
|
|||
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;
|
||||
|
@ -4281,6 +4622,14 @@ package body Exp_Ch6 is
|
|||
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.
|
||||
|
@ -4288,32 +4637,137 @@ package body Exp_Ch6 is
|
|||
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;
|
||||
|
||||
-- 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.
|
||||
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 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 No (Declarations (Bod)) then
|
||||
Set_Declarations (Blk, New_List);
|
||||
end if;
|
||||
|
||||
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;
|
||||
-- For the unconstrained case, capture the name of the local
|
||||
-- variable that holds the result. This must be the first
|
||||
-- declaration in the block, because its bounds cannot depend
|
||||
-- on local variables. Otherwise there is no way to declare the
|
||||
-- result outside of the block. Needless to say, in general the
|
||||
-- bounds will depend on the actuals in the call.
|
||||
|
||||
-- If the context is an assignment statement, as is the case
|
||||
-- for the expansion of an extended return, the left-hand side
|
||||
-- provides bounds even if the return type is unconstrained.
|
||||
|
||||
if Is_Unc then
|
||||
declare
|
||||
First_Decl : Node_Id;
|
||||
|
||||
begin
|
||||
First_Decl := First (Declarations (Blk));
|
||||
|
||||
if Nkind (First_Decl) /= N_Object_Declaration then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Nkind (Parent (N)) /= N_Assignment_Statement then
|
||||
Targ1 := Defining_Identifier (First_Decl);
|
||||
else
|
||||
Targ1 := Name (Parent (N));
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- New semantics
|
||||
|
||||
else
|
||||
declare
|
||||
Bod : Node_Id;
|
||||
|
||||
begin
|
||||
-- General case
|
||||
|
||||
if not Is_Unc then
|
||||
Bod :=
|
||||
Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
|
||||
Blk :=
|
||||
Make_Block_Statement (Loc,
|
||||
Declarations => Declarations (Bod),
|
||||
Handled_Statement_Sequence =>
|
||||
Handled_Statement_Sequence (Bod));
|
||||
|
||||
-- Inline a call to a function that returns an unconstrained type.
|
||||
-- The semantic analyzer checked that frontend-inlined functions
|
||||
-- returning unconstrained types have no declarations and have
|
||||
-- a single extended return statement. As part of its processing
|
||||
-- the function was split 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
|
||||
|
@ -4483,6 +4937,16 @@ package body Exp_Ch6 is
|
|||
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
|
||||
|
||||
|
@ -4523,6 +4987,80 @@ package body Exp_Ch6 is
|
|||
|
||||
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.
|
||||
|
||||
|
@ -4533,7 +5071,14 @@ package body Exp_Ch6 is
|
|||
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.
|
||||
|
@ -4564,8 +5109,18 @@ package body Exp_Ch6 is
|
|||
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;
|
||||
|
@ -4583,11 +5138,14 @@ package body Exp_Ch6 is
|
|||
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
|
||||
|
@ -5566,8 +6124,8 @@ package body Exp_Ch6 is
|
|||
-- 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)))
|
||||
|
@ -8642,4 +9200,75 @@ package body Exp_Ch6 is
|
|||
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;
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -157,6 +157,10 @@ package Exp_Ch6 is
|
|||
-- 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);
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -31,6 +31,7 @@ with Debug; use Debug;
|
|||
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;
|
||||
|
@ -1160,6 +1161,7 @@ begin
|
|||
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
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -642,11 +642,9 @@ package body Inline is
|
|||
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);
|
||||
|
||||
|
@ -669,8 +667,8 @@ package body Inline is
|
|||
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)
|
||||
|
@ -1035,7 +1033,6 @@ package body Inline is
|
|||
|
||||
procedure Initialize is
|
||||
begin
|
||||
Analyzing_Inlined_Bodies := False;
|
||||
Pending_Descriptor.Init;
|
||||
Pending_Instantiations.Init;
|
||||
Inlined_Bodies.Init;
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -110,11 +110,6 @@ package Inline is
|
|||
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 --
|
||||
-----------------
|
||||
|
|
|
@ -25,6 +25,7 @@
|
|||
|
||||
with Aspects; use Aspects;
|
||||
with Atree; use Atree;
|
||||
with Debug; use Debug;
|
||||
with Einfo; use Einfo;
|
||||
with Elists; use Elists;
|
||||
with Errout; use Errout;
|
||||
|
@ -3294,6 +3295,11 @@ package body Sem_Ch12 is
|
|||
-- 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 --
|
||||
-----------------------
|
||||
|
@ -3333,6 +3339,34 @@ package body Sem_Ch12 is
|
|||
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;
|
||||
|
@ -3613,7 +3647,16 @@ package body Sem_Ch12 is
|
|||
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
|
||||
|
|
|
@ -3163,6 +3163,24 @@ package body Sem_Ch3 is
|
|||
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.
|
||||
|
|
|
@ -1852,7 +1852,13 @@ package body Sem_Ch5 is
|
|||
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);
|
||||
|
|
1262
gcc/ada/sem_ch6.adb
1262
gcc/ada/sem_ch6.adb
File diff suppressed because it is too large
Load Diff
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -50,13 +50,33 @@ package Sem_Ch6 is
|
|||
-- 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
|
||||
|
|
|
@ -5611,6 +5611,15 @@ package body Sem_Res is
|
|||
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;
|
||||
|
||||
|
|
|
@ -9389,6 +9389,18 @@ package body Sem_Util is
|
|||
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 --
|
||||
----------------------
|
||||
|
@ -11767,6 +11779,18 @@ package body Sem_Util is
|
|||
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 --
|
||||
---------------------------
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -1115,6 +1115,9 @@ package Sem_Util is
|
|||
-- 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
|
||||
|
@ -1307,6 +1310,9 @@ package Sem_Util is
|
|||
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;
|
||||
|
|
Loading…
Reference in New Issue