1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Debug; use Debug;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Errout; use Errout;
31 with Expander; use Expander;
32 with Exp_Ch6; use Exp_Ch6;
33 with Exp_Ch7; use Exp_Ch7;
34 with Exp_Tss; use Exp_Tss;
35 with Exp_Util; use Exp_Util;
36 with Fname; use Fname;
37 with Fname.UF; use Fname.UF;
39 with Namet; use Namet;
40 with Nmake; use Nmake;
41 with Nlists; use Nlists;
42 with Output; use Output;
43 with Sem_Aux; use Sem_Aux;
44 with Sem_Ch8; use Sem_Ch8;
45 with Sem_Ch10; use Sem_Ch10;
46 with Sem_Ch12; use Sem_Ch12;
47 with Sem_Prag; use Sem_Prag;
48 with Sem_Util; use Sem_Util;
49 with Sinfo; use Sinfo;
50 with Sinput; use Sinput;
51 with Snames; use Snames;
52 with Stand; use Stand;
53 with Uname; use Uname;
54 with Tbuild; use Tbuild;
56 package body Inline is
58 Check_Inlining_Restrictions : constant Boolean := True;
59 -- In the following cases the frontend rejects inlining because they
60 -- are not handled well by the backend. This variable facilitates
61 -- disabling these restrictions to evaluate future versions of the
62 -- GCC backend in which some of the restrictions may be supported.
64 -- - subprograms that have:
65 -- - nested subprograms
67 -- - package declarations
68 -- - task or protected object declarations
69 -- - some of the following statements:
71 -- - asynchronous-select
72 -- - conditional-entry-call
78 Inlined_Calls : Elist_Id;
79 -- List of frontend inlined calls
81 Backend_Calls : Elist_Id;
82 -- List of inline calls passed to the backend
84 Backend_Inlined_Subps : Elist_Id;
85 -- List of subprograms inlined by the backend
87 Backend_Not_Inlined_Subps : Elist_Id;
88 -- List of subprograms that cannot be inlined by the backend
94 -- Inlined functions are actually placed in line by the backend if the
95 -- corresponding bodies are available (i.e. compiled). Whenever we find
96 -- a call to an inlined subprogram, we add the name of the enclosing
97 -- compilation unit to a worklist. After all compilation, and after
98 -- expansion of generic bodies, we traverse the list of pending bodies
99 -- and compile them as well.
101 package Inlined_Bodies is new Table.Table (
102 Table_Component_Type => Entity_Id,
103 Table_Index_Type => Int,
104 Table_Low_Bound => 0,
105 Table_Initial => Alloc.Inlined_Bodies_Initial,
106 Table_Increment => Alloc.Inlined_Bodies_Increment,
107 Table_Name => "Inlined_Bodies");
109 -----------------------
110 -- Inline Processing --
111 -----------------------
113 -- For each call to an inlined subprogram, we make entries in a table
114 -- that stores caller and callee, and indicates the call direction from
115 -- one to the other. We also record the compilation unit that contains
116 -- the callee. After analyzing the bodies of all such compilation units,
117 -- we compute the transitive closure of inlined subprograms called from
118 -- the main compilation unit and make it available to the code generator
119 -- in no particular order, thus allowing cycles in the call graph.
121 Last_Inlined : Entity_Id := Empty;
123 -- For each entry in the table we keep a list of successors in topological
124 -- order, i.e. callers of the current subprogram.
126 type Subp_Index is new Nat;
127 No_Subp : constant Subp_Index := 0;
129 -- The subprogram entities are hashed into the Inlined table
131 Num_Hash_Headers : constant := 512;
133 Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1)
136 type Succ_Index is new Nat;
137 No_Succ : constant Succ_Index := 0;
139 type Succ_Info is record
144 -- The following table stores list elements for the successor lists. These
145 -- lists cannot be chained directly through entries in the Inlined table,
146 -- because a given subprogram can appear in several such lists.
148 package Successors is new Table.Table (
149 Table_Component_Type => Succ_Info,
150 Table_Index_Type => Succ_Index,
151 Table_Low_Bound => 1,
152 Table_Initial => Alloc.Successors_Initial,
153 Table_Increment => Alloc.Successors_Increment,
154 Table_Name => "Successors");
156 type Subp_Info is record
157 Name : Entity_Id := Empty;
158 Next : Subp_Index := No_Subp;
159 First_Succ : Succ_Index := No_Succ;
160 Listed : Boolean := False;
161 Main_Call : Boolean := False;
162 Processed : Boolean := False;
165 package Inlined is new Table.Table (
166 Table_Component_Type => Subp_Info,
167 Table_Index_Type => Subp_Index,
168 Table_Low_Bound => 1,
169 Table_Initial => Alloc.Inlined_Initial,
170 Table_Increment => Alloc.Inlined_Increment,
171 Table_Name => "Inlined");
173 -----------------------
174 -- Local Subprograms --
175 -----------------------
177 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty);
178 -- Make two entries in Inlined table, for an inlined subprogram being
179 -- called, and for the inlined subprogram that contains the call. If
180 -- the call is in the main compilation unit, Caller is Empty.
182 procedure Add_Inlined_Subprogram (Index : Subp_Index);
183 -- Add the subprogram to the list of inlined subprogram for the unit
185 function Add_Subp (E : Entity_Id) return Subp_Index;
186 -- Make entry in Inlined table for subprogram E, or return table index
187 -- that already holds E.
189 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id;
190 pragma Inline (Get_Code_Unit_Entity);
191 -- Return the entity node for the unit containing E. Always return the spec
194 function Has_Initialized_Type (E : Entity_Id) return Boolean;
195 -- If a candidate for inlining contains type declarations for types with
196 -- non-trivial initialization procedures, they are not worth inlining.
198 function Has_Single_Return (N : Node_Id) return Boolean;
199 -- In general we cannot inline functions that return unconstrained type.
200 -- However, we can handle such functions if all return statements return a
201 -- local variable that is the only declaration in the body of the function.
202 -- In that case the call can be replaced by that local variable as is done
203 -- for other inlined calls.
205 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean;
206 -- Return True if E is in the main unit or its spec or in a subunit
208 function Is_Nested (E : Entity_Id) return Boolean;
209 -- If the function is nested inside some other function, it will always
210 -- be compiled if that function is, so don't add it to the inline list.
211 -- We cannot compile a nested function outside the scope of the containing
212 -- function anyway. This is also the case if the function is defined in a
213 -- task body or within an entry (for example, an initialization procedure).
215 procedure Remove_Pragmas (Bod : Node_Id);
216 -- A pragma Unreferenced or pragma Unmodified that mentions a formal
217 -- parameter has no meaning when the body is inlined and the formals
218 -- are rewritten. Remove it from body to inline. The analysis of the
219 -- non-inlined body will handle the pragma properly.
221 ------------------------------
222 -- Deferred Cleanup Actions --
223 ------------------------------
225 -- The cleanup actions for scopes that contain instantiations is delayed
226 -- until after expansion of those instantiations, because they may contain
227 -- finalizable objects or tasks that affect the cleanup code. A scope
228 -- that contains instantiations only needs to be finalized once, even
229 -- if it contains more than one instance. We keep a list of scopes
230 -- that must still be finalized, and call cleanup_actions after all
231 -- the instantiations have been completed.
235 procedure Add_Scope_To_Clean (Inst : Entity_Id);
236 -- Build set of scopes on which cleanup actions must be performed
238 procedure Cleanup_Scopes;
239 -- Complete cleanup actions on scopes that need it
245 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
246 P1 : constant Subp_Index := Add_Subp (Called);
251 if Present (Caller) then
252 P2 := Add_Subp (Caller);
254 -- Add P1 to the list of successors of P2, if not already there.
255 -- Note that P2 may contain more than one call to P1, and only
256 -- one needs to be recorded.
258 J := Inlined.Table (P2).First_Succ;
259 while J /= No_Succ loop
260 if Successors.Table (J).Subp = P1 then
264 J := Successors.Table (J).Next;
267 -- On exit, make a successor entry for P1
269 Successors.Increment_Last;
270 Successors.Table (Successors.Last).Subp := P1;
271 Successors.Table (Successors.Last).Next :=
272 Inlined.Table (P2).First_Succ;
273 Inlined.Table (P2).First_Succ := Successors.Last;
275 Inlined.Table (P1).Main_Call := True;
279 ----------------------
280 -- Add_Inlined_Body --
281 ----------------------
283 procedure Add_Inlined_Body (E : Entity_Id) is
285 type Inline_Level_Type is (Dont_Inline, Inline_Call, Inline_Package);
286 -- Level of inlining for the call: Dont_Inline means no inlining,
287 -- Inline_Call means that only the call is considered for inlining,
288 -- Inline_Package means that the call is considered for inlining and
289 -- its package compiled and scanned for more inlining opportunities.
291 function Must_Inline return Inline_Level_Type;
292 -- Inlining is only done if the call statement N is in the main unit,
293 -- or within the body of another inlined subprogram.
299 function Must_Inline return Inline_Level_Type is
304 -- Check if call is in main unit
306 Scop := Current_Scope;
308 -- Do not try to inline if scope is standard. This could happen, for
309 -- example, for a call to Add_Global_Declaration, and it causes
310 -- trouble to try to inline at this level.
312 if Scop = Standard_Standard then
316 -- Otherwise lookup scope stack to outer scope
318 while Scope (Scop) /= Standard_Standard
319 and then not Is_Child_Unit (Scop)
321 Scop := Scope (Scop);
324 Comp := Parent (Scop);
325 while Nkind (Comp) /= N_Compilation_Unit loop
326 Comp := Parent (Comp);
329 -- If the call is in the main unit, inline the call and compile the
330 -- package of the subprogram to find more calls to be inlined.
332 if Comp = Cunit (Main_Unit)
333 or else Comp = Library_Unit (Cunit (Main_Unit))
336 return Inline_Package;
339 -- The call is not in the main unit. See if it is in some inlined
340 -- subprogram. If so, inline the call and, if the inlining level is
341 -- set to 1, stop there; otherwise also compile the package as above.
343 Scop := Current_Scope;
344 while Scope (Scop) /= Standard_Standard
345 and then not Is_Child_Unit (Scop)
347 if Is_Overloadable (Scop) and then Is_Inlined (Scop) then
350 if Inline_Level = 1 then
353 return Inline_Package;
357 Scop := Scope (Scop);
363 Level : Inline_Level_Type;
365 -- Start of processing for Add_Inlined_Body
368 -- Find unit containing E, and add to list of inlined bodies if needed.
369 -- If the body is already present, no need to load any other unit. This
370 -- is the case for an initialization procedure, which appears in the
371 -- package declaration that contains the type. It is also the case if
372 -- the body has already been analyzed. Finally, if the unit enclosing
373 -- E is an instance, the instance body will be analyzed in any case,
374 -- and there is no need to add the enclosing unit (whose body might not
377 -- Library-level functions must be handled specially, because there is
378 -- no enclosing package to retrieve. In this case, it is the body of
379 -- the function that will have to be loaded.
381 if Is_Abstract_Subprogram (E)
382 or else Is_Nested (E)
383 or else Convention (E) = Convention_Protected
388 Level := Must_Inline;
389 if Level /= Dont_Inline then
391 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
396 -- Library-level inlined function. Add function itself to
397 -- list of needed units.
400 Inlined_Bodies.Increment_Last;
401 Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
403 elsif Ekind (Pack) = E_Package then
406 if Is_Generic_Instance (Pack) then
409 -- Do not inline the package if the subprogram is an init proc
410 -- or other internally generated subprogram, because in that
411 -- case the subprogram body appears in the same unit that
412 -- declares the type, and that body is visible to the back end.
413 -- Do not inline it either if it is in the main unit.
415 elsif Level = Inline_Package
416 and then not Is_Inlined (Pack)
417 and then not Is_Internal (E)
418 and then not In_Main_Unit_Or_Subunit (Pack)
420 Set_Is_Inlined (Pack);
421 Inlined_Bodies.Increment_Last;
422 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
424 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
425 -- calls if the back-end takes care of inlining the call.
427 elsif Level = Inline_Call
428 and then Has_Pragma_Inline_Always (E)
429 and then Back_End_Inlining
431 Set_Is_Inlined (Pack);
432 Inlined_Bodies.Increment_Last;
433 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
438 end Add_Inlined_Body;
440 ----------------------------
441 -- Add_Inlined_Subprogram --
442 ----------------------------
444 procedure Add_Inlined_Subprogram (Index : Subp_Index) is
445 E : constant Entity_Id := Inlined.Table (Index).Name;
446 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
448 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id);
449 -- Append Subp to the list of subprograms inlined by the backend
451 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id);
452 -- Append Subp to the list of subprograms that cannot be inlined by
455 -----------------------------------------
456 -- Register_Backend_Inlined_Subprogram --
457 -----------------------------------------
459 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is
461 Append_New_Elmt (Subp, To => Backend_Inlined_Subps);
462 end Register_Backend_Inlined_Subprogram;
464 ---------------------------------------------
465 -- Register_Backend_Not_Inlined_Subprogram --
466 ---------------------------------------------
468 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is
470 Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps);
471 end Register_Backend_Not_Inlined_Subprogram;
473 -- Start of processing for Add_Inlined_Subprogram
476 -- If the subprogram is to be inlined, and if its unit is known to be
477 -- inlined or is an instance whose body will be analyzed anyway or the
478 -- subprogram has been generated by the compiler, and if it is declared
479 -- at the library level not in the main unit, and if it can be inlined
480 -- by the back-end, then insert it in the list of inlined subprograms.
483 and then (Is_Inlined (Pack)
484 or else Is_Generic_Instance (Pack)
485 or else Is_Internal (E))
486 and then not In_Main_Unit_Or_Subunit (E)
487 and then not Is_Nested (E)
488 and then not Has_Initialized_Type (E)
490 Register_Backend_Inlined_Subprogram (E);
492 if No (Last_Inlined) then
493 Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
495 Set_Next_Inlined_Subprogram (Last_Inlined, E);
500 Register_Backend_Not_Inlined_Subprogram (E);
503 Inlined.Table (Index).Listed := True;
504 end Add_Inlined_Subprogram;
506 ------------------------
507 -- Add_Scope_To_Clean --
508 ------------------------
510 procedure Add_Scope_To_Clean (Inst : Entity_Id) is
511 Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
515 -- If the instance appears in a library-level package declaration,
516 -- all finalization is global, and nothing needs doing here.
518 if Scop = Standard_Standard then
522 -- If the instance is within a generic unit, no finalization code
523 -- can be generated. Note that at this point all bodies have been
524 -- analyzed, and the scope stack itself is not present, and the flag
525 -- Inside_A_Generic is not set.
532 while Present (S) and then S /= Standard_Standard loop
533 if Is_Generic_Unit (S) then
541 Elmt := First_Elmt (To_Clean);
542 while Present (Elmt) loop
543 if Node (Elmt) = Scop then
547 Elmt := Next_Elmt (Elmt);
550 Append_Elmt (Scop, To_Clean);
551 end Add_Scope_To_Clean;
557 function Add_Subp (E : Entity_Id) return Subp_Index is
558 Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
562 -- Initialize entry in Inlined table
564 procedure New_Entry is
566 Inlined.Increment_Last;
567 Inlined.Table (Inlined.Last).Name := E;
568 Inlined.Table (Inlined.Last).Next := No_Subp;
569 Inlined.Table (Inlined.Last).First_Succ := No_Succ;
570 Inlined.Table (Inlined.Last).Listed := False;
571 Inlined.Table (Inlined.Last).Main_Call := False;
572 Inlined.Table (Inlined.Last).Processed := False;
575 -- Start of processing for Add_Subp
578 if Hash_Headers (Index) = No_Subp then
580 Hash_Headers (Index) := Inlined.Last;
584 J := Hash_Headers (Index);
585 while J /= No_Subp loop
586 if Inlined.Table (J).Name = E then
590 J := Inlined.Table (J).Next;
594 -- On exit, subprogram was not found. Enter in table. Index is
595 -- the current last entry on the hash chain.
598 Inlined.Table (Index).Next := Inlined.Last;
603 ----------------------------
604 -- Analyze_Inlined_Bodies --
605 ----------------------------
607 procedure Analyze_Inlined_Bodies is
614 type Pending_Index is new Nat;
616 package Pending_Inlined is new Table.Table (
617 Table_Component_Type => Subp_Index,
618 Table_Index_Type => Pending_Index,
619 Table_Low_Bound => 1,
620 Table_Initial => Alloc.Inlined_Initial,
621 Table_Increment => Alloc.Inlined_Increment,
622 Table_Name => "Pending_Inlined");
623 -- The workpile used to compute the transitive closure
625 function Is_Ancestor_Of_Main
627 Nam : Node_Id) return Boolean;
628 -- Determine whether the unit whose body is loaded is an ancestor of
629 -- the main unit, and has a with_clause on it. The body is not
630 -- analyzed yet, so the check is purely lexical: the name of the with
631 -- clause is a selected component, and names of ancestors must match.
633 -------------------------
634 -- Is_Ancestor_Of_Main --
635 -------------------------
637 function Is_Ancestor_Of_Main
639 Nam : Node_Id) return Boolean
644 if Nkind (Nam) /= N_Selected_Component then
648 if Chars (Selector_Name (Nam)) /=
649 Chars (Cunit_Entity (Main_Unit))
654 Pref := Prefix (Nam);
655 if Nkind (Pref) = N_Identifier then
657 -- Par is an ancestor of Par.Child.
659 return Chars (Pref) = Chars (U_Name);
661 elsif Nkind (Pref) = N_Selected_Component
662 and then Chars (Selector_Name (Pref)) = Chars (U_Name)
664 -- Par.Child is an ancestor of Par.Child.Grand.
666 return True; -- should check that ancestor match
669 -- A is an ancestor of A.B.C if it is an ancestor of A.B
671 return Is_Ancestor_Of_Main (U_Name, Pref);
674 end Is_Ancestor_Of_Main;
676 -- Start of processing for Analyze_Inlined_Bodies
679 if Serious_Errors_Detected = 0 then
680 Push_Scope (Standard_Standard);
683 while J <= Inlined_Bodies.Last
684 and then Serious_Errors_Detected = 0
686 Pack := Inlined_Bodies.Table (J);
688 and then Scope (Pack) /= Standard_Standard
689 and then not Is_Child_Unit (Pack)
691 Pack := Scope (Pack);
694 Comp_Unit := Parent (Pack);
695 while Present (Comp_Unit)
696 and then Nkind (Comp_Unit) /= N_Compilation_Unit
698 Comp_Unit := Parent (Comp_Unit);
701 -- Load the body, unless it is the main unit, or is an instance
702 -- whose body has already been analyzed.
704 if Present (Comp_Unit)
705 and then Comp_Unit /= Cunit (Main_Unit)
706 and then Body_Required (Comp_Unit)
707 and then (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
708 or else No (Corresponding_Body (Unit (Comp_Unit))))
711 Bname : constant Unit_Name_Type :=
712 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
717 if not Is_Loaded (Bname) then
718 Style_Check := False;
719 Load_Needed_Body (Comp_Unit, OK, Do_Analyze => False);
723 -- Warn that a body was not available for inlining
726 Error_Msg_Unit_1 := Bname;
728 ("one or more inlined subprograms accessed in $!??",
731 Get_File_Name (Bname, Subunit => False);
732 Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
735 -- If the package to be inlined is an ancestor unit of
736 -- the main unit, and it has a semantic dependence on
737 -- it, the inlining cannot take place to prevent an
738 -- elaboration circularity. The desired body is not
739 -- analyzed yet, to prevent the completion of Taft
740 -- amendment types that would lead to elaboration
741 -- circularities in gigi.
744 U_Id : constant Entity_Id :=
745 Defining_Entity (Unit (Comp_Unit));
746 Body_Unit : constant Node_Id :=
747 Library_Unit (Comp_Unit);
751 Item := First (Context_Items (Body_Unit));
752 while Present (Item) loop
753 if Nkind (Item) = N_With_Clause
755 Is_Ancestor_Of_Main (U_Id, Name (Item))
757 Set_Is_Inlined (U_Id, False);
764 -- If no suspicious with_clauses, analyze the body.
766 if Is_Inlined (U_Id) then
767 Semantics (Body_Unit);
778 -- The analysis of required bodies may have produced additional
779 -- generic instantiations. To obtain further inlining, we perform
780 -- another round of generic body instantiations. Establishing a
781 -- fully recursive loop between inlining and generic instantiations
782 -- is unlikely to yield more than this one additional pass.
786 -- The list of inlined subprograms is an overestimate, because it
787 -- includes inlined functions called from functions that are compiled
788 -- as part of an inlined package, but are not themselves called. An
789 -- accurate computation of just those subprograms that are needed
790 -- requires that we perform a transitive closure over the call graph,
791 -- starting from calls in the main program.
793 for Index in Inlined.First .. Inlined.Last loop
794 if not Is_Called (Inlined.Table (Index).Name) then
796 -- This means that Add_Inlined_Body added the subprogram to the
797 -- table but wasn't able to handle its code unit. Do nothing.
799 Inlined.Table (Index).Processed := True;
801 elsif Inlined.Table (Index).Main_Call then
802 Pending_Inlined.Increment_Last;
803 Pending_Inlined.Table (Pending_Inlined.Last) := Index;
804 Inlined.Table (Index).Processed := True;
807 Set_Is_Called (Inlined.Table (Index).Name, False);
811 -- Iterate over the workpile until it is emptied, propagating the
812 -- Is_Called flag to the successors of the processed subprogram.
814 while Pending_Inlined.Last >= Pending_Inlined.First loop
815 Subp := Pending_Inlined.Table (Pending_Inlined.Last);
816 Pending_Inlined.Decrement_Last;
818 S := Inlined.Table (Subp).First_Succ;
820 while S /= No_Succ loop
821 Subp := Successors.Table (S).Subp;
823 if not Inlined.Table (Subp).Processed then
824 Set_Is_Called (Inlined.Table (Subp).Name);
825 Pending_Inlined.Increment_Last;
826 Pending_Inlined.Table (Pending_Inlined.Last) := Subp;
827 Inlined.Table (Subp).Processed := True;
830 S := Successors.Table (S).Next;
834 -- Finally add the called subprograms to the list of inlined
835 -- subprograms for the unit.
837 for Index in Inlined.First .. Inlined.Last loop
838 if Is_Called (Inlined.Table (Index).Name)
839 and then not Inlined.Table (Index).Listed
841 Add_Inlined_Subprogram (Index);
847 end Analyze_Inlined_Bodies;
849 --------------------------
850 -- Build_Body_To_Inline --
851 --------------------------
853 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
854 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
855 Analysis_Status : constant Boolean := Full_Analysis;
856 Original_Body : Node_Id;
857 Body_To_Analyze : Node_Id;
858 Max_Size : constant := 10;
860 function Has_Pending_Instantiation return Boolean;
861 -- If some enclosing body contains instantiations that appear before
862 -- the corresponding generic body, the enclosing body has a freeze node
863 -- so that it can be elaborated after the generic itself. This might
864 -- conflict with subsequent inlinings, so that it is unsafe to try to
865 -- inline in such a case.
867 function Has_Single_Return_In_GNATprove_Mode return Boolean;
868 -- This function is called only in GNATprove mode, and it returns
869 -- True if the subprogram has no return statement or a single return
870 -- statement as last statement. It returns False for subprogram with
871 -- a single return as last statement inside one or more blocks, as
872 -- inlining would generate gotos in that case as well (although the
873 -- goto is useless in that case).
875 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
876 -- If the body of the subprogram includes a call that returns an
877 -- unconstrained type, the secondary stack is involved, and it
878 -- is not worth inlining.
880 -------------------------------
881 -- Has_Pending_Instantiation --
882 -------------------------------
884 function Has_Pending_Instantiation return Boolean is
889 while Present (S) loop
890 if Is_Compilation_Unit (S)
891 or else Is_Child_Unit (S)
895 elsif Ekind (S) = E_Package
896 and then Has_Forward_Instantiation (S)
905 end Has_Pending_Instantiation;
907 -----------------------------------------
908 -- Has_Single_Return_In_GNATprove_Mode --
909 -----------------------------------------
911 function Has_Single_Return_In_GNATprove_Mode return Boolean is
912 Last_Statement : Node_Id := Empty;
914 function Check_Return (N : Node_Id) return Traverse_Result;
915 -- Returns OK on node N if this is not a return statement different
916 -- from the last statement in the subprogram.
922 function Check_Return (N : Node_Id) return Traverse_Result is
924 if Nkind_In (N, N_Simple_Return_Statement,
925 N_Extended_Return_Statement)
927 if N = Last_Statement then
938 function Check_All_Returns is new Traverse_Func (Check_Return);
940 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
943 -- Retrieve the last statement
945 Last_Statement := Last (Statements (Handled_Statement_Sequence (N)));
947 -- Check that the last statement is the only possible return
948 -- statement in the subprogram.
950 return Check_All_Returns (N) = OK;
951 end Has_Single_Return_In_GNATprove_Mode;
953 --------------------------
954 -- Uses_Secondary_Stack --
955 --------------------------
957 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
958 function Check_Call (N : Node_Id) return Traverse_Result;
959 -- Look for function calls that return an unconstrained type
965 function Check_Call (N : Node_Id) return Traverse_Result is
967 if Nkind (N) = N_Function_Call
968 and then Is_Entity_Name (Name (N))
969 and then Is_Composite_Type (Etype (Entity (Name (N))))
970 and then not Is_Constrained (Etype (Entity (Name (N))))
973 ("cannot inline & (call returns unconstrained type)?",
981 function Check_Calls is new Traverse_Func (Check_Call);
984 return Check_Calls (Bod) = Abandon;
985 end Uses_Secondary_Stack;
987 -- Start of processing for Build_Body_To_Inline
990 -- Return immediately if done already
992 if Nkind (Decl) = N_Subprogram_Declaration
993 and then Present (Body_To_Inline (Decl))
997 -- Subprograms that have return statements in the middle of the body are
998 -- inlined with gotos. GNATprove does not currently support gotos, so
999 -- we prevent such inlining.
1001 elsif GNATprove_Mode
1002 and then not Has_Single_Return_In_GNATprove_Mode
1004 Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
1007 -- Functions that return unconstrained composite types require
1008 -- secondary stack handling, and cannot currently be inlined, unless
1009 -- all return statements return a local variable that is the first
1010 -- local declaration in the body.
1012 elsif Ekind (Spec_Id) = E_Function
1013 and then not Is_Scalar_Type (Etype (Spec_Id))
1014 and then not Is_Access_Type (Etype (Spec_Id))
1015 and then not Is_Constrained (Etype (Spec_Id))
1017 if not Has_Single_Return (N) then
1019 ("cannot inline & (unconstrained return type)?", N, Spec_Id);
1023 -- Ditto for functions that return controlled types, where controlled
1024 -- actions interfere in complex ways with inlining.
1026 elsif Ekind (Spec_Id) = E_Function
1027 and then Needs_Finalization (Etype (Spec_Id))
1030 ("cannot inline & (controlled return type)?", N, Spec_Id);
1034 if Present (Declarations (N))
1035 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
1040 if Present (Handled_Statement_Sequence (N)) then
1041 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1043 ("cannot inline& (exception handler)?",
1044 First (Exception_Handlers (Handled_Statement_Sequence (N))),
1048 elsif Has_Excluded_Statement
1049 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
1055 -- We do not inline a subprogram that is too large, unless it is marked
1056 -- Inline_Always or we are in GNATprove mode. This pragma does not
1057 -- suppress the other checks on inlining (forbidden declarations,
1060 if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode)
1061 and then List_Length
1062 (Statements (Handled_Statement_Sequence (N))) > Max_Size
1064 Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id);
1068 if Has_Pending_Instantiation then
1070 ("cannot inline& (forward instance within enclosing body)?",
1075 -- Within an instance, the body to inline must be treated as a nested
1076 -- generic, so that the proper global references are preserved.
1078 -- Note that we do not do this at the library level, because it is not
1079 -- needed, and furthermore this causes trouble if front end inlining
1080 -- is activated (-gnatN).
1082 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1083 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1084 Original_Body := Copy_Generic_Node (N, Empty, True);
1086 Original_Body := Copy_Separate_Tree (N);
1089 -- We need to capture references to the formals in order to substitute
1090 -- the actuals at the point of inlining, i.e. instantiation. To treat
1091 -- the formals as globals to the body to inline, we nest it within a
1092 -- dummy parameterless subprogram, declared within the real one. To
1093 -- avoid generating an internal name (which is never public, and which
1094 -- affects serial numbers of other generated names), we use an internal
1095 -- symbol that cannot conflict with user declarations.
1097 Set_Parameter_Specifications (Specification (Original_Body), No_List);
1098 Set_Defining_Unit_Name
1099 (Specification (Original_Body),
1100 Make_Defining_Identifier (Sloc (N), Name_uParent));
1101 Set_Corresponding_Spec (Original_Body, Empty);
1103 -- Remove those pragmas that have no meaining in an inlined body.
1105 Remove_Pragmas (Original_Body);
1107 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
1109 -- Set return type of function, which is also global and does not need
1112 if Ekind (Spec_Id) = E_Function then
1113 Set_Result_Definition (Specification (Body_To_Analyze),
1114 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1117 if No (Declarations (N)) then
1118 Set_Declarations (N, New_List (Body_To_Analyze));
1120 Append (Body_To_Analyze, Declarations (N));
1123 -- The body to inline is pre-analyzed. In GNATprove mode we must
1124 -- disable full analysis as well so that light expansion does not
1125 -- take place either, and name resolution is unaffected.
1127 Expander_Mode_Save_And_Set (False);
1128 Full_Analysis := False;
1130 Analyze (Body_To_Analyze);
1131 Push_Scope (Defining_Entity (Body_To_Analyze));
1132 Save_Global_References (Original_Body);
1134 Remove (Body_To_Analyze);
1136 Expander_Mode_Restore;
1137 Full_Analysis := Analysis_Status;
1139 -- Restore environment if previously saved
1141 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1145 -- If secondary stack is used, there is no point in inlining. We have
1146 -- already issued the warning in this case, so nothing to do.
1148 if Uses_Secondary_Stack (Body_To_Analyze) then
1152 Set_Body_To_Inline (Decl, Original_Body);
1153 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1154 Set_Is_Inlined (Spec_Id);
1155 end Build_Body_To_Inline;
1161 procedure Cannot_Inline
1165 Is_Serious : Boolean := False)
1168 -- In GNATprove mode, inlining is the technical means by which the
1169 -- higher-level goal of contextual analysis is reached, so issue
1170 -- messages about failure to apply contextual analysis to a
1171 -- subprogram, rather than failure to inline it.
1174 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
1177 Len1 : constant Positive :=
1178 String (String'("cannot inline"))'Length;
1179 Len2 : constant Positive :=
1180 String (String'("info: no contextual analysis of"))'Length;
1182 New_Msg : String (1 .. Msg'Length + Len2 - Len1);
1185 New_Msg (1 .. Len2) := "info: no contextual analysis of";
1186 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
1187 Msg (Msg'First + Len1 .. Msg'Last);
1188 Cannot_Inline (New_Msg, N, Subp, Is_Serious);
1193 pragma Assert (Msg (Msg'Last) = '?');
1195 -- Legacy front end inlining model
1197 if not Back_End_Inlining then
1199 -- Do not emit warning if this is a predefined unit which is not
1200 -- the main unit. With validity checks enabled, some predefined
1201 -- subprograms may contain nested subprograms and become ineligible
1204 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
1205 and then not In_Extended_Main_Source_Unit (Subp)
1209 -- In GNATprove mode, issue a warning, and indicate that the
1210 -- subprogram is not always inlined by setting flag Is_Inlined_Always
1213 elsif GNATprove_Mode then
1214 Set_Is_Inlined_Always (Subp, False);
1215 Error_Msg_NE (Msg & "p?", N, Subp);
1217 elsif Has_Pragma_Inline_Always (Subp) then
1219 -- Remove last character (question mark) to make this into an
1220 -- error, because the Inline_Always pragma cannot be obeyed.
1222 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1224 elsif Ineffective_Inline_Warnings then
1225 Error_Msg_NE (Msg & "p?", N, Subp);
1232 elsif Is_Serious then
1234 -- Remove last character (question mark) to make this into an error.
1236 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1238 -- In GNATprove mode, issue a warning, and indicate that the subprogram
1239 -- is not always inlined by setting flag Is_Inlined_Always to False.
1241 elsif GNATprove_Mode then
1242 Set_Is_Inlined_Always (Subp, False);
1243 Error_Msg_NE (Msg & "p?", N, Subp);
1245 -- Do not issue errors/warnings when compiling with optimizations
1247 elsif Optimization_Level = 0 then
1249 -- Do not emit warning if this is a predefined unit which is not
1250 -- the main unit. This behavior is currently provided for backward
1251 -- compatibility but it will be removed when we enforce the
1252 -- strictness of the new rules.
1254 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
1255 and then not In_Extended_Main_Source_Unit (Subp)
1259 elsif Has_Pragma_Inline_Always (Subp) then
1261 -- Emit a warning if this is a call to a runtime subprogram
1262 -- which is located inside a generic. Previously this call
1263 -- was silently skipped.
1265 if Is_Generic_Instance (Subp) then
1267 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
1269 if Is_Predefined_File_Name
1270 (Unit_File_Name (Get_Source_Unit (Gen_P)))
1272 Set_Is_Inlined (Subp, False);
1273 Error_Msg_NE (Msg & "p?", N, Subp);
1279 -- Remove last character (question mark) to make this into an
1280 -- error, because the Inline_Always pragma cannot be obeyed.
1282 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1284 else pragma Assert (Front_End_Inlining);
1285 Set_Is_Inlined (Subp, False);
1287 -- When inlining cannot take place we must issue an error.
1288 -- For backward compatibility we still report a warning.
1290 if Ineffective_Inline_Warnings then
1291 Error_Msg_NE (Msg & "p?", N, Subp);
1295 -- Compiling with optimizations enabled it is too early to report
1296 -- problems since the backend may still perform inlining. In order
1297 -- to report unhandled inlinings the program must be compiled with
1298 -- -Winline and the error is reported by the backend.
1305 --------------------------------------
1306 -- Can_Be_Inlined_In_GNATprove_Mode --
1307 --------------------------------------
1309 function Can_Be_Inlined_In_GNATprove_Mode
1310 (Spec_Id : Entity_Id;
1311 Body_Id : Entity_Id) return Boolean
1313 function Has_Some_Contract (Id : Entity_Id) return Boolean;
1314 -- Returns True if subprogram Id has any contract (Pre, Post, Global,
1317 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
1318 -- Returns True if subprogram Id defines a compilation unit
1319 -- Shouldn't this be in Sem_Aux???
1321 function In_Package_Visible_Spec (Id : Node_Id) return Boolean;
1322 -- Returns True if subprogram Id is defined in the visible part of a
1323 -- package specification.
1325 function Is_Expression_Function (Id : Entity_Id) return Boolean;
1326 -- Returns True if subprogram Id was defined originally as an expression
1329 -----------------------
1330 -- Has_Some_Contract --
1331 -----------------------
1333 function Has_Some_Contract (Id : Entity_Id) return Boolean is
1334 Items : constant Node_Id := Contract (Id);
1336 return Present (Items)
1337 and then (Present (Pre_Post_Conditions (Items)) or else
1338 Present (Contract_Test_Cases (Items)) or else
1339 Present (Classifications (Items)));
1340 end Has_Some_Contract;
1342 -----------------------------
1343 -- In_Package_Visible_Spec --
1344 -----------------------------
1346 function In_Package_Visible_Spec (Id : Node_Id) return Boolean is
1347 Decl : Node_Id := Parent (Parent (Id));
1351 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1352 Decl := Parent (Decl);
1357 return Nkind (P) = N_Package_Specification
1358 and then List_Containing (Decl) = Visible_Declarations (P);
1359 end In_Package_Visible_Spec;
1361 ----------------------------
1362 -- Is_Expression_Function --
1363 ----------------------------
1365 function Is_Expression_Function (Id : Entity_Id) return Boolean is
1366 Decl : Node_Id := Parent (Parent (Id));
1368 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1369 Decl := Parent (Decl);
1372 return Nkind (Original_Node (Decl)) = N_Expression_Function;
1373 end Is_Expression_Function;
1375 ------------------------
1376 -- Is_Unit_Subprogram --
1377 ------------------------
1379 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1380 Decl : Node_Id := Parent (Parent (Id));
1382 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1383 Decl := Parent (Decl);
1386 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1387 end Is_Unit_Subprogram;
1389 -- Local declarations
1391 Id : Entity_Id; -- Procedure or function entity for the subprogram
1393 -- Start of Can_Be_Inlined_In_GNATprove_Mode
1396 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1398 if Present (Spec_Id) then
1404 -- Only local subprograms without contracts are inlined in GNATprove
1405 -- mode, as these are the subprograms which a user is not interested in
1406 -- analyzing in isolation, but rather in the context of their call. This
1407 -- is a convenient convention, that could be changed for an explicit
1408 -- pragma/aspect one day.
1410 -- In a number of special cases, inlining is not desirable or not
1411 -- possible, see below.
1413 -- Do not inline unit-level subprograms
1415 if Is_Unit_Subprogram (Id) then
1418 -- Do not inline subprograms declared in the visible part of a package
1420 elsif In_Package_Visible_Spec (Id) then
1423 -- Do not inline subprograms that have a contract on the spec or the
1424 -- body. Use the contract(s) instead in GNATprove.
1426 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
1428 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
1432 -- Do not inline expression functions, which are directly inlined at the
1435 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
1437 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
1441 -- Do not inline generic subprogram instances. The visibility rules of
1442 -- generic instances plays badly with inlining.
1444 elsif Is_Generic_Instance (Spec_Id) then
1447 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1448 -- the subprogram body, a similar check is performed after the body
1449 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1451 elsif Present (Spec_Id)
1453 (No (SPARK_Pragma (Spec_Id))
1454 or else Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Spec_Id)) /= On)
1458 -- Subprograms in generic instances are currently not inlined, to avoid
1459 -- problems with inlining of standard library subprograms.
1461 elsif Instantiation_Location (Sloc (Id)) /= No_Location then
1464 -- Don't inline predicate functions (treated specially by GNATprove)
1466 elsif Is_Predicate_Function (Id) then
1469 -- Otherwise, this is a subprogram declared inside the private part of a
1470 -- package, or inside a package body, or locally in a subprogram, and it
1471 -- does not have any contract. Inline it.
1476 end Can_Be_Inlined_In_GNATprove_Mode;
1478 --------------------------------------------
1479 -- Check_And_Split_Unconstrained_Function --
1480 --------------------------------------------
1482 procedure Check_And_Split_Unconstrained_Function
1484 Spec_Id : Entity_Id;
1485 Body_Id : Entity_Id)
1487 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
1488 -- Use generic machinery to build an unexpanded body for the subprogram.
1489 -- This body is subsequently used for inline expansions at call sites.
1491 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
1492 -- Return true if we generate code for the function body N, the function
1493 -- body N has no local declarations and its unique statement is a single
1494 -- extended return statement with a handled statements sequence.
1496 procedure Generate_Subprogram_Body
1498 Body_To_Inline : out Node_Id);
1499 -- Generate a parameterless duplicate of subprogram body N. Occurrences
1500 -- of pragmas referencing the formals are removed since they have no
1501 -- meaning when the body is inlined and the formals are rewritten (the
1502 -- analysis of the non-inlined body will handle these pragmas properly).
1503 -- A new internal name is associated with Body_To_Inline.
1505 procedure Split_Unconstrained_Function
1507 Spec_Id : Entity_Id);
1508 -- N is an inlined function body that returns an unconstrained type and
1509 -- has a single extended return statement. Split N in two subprograms:
1510 -- a procedure P' and a function F'. The formals of P' duplicate the
1511 -- formals of N plus an extra formal which is used return a value;
1512 -- its body is composed by the declarations and list of statements
1513 -- of the extended return statement of N.
1515 --------------------------
1516 -- Build_Body_To_Inline --
1517 --------------------------
1519 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
1520 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1521 Original_Body : Node_Id;
1522 Body_To_Analyze : Node_Id;
1525 pragma Assert (Current_Scope = Spec_Id);
1527 -- Within an instance, the body to inline must be treated as a nested
1528 -- generic, so that the proper global references are preserved. We
1529 -- do not do this at the library level, because it is not needed, and
1530 -- furthermore this causes trouble if front end inlining is activated
1534 and then Scope (Current_Scope) /= Standard_Standard
1536 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1539 -- We need to capture references to the formals in order
1540 -- to substitute the actuals at the point of inlining, i.e.
1541 -- instantiation. To treat the formals as globals to the body to
1542 -- inline, we nest it within a dummy parameterless subprogram,
1543 -- declared within the real one.
1545 Generate_Subprogram_Body (N, Original_Body);
1546 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
1548 -- Set return type of function, which is also global and does not
1549 -- need to be resolved.
1551 if Ekind (Spec_Id) = E_Function then
1552 Set_Result_Definition (Specification (Body_To_Analyze),
1553 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1556 if No (Declarations (N)) then
1557 Set_Declarations (N, New_List (Body_To_Analyze));
1559 Append_To (Declarations (N), Body_To_Analyze);
1562 Preanalyze (Body_To_Analyze);
1564 Push_Scope (Defining_Entity (Body_To_Analyze));
1565 Save_Global_References (Original_Body);
1567 Remove (Body_To_Analyze);
1569 -- Restore environment if previously saved
1572 and then Scope (Current_Scope) /= Standard_Standard
1577 pragma Assert (No (Body_To_Inline (Decl)));
1578 Set_Body_To_Inline (Decl, Original_Body);
1579 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1580 end Build_Body_To_Inline;
1582 --------------------------------------
1583 -- Can_Split_Unconstrained_Function --
1584 --------------------------------------
1586 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean
1588 Ret_Node : constant Node_Id :=
1589 First (Statements (Handled_Statement_Sequence (N)));
1593 -- No user defined declarations allowed in the function except inside
1594 -- the unique return statement; implicit labels are the only allowed
1597 if not Is_Empty_List (Declarations (N)) then
1598 D := First (Declarations (N));
1599 while Present (D) loop
1600 if Nkind (D) /= N_Implicit_Label_Declaration then
1608 -- We only split the inlined function when we are generating the code
1609 -- of its body; otherwise we leave duplicated split subprograms in
1610 -- the tree which (if referenced) generate wrong references at link
1613 return In_Extended_Main_Code_Unit (N)
1614 and then Present (Ret_Node)
1615 and then Nkind (Ret_Node) = N_Extended_Return_Statement
1616 and then No (Next (Ret_Node))
1617 and then Present (Handled_Statement_Sequence (Ret_Node));
1618 end Can_Split_Unconstrained_Function;
1620 -----------------------------
1621 -- Generate_Body_To_Inline --
1622 -----------------------------
1624 procedure Generate_Subprogram_Body
1626 Body_To_Inline : out Node_Id)
1629 -- Within an instance, the body to inline must be treated as a nested
1630 -- generic, so that the proper global references are preserved.
1632 -- Note that we do not do this at the library level, because it
1633 -- is not needed, and furthermore this causes trouble if front
1634 -- end inlining is activated (-gnatN).
1637 and then Scope (Current_Scope) /= Standard_Standard
1639 Body_To_Inline := Copy_Generic_Node (N, Empty, True);
1641 Body_To_Inline := Copy_Separate_Tree (N);
1644 -- A pragma Unreferenced or pragma Unmodified that mentions a formal
1645 -- parameter has no meaning when the body is inlined and the formals
1646 -- are rewritten. Remove it from body to inline. The analysis of the
1647 -- non-inlined body will handle the pragma properly.
1649 Remove_Pragmas (Body_To_Inline);
1651 -- We need to capture references to the formals in order
1652 -- to substitute the actuals at the point of inlining, i.e.
1653 -- instantiation. To treat the formals as globals to the body to
1654 -- inline, we nest it within a dummy parameterless subprogram,
1655 -- declared within the real one.
1657 Set_Parameter_Specifications
1658 (Specification (Body_To_Inline), No_List);
1660 -- A new internal name is associated with Body_To_Inline to avoid
1661 -- conflicts when the non-inlined body N is analyzed.
1663 Set_Defining_Unit_Name (Specification (Body_To_Inline),
1664 Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P')));
1665 Set_Corresponding_Spec (Body_To_Inline, Empty);
1666 end Generate_Subprogram_Body;
1668 ----------------------------------
1669 -- Split_Unconstrained_Function --
1670 ----------------------------------
1672 procedure Split_Unconstrained_Function
1674 Spec_Id : Entity_Id)
1676 Loc : constant Source_Ptr := Sloc (N);
1677 Ret_Node : constant Node_Id :=
1678 First (Statements (Handled_Statement_Sequence (N)));
1679 Ret_Obj : constant Node_Id :=
1680 First (Return_Object_Declarations (Ret_Node));
1682 procedure Build_Procedure
1683 (Proc_Id : out Entity_Id;
1684 Decl_List : out List_Id);
1685 -- Build a procedure containing the statements found in the extended
1686 -- return statement of the unconstrained function body N.
1688 ---------------------
1689 -- Build_Procedure --
1690 ---------------------
1692 procedure Build_Procedure
1693 (Proc_Id : out Entity_Id;
1694 Decl_List : out List_Id)
1697 Formal_List : constant List_Id := New_List;
1698 Proc_Spec : Node_Id;
1699 Proc_Body : Node_Id;
1700 Subp_Name : constant Name_Id := New_Internal_Name ('F');
1701 Body_Decl_List : List_Id := No_List;
1702 Param_Type : Node_Id;
1705 if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then
1707 New_Copy (Object_Definition (Ret_Obj));
1710 New_Copy (Subtype_Mark (Object_Definition (Ret_Obj)));
1713 Append_To (Formal_List,
1714 Make_Parameter_Specification (Loc,
1715 Defining_Identifier =>
1716 Make_Defining_Identifier (Loc,
1717 Chars => Chars (Defining_Identifier (Ret_Obj))),
1718 In_Present => False,
1719 Out_Present => True,
1720 Null_Exclusion_Present => False,
1721 Parameter_Type => Param_Type));
1723 Formal := First_Formal (Spec_Id);
1724 while Present (Formal) loop
1725 Append_To (Formal_List,
1726 Make_Parameter_Specification (Loc,
1727 Defining_Identifier =>
1728 Make_Defining_Identifier (Sloc (Formal),
1729 Chars => Chars (Formal)),
1730 In_Present => In_Present (Parent (Formal)),
1731 Out_Present => Out_Present (Parent (Formal)),
1732 Null_Exclusion_Present =>
1733 Null_Exclusion_Present (Parent (Formal)),
1735 New_Occurrence_Of (Etype (Formal), Loc),
1737 Copy_Separate_Tree (Expression (Parent (Formal)))));
1739 Next_Formal (Formal);
1742 Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name);
1745 Make_Procedure_Specification (Loc,
1746 Defining_Unit_Name => Proc_Id,
1747 Parameter_Specifications => Formal_List);
1749 Decl_List := New_List;
1751 Append_To (Decl_List,
1752 Make_Subprogram_Declaration (Loc, Proc_Spec));
1754 -- Can_Convert_Unconstrained_Function checked that the function
1755 -- has no local declarations except implicit label declarations.
1756 -- Copy these declarations to the built procedure.
1758 if Present (Declarations (N)) then
1759 Body_Decl_List := New_List;
1766 D := First (Declarations (N));
1767 while Present (D) loop
1768 pragma Assert (Nkind (D) = N_Implicit_Label_Declaration);
1771 Make_Implicit_Label_Declaration (Loc,
1772 Make_Defining_Identifier (Loc,
1773 Chars => Chars (Defining_Identifier (D))),
1774 Label_Construct => Empty);
1775 Append_To (Body_Decl_List, New_D);
1782 pragma Assert (Present (Handled_Statement_Sequence (Ret_Node)));
1785 Make_Subprogram_Body (Loc,
1786 Specification => Copy_Separate_Tree (Proc_Spec),
1787 Declarations => Body_Decl_List,
1788 Handled_Statement_Sequence =>
1789 Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node)));
1791 Set_Defining_Unit_Name (Specification (Proc_Body),
1792 Make_Defining_Identifier (Loc, Subp_Name));
1794 Append_To (Decl_List, Proc_Body);
1795 end Build_Procedure;
1799 New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj);
1801 Proc_Id : Entity_Id;
1802 Proc_Call : Node_Id;
1804 -- Start of processing for Split_Unconstrained_Function
1807 -- Build the associated procedure, analyze it and insert it before
1808 -- the function body N.
1811 Scope : constant Entity_Id := Current_Scope;
1812 Decl_List : List_Id;
1815 Build_Procedure (Proc_Id, Decl_List);
1816 Insert_Actions (N, Decl_List);
1820 -- Build the call to the generated procedure
1823 Actual_List : constant List_Id := New_List;
1827 Append_To (Actual_List,
1828 New_Occurrence_Of (Defining_Identifier (New_Obj), Loc));
1830 Formal := First_Formal (Spec_Id);
1831 while Present (Formal) loop
1832 Append_To (Actual_List, New_Occurrence_Of (Formal, Loc));
1834 -- Avoid spurious warning on unreferenced formals
1836 Set_Referenced (Formal);
1837 Next_Formal (Formal);
1841 Make_Procedure_Call_Statement (Loc,
1842 Name => New_Occurrence_Of (Proc_Id, Loc),
1843 Parameter_Associations => Actual_List);
1851 -- main_1__F1b (New_Obj, ...);
1856 Make_Block_Statement (Loc,
1857 Declarations => New_List (New_Obj),
1858 Handled_Statement_Sequence =>
1859 Make_Handled_Sequence_Of_Statements (Loc,
1860 Statements => New_List (
1864 Make_Simple_Return_Statement (Loc,
1867 (Defining_Identifier (New_Obj), Loc)))));
1869 Rewrite (Ret_Node, Blk_Stmt);
1870 end Split_Unconstrained_Function;
1874 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1876 -- Start of processing for Check_And_Split_Unconstrained_Function
1879 pragma Assert (Back_End_Inlining
1880 and then Ekind (Spec_Id) = E_Function
1881 and then Returns_Unconstrained_Type (Spec_Id)
1882 and then Comes_From_Source (Body_Id)
1883 and then (Has_Pragma_Inline_Always (Spec_Id)
1884 or else Optimization_Level > 0));
1886 -- This routine must not be used in GNATprove mode since GNATprove
1887 -- relies on frontend inlining
1889 pragma Assert (not GNATprove_Mode);
1891 -- No need to split the function if we cannot generate the code
1893 if Serious_Errors_Detected /= 0 then
1897 -- Do not inline any subprogram that contains nested subprograms,
1898 -- since the backend inlining circuit seems to generate uninitialized
1899 -- references in this case. We know this happens in the case of front
1900 -- end ZCX support, but it also appears it can happen in other cases
1901 -- as well. The backend often rejects attempts to inline in the case
1902 -- of nested procedures anyway, so little if anything is lost by this.
1903 -- Note that this is test is for the benefit of the back-end. There
1904 -- is a separate test for front-end inlining that also rejects nested
1907 -- Do not do this test if errors have been detected, because in some
1908 -- error cases, this code blows up, and we don't need it anyway if
1909 -- there have been errors, since we won't get to the linker anyway.
1917 P_Ent := Scope (P_Ent);
1918 exit when No (P_Ent) or else P_Ent = Standard_Standard;
1920 if Is_Subprogram (P_Ent) then
1921 Set_Is_Inlined (P_Ent, False);
1923 if Comes_From_Source (P_Ent)
1924 and then (Has_Pragma_Inline (P_Ent))
1927 ("cannot inline& (nested subprogram)?", N, P_Ent,
1928 Is_Serious => True);
1935 -- No action needed in stubs since the attribute Body_To_Inline
1938 if Nkind (Decl) = N_Subprogram_Body_Stub then
1941 -- Cannot build the body to inline if the attribute is already set.
1942 -- This attribute may have been set if this is a subprogram renaming
1943 -- declarations (see Freeze.Build_Renamed_Body).
1945 elsif Present (Body_To_Inline (Decl)) then
1948 -- Check excluded declarations
1950 elsif Present (Declarations (N))
1951 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
1955 -- Check excluded statements. There is no need to protect us against
1956 -- exception handlers since they are supported by the GCC backend.
1958 elsif Present (Handled_Statement_Sequence (N))
1959 and then Has_Excluded_Statement
1960 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
1965 -- Build the body to inline only if really needed
1967 if Can_Split_Unconstrained_Function (N) then
1968 Split_Unconstrained_Function (N, Spec_Id);
1969 Build_Body_To_Inline (N, Spec_Id);
1970 Set_Is_Inlined (Spec_Id);
1972 end Check_And_Split_Unconstrained_Function;
1974 -------------------------------------
1975 -- Check_Package_Body_For_Inlining --
1976 -------------------------------------
1978 procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
1979 Bname : Unit_Name_Type;
1984 -- Legacy implementation (relying on frontend inlining)
1986 if not Back_End_Inlining
1987 and then Is_Compilation_Unit (P)
1988 and then not Is_Generic_Instance (P)
1990 Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
1992 E := First_Entity (P);
1993 while Present (E) loop
1994 if Has_Pragma_Inline_Always (E)
1995 or else (Has_Pragma_Inline (E) and Front_End_Inlining)
1997 if not Is_Loaded (Bname) then
1998 Load_Needed_Body (N, OK);
2002 -- Check we are not trying to inline a parent whose body
2003 -- depends on a child, when we are compiling the body of
2004 -- the child. Otherwise we have a potential elaboration
2005 -- circularity with inlined subprograms and with
2006 -- Taft-Amendment types.
2009 Comp : Node_Id; -- Body just compiled
2010 Child_Spec : Entity_Id; -- Spec of main unit
2011 Ent : Entity_Id; -- For iteration
2012 With_Clause : Node_Id; -- Context of body.
2015 if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
2016 and then Present (Body_Entity (P))
2020 ((Unit (Library_Unit (Cunit (Main_Unit)))));
2023 Parent (Unit_Declaration_Node (Body_Entity (P)));
2025 -- Check whether the context of the body just
2026 -- compiled includes a child of itself, and that
2027 -- child is the spec of the main compilation.
2029 With_Clause := First (Context_Items (Comp));
2030 while Present (With_Clause) loop
2031 if Nkind (With_Clause) = N_With_Clause
2033 Scope (Entity (Name (With_Clause))) = P
2035 Entity (Name (With_Clause)) = Child_Spec
2037 Error_Msg_Node_2 := Child_Spec;
2039 ("body of & depends on child unit&??",
2042 ("\subprograms in body cannot be inlined??",
2045 -- Disable further inlining from this unit,
2046 -- and keep Taft-amendment types incomplete.
2048 Ent := First_Entity (P);
2049 while Present (Ent) loop
2051 and then Has_Completion_In_Body (Ent)
2053 Set_Full_View (Ent, Empty);
2055 elsif Is_Subprogram (Ent) then
2056 Set_Is_Inlined (Ent, False);
2070 elsif Ineffective_Inline_Warnings then
2071 Error_Msg_Unit_1 := Bname;
2073 ("unable to inline subprograms defined in $??", P);
2074 Error_Msg_N ("\body not found??", P);
2085 end Check_Package_Body_For_Inlining;
2087 --------------------
2088 -- Cleanup_Scopes --
2089 --------------------
2091 procedure Cleanup_Scopes is
2097 Elmt := First_Elmt (To_Clean);
2098 while Present (Elmt) loop
2099 Scop := Node (Elmt);
2101 if Ekind (Scop) = E_Entry then
2102 Scop := Protected_Body_Subprogram (Scop);
2104 elsif Is_Subprogram (Scop)
2105 and then Is_Protected_Type (Scope (Scop))
2106 and then Present (Protected_Body_Subprogram (Scop))
2108 -- If a protected operation contains an instance, its cleanup
2109 -- operations have been delayed, and the subprogram has been
2110 -- rewritten in the expansion of the enclosing protected body. It
2111 -- is the corresponding subprogram that may require the cleanup
2112 -- operations, so propagate the information that triggers cleanup
2116 (Protected_Body_Subprogram (Scop),
2117 Uses_Sec_Stack (Scop));
2119 Scop := Protected_Body_Subprogram (Scop);
2122 if Ekind (Scop) = E_Block then
2123 Decl := Parent (Block_Node (Scop));
2126 Decl := Unit_Declaration_Node (Scop);
2128 if Nkind_In (Decl, N_Subprogram_Declaration,
2129 N_Task_Type_Declaration,
2130 N_Subprogram_Body_Stub)
2132 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
2137 Expand_Cleanup_Actions (Decl);
2140 Elmt := Next_Elmt (Elmt);
2144 -------------------------
2145 -- Expand_Inlined_Call --
2146 -------------------------
2148 procedure Expand_Inlined_Call
2151 Orig_Subp : Entity_Id)
2153 Loc : constant Source_Ptr := Sloc (N);
2154 Is_Predef : constant Boolean :=
2155 Is_Predefined_File_Name
2156 (Unit_File_Name (Get_Source_Unit (Subp)));
2157 Orig_Bod : constant Node_Id :=
2158 Body_To_Inline (Unit_Declaration_Node (Subp));
2162 Decls : constant List_Id := New_List;
2163 Exit_Lab : Entity_Id := Empty;
2170 Ret_Type : Entity_Id;
2173 -- The target of the call. If context is an assignment statement then
2174 -- this is the left-hand side of the assignment, else it is a temporary
2175 -- to which the return value is assigned prior to rewriting the call.
2178 -- A separate target used when the return type is unconstrained
2181 Temp_Typ : Entity_Id;
2183 Return_Object : Entity_Id := Empty;
2184 -- Entity in declaration in an extended_return_statement
2187 Is_Unc_Decl : Boolean;
2188 -- If the type returned by the function is unconstrained and the call
2189 -- can be inlined, special processing is required.
2191 procedure Make_Exit_Label;
2192 -- Build declaration for exit label to be used in Return statements,
2193 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2194 -- declaration). Does nothing if Exit_Lab already set.
2196 function Process_Formals (N : Node_Id) return Traverse_Result;
2197 -- Replace occurrence of a formal with the corresponding actual, or the
2198 -- thunk generated for it. Replace a return statement with an assignment
2199 -- to the target of the call, with appropriate conversions if needed.
2201 function Process_Sloc (Nod : Node_Id) return Traverse_Result;
2202 -- If the call being expanded is that of an internal subprogram, set the
2203 -- sloc of the generated block to that of the call itself, so that the
2204 -- expansion is skipped by the "next" command in gdb. Same processing
2205 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2206 -- Debug_Generated_Code is true, suppress this change to simplify our
2207 -- own development. Same in GNATprove mode, to ensure that warnings and
2208 -- diagnostics point to the proper location.
2210 procedure Reset_Dispatching_Calls (N : Node_Id);
2211 -- In subtree N search for occurrences of dispatching calls that use the
2212 -- Ada 2005 Object.Operation notation and the object is a formal of the
2213 -- inlined subprogram. Reset the entity associated with Operation in all
2214 -- the found occurrences.
2216 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
2217 -- If the function body is a single expression, replace call with
2218 -- expression, else insert block appropriately.
2220 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
2221 -- If procedure body has no local variables, inline body without
2222 -- creating block, otherwise rewrite call with block.
2224 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
2225 -- Determine whether a formal parameter is used only once in Orig_Bod
2227 ---------------------
2228 -- Make_Exit_Label --
2229 ---------------------
2231 procedure Make_Exit_Label is
2232 Lab_Ent : Entity_Id;
2234 if No (Exit_Lab) then
2235 Lab_Ent := Make_Temporary (Loc, 'L');
2236 Lab_Id := New_Occurrence_Of (Lab_Ent, Loc);
2237 Exit_Lab := Make_Label (Loc, Lab_Id);
2239 Make_Implicit_Label_Declaration (Loc,
2240 Defining_Identifier => Lab_Ent,
2241 Label_Construct => Exit_Lab);
2243 end Make_Exit_Label;
2245 ---------------------
2246 -- Process_Formals --
2247 ---------------------
2249 function Process_Formals (N : Node_Id) return Traverse_Result is
2255 if Is_Entity_Name (N) and then Present (Entity (N)) then
2258 if Is_Formal (E) and then Scope (E) = Subp then
2259 A := Renamed_Object (E);
2261 -- Rewrite the occurrence of the formal into an occurrence of
2262 -- the actual. Also establish visibility on the proper view of
2263 -- the actual's subtype for the body's context (if the actual's
2264 -- subtype is private at the call point but its full view is
2265 -- visible to the body, then the inlined tree here must be
2266 -- analyzed with the full view).
2268 if Is_Entity_Name (A) then
2269 Rewrite (N, New_Occurrence_Of (Entity (A), Loc));
2270 Check_Private_View (N);
2272 elsif Nkind (A) = N_Defining_Identifier then
2273 Rewrite (N, New_Occurrence_Of (A, Loc));
2274 Check_Private_View (N);
2279 Rewrite (N, New_Copy (A));
2285 elsif Is_Entity_Name (N)
2286 and then Present (Return_Object)
2287 and then Chars (N) = Chars (Return_Object)
2289 -- Occurrence within an extended return statement. The return
2290 -- object is local to the body been inlined, and thus the generic
2291 -- copy is not analyzed yet, so we match by name, and replace it
2292 -- with target of call.
2294 if Nkind (Targ) = N_Defining_Identifier then
2295 Rewrite (N, New_Occurrence_Of (Targ, Loc));
2297 Rewrite (N, New_Copy_Tree (Targ));
2302 elsif Nkind (N) = N_Simple_Return_Statement then
2303 if No (Expression (N)) then
2306 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2309 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
2310 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
2312 -- Function body is a single expression. No need for
2318 Num_Ret := Num_Ret + 1;
2322 -- Because of the presence of private types, the views of the
2323 -- expression and the context may be different, so place an
2324 -- unchecked conversion to the context type to avoid spurious
2325 -- errors, e.g. when the expression is a numeric literal and
2326 -- the context is private. If the expression is an aggregate,
2327 -- use a qualified expression, because an aggregate is not a
2328 -- legal argument of a conversion. Ditto for numeric literals,
2329 -- which must be resolved to a specific type.
2331 if Nkind_In (Expression (N), N_Aggregate,
2337 Make_Qualified_Expression (Sloc (N),
2338 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2339 Expression => Relocate_Node (Expression (N)));
2342 Unchecked_Convert_To
2343 (Ret_Type, Relocate_Node (Expression (N)));
2346 if Nkind (Targ) = N_Defining_Identifier then
2348 Make_Assignment_Statement (Loc,
2349 Name => New_Occurrence_Of (Targ, Loc),
2350 Expression => Ret));
2353 Make_Assignment_Statement (Loc,
2354 Name => New_Copy (Targ),
2355 Expression => Ret));
2358 Set_Assignment_OK (Name (N));
2360 if Present (Exit_Lab) then
2362 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2368 -- An extended return becomes a block whose first statement is the
2369 -- assignment of the initial expression of the return object to the
2370 -- target of the call itself.
2372 elsif Nkind (N) = N_Extended_Return_Statement then
2374 Return_Decl : constant Entity_Id :=
2375 First (Return_Object_Declarations (N));
2379 Return_Object := Defining_Identifier (Return_Decl);
2381 if Present (Expression (Return_Decl)) then
2382 if Nkind (Targ) = N_Defining_Identifier then
2384 Make_Assignment_Statement (Loc,
2385 Name => New_Occurrence_Of (Targ, Loc),
2386 Expression => Expression (Return_Decl));
2389 Make_Assignment_Statement (Loc,
2390 Name => New_Copy (Targ),
2391 Expression => Expression (Return_Decl));
2394 Set_Assignment_OK (Name (Assign));
2396 if No (Handled_Statement_Sequence (N)) then
2397 Set_Handled_Statement_Sequence (N,
2398 Make_Handled_Sequence_Of_Statements (Loc,
2399 Statements => New_List));
2403 Statements (Handled_Statement_Sequence (N)));
2407 Make_Block_Statement (Loc,
2408 Handled_Statement_Sequence =>
2409 Handled_Statement_Sequence (N)));
2414 -- Remove pragma Unreferenced since it may refer to formals that
2415 -- are not visible in the inlined body, and in any case we will
2416 -- not be posting warnings on the inlined body so it is unneeded.
2418 elsif Nkind (N) = N_Pragma
2419 and then Pragma_Name (N) = Name_Unreferenced
2421 Rewrite (N, Make_Null_Statement (Sloc (N)));
2427 end Process_Formals;
2429 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
2435 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
2437 if not Debug_Generated_Code then
2438 Set_Sloc (Nod, Sloc (N));
2439 Set_Comes_From_Source (Nod, False);
2445 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
2447 ------------------------------
2448 -- Reset_Dispatching_Calls --
2449 ------------------------------
2451 procedure Reset_Dispatching_Calls (N : Node_Id) is
2453 function Do_Reset (N : Node_Id) return Traverse_Result;
2454 -- Comment required ???
2460 function Do_Reset (N : Node_Id) return Traverse_Result is
2462 if Nkind (N) = N_Procedure_Call_Statement
2463 and then Nkind (Name (N)) = N_Selected_Component
2464 and then Nkind (Prefix (Name (N))) = N_Identifier
2465 and then Is_Formal (Entity (Prefix (Name (N))))
2466 and then Is_Dispatching_Operation
2467 (Entity (Selector_Name (Name (N))))
2469 Set_Entity (Selector_Name (Name (N)), Empty);
2475 function Do_Reset_Calls is new Traverse_Func (Do_Reset);
2479 Dummy : constant Traverse_Result := Do_Reset_Calls (N);
2480 pragma Unreferenced (Dummy);
2482 -- Start of processing for Reset_Dispatching_Calls
2486 end Reset_Dispatching_Calls;
2488 ---------------------------
2489 -- Rewrite_Function_Call --
2490 ---------------------------
2492 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
2493 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2494 Fst : constant Node_Id := First (Statements (HSS));
2497 -- Optimize simple case: function body is a single return statement,
2498 -- which has been expanded into an assignment.
2500 if Is_Empty_List (Declarations (Blk))
2501 and then Nkind (Fst) = N_Assignment_Statement
2502 and then No (Next (Fst))
2504 -- The function call may have been rewritten as the temporary
2505 -- that holds the result of the call, in which case remove the
2506 -- now useless declaration.
2508 if Nkind (N) = N_Identifier
2509 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2511 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
2514 Rewrite (N, Expression (Fst));
2516 elsif Nkind (N) = N_Identifier
2517 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2519 -- The block assigns the result of the call to the temporary
2521 Insert_After (Parent (Entity (N)), Blk);
2523 -- If the context is an assignment, and the left-hand side is free of
2524 -- side-effects, the replacement is also safe.
2525 -- Can this be generalized further???
2527 elsif Nkind (Parent (N)) = N_Assignment_Statement
2529 (Is_Entity_Name (Name (Parent (N)))
2531 (Nkind (Name (Parent (N))) = N_Explicit_Dereference
2532 and then Is_Entity_Name (Prefix (Name (Parent (N)))))
2535 (Nkind (Name (Parent (N))) = N_Selected_Component
2536 and then Is_Entity_Name (Prefix (Name (Parent (N))))))
2538 -- Replace assignment with the block
2541 Original_Assignment : constant Node_Id := Parent (N);
2544 -- Preserve the original assignment node to keep the complete
2545 -- assignment subtree consistent enough for Analyze_Assignment
2546 -- to proceed (specifically, the original Lhs node must still
2547 -- have an assignment statement as its parent).
2549 -- We cannot rely on Original_Node to go back from the block
2550 -- node to the assignment node, because the assignment might
2551 -- already be a rewrite substitution.
2553 Discard_Node (Relocate_Node (Original_Assignment));
2554 Rewrite (Original_Assignment, Blk);
2557 elsif Nkind (Parent (N)) = N_Object_Declaration then
2559 -- A call to a function which returns an unconstrained type
2560 -- found in the expression initializing an object-declaration is
2561 -- expanded into a procedure call which must be added after the
2562 -- object declaration.
2564 if Is_Unc_Decl and Back_End_Inlining then
2565 Insert_Action_After (Parent (N), Blk);
2567 Set_Expression (Parent (N), Empty);
2568 Insert_After (Parent (N), Blk);
2571 elsif Is_Unc and then not Back_End_Inlining then
2572 Insert_Before (Parent (N), Blk);
2574 end Rewrite_Function_Call;
2576 ----------------------------
2577 -- Rewrite_Procedure_Call --
2578 ----------------------------
2580 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
2581 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2584 -- If there is a transient scope for N, this will be the scope of the
2585 -- actions for N, and the statements in Blk need to be within this
2586 -- scope. For example, they need to have visibility on the constant
2587 -- declarations created for the formals.
2589 -- If N needs no transient scope, and if there are no declarations in
2590 -- the inlined body, we can do a little optimization and insert the
2591 -- statements for the body directly after N, and rewrite N to a
2592 -- null statement, instead of rewriting N into a full-blown block
2595 if not Scope_Is_Transient
2596 and then Is_Empty_List (Declarations (Blk))
2598 Insert_List_After (N, Statements (HSS));
2599 Rewrite (N, Make_Null_Statement (Loc));
2603 end Rewrite_Procedure_Call;
2605 -------------------------
2606 -- Formal_Is_Used_Once --
2607 -------------------------
2609 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
2610 Use_Counter : Int := 0;
2612 function Count_Uses (N : Node_Id) return Traverse_Result;
2613 -- Traverse the tree and count the uses of the formal parameter.
2614 -- In this case, for optimization purposes, we do not need to
2615 -- continue the traversal once more than one use is encountered.
2621 function Count_Uses (N : Node_Id) return Traverse_Result is
2623 -- The original node is an identifier
2625 if Nkind (N) = N_Identifier
2626 and then Present (Entity (N))
2628 -- Original node's entity points to the one in the copied body
2630 and then Nkind (Entity (N)) = N_Identifier
2631 and then Present (Entity (Entity (N)))
2633 -- The entity of the copied node is the formal parameter
2635 and then Entity (Entity (N)) = Formal
2637 Use_Counter := Use_Counter + 1;
2639 if Use_Counter > 1 then
2641 -- Denote more than one use and abandon the traversal
2652 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
2654 -- Start of processing for Formal_Is_Used_Once
2657 Count_Formal_Uses (Orig_Bod);
2658 return Use_Counter = 1;
2659 end Formal_Is_Used_Once;
2661 -- Start of processing for Expand_Inlined_Call
2664 -- Initializations for old/new semantics
2666 if not Back_End_Inlining then
2667 Is_Unc := Is_Array_Type (Etype (Subp))
2668 and then not Is_Constrained (Etype (Subp));
2669 Is_Unc_Decl := False;
2671 Is_Unc := Returns_Unconstrained_Type (Subp)
2672 and then Optimization_Level > 0;
2673 Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration
2677 -- Check for an illegal attempt to inline a recursive procedure. If the
2678 -- subprogram has parameters this is detected when trying to supply a
2679 -- binding for parameters that already have one. For parameterless
2680 -- subprograms this must be done explicitly.
2682 if In_Open_Scopes (Subp) then
2683 Error_Msg_N ("call to recursive subprogram cannot be inlined??", N);
2684 Set_Is_Inlined (Subp, False);
2686 -- In GNATprove mode, issue a warning, and indicate that the
2687 -- subprogram is not always inlined by setting flag Is_Inlined_Always
2690 if GNATprove_Mode then
2691 Set_Is_Inlined_Always (Subp, False);
2696 -- Skip inlining if this is not a true inlining since the attribute
2697 -- Body_To_Inline is also set for renamings (see sinfo.ads)
2699 elsif Nkind (Orig_Bod) in N_Entity then
2702 -- Skip inlining if the function returns an unconstrained type using
2703 -- an extended return statement since this part of the new inlining
2704 -- model which is not yet supported by the current implementation. ???
2708 Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod))))
2709 = N_Extended_Return_Statement
2710 and then not Back_End_Inlining
2715 if Nkind (Orig_Bod) = N_Defining_Identifier
2716 or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
2718 -- Subprogram is renaming_as_body. Calls occurring after the renaming
2719 -- can be replaced with calls to the renamed entity directly, because
2720 -- the subprograms are subtype conformant. If the renamed subprogram
2721 -- is an inherited operation, we must redo the expansion because
2722 -- implicit conversions may be needed. Similarly, if the renamed
2723 -- entity is inlined, expand the call for further optimizations.
2725 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
2727 if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then
2734 -- Register the call in the list of inlined calls
2736 Append_New_Elmt (N, To => Inlined_Calls);
2738 -- Use generic machinery to copy body of inlined subprogram, as if it
2739 -- were an instantiation, resetting source locations appropriately, so
2740 -- that nested inlined calls appear in the main unit.
2742 Save_Env (Subp, Empty);
2743 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
2747 if not Back_End_Inlining then
2752 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
2754 Make_Block_Statement (Loc,
2755 Declarations => Declarations (Bod),
2756 Handled_Statement_Sequence =>
2757 Handled_Statement_Sequence (Bod));
2759 if No (Declarations (Bod)) then
2760 Set_Declarations (Blk, New_List);
2763 -- For the unconstrained case, capture the name of the local
2764 -- variable that holds the result. This must be the first
2765 -- declaration in the block, because its bounds cannot depend
2766 -- on local variables. Otherwise there is no way to declare the
2767 -- result outside of the block. Needless to say, in general the
2768 -- bounds will depend on the actuals in the call.
2770 -- If the context is an assignment statement, as is the case
2771 -- for the expansion of an extended return, the left-hand side
2772 -- provides bounds even if the return type is unconstrained.
2776 First_Decl : Node_Id;
2779 First_Decl := First (Declarations (Blk));
2781 if Nkind (First_Decl) /= N_Object_Declaration then
2785 if Nkind (Parent (N)) /= N_Assignment_Statement then
2786 Targ1 := Defining_Identifier (First_Decl);
2788 Targ1 := Name (Parent (N));
2805 Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
2807 Make_Block_Statement (Loc,
2808 Declarations => Declarations (Bod),
2809 Handled_Statement_Sequence =>
2810 Handled_Statement_Sequence (Bod));
2812 -- Inline a call to a function that returns an unconstrained type.
2813 -- The semantic analyzer checked that frontend-inlined functions
2814 -- returning unconstrained types have no declarations and have
2815 -- a single extended return statement. As part of its processing
2816 -- the function was split in two subprograms: a procedure P and
2817 -- a function F that has a block with a call to procedure P (see
2818 -- Split_Unconstrained_Function).
2824 (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
2828 Blk_Stmt : constant Node_Id :=
2829 First (Statements (Handled_Statement_Sequence (Orig_Bod)));
2830 First_Stmt : constant Node_Id :=
2831 First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
2832 Second_Stmt : constant Node_Id := Next (First_Stmt);
2836 (Nkind (First_Stmt) = N_Procedure_Call_Statement
2837 and then Nkind (Second_Stmt) = N_Simple_Return_Statement
2838 and then No (Next (Second_Stmt)));
2843 (Statements (Handled_Statement_Sequence (Orig_Bod))),
2844 Empty, Instantiating => True);
2847 -- Capture the name of the local variable that holds the
2848 -- result. This must be the first declaration in the block,
2849 -- because its bounds cannot depend on local variables.
2850 -- Otherwise there is no way to declare the result outside
2851 -- of the block. Needless to say, in general the bounds will
2852 -- depend on the actuals in the call.
2854 if Nkind (Parent (N)) /= N_Assignment_Statement then
2855 Targ1 := Defining_Identifier (First (Declarations (Blk)));
2857 -- If the context is an assignment statement, as is the case
2858 -- for the expansion of an extended return, the left-hand
2859 -- side provides bounds even if the return type is
2863 Targ1 := Name (Parent (N));
2868 if No (Declarations (Bod)) then
2869 Set_Declarations (Blk, New_List);
2874 -- If this is a derived function, establish the proper return type
2876 if Present (Orig_Subp) and then Orig_Subp /= Subp then
2877 Ret_Type := Etype (Orig_Subp);
2879 Ret_Type := Etype (Subp);
2882 -- Create temporaries for the actuals that are expressions, or that are
2883 -- scalars and require copying to preserve semantics.
2885 F := First_Formal (Subp);
2886 A := First_Actual (N);
2887 while Present (F) loop
2888 if Present (Renamed_Object (F)) then
2890 -- If expander is active, it is an error to try to inline a
2891 -- recursive program. In GNATprove mode, just indicate that the
2892 -- inlining will not happen, and mark the subprogram as not always
2895 if GNATprove_Mode then
2897 ("cannot inline call to recursive subprogram?", N, Subp);
2898 Set_Is_Inlined_Always (Subp, False);
2901 ("cannot inline call to recursive subprogram", N);
2907 -- Reset Last_Assignment for any parameters of mode out or in out, to
2908 -- prevent spurious warnings about overwriting for assignments to the
2909 -- formal in the inlined code.
2911 if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
2912 Set_Last_Assignment (Entity (A), Empty);
2915 -- If the argument may be a controlling argument in a call within
2916 -- the inlined body, we must preserve its classwide nature to insure
2917 -- that dynamic dispatching take place subsequently. If the formal
2918 -- has a constraint it must be preserved to retain the semantics of
2921 if Is_Class_Wide_Type (Etype (F))
2922 or else (Is_Access_Type (Etype (F))
2923 and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
2925 Temp_Typ := Etype (F);
2927 elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
2928 and then Etype (F) /= Base_Type (Etype (F))
2930 Temp_Typ := Etype (F);
2932 Temp_Typ := Etype (A);
2935 -- If the actual is a simple name or a literal, no need to
2936 -- create a temporary, object can be used directly.
2938 -- If the actual is a literal and the formal has its address taken,
2939 -- we cannot pass the literal itself as an argument, so its value
2940 -- must be captured in a temporary.
2942 if (Is_Entity_Name (A)
2944 (not Is_Scalar_Type (Etype (A))
2945 or else Ekind (Entity (A)) = E_Enumeration_Literal))
2947 -- When the actual is an identifier and the corresponding formal is
2948 -- used only once in the original body, the formal can be substituted
2949 -- directly with the actual parameter.
2951 or else (Nkind (A) = N_Identifier
2952 and then Formal_Is_Used_Once (F))
2955 (Nkind_In (A, N_Real_Literal,
2957 N_Character_Literal)
2958 and then not Address_Taken (F))
2960 if Etype (F) /= Etype (A) then
2962 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
2964 Set_Renamed_Object (F, A);
2968 Temp := Make_Temporary (Loc, 'C');
2970 -- If the actual for an in/in-out parameter is a view conversion,
2971 -- make it into an unchecked conversion, given that an untagged
2972 -- type conversion is not a proper object for a renaming.
2974 -- In-out conversions that involve real conversions have already
2975 -- been transformed in Expand_Actuals.
2977 if Nkind (A) = N_Type_Conversion
2978 and then Ekind (F) /= E_In_Parameter
2981 Make_Unchecked_Type_Conversion (Loc,
2982 Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
2983 Expression => Relocate_Node (Expression (A)));
2985 elsif Etype (F) /= Etype (A) then
2986 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
2987 Temp_Typ := Etype (F);
2990 New_A := Relocate_Node (A);
2993 Set_Sloc (New_A, Sloc (N));
2995 -- If the actual has a by-reference type, it cannot be copied,
2996 -- so its value is captured in a renaming declaration. Otherwise
2997 -- declare a local constant initialized with the actual.
2999 -- We also use a renaming declaration for expressions of an array
3000 -- type that is not bit-packed, both for efficiency reasons and to
3001 -- respect the semantics of the call: in most cases the original
3002 -- call will pass the parameter by reference, and thus the inlined
3003 -- code will have the same semantics.
3005 -- Finally, we need a renaming declaration in the case of limited
3006 -- types for which initialization cannot be by copy either.
3008 if Ekind (F) = E_In_Parameter
3009 and then not Is_By_Reference_Type (Etype (A))
3010 and then not Is_Limited_Type (Etype (A))
3012 (not Is_Array_Type (Etype (A))
3013 or else not Is_Object_Reference (A)
3014 or else Is_Bit_Packed_Array (Etype (A)))
3017 Make_Object_Declaration (Loc,
3018 Defining_Identifier => Temp,
3019 Constant_Present => True,
3020 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3021 Expression => New_A);
3024 Make_Object_Renaming_Declaration (Loc,
3025 Defining_Identifier => Temp,
3026 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
3030 Append (Decl, Decls);
3031 Set_Renamed_Object (F, Temp);
3038 -- Establish target of function call. If context is not assignment or
3039 -- declaration, create a temporary as a target. The declaration for the
3040 -- temporary may be subsequently optimized away if the body is a single
3041 -- expression, or if the left-hand side of the assignment is simple
3042 -- enough, i.e. an entity or an explicit dereference of one.
3044 if Ekind (Subp) = E_Function then
3045 if Nkind (Parent (N)) = N_Assignment_Statement
3046 and then Is_Entity_Name (Name (Parent (N)))
3048 Targ := Name (Parent (N));
3050 elsif Nkind (Parent (N)) = N_Assignment_Statement
3051 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
3052 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3054 Targ := Name (Parent (N));
3056 elsif Nkind (Parent (N)) = N_Assignment_Statement
3057 and then Nkind (Name (Parent (N))) = N_Selected_Component
3058 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3060 Targ := New_Copy_Tree (Name (Parent (N)));
3062 elsif Nkind (Parent (N)) = N_Object_Declaration
3063 and then Is_Limited_Type (Etype (Subp))
3065 Targ := Defining_Identifier (Parent (N));
3067 -- New semantics: In an object declaration avoid an extra copy
3068 -- of the result of a call to an inlined function that returns
3069 -- an unconstrained type
3071 elsif Back_End_Inlining
3072 and then Nkind (Parent (N)) = N_Object_Declaration
3075 Targ := Defining_Identifier (Parent (N));
3078 -- Replace call with temporary and create its declaration
3080 Temp := Make_Temporary (Loc, 'C');
3081 Set_Is_Internal (Temp);
3083 -- For the unconstrained case, the generated temporary has the
3084 -- same constrained declaration as the result variable. It may
3085 -- eventually be possible to remove that temporary and use the
3086 -- result variable directly.
3088 if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement
3091 Make_Object_Declaration (Loc,
3092 Defining_Identifier => Temp,
3093 Object_Definition =>
3094 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3096 Replace_Formals (Decl);
3100 Make_Object_Declaration (Loc,
3101 Defining_Identifier => Temp,
3102 Object_Definition => New_Occurrence_Of (Ret_Type, Loc));
3104 Set_Etype (Temp, Ret_Type);
3107 Set_No_Initialization (Decl);
3108 Append (Decl, Decls);
3109 Rewrite (N, New_Occurrence_Of (Temp, Loc));
3114 Insert_Actions (N, Decls);
3118 -- Special management for inlining a call to a function that returns
3119 -- an unconstrained type and initializes an object declaration: we
3120 -- avoid generating undesired extra calls and goto statements.
3123 -- function Func (...) return ...
3126 -- Result : String (1 .. 4);
3128 -- Proc (Result, ...);
3133 -- Result : String := Func (...);
3135 -- Replace this object declaration by:
3137 -- Result : String (1 .. 4);
3138 -- Proc (Result, ...);
3140 Remove_Homonym (Targ);
3143 Make_Object_Declaration
3145 Defining_Identifier => Targ,
3146 Object_Definition =>
3147 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3148 Replace_Formals (Decl);
3149 Rewrite (Parent (N), Decl);
3150 Analyze (Parent (N));
3152 -- Avoid spurious warnings since we know that this declaration is
3153 -- referenced by the procedure call.
3155 Set_Never_Set_In_Source (Targ, False);
3157 -- Remove the local declaration of the extended return stmt from the
3160 Remove (Parent (Targ1));
3162 -- Update the reference to the result (since we have rewriten the
3163 -- object declaration)
3166 Blk_Call_Stmt : Node_Id;
3169 -- Capture the call to the procedure
3172 First (Statements (Handled_Statement_Sequence (Blk)));
3174 (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement);
3176 Remove (First (Parameter_Associations (Blk_Call_Stmt)));
3177 Prepend_To (Parameter_Associations (Blk_Call_Stmt),
3178 New_Occurrence_Of (Targ, Loc));
3181 -- Remove the return statement
3184 (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3185 N_Simple_Return_Statement);
3187 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3190 -- Traverse the tree and replace formals with actuals or their thunks.
3191 -- Attach block to tree before analysis and rewriting.
3193 Replace_Formals (Blk);
3194 Set_Parent (Blk, N);
3196 if GNATprove_Mode then
3199 elsif not Comes_From_Source (Subp) or else Is_Predef then
3205 -- No action needed since return statement has been already removed
3209 elsif Present (Exit_Lab) then
3211 -- If the body was a single expression, the single return statement
3212 -- and the corresponding label are useless.
3216 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3219 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3221 Append (Lab_Decl, (Declarations (Blk)));
3222 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
3226 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3227 -- on conflicting private views that Gigi would ignore. If this is a
3228 -- predefined unit, analyze with checks off, as is done in the non-
3229 -- inlined run-time units.
3232 I_Flag : constant Boolean := In_Inlined_Body;
3235 In_Inlined_Body := True;
3239 Style : constant Boolean := Style_Check;
3242 Style_Check := False;
3244 -- Search for dispatching calls that use the Object.Operation
3245 -- notation using an Object that is a parameter of the inlined
3246 -- function. We reset the decoration of Operation to force
3247 -- the reanalysis of the inlined dispatching call because
3248 -- the actual object has been inlined.
3250 Reset_Dispatching_Calls (Blk);
3252 Analyze (Blk, Suppress => All_Checks);
3253 Style_Check := Style;
3260 In_Inlined_Body := I_Flag;
3263 if Ekind (Subp) = E_Procedure then
3264 Rewrite_Procedure_Call (N, Blk);
3267 Rewrite_Function_Call (N, Blk);
3272 -- For the unconstrained case, the replacement of the call has been
3273 -- made prior to the complete analysis of the generated declarations.
3274 -- Propagate the proper type now.
3277 if Nkind (N) = N_Identifier then
3278 Set_Etype (N, Etype (Entity (N)));
3280 Set_Etype (N, Etype (Targ1));
3287 -- Cleanup mapping between formals and actuals for other expansions
3289 F := First_Formal (Subp);
3290 while Present (F) loop
3291 Set_Renamed_Object (F, Empty);
3294 end Expand_Inlined_Call;
3296 --------------------------
3297 -- Get_Code_Unit_Entity --
3298 --------------------------
3300 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
3301 Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E));
3304 if Ekind (Unit) = E_Package_Body then
3305 Unit := Spec_Entity (Unit);
3309 end Get_Code_Unit_Entity;
3311 ------------------------------
3312 -- Has_Excluded_Declaration --
3313 ------------------------------
3315 function Has_Excluded_Declaration
3317 Decls : List_Id) return Boolean
3321 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
3322 -- Nested subprograms make a given body ineligible for inlining, but
3323 -- we make an exception for instantiations of unchecked conversion.
3324 -- The body has not been analyzed yet, so check the name, and verify
3325 -- that the visible entity with that name is the predefined unit.
3327 -----------------------------
3328 -- Is_Unchecked_Conversion --
3329 -----------------------------
3331 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
3332 Id : constant Node_Id := Name (D);
3336 if Nkind (Id) = N_Identifier
3337 and then Chars (Id) = Name_Unchecked_Conversion
3339 Conv := Current_Entity (Id);
3341 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
3342 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
3344 Conv := Current_Entity (Selector_Name (Id));
3349 return Present (Conv)
3350 and then Is_Predefined_File_Name
3351 (Unit_File_Name (Get_Source_Unit (Conv)))
3352 and then Is_Intrinsic_Subprogram (Conv);
3353 end Is_Unchecked_Conversion;
3355 -- Start of processing for Has_Excluded_Declaration
3358 -- No action needed if the check is not needed
3360 if not Check_Inlining_Restrictions then
3365 while Present (D) loop
3366 if Nkind (D) = N_Subprogram_Body then
3368 ("cannot inline & (nested subprogram)?",
3372 elsif Nkind (D) = N_Task_Type_Declaration
3373 or else Nkind (D) = N_Single_Task_Declaration
3376 ("cannot inline & (nested task type declaration)?",
3380 elsif Nkind (D) = N_Protected_Type_Declaration
3381 or else Nkind (D) = N_Single_Protected_Declaration
3384 ("cannot inline & (nested protected type declaration)?",
3388 elsif Nkind (D) = N_Package_Declaration then
3390 ("cannot inline & (nested package declaration)?",
3394 elsif Nkind (D) = N_Function_Instantiation
3395 and then not Is_Unchecked_Conversion (D)
3398 ("cannot inline & (nested function instantiation)?",
3402 elsif Nkind (D) = N_Procedure_Instantiation then
3404 ("cannot inline & (nested procedure instantiation)?",
3408 elsif Nkind (D) = N_Package_Instantiation then
3410 ("cannot inline & (nested package instantiation)?",
3419 end Has_Excluded_Declaration;
3421 ----------------------------
3422 -- Has_Excluded_Statement --
3423 ----------------------------
3425 function Has_Excluded_Statement
3427 Stats : List_Id) return Boolean
3433 -- No action needed if the check is not needed
3435 if not Check_Inlining_Restrictions then
3440 while Present (S) loop
3441 if Nkind_In (S, N_Abort_Statement,
3442 N_Asynchronous_Select,
3443 N_Conditional_Entry_Call,
3444 N_Delay_Relative_Statement,
3445 N_Delay_Until_Statement,
3450 ("cannot inline & (non-allowed statement)?", S, Subp);
3453 elsif Nkind (S) = N_Block_Statement then
3454 if Present (Declarations (S))
3455 and then Has_Excluded_Declaration (Subp, Declarations (S))
3459 elsif Present (Handled_Statement_Sequence (S)) then
3460 if not Back_End_Inlining
3463 (Exception_Handlers (Handled_Statement_Sequence (S)))
3466 ("cannot inline& (exception handler)?",
3467 First (Exception_Handlers
3468 (Handled_Statement_Sequence (S))),
3472 elsif Has_Excluded_Statement
3473 (Subp, Statements (Handled_Statement_Sequence (S)))
3479 elsif Nkind (S) = N_Case_Statement then
3480 E := First (Alternatives (S));
3481 while Present (E) loop
3482 if Has_Excluded_Statement (Subp, Statements (E)) then
3489 elsif Nkind (S) = N_If_Statement then
3490 if Has_Excluded_Statement (Subp, Then_Statements (S)) then
3494 if Present (Elsif_Parts (S)) then
3495 E := First (Elsif_Parts (S));
3496 while Present (E) loop
3497 if Has_Excluded_Statement (Subp, Then_Statements (E)) then
3505 if Present (Else_Statements (S))
3506 and then Has_Excluded_Statement (Subp, Else_Statements (S))
3511 elsif Nkind (S) = N_Loop_Statement
3512 and then Has_Excluded_Statement (Subp, Statements (S))
3516 elsif Nkind (S) = N_Extended_Return_Statement then
3517 if Present (Handled_Statement_Sequence (S))
3519 Has_Excluded_Statement
3520 (Subp, Statements (Handled_Statement_Sequence (S)))
3524 elsif not Back_End_Inlining
3525 and then Present (Handled_Statement_Sequence (S))
3527 Present (Exception_Handlers
3528 (Handled_Statement_Sequence (S)))
3531 ("cannot inline& (exception handler)?",
3532 First (Exception_Handlers (Handled_Statement_Sequence (S))),
3542 end Has_Excluded_Statement;
3544 --------------------------
3545 -- Has_Initialized_Type --
3546 --------------------------
3548 function Has_Initialized_Type (E : Entity_Id) return Boolean is
3549 E_Body : constant Node_Id := Get_Subprogram_Body (E);
3553 if No (E_Body) then -- imported subprogram
3557 Decl := First (Declarations (E_Body));
3558 while Present (Decl) loop
3559 if Nkind (Decl) = N_Full_Type_Declaration
3560 and then Present (Init_Proc (Defining_Identifier (Decl)))
3570 end Has_Initialized_Type;
3572 -----------------------
3573 -- Has_Single_Return --
3574 -----------------------
3576 function Has_Single_Return (N : Node_Id) return Boolean is
3577 Return_Statement : Node_Id := Empty;
3579 function Check_Return (N : Node_Id) return Traverse_Result;
3585 function Check_Return (N : Node_Id) return Traverse_Result is
3587 if Nkind (N) = N_Simple_Return_Statement then
3588 if Present (Expression (N))
3589 and then Is_Entity_Name (Expression (N))
3591 if No (Return_Statement) then
3592 Return_Statement := N;
3595 elsif Chars (Expression (N)) =
3596 Chars (Expression (Return_Statement))
3604 -- A return statement within an extended return is a noop
3607 elsif No (Expression (N))
3609 Nkind (Parent (Parent (N))) = N_Extended_Return_Statement
3614 -- Expression has wrong form
3619 -- We can only inline a build-in-place function if it has a single
3622 elsif Nkind (N) = N_Extended_Return_Statement then
3623 if No (Return_Statement) then
3624 Return_Statement := N;
3636 function Check_All_Returns is new Traverse_Func (Check_Return);
3638 -- Start of processing for Has_Single_Return
3641 if Check_All_Returns (N) /= OK then
3644 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
3648 return Present (Declarations (N))
3649 and then Present (First (Declarations (N)))
3650 and then Chars (Expression (Return_Statement)) =
3651 Chars (Defining_Identifier (First (Declarations (N))));
3653 end Has_Single_Return;
3655 -----------------------------
3656 -- In_Main_Unit_Or_Subunit --
3657 -----------------------------
3659 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is
3660 Comp : Node_Id := Cunit (Get_Code_Unit (E));
3663 -- Check whether the subprogram or package to inline is within the main
3664 -- unit or its spec or within a subunit. In either case there are no
3665 -- additional bodies to process. If the subprogram appears in a parent
3666 -- of the current unit, the check on whether inlining is possible is
3667 -- done in Analyze_Inlined_Bodies.
3669 while Nkind (Unit (Comp)) = N_Subunit loop
3670 Comp := Library_Unit (Comp);
3673 return Comp = Cunit (Main_Unit)
3674 or else Comp = Library_Unit (Cunit (Main_Unit));
3675 end In_Main_Unit_Or_Subunit;
3681 procedure Initialize is
3683 Pending_Descriptor.Init;
3684 Pending_Instantiations.Init;
3685 Inlined_Bodies.Init;
3689 for J in Hash_Headers'Range loop
3690 Hash_Headers (J) := No_Subp;
3693 Inlined_Calls := No_Elist;
3694 Backend_Calls := No_Elist;
3695 Backend_Inlined_Subps := No_Elist;
3696 Backend_Not_Inlined_Subps := No_Elist;
3699 ------------------------
3700 -- Instantiate_Bodies --
3701 ------------------------
3703 -- Generic bodies contain all the non-local references, so an
3704 -- instantiation does not need any more context than Standard
3705 -- itself, even if the instantiation appears in an inner scope.
3706 -- Generic associations have verified that the contract model is
3707 -- satisfied, so that any error that may occur in the analysis of
3708 -- the body is an internal error.
3710 procedure Instantiate_Bodies is
3712 Info : Pending_Body_Info;
3715 if Serious_Errors_Detected = 0 then
3716 Expander_Active := (Operating_Mode = Opt.Generate_Code);
3717 Push_Scope (Standard_Standard);
3718 To_Clean := New_Elmt_List;
3720 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
3724 -- A body instantiation may generate additional instantiations, so
3725 -- the following loop must scan to the end of a possibly expanding
3726 -- set (that's why we can't simply use a FOR loop here).
3729 while J <= Pending_Instantiations.Last
3730 and then Serious_Errors_Detected = 0
3732 Info := Pending_Instantiations.Table (J);
3734 -- If the instantiation node is absent, it has been removed
3735 -- as part of unreachable code.
3737 if No (Info.Inst_Node) then
3740 elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
3741 Instantiate_Package_Body (Info);
3742 Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
3745 Instantiate_Subprogram_Body (Info);
3751 -- Reset the table of instantiations. Additional instantiations
3752 -- may be added through inlining, when additional bodies are
3755 Pending_Instantiations.Init;
3757 -- We can now complete the cleanup actions of scopes that contain
3758 -- pending instantiations (skipped for generic units, since we
3759 -- never need any cleanups in generic units).
3760 -- pending instantiations.
3763 and then not Is_Generic_Unit (Main_Unit_Entity)
3766 elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
3772 end Instantiate_Bodies;
3778 function Is_Nested (E : Entity_Id) return Boolean is
3783 while Scop /= Standard_Standard loop
3784 if Ekind (Scop) in Subprogram_Kind then
3787 elsif Ekind (Scop) = E_Task_Type
3788 or else Ekind (Scop) = E_Entry
3789 or else Ekind (Scop) = E_Entry_Family
3794 Scop := Scope (Scop);
3800 ------------------------
3801 -- List_Inlining_Info --
3802 ------------------------
3804 procedure List_Inlining_Info is
3810 if not Debug_Flag_Dot_J then
3814 -- Generate listing of calls inlined by the frontend
3816 if Present (Inlined_Calls) then
3818 Elmt := First_Elmt (Inlined_Calls);
3819 while Present (Elmt) loop
3822 if In_Extended_Main_Code_Unit (Nod) then
3826 Write_Str ("List of calls inlined by the frontend");
3833 Write_Location (Sloc (Nod));
3842 -- Generate listing of calls passed to the backend
3844 if Present (Backend_Calls) then
3847 Elmt := First_Elmt (Backend_Calls);
3848 while Present (Elmt) loop
3851 if In_Extended_Main_Code_Unit (Nod) then
3855 Write_Str ("List of inlined calls passed to the backend");
3862 Write_Location (Sloc (Nod));
3870 -- Generate listing of subprograms passed to the backend
3872 if Present (Backend_Inlined_Subps)
3873 and then Back_End_Inlining
3877 Elmt := First_Elmt (Backend_Inlined_Subps);
3878 while Present (Elmt) loop
3885 ("List of inlined subprograms passed to the backend");
3892 Write_Name (Chars (Nod));
3894 Write_Location (Sloc (Nod));
3902 -- Generate listing of subprograms that cannot be inlined by the backend
3904 if Present (Backend_Not_Inlined_Subps)
3905 and then Back_End_Inlining
3909 Elmt := First_Elmt (Backend_Not_Inlined_Subps);
3910 while Present (Elmt) loop
3917 ("List of subprograms that cannot be inlined by the backend");
3924 Write_Name (Chars (Nod));
3926 Write_Location (Sloc (Nod));
3933 end List_Inlining_Info;
3941 Pending_Instantiations.Locked := True;
3942 Inlined_Bodies.Locked := True;
3943 Successors.Locked := True;
3944 Inlined.Locked := True;
3945 Pending_Instantiations.Release;
3946 Inlined_Bodies.Release;
3951 ---------------------------
3952 -- Register_Backend_Call --
3953 ---------------------------
3955 procedure Register_Backend_Call (N : Node_Id) is
3957 Append_New_Elmt (N, To => Backend_Calls);
3958 end Register_Backend_Call;
3960 --------------------------
3961 -- Remove_Dead_Instance --
3962 --------------------------
3964 procedure Remove_Dead_Instance (N : Node_Id) is
3969 while J <= Pending_Instantiations.Last loop
3970 if Pending_Instantiations.Table (J).Inst_Node = N then
3971 Pending_Instantiations.Table (J).Inst_Node := Empty;
3977 end Remove_Dead_Instance;
3979 --------------------
3980 -- Remove_Pragmas --
3981 --------------------
3983 procedure Remove_Pragmas (Bod : Node_Id) is
3988 Decl := First (Declarations (Bod));
3989 while Present (Decl) loop
3992 if Nkind (Decl) = N_Pragma
3993 and then Nam_In (Pragma_Name (Decl), Name_Contract_Cases,