diff options
| author | Javier Miranda <miranda@adacore.com> | 2012-03-07 14:56:40 +0000 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2012-03-07 15:56:40 +0100 |
| commit | 84f4072a8e1097b05597a62fb96f28f9c48f868a (patch) | |
| tree | 52cd3c2b010767c3a763388a9abbd0153db9e200 /gcc | |
| parent | 844ec03891e1e5d99d7a8da2860a3ebfbfad62c8 (diff) | |
| download | gcc-84f4072a8e1097b05597a62fb96f28f9c48f868a.zip gcc-84f4072a8e1097b05597a62fb96f28f9c48f868a.tar.gz gcc-84f4072a8e1097b05597a62fb96f28f9c48f868a.tar.bz2 | |
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
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 42 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 771 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/gnat1drv.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/inline.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/inline.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 1262 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.ads | 32 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 8 |
16 files changed, 2148 insertions, 120 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 645f9d5..41b7b0d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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, diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 99ba3d5..3fd2d64 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.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. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 07885c2..dff4e3e 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 2b86d14..1d43e52 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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; + + 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 @@ -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; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 77df2b7..42ba07d 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -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); diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index cd99251..7665c2b 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.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- -- @@ -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 diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 609c803..4735535 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.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- -- @@ -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; diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index 04cb323..63c043d 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -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 -- ----------------- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index d637827..5acd7dc 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 4618a71..3e1059f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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. diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 1ab90ad..42d7756 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -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); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 3679dcc..10d4a63 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -132,6 +132,15 @@ package body Sem_Ch6 is 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; @@ -2514,6 +2523,7 @@ package body Sem_Ch6 is 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 @@ -2534,6 +2544,8 @@ package body Sem_Ch6 is 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 @@ -2842,14 +2854,31 @@ package body Sem_Ch6 is 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 @@ -4086,29 +4115,1224 @@ package body Sem_Ch6 is -- 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 - elsif Has_Pragma_Inline_Always (Subp) 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. - -- Remove last character (question mark) to make this into an error, - -- because the Inline_Always pragma cannot be obeyed. + 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 Is_Serious then + + -- Remove last character (question mark) to make this into an error. Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); - 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 -- ----------------------- diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index 6d5496c..7b38792 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -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 diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4615bca..46a8b19 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 14376bb..9ce15c5 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 -- --------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index d7154a2..2ef728d 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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; |