1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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 Aspects; use Aspects;
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Expander; use Expander;
33 with Exp_Ch6; use Exp_Ch6;
34 with Exp_Ch7; use Exp_Ch7;
35 with Exp_Tss; use Exp_Tss;
36 with Exp_Util; use Exp_Util;
37 with Fname; use Fname;
38 with Fname.UF; use Fname.UF;
40 with Namet; use Namet;
41 with Nmake; use Nmake;
42 with Nlists; use Nlists;
43 with Output; use Output;
44 with Sem_Aux; use Sem_Aux;
45 with Sem_Ch8; use Sem_Ch8;
46 with Sem_Ch10; use Sem_Ch10;
47 with Sem_Ch12; use Sem_Ch12;
48 with Sem_Prag; use Sem_Prag;
49 with Sem_Util; use Sem_Util;
50 with Sinfo; use Sinfo;
51 with Sinput; use Sinput;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Uname; use Uname;
55 with Tbuild; use Tbuild;
57 package body Inline is
59 Check_Inlining_Restrictions : constant Boolean := True;
60 -- In the following cases the frontend rejects inlining because they
61 -- are not handled well by the backend. This variable facilitates
62 -- disabling these restrictions to evaluate future versions of the
63 -- GCC backend in which some of the restrictions may be supported.
65 -- - subprograms that have:
66 -- - nested subprograms
68 -- - package declarations
69 -- - task or protected object declarations
70 -- - some of the following statements:
72 -- - asynchronous-select
73 -- - conditional-entry-call
79 Inlined_Calls : Elist_Id;
80 -- List of frontend inlined calls
82 Backend_Calls : Elist_Id;
83 -- List of inline calls passed to the backend
85 Backend_Inlined_Subps : Elist_Id;
86 -- List of subprograms inlined by the backend
88 Backend_Not_Inlined_Subps : Elist_Id;
89 -- List of subprograms that cannot be inlined by the backend
95 -- Inlined functions are actually placed in line by the backend if the
96 -- corresponding bodies are available (i.e. compiled). Whenever we find
97 -- a call to an inlined subprogram, we add the name of the enclosing
98 -- compilation unit to a worklist. After all compilation, and after
99 -- expansion of generic bodies, we traverse the list of pending bodies
100 -- and compile them as well.
102 package Inlined_Bodies is new Table.Table (
103 Table_Component_Type => Entity_Id,
104 Table_Index_Type => Int,
105 Table_Low_Bound => 0,
106 Table_Initial => Alloc.Inlined_Bodies_Initial,
107 Table_Increment => Alloc.Inlined_Bodies_Increment,
108 Table_Name => "Inlined_Bodies");
110 -----------------------
111 -- Inline Processing --
112 -----------------------
114 -- For each call to an inlined subprogram, we make entries in a table
115 -- that stores caller and callee, and indicates the call direction from
116 -- one to the other. We also record the compilation unit that contains
117 -- the callee. After analyzing the bodies of all such compilation units,
118 -- we compute the transitive closure of inlined subprograms called from
119 -- the main compilation unit and make it available to the code generator
120 -- in no particular order, thus allowing cycles in the call graph.
122 Last_Inlined : Entity_Id := Empty;
124 -- For each entry in the table we keep a list of successors in topological
125 -- order, i.e. callers of the current subprogram.
127 type Subp_Index is new Nat;
128 No_Subp : constant Subp_Index := 0;
130 -- The subprogram entities are hashed into the Inlined table
132 Num_Hash_Headers : constant := 512;
134 Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1)
137 type Succ_Index is new Nat;
138 No_Succ : constant Succ_Index := 0;
140 type Succ_Info is record
145 -- The following table stores list elements for the successor lists. These
146 -- lists cannot be chained directly through entries in the Inlined table,
147 -- because a given subprogram can appear in several such lists.
149 package Successors is new Table.Table (
150 Table_Component_Type => Succ_Info,
151 Table_Index_Type => Succ_Index,
152 Table_Low_Bound => 1,
153 Table_Initial => Alloc.Successors_Initial,
154 Table_Increment => Alloc.Successors_Increment,
155 Table_Name => "Successors");
157 type Subp_Info is record
158 Name : Entity_Id := Empty;
159 Next : Subp_Index := No_Subp;
160 First_Succ : Succ_Index := No_Succ;
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 (E : Entity_Id);
183 -- Add subprogram E 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 -- nontrivial 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_Aspects_And_Pragmas (Body_Decl : Node_Id);
216 -- Remove all aspects and/or pragmas that have no meaning in inlined body
217 -- Body_Decl. The analysis of these items is performed on the non-inlined
218 -- body. The items currently removed are:
231 ------------------------------
232 -- Deferred Cleanup Actions --
233 ------------------------------
235 -- The cleanup actions for scopes that contain instantiations is delayed
236 -- until after expansion of those instantiations, because they may contain
237 -- finalizable objects or tasks that affect the cleanup code. A scope
238 -- that contains instantiations only needs to be finalized once, even
239 -- if it contains more than one instance. We keep a list of scopes
240 -- that must still be finalized, and call cleanup_actions after all
241 -- the instantiations have been completed.
245 procedure Add_Scope_To_Clean (Inst : Entity_Id);
246 -- Build set of scopes on which cleanup actions must be performed
248 procedure Cleanup_Scopes;
249 -- Complete cleanup actions on scopes that need it
255 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
256 P1 : constant Subp_Index := Add_Subp (Called);
261 if Present (Caller) then
262 P2 := Add_Subp (Caller);
264 -- Add P1 to the list of successors of P2, if not already there.
265 -- Note that P2 may contain more than one call to P1, and only
266 -- one needs to be recorded.
268 J := Inlined.Table (P2).First_Succ;
269 while J /= No_Succ loop
270 if Successors.Table (J).Subp = P1 then
274 J := Successors.Table (J).Next;
277 -- On exit, make a successor entry for P1
279 Successors.Increment_Last;
280 Successors.Table (Successors.Last).Subp := P1;
281 Successors.Table (Successors.Last).Next :=
282 Inlined.Table (P2).First_Succ;
283 Inlined.Table (P2).First_Succ := Successors.Last;
285 Inlined.Table (P1).Main_Call := True;
289 ----------------------
290 -- Add_Inlined_Body --
291 ----------------------
293 procedure Add_Inlined_Body (E : Entity_Id; N : Node_Id) is
295 type Inline_Level_Type is (Dont_Inline, Inline_Call, Inline_Package);
296 -- Level of inlining for the call: Dont_Inline means no inlining,
297 -- Inline_Call means that only the call is considered for inlining,
298 -- Inline_Package means that the call is considered for inlining and
299 -- its package compiled and scanned for more inlining opportunities.
301 function Must_Inline return Inline_Level_Type;
302 -- Inlining is only done if the call statement N is in the main unit,
303 -- or within the body of another inlined subprogram.
309 function Must_Inline return Inline_Level_Type is
314 -- Check if call is in main unit
316 Scop := Current_Scope;
318 -- Do not try to inline if scope is standard. This could happen, for
319 -- example, for a call to Add_Global_Declaration, and it causes
320 -- trouble to try to inline at this level.
322 if Scop = Standard_Standard then
326 -- Otherwise lookup scope stack to outer scope
328 while Scope (Scop) /= Standard_Standard
329 and then not Is_Child_Unit (Scop)
331 Scop := Scope (Scop);
334 Comp := Parent (Scop);
335 while Nkind (Comp) /= N_Compilation_Unit loop
336 Comp := Parent (Comp);
339 -- If the call is in the main unit, inline the call and compile the
340 -- package of the subprogram to find more calls to be inlined.
342 if Comp = Cunit (Main_Unit)
343 or else Comp = Library_Unit (Cunit (Main_Unit))
346 return Inline_Package;
349 -- The call is not in the main unit. See if it is in some subprogram
350 -- that can be inlined outside its unit. If so, inline the call and,
351 -- if the inlining level is set to 1, stop there; otherwise also
352 -- compile the package as above.
354 Scop := Current_Scope;
355 while Scope (Scop) /= Standard_Standard
356 and then not Is_Child_Unit (Scop)
358 if Is_Overloadable (Scop)
359 and then Is_Inlined (Scop)
360 and then not Is_Nested (Scop)
364 if Inline_Level = 1 then
367 return Inline_Package;
371 Scop := Scope (Scop);
377 Level : Inline_Level_Type;
379 -- Start of processing for Add_Inlined_Body
382 Append_New_Elmt (N, To => Backend_Calls);
384 -- Skip subprograms that cannot be inlined outside their unit
386 if Is_Abstract_Subprogram (E)
387 or else Convention (E) = Convention_Protected
388 or else Is_Nested (E)
393 -- Find out whether the call must be inlined. Unless the result is
394 -- Dont_Inline, Must_Inline also creates an edge for the call in the
395 -- callgraph; however, it will not be activated until after Is_Called
396 -- is set on the subprogram.
398 Level := Must_Inline;
400 if Level = Dont_Inline then
404 -- If the call was generated by the compiler and is to a subprogram in
405 -- a run-time unit, we need to suppress debugging information for it,
406 -- so that the code that is eventually inlined will not affect the
407 -- debugging of the program. We do not do it if the call comes from
408 -- source because, even if the call is inlined, the user may expect it
409 -- to be present in the debugging information.
411 if not Comes_From_Source (N)
412 and then In_Extended_Main_Source_Unit (N)
414 Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (E)))
416 Set_Needs_Debug_Info (E, False);
419 -- If the subprogram is an expression function, then there is no need to
420 -- load any package body since the body of the function is in the spec.
422 if Is_Expression_Function (E) then
427 -- Find unit containing E, and add to list of inlined bodies if needed.
428 -- If the body is already present, no need to load any other unit. This
429 -- is the case for an initialization procedure, which appears in the
430 -- package declaration that contains the type. It is also the case if
431 -- the body has already been analyzed. Finally, if the unit enclosing
432 -- E is an instance, the instance body will be analyzed in any case,
433 -- and there is no need to add the enclosing unit (whose body might not
436 -- Library-level functions must be handled specially, because there is
437 -- no enclosing package to retrieve. In this case, it is the body of
438 -- the function that will have to be loaded.
441 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
446 Inlined_Bodies.Increment_Last;
447 Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
449 elsif Ekind (Pack) = E_Package then
452 if Is_Generic_Instance (Pack) then
455 -- Do not inline the package if the subprogram is an init proc
456 -- or other internally generated subprogram, because in that
457 -- case the subprogram body appears in the same unit that
458 -- declares the type, and that body is visible to the back end.
459 -- Do not inline it either if it is in the main unit.
460 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
461 -- calls if the back-end takes care of inlining the call.
463 elsif (Level = Inline_Package
464 or else (Level = Inline_Call
465 and then Has_Pragma_Inline_Always (E)
466 and then Back_End_Inlining))
467 and then not Is_Inlined (Pack)
468 and then not Is_Internal (E)
469 and then not In_Main_Unit_Or_Subunit (Pack)
471 Set_Is_Inlined (Pack);
472 Inlined_Bodies.Increment_Last;
473 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
477 -- Ensure that Analyze_Inlined_Bodies will be invoked after
478 -- completing the analysis of the current unit.
480 Inline_Processing_Required := True;
482 end Add_Inlined_Body;
484 ----------------------------
485 -- Add_Inlined_Subprogram --
486 ----------------------------
488 procedure Add_Inlined_Subprogram (E : Entity_Id) is
489 Decl : constant Node_Id := Parent (Declaration_Node (E));
490 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
492 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id);
493 -- Append Subp to the list of subprograms inlined by the backend
495 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id);
496 -- Append Subp to the list of subprograms that cannot be inlined by
499 -----------------------------------------
500 -- Register_Backend_Inlined_Subprogram --
501 -----------------------------------------
503 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is
505 Append_New_Elmt (Subp, To => Backend_Inlined_Subps);
506 end Register_Backend_Inlined_Subprogram;
508 ---------------------------------------------
509 -- Register_Backend_Not_Inlined_Subprogram --
510 ---------------------------------------------
512 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is
514 Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps);
515 end Register_Backend_Not_Inlined_Subprogram;
517 -- Start of processing for Add_Inlined_Subprogram
520 -- If the subprogram is to be inlined, and if its unit is known to be
521 -- inlined or is an instance whose body will be analyzed anyway or the
522 -- subprogram was generated as a body by the compiler (for example an
523 -- initialization procedure) or its declaration was provided along with
524 -- the body (for example an expression function), and if it is declared
525 -- at the library level not in the main unit, and if it can be inlined
526 -- by the back-end, then insert it in the list of inlined subprograms.
529 and then (Is_Inlined (Pack)
530 or else Is_Generic_Instance (Pack)
531 or else Nkind (Decl) = N_Subprogram_Body
532 or else Present (Corresponding_Body (Decl)))
533 and then not In_Main_Unit_Or_Subunit (E)
534 and then not Is_Nested (E)
535 and then not Has_Initialized_Type (E)
537 Register_Backend_Inlined_Subprogram (E);
539 if No (Last_Inlined) then
540 Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
542 Set_Next_Inlined_Subprogram (Last_Inlined, E);
548 Register_Backend_Not_Inlined_Subprogram (E);
550 end Add_Inlined_Subprogram;
552 ------------------------
553 -- Add_Scope_To_Clean --
554 ------------------------
556 procedure Add_Scope_To_Clean (Inst : Entity_Id) is
557 Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
561 -- If the instance appears in a library-level package declaration,
562 -- all finalization is global, and nothing needs doing here.
564 if Scop = Standard_Standard then
568 -- If the instance is within a generic unit, no finalization code
569 -- can be generated. Note that at this point all bodies have been
570 -- analyzed, and the scope stack itself is not present, and the flag
571 -- Inside_A_Generic is not set.
578 while Present (S) and then S /= Standard_Standard loop
579 if Is_Generic_Unit (S) then
587 Elmt := First_Elmt (To_Clean);
588 while Present (Elmt) loop
589 if Node (Elmt) = Scop then
593 Elmt := Next_Elmt (Elmt);
596 Append_Elmt (Scop, To_Clean);
597 end Add_Scope_To_Clean;
603 function Add_Subp (E : Entity_Id) return Subp_Index is
604 Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
608 -- Initialize entry in Inlined table
610 procedure New_Entry is
612 Inlined.Increment_Last;
613 Inlined.Table (Inlined.Last).Name := E;
614 Inlined.Table (Inlined.Last).Next := No_Subp;
615 Inlined.Table (Inlined.Last).First_Succ := No_Succ;
616 Inlined.Table (Inlined.Last).Main_Call := False;
617 Inlined.Table (Inlined.Last).Processed := False;
620 -- Start of processing for Add_Subp
623 if Hash_Headers (Index) = No_Subp then
625 Hash_Headers (Index) := Inlined.Last;
629 J := Hash_Headers (Index);
630 while J /= No_Subp loop
631 if Inlined.Table (J).Name = E then
635 J := Inlined.Table (J).Next;
639 -- On exit, subprogram was not found. Enter in table. Index is
640 -- the current last entry on the hash chain.
643 Inlined.Table (Index).Next := Inlined.Last;
648 ----------------------------
649 -- Analyze_Inlined_Bodies --
650 ----------------------------
652 procedure Analyze_Inlined_Bodies is
659 type Pending_Index is new Nat;
661 package Pending_Inlined is new Table.Table (
662 Table_Component_Type => Subp_Index,
663 Table_Index_Type => Pending_Index,
664 Table_Low_Bound => 1,
665 Table_Initial => Alloc.Inlined_Initial,
666 Table_Increment => Alloc.Inlined_Increment,
667 Table_Name => "Pending_Inlined");
668 -- The workpile used to compute the transitive closure
670 function Is_Ancestor_Of_Main
672 Nam : Node_Id) return Boolean;
673 -- Determine whether the unit whose body is loaded is an ancestor of
674 -- the main unit, and has a with_clause on it. The body is not
675 -- analyzed yet, so the check is purely lexical: the name of the with
676 -- clause is a selected component, and names of ancestors must match.
678 -------------------------
679 -- Is_Ancestor_Of_Main --
680 -------------------------
682 function Is_Ancestor_Of_Main
684 Nam : Node_Id) return Boolean
689 if Nkind (Nam) /= N_Selected_Component then
693 if Chars (Selector_Name (Nam)) /=
694 Chars (Cunit_Entity (Main_Unit))
699 Pref := Prefix (Nam);
700 if Nkind (Pref) = N_Identifier then
702 -- Par is an ancestor of Par.Child.
704 return Chars (Pref) = Chars (U_Name);
706 elsif Nkind (Pref) = N_Selected_Component
707 and then Chars (Selector_Name (Pref)) = Chars (U_Name)
709 -- Par.Child is an ancestor of Par.Child.Grand.
711 return True; -- should check that ancestor match
714 -- A is an ancestor of A.B.C if it is an ancestor of A.B
716 return Is_Ancestor_Of_Main (U_Name, Pref);
719 end Is_Ancestor_Of_Main;
721 -- Start of processing for Analyze_Inlined_Bodies
724 if Serious_Errors_Detected = 0 then
725 Push_Scope (Standard_Standard);
728 while J <= Inlined_Bodies.Last
729 and then Serious_Errors_Detected = 0
731 Pack := Inlined_Bodies.Table (J);
733 and then Scope (Pack) /= Standard_Standard
734 and then not Is_Child_Unit (Pack)
736 Pack := Scope (Pack);
739 Comp_Unit := Parent (Pack);
740 while Present (Comp_Unit)
741 and then Nkind (Comp_Unit) /= N_Compilation_Unit
743 Comp_Unit := Parent (Comp_Unit);
746 -- Load the body, unless it is the main unit, or is an instance
747 -- whose body has already been analyzed.
749 if Present (Comp_Unit)
750 and then Comp_Unit /= Cunit (Main_Unit)
751 and then Body_Required (Comp_Unit)
752 and then (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
753 or else No (Corresponding_Body (Unit (Comp_Unit))))
756 Bname : constant Unit_Name_Type :=
757 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
762 if not Is_Loaded (Bname) then
763 Style_Check := False;
764 Load_Needed_Body (Comp_Unit, OK, Do_Analyze => False);
768 -- Warn that a body was not available for inlining
771 Error_Msg_Unit_1 := Bname;
773 ("one or more inlined subprograms accessed in $!??",
776 Get_File_Name (Bname, Subunit => False);
777 Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
780 -- If the package to be inlined is an ancestor unit of
781 -- the main unit, and it has a semantic dependence on
782 -- it, the inlining cannot take place to prevent an
783 -- elaboration circularity. The desired body is not
784 -- analyzed yet, to prevent the completion of Taft
785 -- amendment types that would lead to elaboration
786 -- circularities in gigi.
789 U_Id : constant Entity_Id :=
790 Defining_Entity (Unit (Comp_Unit));
791 Body_Unit : constant Node_Id :=
792 Library_Unit (Comp_Unit);
796 Item := First (Context_Items (Body_Unit));
797 while Present (Item) loop
798 if Nkind (Item) = N_With_Clause
800 Is_Ancestor_Of_Main (U_Id, Name (Item))
802 Set_Is_Inlined (U_Id, False);
809 -- If no suspicious with_clauses, analyze the body.
811 if Is_Inlined (U_Id) then
812 Semantics (Body_Unit);
822 if J > Inlined_Bodies.Last then
824 -- The analysis of required bodies may have produced additional
825 -- generic instantiations. To obtain further inlining, we need
826 -- to perform another round of generic body instantiations.
830 -- Symmetrically, the instantiation of required generic bodies
831 -- may have caused additional bodies to be inlined. To obtain
832 -- further inlining, we keep looping over the inlined bodies.
836 -- The list of inlined subprograms is an overestimate, because it
837 -- includes inlined functions called from functions that are compiled
838 -- as part of an inlined package, but are not themselves called. An
839 -- accurate computation of just those subprograms that are needed
840 -- requires that we perform a transitive closure over the call graph,
841 -- starting from calls in the main compilation unit.
843 for Index in Inlined.First .. Inlined.Last loop
844 if not Is_Called (Inlined.Table (Index).Name) then
846 -- This means that Add_Inlined_Body added the subprogram to the
847 -- table but wasn't able to handle its code unit. Do nothing.
849 Inlined.Table (Index).Processed := True;
851 elsif Inlined.Table (Index).Main_Call then
852 Pending_Inlined.Increment_Last;
853 Pending_Inlined.Table (Pending_Inlined.Last) := Index;
854 Inlined.Table (Index).Processed := True;
857 Set_Is_Called (Inlined.Table (Index).Name, False);
861 -- Iterate over the workpile until it is emptied, propagating the
862 -- Is_Called flag to the successors of the processed subprogram.
864 while Pending_Inlined.Last >= Pending_Inlined.First loop
865 Subp := Pending_Inlined.Table (Pending_Inlined.Last);
866 Pending_Inlined.Decrement_Last;
868 S := Inlined.Table (Subp).First_Succ;
870 while S /= No_Succ loop
871 Subp := Successors.Table (S).Subp;
873 if not Inlined.Table (Subp).Processed then
874 Set_Is_Called (Inlined.Table (Subp).Name);
875 Pending_Inlined.Increment_Last;
876 Pending_Inlined.Table (Pending_Inlined.Last) := Subp;
877 Inlined.Table (Subp).Processed := True;
880 S := Successors.Table (S).Next;
884 -- Finally add the called subprograms to the list of inlined
885 -- subprograms for the unit.
887 for Index in Inlined.First .. Inlined.Last loop
888 if Is_Called (Inlined.Table (Index).Name) then
889 Add_Inlined_Subprogram (Inlined.Table (Index).Name);
895 end Analyze_Inlined_Bodies;
897 --------------------------
898 -- Build_Body_To_Inline --
899 --------------------------
901 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
902 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
903 Analysis_Status : constant Boolean := Full_Analysis;
904 Original_Body : Node_Id;
905 Body_To_Analyze : Node_Id;
906 Max_Size : constant := 10;
908 function Has_Pending_Instantiation return Boolean;
909 -- If some enclosing body contains instantiations that appear before
910 -- the corresponding generic body, the enclosing body has a freeze node
911 -- so that it can be elaborated after the generic itself. This might
912 -- conflict with subsequent inlinings, so that it is unsafe to try to
913 -- inline in such a case.
915 function Has_Single_Return_In_GNATprove_Mode return Boolean;
916 -- This function is called only in GNATprove mode, and it returns
917 -- True if the subprogram has no return statement or a single return
918 -- statement as last statement. It returns False for subprogram with
919 -- a single return as last statement inside one or more blocks, as
920 -- inlining would generate gotos in that case as well (although the
921 -- goto is useless in that case).
923 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
924 -- If the body of the subprogram includes a call that returns an
925 -- unconstrained type, the secondary stack is involved, and it
926 -- is not worth inlining.
928 -------------------------------
929 -- Has_Pending_Instantiation --
930 -------------------------------
932 function Has_Pending_Instantiation return Boolean is
937 while Present (S) loop
938 if Is_Compilation_Unit (S)
939 or else Is_Child_Unit (S)
943 elsif Ekind (S) = E_Package
944 and then Has_Forward_Instantiation (S)
953 end Has_Pending_Instantiation;
955 -----------------------------------------
956 -- Has_Single_Return_In_GNATprove_Mode --
957 -----------------------------------------
959 function Has_Single_Return_In_GNATprove_Mode return Boolean is
960 Last_Statement : Node_Id := Empty;
962 function Check_Return (N : Node_Id) return Traverse_Result;
963 -- Returns OK on node N if this is not a return statement different
964 -- from the last statement in the subprogram.
970 function Check_Return (N : Node_Id) return Traverse_Result is
972 if Nkind_In (N, N_Simple_Return_Statement,
973 N_Extended_Return_Statement)
975 if N = Last_Statement then
986 function Check_All_Returns is new Traverse_Func (Check_Return);
988 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
991 -- Retrieve the last statement
993 Last_Statement := Last (Statements (Handled_Statement_Sequence (N)));
995 -- Check that the last statement is the only possible return
996 -- statement in the subprogram.
998 return Check_All_Returns (N) = OK;
999 end Has_Single_Return_In_GNATprove_Mode;
1001 --------------------------
1002 -- Uses_Secondary_Stack --
1003 --------------------------
1005 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
1006 function Check_Call (N : Node_Id) return Traverse_Result;
1007 -- Look for function calls that return an unconstrained type
1013 function Check_Call (N : Node_Id) return Traverse_Result is
1015 if Nkind (N) = N_Function_Call
1016 and then Is_Entity_Name (Name (N))
1017 and then Is_Composite_Type (Etype (Entity (Name (N))))
1018 and then not Is_Constrained (Etype (Entity (Name (N))))
1021 ("cannot inline & (call returns unconstrained type)?",
1029 function Check_Calls is new Traverse_Func (Check_Call);
1032 return Check_Calls (Bod) = Abandon;
1033 end Uses_Secondary_Stack;
1035 -- Start of processing for Build_Body_To_Inline
1038 -- Return immediately if done already
1040 if Nkind (Decl) = N_Subprogram_Declaration
1041 and then Present (Body_To_Inline (Decl))
1045 -- Subprograms that have return statements in the middle of the body are
1046 -- inlined with gotos. GNATprove does not currently support gotos, so
1047 -- we prevent such inlining.
1049 elsif GNATprove_Mode
1050 and then not Has_Single_Return_In_GNATprove_Mode
1052 Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
1055 -- Functions that return unconstrained composite types require
1056 -- secondary stack handling, and cannot currently be inlined, unless
1057 -- all return statements return a local variable that is the first
1058 -- local declaration in the body.
1060 elsif Ekind (Spec_Id) = E_Function
1061 and then not Is_Scalar_Type (Etype (Spec_Id))
1062 and then not Is_Access_Type (Etype (Spec_Id))
1063 and then not Is_Constrained (Etype (Spec_Id))
1065 if not Has_Single_Return (N) then
1067 ("cannot inline & (unconstrained return type)?", N, Spec_Id);
1071 -- Ditto for functions that return controlled types, where controlled
1072 -- actions interfere in complex ways with inlining.
1074 elsif Ekind (Spec_Id) = E_Function
1075 and then Needs_Finalization (Etype (Spec_Id))
1078 ("cannot inline & (controlled return type)?", N, Spec_Id);
1082 if Present (Declarations (N))
1083 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
1088 if Present (Handled_Statement_Sequence (N)) then
1089 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1091 ("cannot inline& (exception handler)?",
1092 First (Exception_Handlers (Handled_Statement_Sequence (N))),
1096 elsif Has_Excluded_Statement
1097 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
1103 -- We do not inline a subprogram that is too large, unless it is marked
1104 -- Inline_Always or we are in GNATprove mode. This pragma does not
1105 -- suppress the other checks on inlining (forbidden declarations,
1108 if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode)
1109 and then List_Length
1110 (Statements (Handled_Statement_Sequence (N))) > Max_Size
1112 Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id);
1116 if Has_Pending_Instantiation then
1118 ("cannot inline& (forward instance within enclosing body)?",
1123 -- Within an instance, the body to inline must be treated as a nested
1124 -- generic, so that the proper global references are preserved.
1126 -- Note that we do not do this at the library level, because it is not
1127 -- needed, and furthermore this causes trouble if front end inlining
1128 -- is activated (-gnatN).
1130 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1131 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1132 Original_Body := Copy_Generic_Node (N, Empty, True);
1134 Original_Body := Copy_Separate_Tree (N);
1137 -- We need to capture references to the formals in order to substitute
1138 -- the actuals at the point of inlining, i.e. instantiation. To treat
1139 -- the formals as globals to the body to inline, we nest it within a
1140 -- dummy parameterless subprogram, declared within the real one. To
1141 -- avoid generating an internal name (which is never public, and which
1142 -- affects serial numbers of other generated names), we use an internal
1143 -- symbol that cannot conflict with user declarations.
1145 Set_Parameter_Specifications (Specification (Original_Body), No_List);
1146 Set_Defining_Unit_Name
1147 (Specification (Original_Body),
1148 Make_Defining_Identifier (Sloc (N), Name_uParent));
1149 Set_Corresponding_Spec (Original_Body, Empty);
1151 -- Remove all aspects/pragmas that have no meaining in an inlined body
1153 Remove_Aspects_And_Pragmas (Original_Body);
1155 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
1157 -- Set return type of function, which is also global and does not need
1160 if Ekind (Spec_Id) = E_Function then
1161 Set_Result_Definition
1162 (Specification (Body_To_Analyze),
1163 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1166 if No (Declarations (N)) then
1167 Set_Declarations (N, New_List (Body_To_Analyze));
1169 Append (Body_To_Analyze, Declarations (N));
1172 -- The body to inline is pre-analyzed. In GNATprove mode we must disable
1173 -- full analysis as well so that light expansion does not take place
1174 -- either, and name resolution is unaffected.
1176 Expander_Mode_Save_And_Set (False);
1177 Full_Analysis := False;
1179 Analyze (Body_To_Analyze);
1180 Push_Scope (Defining_Entity (Body_To_Analyze));
1181 Save_Global_References (Original_Body);
1183 Remove (Body_To_Analyze);
1185 Expander_Mode_Restore;
1186 Full_Analysis := Analysis_Status;
1188 -- Restore environment if previously saved
1190 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1194 -- If secondary stack is used, there is no point in inlining. We have
1195 -- already issued the warning in this case, so nothing to do.
1197 if Uses_Secondary_Stack (Body_To_Analyze) then
1201 Set_Body_To_Inline (Decl, Original_Body);
1202 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1203 Set_Is_Inlined (Spec_Id);
1204 end Build_Body_To_Inline;
1210 procedure Cannot_Inline
1214 Is_Serious : Boolean := False)
1217 -- In GNATprove mode, inlining is the technical means by which the
1218 -- higher-level goal of contextual analysis is reached, so issue
1219 -- messages about failure to apply contextual analysis to a
1220 -- subprogram, rather than failure to inline it.
1223 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
1226 Len1 : constant Positive :=
1227 String (String'("cannot inline"))'Length;
1228 Len2 : constant Positive :=
1229 String (String'("info: no contextual analysis of"))'Length;
1231 New_Msg : String (1 .. Msg'Length + Len2 - Len1);
1234 New_Msg (1 .. Len2) := "info: no contextual analysis of";
1235 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
1236 Msg (Msg'First + Len1 .. Msg'Last);
1237 Cannot_Inline (New_Msg, N, Subp, Is_Serious);
1242 pragma Assert (Msg (Msg'Last) = '?');
1244 -- Legacy front end inlining model
1246 if not Back_End_Inlining then
1248 -- Do not emit warning if this is a predefined unit which is not
1249 -- the main unit. With validity checks enabled, some predefined
1250 -- subprograms may contain nested subprograms and become ineligible
1253 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
1254 and then not In_Extended_Main_Source_Unit (Subp)
1258 -- In GNATprove mode, issue a warning, and indicate that the
1259 -- subprogram is not always inlined by setting flag Is_Inlined_Always
1262 elsif GNATprove_Mode then
1263 Set_Is_Inlined_Always (Subp, False);
1264 Error_Msg_NE (Msg & "p?", N, Subp);
1266 elsif Has_Pragma_Inline_Always (Subp) then
1268 -- Remove last character (question mark) to make this into an
1269 -- error, because the Inline_Always pragma cannot be obeyed.
1271 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1273 elsif Ineffective_Inline_Warnings then
1274 Error_Msg_NE (Msg & "p?", N, Subp);
1277 -- New semantics relying on back end inlining
1279 elsif Is_Serious then
1281 -- Remove last character (question mark) to make this into an error.
1283 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1285 -- In GNATprove mode, issue a warning, and indicate that the subprogram
1286 -- is not always inlined by setting flag Is_Inlined_Always to False.
1288 elsif GNATprove_Mode then
1289 Set_Is_Inlined_Always (Subp, False);
1290 Error_Msg_NE (Msg & "p?", N, Subp);
1294 -- Do not emit warning if this is a predefined unit which is not
1295 -- the main unit. This behavior is currently provided for backward
1296 -- compatibility but it will be removed when we enforce the
1297 -- strictness of the new rules.
1299 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
1300 and then not In_Extended_Main_Source_Unit (Subp)
1304 elsif Has_Pragma_Inline_Always (Subp) then
1306 -- Emit a warning if this is a call to a runtime subprogram
1307 -- which is located inside a generic. Previously this call
1308 -- was silently skipped.
1310 if Is_Generic_Instance (Subp) then
1312 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
1314 if Is_Predefined_File_Name
1315 (Unit_File_Name (Get_Source_Unit (Gen_P)))
1317 Set_Is_Inlined (Subp, False);
1318 Error_Msg_NE (Msg & "p?", N, Subp);
1324 -- Remove last character (question mark) to make this into an
1325 -- error, because the Inline_Always pragma cannot be obeyed.
1327 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1330 Set_Is_Inlined (Subp, False);
1332 if Ineffective_Inline_Warnings then
1333 Error_Msg_NE (Msg & "p?", N, Subp);
1339 --------------------------------------
1340 -- Can_Be_Inlined_In_GNATprove_Mode --
1341 --------------------------------------
1343 function Can_Be_Inlined_In_GNATprove_Mode
1344 (Spec_Id : Entity_Id;
1345 Body_Id : Entity_Id) return Boolean
1347 function Has_Formal_With_Discriminant_Dependent_Fields
1348 (Id : Entity_Id) return Boolean;
1349 -- Returns true if the subprogram has at least one formal parameter of
1350 -- an unconstrained record type with per-object constraints on component
1353 function Has_Some_Contract (Id : Entity_Id) return Boolean;
1354 -- Returns True if subprogram Id has any contract (Pre, Post, Global,
1357 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
1358 -- Returns True if subprogram Id defines a compilation unit
1359 -- Shouldn't this be in Sem_Aux???
1361 function In_Package_Visible_Spec (Id : Node_Id) return Boolean;
1362 -- Returns True if subprogram Id is defined in the visible part of a
1363 -- package specification.
1365 ---------------------------------------------------
1366 -- Has_Formal_With_Discriminant_Dependent_Fields --
1367 ---------------------------------------------------
1369 function Has_Formal_With_Discriminant_Dependent_Fields
1370 (Id : Entity_Id) return Boolean is
1372 function Has_Discriminant_Dependent_Component
1373 (Typ : Entity_Id) return Boolean;
1374 -- Determine whether unconstrained record type Typ has at least
1375 -- one component that depends on a discriminant.
1377 ------------------------------------------
1378 -- Has_Discriminant_Dependent_Component --
1379 ------------------------------------------
1381 function Has_Discriminant_Dependent_Component
1382 (Typ : Entity_Id) return Boolean
1387 -- Inspect all components of the record type looking for one
1388 -- that depends on a discriminant.
1390 Comp := First_Component (Typ);
1391 while Present (Comp) loop
1392 if Has_Discriminant_Dependent_Constraint (Comp) then
1396 Next_Component (Comp);
1400 end Has_Discriminant_Dependent_Component;
1404 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1406 Formal_Typ : Entity_Id;
1408 -- Start of processing for
1409 -- Has_Formal_With_Discriminant_Dependent_Component
1412 -- Inspect all parameters of the subprogram looking for a formal
1413 -- of an unconstrained record type with at least one discriminant
1414 -- dependent component.
1416 Formal := First_Formal (Subp_Id);
1417 while Present (Formal) loop
1418 Formal_Typ := Etype (Formal);
1420 if Is_Record_Type (Formal_Typ)
1421 and then not Is_Constrained (Formal_Typ)
1422 and then Has_Discriminant_Dependent_Component (Formal_Typ)
1427 Next_Formal (Formal);
1431 end Has_Formal_With_Discriminant_Dependent_Fields;
1433 -----------------------
1434 -- Has_Some_Contract --
1435 -----------------------
1437 function Has_Some_Contract (Id : Entity_Id) return Boolean is
1441 -- A call to an expression function may precede the actual body which
1442 -- is inserted at the end of the enclosing declarations. Ensure that
1443 -- the related entity is decorated before inspecting the contract.
1445 if Is_Subprogram_Or_Generic_Subprogram (Id) then
1446 Items := Contract (Id);
1448 return Present (Items)
1449 and then (Present (Pre_Post_Conditions (Items)) or else
1450 Present (Contract_Test_Cases (Items)) or else
1451 Present (Classifications (Items)));
1455 end Has_Some_Contract;
1457 -----------------------------
1458 -- In_Package_Visible_Spec --
1459 -----------------------------
1461 function In_Package_Visible_Spec (Id : Node_Id) return Boolean is
1462 Decl : Node_Id := Parent (Parent (Id));
1466 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1467 Decl := Parent (Decl);
1472 return Nkind (P) = N_Package_Specification
1473 and then List_Containing (Decl) = Visible_Declarations (P);
1474 end In_Package_Visible_Spec;
1476 ------------------------
1477 -- Is_Unit_Subprogram --
1478 ------------------------
1480 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1481 Decl : Node_Id := Parent (Parent (Id));
1483 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1484 Decl := Parent (Decl);
1487 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1488 end Is_Unit_Subprogram;
1490 -- Local declarations
1492 Id : Entity_Id; -- Procedure or function entity for the subprogram
1494 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1497 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1499 if Present (Spec_Id) then
1505 -- Only local subprograms without contracts are inlined in GNATprove
1506 -- mode, as these are the subprograms which a user is not interested in
1507 -- analyzing in isolation, but rather in the context of their call. This
1508 -- is a convenient convention, that could be changed for an explicit
1509 -- pragma/aspect one day.
1511 -- In a number of special cases, inlining is not desirable or not
1512 -- possible, see below.
1514 -- Do not inline unit-level subprograms
1516 if Is_Unit_Subprogram (Id) then
1519 -- Do not inline subprograms declared in the visible part of a package
1521 elsif In_Package_Visible_Spec (Id) then
1524 -- Do not inline subprograms marked No_Return, possibly used for
1525 -- signaling errors, which GNATprove handles specially.
1527 elsif No_Return (Id) then
1530 -- Do not inline subprograms that have a contract on the spec or the
1531 -- body. Use the contract(s) instead in GNATprove.
1533 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
1535 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
1539 -- Do not inline expression functions, which are directly inlined at the
1542 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
1544 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
1548 -- Do not inline generic subprogram instances. The visibility rules of
1549 -- generic instances plays badly with inlining.
1551 elsif Is_Generic_Instance (Spec_Id) then
1554 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1555 -- the subprogram body, a similar check is performed after the body
1556 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1558 elsif Present (Spec_Id)
1560 (No (SPARK_Pragma (Spec_Id))
1562 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
1566 -- Subprograms in generic instances are currently not inlined, to avoid
1567 -- problems with inlining of standard library subprograms.
1569 elsif Instantiation_Location (Sloc (Id)) /= No_Location then
1572 -- Do not inline predicate functions (treated specially by GNATprove)
1574 elsif Is_Predicate_Function (Id) then
1577 -- Do not inline subprograms with a parameter of an unconstrained
1578 -- record type if it has discrimiant dependent fields. Indeed, with
1579 -- such parameters, the frontend cannot always ensure type compliance
1580 -- in record component accesses (in particular with records containing
1583 elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
1586 -- Otherwise, this is a subprogram declared inside the private part of a
1587 -- package, or inside a package body, or locally in a subprogram, and it
1588 -- does not have any contract. Inline it.
1593 end Can_Be_Inlined_In_GNATprove_Mode;
1595 --------------------------------------------
1596 -- Check_And_Split_Unconstrained_Function --
1597 --------------------------------------------
1599 procedure Check_And_Split_Unconstrained_Function
1601 Spec_Id : Entity_Id;
1602 Body_Id : Entity_Id)
1604 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
1605 -- Use generic machinery to build an unexpanded body for the subprogram.
1606 -- This body is subsequently used for inline expansions at call sites.
1608 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
1609 -- Return true if we generate code for the function body N, the function
1610 -- body N has no local declarations and its unique statement is a single
1611 -- extended return statement with a handled statements sequence.
1613 procedure Generate_Subprogram_Body
1615 Body_To_Inline : out Node_Id);
1616 -- Generate a parameterless duplicate of subprogram body N. Occurrences
1617 -- of pragmas referencing the formals are removed since they have no
1618 -- meaning when the body is inlined and the formals are rewritten (the
1619 -- analysis of the non-inlined body will handle these pragmas properly).
1620 -- A new internal name is associated with Body_To_Inline.
1622 procedure Split_Unconstrained_Function
1624 Spec_Id : Entity_Id);
1625 -- N is an inlined function body that returns an unconstrained type and
1626 -- has a single extended return statement. Split N in two subprograms:
1627 -- a procedure P' and a function F'. The formals of P' duplicate the
1628 -- formals of N plus an extra formal which is used return a value;
1629 -- its body is composed by the declarations and list of statements
1630 -- of the extended return statement of N.
1632 --------------------------
1633 -- Build_Body_To_Inline --
1634 --------------------------
1636 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
1637 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1638 Original_Body : Node_Id;
1639 Body_To_Analyze : Node_Id;
1642 pragma Assert (Current_Scope = Spec_Id);
1644 -- Within an instance, the body to inline must be treated as a nested
1645 -- generic, so that the proper global references are preserved. We
1646 -- do not do this at the library level, because it is not needed, and
1647 -- furthermore this causes trouble if front end inlining is activated
1651 and then Scope (Current_Scope) /= Standard_Standard
1653 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1656 -- We need to capture references to the formals in order
1657 -- to substitute the actuals at the point of inlining, i.e.
1658 -- instantiation. To treat the formals as globals to the body to
1659 -- inline, we nest it within a dummy parameterless subprogram,
1660 -- declared within the real one.
1662 Generate_Subprogram_Body (N, Original_Body);
1663 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
1665 -- Set return type of function, which is also global and does not
1666 -- need to be resolved.
1668 if Ekind (Spec_Id) = E_Function then
1669 Set_Result_Definition (Specification (Body_To_Analyze),
1670 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1673 if No (Declarations (N)) then
1674 Set_Declarations (N, New_List (Body_To_Analyze));
1676 Append_To (Declarations (N), Body_To_Analyze);
1679 Preanalyze (Body_To_Analyze);
1681 Push_Scope (Defining_Entity (Body_To_Analyze));
1682 Save_Global_References (Original_Body);
1684 Remove (Body_To_Analyze);
1686 -- Restore environment if previously saved
1689 and then Scope (Current_Scope) /= Standard_Standard
1694 pragma Assert (No (Body_To_Inline (Decl)));
1695 Set_Body_To_Inline (Decl, Original_Body);
1696 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1697 end Build_Body_To_Inline;
1699 --------------------------------------
1700 -- Can_Split_Unconstrained_Function --
1701 --------------------------------------
1703 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean
1705 Ret_Node : constant Node_Id :=
1706 First (Statements (Handled_Statement_Sequence (N)));
1710 -- No user defined declarations allowed in the function except inside
1711 -- the unique return statement; implicit labels are the only allowed
1714 if not Is_Empty_List (Declarations (N)) then
1715 D := First (Declarations (N));
1716 while Present (D) loop
1717 if Nkind (D) /= N_Implicit_Label_Declaration then
1725 -- We only split the inlined function when we are generating the code
1726 -- of its body; otherwise we leave duplicated split subprograms in
1727 -- the tree which (if referenced) generate wrong references at link
1730 return In_Extended_Main_Code_Unit (N)
1731 and then Present (Ret_Node)
1732 and then Nkind (Ret_Node) = N_Extended_Return_Statement
1733 and then No (Next (Ret_Node))
1734 and then Present (Handled_Statement_Sequence (Ret_Node));
1735 end Can_Split_Unconstrained_Function;
1737 -----------------------------
1738 -- Generate_Body_To_Inline --
1739 -----------------------------
1741 procedure Generate_Subprogram_Body
1743 Body_To_Inline : out Node_Id)
1746 -- Within an instance, the body to inline must be treated as a nested
1747 -- generic, so that the proper global references are preserved.
1749 -- Note that we do not do this at the library level, because it
1750 -- is not needed, and furthermore this causes trouble if front
1751 -- end inlining is activated (-gnatN).
1754 and then Scope (Current_Scope) /= Standard_Standard
1756 Body_To_Inline := Copy_Generic_Node (N, Empty, True);
1758 Body_To_Inline := Copy_Separate_Tree (N);
1761 -- Remove all aspects/pragmas that have no meaning in an inlined body
1763 Remove_Aspects_And_Pragmas (Body_To_Inline);
1765 -- We need to capture references to the formals in order
1766 -- to substitute the actuals at the point of inlining, i.e.
1767 -- instantiation. To treat the formals as globals to the body to
1768 -- inline, we nest it within a dummy parameterless subprogram,
1769 -- declared within the real one.
1771 Set_Parameter_Specifications
1772 (Specification (Body_To_Inline), No_List);
1774 -- A new internal name is associated with Body_To_Inline to avoid
1775 -- conflicts when the non-inlined body N is analyzed.
1777 Set_Defining_Unit_Name (Specification (Body_To_Inline),
1778 Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P')));
1779 Set_Corresponding_Spec (Body_To_Inline, Empty);
1780 end Generate_Subprogram_Body;
1782 ----------------------------------
1783 -- Split_Unconstrained_Function --
1784 ----------------------------------
1786 procedure Split_Unconstrained_Function
1788 Spec_Id : Entity_Id)
1790 Loc : constant Source_Ptr := Sloc (N);
1791 Ret_Node : constant Node_Id :=
1792 First (Statements (Handled_Statement_Sequence (N)));
1793 Ret_Obj : constant Node_Id :=
1794 First (Return_Object_Declarations (Ret_Node));
1796 procedure Build_Procedure
1797 (Proc_Id : out Entity_Id;
1798 Decl_List : out List_Id);
1799 -- Build a procedure containing the statements found in the extended
1800 -- return statement of the unconstrained function body N.
1802 ---------------------
1803 -- Build_Procedure --
1804 ---------------------
1806 procedure Build_Procedure
1807 (Proc_Id : out Entity_Id;
1808 Decl_List : out List_Id)
1811 Formal_List : constant List_Id := New_List;
1812 Proc_Spec : Node_Id;
1813 Proc_Body : Node_Id;
1814 Subp_Name : constant Name_Id := New_Internal_Name ('F');
1815 Body_Decl_List : List_Id := No_List;
1816 Param_Type : Node_Id;
1819 if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then
1821 New_Copy (Object_Definition (Ret_Obj));
1824 New_Copy (Subtype_Mark (Object_Definition (Ret_Obj)));
1827 Append_To (Formal_List,
1828 Make_Parameter_Specification (Loc,
1829 Defining_Identifier =>
1830 Make_Defining_Identifier (Loc,
1831 Chars => Chars (Defining_Identifier (Ret_Obj))),
1832 In_Present => False,
1833 Out_Present => True,
1834 Null_Exclusion_Present => False,
1835 Parameter_Type => Param_Type));
1837 Formal := First_Formal (Spec_Id);
1839 -- Note that we copy the parameter type rather than creating
1840 -- a reference to it, because it may be a class-wide entity
1841 -- that will not be retrieved by name.
1843 while Present (Formal) loop
1844 Append_To (Formal_List,
1845 Make_Parameter_Specification (Loc,
1846 Defining_Identifier =>
1847 Make_Defining_Identifier (Sloc (Formal),
1848 Chars => Chars (Formal)),
1849 In_Present => In_Present (Parent (Formal)),
1850 Out_Present => Out_Present (Parent (Formal)),
1851 Null_Exclusion_Present =>
1852 Null_Exclusion_Present (Parent (Formal)),
1854 New_Copy_Tree (Parameter_Type (Parent (Formal))),
1856 Copy_Separate_Tree (Expression (Parent (Formal)))));
1858 Next_Formal (Formal);
1861 Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name);
1864 Make_Procedure_Specification (Loc,
1865 Defining_Unit_Name => Proc_Id,
1866 Parameter_Specifications => Formal_List);
1868 Decl_List := New_List;
1870 Append_To (Decl_List,
1871 Make_Subprogram_Declaration (Loc, Proc_Spec));
1873 -- Can_Convert_Unconstrained_Function checked that the function
1874 -- has no local declarations except implicit label declarations.
1875 -- Copy these declarations to the built procedure.
1877 if Present (Declarations (N)) then
1878 Body_Decl_List := New_List;
1885 D := First (Declarations (N));
1886 while Present (D) loop
1887 pragma Assert (Nkind (D) = N_Implicit_Label_Declaration);
1890 Make_Implicit_Label_Declaration (Loc,
1891 Make_Defining_Identifier (Loc,
1892 Chars => Chars (Defining_Identifier (D))),
1893 Label_Construct => Empty);
1894 Append_To (Body_Decl_List, New_D);
1901 pragma Assert (Present (Handled_Statement_Sequence (Ret_Node)));
1904 Make_Subprogram_Body (Loc,
1905 Specification => Copy_Separate_Tree (Proc_Spec),
1906 Declarations => Body_Decl_List,
1907 Handled_Statement_Sequence =>
1908 Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node)));
1910 Set_Defining_Unit_Name (Specification (Proc_Body),
1911 Make_Defining_Identifier (Loc, Subp_Name));
1913 Append_To (Decl_List, Proc_Body);
1914 end Build_Procedure;
1918 New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj);
1920 Proc_Id : Entity_Id;
1921 Proc_Call : Node_Id;
1923 -- Start of processing for Split_Unconstrained_Function
1926 -- Build the associated procedure, analyze it and insert it before
1927 -- the function body N.
1930 Scope : constant Entity_Id := Current_Scope;
1931 Decl_List : List_Id;
1934 Build_Procedure (Proc_Id, Decl_List);
1935 Insert_Actions (N, Decl_List);
1939 -- Build the call to the generated procedure
1942 Actual_List : constant List_Id := New_List;
1946 Append_To (Actual_List,
1947 New_Occurrence_Of (Defining_Identifier (New_Obj), Loc));
1949 Formal := First_Formal (Spec_Id);
1950 while Present (Formal) loop
1951 Append_To (Actual_List, New_Occurrence_Of (Formal, Loc));
1953 -- Avoid spurious warning on unreferenced formals
1955 Set_Referenced (Formal);
1956 Next_Formal (Formal);
1960 Make_Procedure_Call_Statement (Loc,
1961 Name => New_Occurrence_Of (Proc_Id, Loc),
1962 Parameter_Associations => Actual_List);
1970 -- main_1__F1b (New_Obj, ...);
1975 Make_Block_Statement (Loc,
1976 Declarations => New_List (New_Obj),
1977 Handled_Statement_Sequence =>
1978 Make_Handled_Sequence_Of_Statements (Loc,
1979 Statements => New_List (
1983 Make_Simple_Return_Statement (Loc,
1986 (Defining_Identifier (New_Obj), Loc)))));
1988 Rewrite (Ret_Node, Blk_Stmt);
1989 end Split_Unconstrained_Function;
1993 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1995 -- Start of processing for Check_And_Split_Unconstrained_Function
1998 pragma Assert (Back_End_Inlining
1999 and then Ekind (Spec_Id) = E_Function
2000 and then Returns_Unconstrained_Type (Spec_Id)
2001 and then Comes_From_Source (Body_Id)
2002 and then (Has_Pragma_Inline_Always (Spec_Id)
2003 or else Optimization_Level > 0));
2005 -- This routine must not be used in GNATprove mode since GNATprove
2006 -- relies on frontend inlining
2008 pragma Assert (not GNATprove_Mode);
2010 -- No need to split the function if we cannot generate the code
2012 if Serious_Errors_Detected /= 0 then
2016 -- No action needed in stubs since the attribute Body_To_Inline
2019 if Nkind (Decl) = N_Subprogram_Body_Stub then
2022 -- Cannot build the body to inline if the attribute is already set.
2023 -- This attribute may have been set if this is a subprogram renaming
2024 -- declarations (see Freeze.Build_Renamed_Body).
2026 elsif Present (Body_To_Inline (Decl)) then
2029 -- Check excluded declarations
2031 elsif Present (Declarations (N))
2032 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
2036 -- Check excluded statements. There is no need to protect us against
2037 -- exception handlers since they are supported by the GCC backend.
2039 elsif Present (Handled_Statement_Sequence (N))
2040 and then Has_Excluded_Statement
2041 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
2046 -- Build the body to inline only if really needed
2048 if Can_Split_Unconstrained_Function (N) then
2049 Split_Unconstrained_Function (N, Spec_Id);
2050 Build_Body_To_Inline (N, Spec_Id);
2051 Set_Is_Inlined (Spec_Id);
2053 end Check_And_Split_Unconstrained_Function;
2055 -------------------------------------
2056 -- Check_Package_Body_For_Inlining --
2057 -------------------------------------
2059 procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
2060 Bname : Unit_Name_Type;
2065 -- Legacy implementation (relying on frontend inlining)
2067 if not Back_End_Inlining
2068 and then Is_Compilation_Unit (P)
2069 and then not Is_Generic_Instance (P)
2071 Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
2073 E := First_Entity (P);
2074 while Present (E) loop
2075 if Has_Pragma_Inline_Always (E)
2076 or else (Has_Pragma_Inline (E) and Front_End_Inlining)
2078 if not Is_Loaded (Bname) then
2079 Load_Needed_Body (N, OK);
2083 -- Check we are not trying to inline a parent whose body
2084 -- depends on a child, when we are compiling the body of
2085 -- the child. Otherwise we have a potential elaboration
2086 -- circularity with inlined subprograms and with
2087 -- Taft-Amendment types.
2090 Comp : Node_Id; -- Body just compiled
2091 Child_Spec : Entity_Id; -- Spec of main unit
2092 Ent : Entity_Id; -- For iteration
2093 With_Clause : Node_Id; -- Context of body.
2096 if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
2097 and then Present (Body_Entity (P))
2101 ((Unit (Library_Unit (Cunit (Main_Unit)))));
2104 Parent (Unit_Declaration_Node (Body_Entity (P)));
2106 -- Check whether the context of the body just
2107 -- compiled includes a child of itself, and that
2108 -- child is the spec of the main compilation.
2110 With_Clause := First (Context_Items (Comp));
2111 while Present (With_Clause) loop
2112 if Nkind (With_Clause) = N_With_Clause
2114 Scope (Entity (Name (With_Clause))) = P
2116 Entity (Name (With_Clause)) = Child_Spec
2118 Error_Msg_Node_2 := Child_Spec;
2120 ("body of & depends on child unit&??",
2123 ("\subprograms in body cannot be inlined??",
2126 -- Disable further inlining from this unit,
2127 -- and keep Taft-amendment types incomplete.
2129 Ent := First_Entity (P);
2130 while Present (Ent) loop
2132 and then Has_Completion_In_Body (Ent)
2134 Set_Full_View (Ent, Empty);
2136 elsif Is_Subprogram (Ent) then
2137 Set_Is_Inlined (Ent, False);
2151 elsif Ineffective_Inline_Warnings then
2152 Error_Msg_Unit_1 := Bname;
2154 ("unable to inline subprograms defined in $??", P);
2155 Error_Msg_N ("\body not found??", P);
2166 end Check_Package_Body_For_Inlining;
2168 --------------------
2169 -- Cleanup_Scopes --
2170 --------------------
2172 procedure Cleanup_Scopes is
2178 Elmt := First_Elmt (To_Clean);
2179 while Present (Elmt) loop
2180 Scop := Node (Elmt);
2182 if Ekind (Scop) = E_Entry then
2183 Scop := Protected_Body_Subprogram (Scop);
2185 elsif Is_Subprogram (Scop)
2186 and then Is_Protected_Type (Scope (Scop))
2187 and then Present (Protected_Body_Subprogram (Scop))
2189 -- If a protected operation contains an instance, its cleanup
2190 -- operations have been delayed, and the subprogram has been
2191 -- rewritten in the expansion of the enclosing protected body. It
2192 -- is the corresponding subprogram that may require the cleanup
2193 -- operations, so propagate the information that triggers cleanup
2197 (Protected_Body_Subprogram (Scop),
2198 Uses_Sec_Stack (Scop));
2200 Scop := Protected_Body_Subprogram (Scop);
2203 if Ekind (Scop) = E_Block then
2204 Decl := Parent (Block_Node (Scop));
2207 Decl := Unit_Declaration_Node (Scop);
2209 if Nkind_In (Decl, N_Subprogram_Declaration,
2210 N_Task_Type_Declaration,
2211 N_Subprogram_Body_Stub)
2213 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
2218 Expand_Cleanup_Actions (Decl);
2221 Elmt := Next_Elmt (Elmt);
2225 -------------------------
2226 -- Expand_Inlined_Call --
2227 -------------------------
2229 procedure Expand_Inlined_Call
2232 Orig_Subp : Entity_Id)
2234 Loc : constant Source_Ptr := Sloc (N);
2235 Is_Predef : constant Boolean :=
2236 Is_Predefined_File_Name
2237 (Unit_File_Name (Get_Source_Unit (Subp)));
2238 Orig_Bod : constant Node_Id :=
2239 Body_To_Inline (Unit_Declaration_Node (Subp));
2243 Decls : constant List_Id := New_List;
2244 Exit_Lab : Entity_Id := Empty;
2251 Ret_Type : Entity_Id;
2254 -- The target of the call. If context is an assignment statement then
2255 -- this is the left-hand side of the assignment, else it is a temporary
2256 -- to which the return value is assigned prior to rewriting the call.
2259 -- A separate target used when the return type is unconstrained
2262 Temp_Typ : Entity_Id;
2264 Return_Object : Entity_Id := Empty;
2265 -- Entity in declaration in an extended_return_statement
2268 Is_Unc_Decl : Boolean;
2269 -- If the type returned by the function is unconstrained and the call
2270 -- can be inlined, special processing is required.
2272 procedure Declare_Postconditions_Result;
2273 -- When generating C code, declare _Result, which may be used in the
2274 -- inlined _Postconditions procedure to verify the return value.
2276 procedure Make_Exit_Label;
2277 -- Build declaration for exit label to be used in Return statements,
2278 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2279 -- declaration). Does nothing if Exit_Lab already set.
2281 function Process_Formals (N : Node_Id) return Traverse_Result;
2282 -- Replace occurrence of a formal with the corresponding actual, or the
2283 -- thunk generated for it. Replace a return statement with an assignment
2284 -- to the target of the call, with appropriate conversions if needed.
2286 function Process_Sloc (Nod : Node_Id) return Traverse_Result;
2287 -- If the call being expanded is that of an internal subprogram, set the
2288 -- sloc of the generated block to that of the call itself, so that the
2289 -- expansion is skipped by the "next" command in gdb. Same processing
2290 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2291 -- Debug_Generated_Code is true, suppress this change to simplify our
2292 -- own development. Same in GNATprove mode, to ensure that warnings and
2293 -- diagnostics point to the proper location.
2295 procedure Reset_Dispatching_Calls (N : Node_Id);
2296 -- In subtree N search for occurrences of dispatching calls that use the
2297 -- Ada 2005 Object.Operation notation and the object is a formal of the
2298 -- inlined subprogram. Reset the entity associated with Operation in all
2299 -- the found occurrences.
2301 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
2302 -- If the function body is a single expression, replace call with
2303 -- expression, else insert block appropriately.
2305 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
2306 -- If procedure body has no local variables, inline body without
2307 -- creating block, otherwise rewrite call with block.
2309 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
2310 -- Determine whether a formal parameter is used only once in Orig_Bod
2312 -----------------------------------
2313 -- Declare_Postconditions_Result --
2314 -----------------------------------
2316 procedure Declare_Postconditions_Result is
2317 Enclosing_Subp : constant Entity_Id := Scope (Subp);
2322 and then Is_Subprogram (Enclosing_Subp)
2323 and then Present (Postconditions_Proc (Enclosing_Subp)));
2325 if Ekind (Enclosing_Subp) = E_Function then
2326 if Nkind (First (Parameter_Associations (N))) in
2327 N_Numeric_Or_String_Literal
2329 Append_To (Declarations (Blk),
2330 Make_Object_Declaration (Loc,
2331 Defining_Identifier =>
2332 Make_Defining_Identifier (Loc, Name_uResult),
2333 Constant_Present => True,
2334 Object_Definition =>
2335 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2337 New_Copy_Tree (First (Parameter_Associations (N)))));
2339 Append_To (Declarations (Blk),
2340 Make_Object_Renaming_Declaration (Loc,
2341 Defining_Identifier =>
2342 Make_Defining_Identifier (Loc, Name_uResult),
2344 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2346 New_Copy_Tree (First (Parameter_Associations (N)))));
2349 end Declare_Postconditions_Result;
2351 ---------------------
2352 -- Make_Exit_Label --
2353 ---------------------
2355 procedure Make_Exit_Label is
2356 Lab_Ent : Entity_Id;
2358 if No (Exit_Lab) then
2359 Lab_Ent := Make_Temporary (Loc, 'L');
2360 Lab_Id := New_Occurrence_Of (Lab_Ent, Loc);
2361 Exit_Lab := Make_Label (Loc, Lab_Id);
2363 Make_Implicit_Label_Declaration (Loc,
2364 Defining_Identifier => Lab_Ent,
2365 Label_Construct => Exit_Lab);
2367 end Make_Exit_Label;
2369 ---------------------
2370 -- Process_Formals --
2371 ---------------------
2373 function Process_Formals (N : Node_Id) return Traverse_Result is
2379 if Is_Entity_Name (N) and then Present (Entity (N)) then
2382 if Is_Formal (E) and then Scope (E) = Subp then
2383 A := Renamed_Object (E);
2385 -- Rewrite the occurrence of the formal into an occurrence of
2386 -- the actual. Also establish visibility on the proper view of
2387 -- the actual's subtype for the body's context (if the actual's
2388 -- subtype is private at the call point but its full view is
2389 -- visible to the body, then the inlined tree here must be
2390 -- analyzed with the full view).
2392 if Is_Entity_Name (A) then
2393 Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N)));
2394 Check_Private_View (N);
2396 elsif Nkind (A) = N_Defining_Identifier then
2397 Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
2398 Check_Private_View (N);
2403 Rewrite (N, New_Copy (A));
2409 elsif Is_Entity_Name (N)
2410 and then Present (Return_Object)
2411 and then Chars (N) = Chars (Return_Object)
2413 -- Occurrence within an extended return statement. The return
2414 -- object is local to the body been inlined, and thus the generic
2415 -- copy is not analyzed yet, so we match by name, and replace it
2416 -- with target of call.
2418 if Nkind (Targ) = N_Defining_Identifier then
2419 Rewrite (N, New_Occurrence_Of (Targ, Loc));
2421 Rewrite (N, New_Copy_Tree (Targ));
2426 elsif Nkind (N) = N_Simple_Return_Statement then
2427 if No (Expression (N)) then
2430 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2433 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
2434 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
2436 -- Function body is a single expression. No need for
2442 Num_Ret := Num_Ret + 1;
2446 -- Because of the presence of private types, the views of the
2447 -- expression and the context may be different, so place an
2448 -- unchecked conversion to the context type to avoid spurious
2449 -- errors, e.g. when the expression is a numeric literal and
2450 -- the context is private. If the expression is an aggregate,
2451 -- use a qualified expression, because an aggregate is not a
2452 -- legal argument of a conversion. Ditto for numeric literals,
2453 -- which must be resolved to a specific type.
2455 if Nkind_In (Expression (N), N_Aggregate,
2461 Make_Qualified_Expression (Sloc (N),
2462 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2463 Expression => Relocate_Node (Expression (N)));
2466 Unchecked_Convert_To
2467 (Ret_Type, Relocate_Node (Expression (N)));
2470 if Nkind (Targ) = N_Defining_Identifier then
2472 Make_Assignment_Statement (Loc,
2473 Name => New_Occurrence_Of (Targ, Loc),
2474 Expression => Ret));
2477 Make_Assignment_Statement (Loc,
2478 Name => New_Copy (Targ),
2479 Expression => Ret));
2482 Set_Assignment_OK (Name (N));
2484 if Present (Exit_Lab) then
2486 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2492 -- An extended return becomes a block whose first statement is the
2493 -- assignment of the initial expression of the return object to the
2494 -- target of the call itself.
2496 elsif Nkind (N) = N_Extended_Return_Statement then
2498 Return_Decl : constant Entity_Id :=
2499 First (Return_Object_Declarations (N));
2503 Return_Object := Defining_Identifier (Return_Decl);
2505 if Present (Expression (Return_Decl)) then
2506 if Nkind (Targ) = N_Defining_Identifier then
2508 Make_Assignment_Statement (Loc,
2509 Name => New_Occurrence_Of (Targ, Loc),
2510 Expression => Expression (Return_Decl));
2513 Make_Assignment_Statement (Loc,
2514 Name => New_Copy (Targ),
2515 Expression => Expression (Return_Decl));
2518 Set_Assignment_OK (Name (Assign));
2520 if No (Handled_Statement_Sequence (N)) then
2521 Set_Handled_Statement_Sequence (N,
2522 Make_Handled_Sequence_Of_Statements (Loc,
2523 Statements => New_List));
2527 Statements (Handled_Statement_Sequence (N)));
2531 Make_Block_Statement (Loc,
2532 Handled_Statement_Sequence =>
2533 Handled_Statement_Sequence (N)));
2538 -- Remove pragma Unreferenced since it may refer to formals that
2539 -- are not visible in the inlined body, and in any case we will
2540 -- not be posting warnings on the inlined body so it is unneeded.
2542 elsif Nkind (N) = N_Pragma
2543 and then Pragma_Name (N) = Name_Unreferenced
2545 Rewrite (N, Make_Null_Statement (Sloc (N)));
2551 end Process_Formals;
2553 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
2559 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
2561 if not Debug_Generated_Code then
2562 Set_Sloc (Nod, Sloc (N));
2563 Set_Comes_From_Source (Nod, False);
2569 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
2571 ------------------------------
2572 -- Reset_Dispatching_Calls --
2573 ------------------------------
2575 procedure Reset_Dispatching_Calls (N : Node_Id) is
2577 function Do_Reset (N : Node_Id) return Traverse_Result;
2578 -- Comment required ???
2584 function Do_Reset (N : Node_Id) return Traverse_Result is
2586 if Nkind (N) = N_Procedure_Call_Statement
2587 and then Nkind (Name (N)) = N_Selected_Component
2588 and then Nkind (Prefix (Name (N))) = N_Identifier
2589 and then Is_Formal (Entity (Prefix (Name (N))))
2590 and then Is_Dispatching_Operation
2591 (Entity (Selector_Name (Name (N))))
2593 Set_Entity (Selector_Name (Name (N)), Empty);
2599 function Do_Reset_Calls is new Traverse_Func (Do_Reset);
2603 Dummy : constant Traverse_Result := Do_Reset_Calls (N);
2604 pragma Unreferenced (Dummy);
2606 -- Start of processing for Reset_Dispatching_Calls
2610 end Reset_Dispatching_Calls;
2612 ---------------------------
2613 -- Rewrite_Function_Call --
2614 ---------------------------
2616 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
2617 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2618 Fst : constant Node_Id := First (Statements (HSS));
2621 -- Optimize simple case: function body is a single return statement,
2622 -- which has been expanded into an assignment.
2624 if Is_Empty_List (Declarations (Blk))
2625 and then Nkind (Fst) = N_Assignment_Statement
2626 and then No (Next (Fst))
2628 -- The function call may have been rewritten as the temporary
2629 -- that holds the result of the call, in which case remove the
2630 -- now useless declaration.
2632 if Nkind (N) = N_Identifier
2633 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2635 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
2638 Rewrite (N, Expression (Fst));
2640 elsif Nkind (N) = N_Identifier
2641 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2643 -- The block assigns the result of the call to the temporary
2645 Insert_After (Parent (Entity (N)), Blk);
2647 -- If the context is an assignment, and the left-hand side is free of
2648 -- side-effects, the replacement is also safe.
2649 -- Can this be generalized further???
2651 elsif Nkind (Parent (N)) = N_Assignment_Statement
2653 (Is_Entity_Name (Name (Parent (N)))
2655 (Nkind (Name (Parent (N))) = N_Explicit_Dereference
2656 and then Is_Entity_Name (Prefix (Name (Parent (N)))))
2659 (Nkind (Name (Parent (N))) = N_Selected_Component
2660 and then Is_Entity_Name (Prefix (Name (Parent (N))))))
2662 -- Replace assignment with the block
2665 Original_Assignment : constant Node_Id := Parent (N);
2668 -- Preserve the original assignment node to keep the complete
2669 -- assignment subtree consistent enough for Analyze_Assignment
2670 -- to proceed (specifically, the original Lhs node must still
2671 -- have an assignment statement as its parent).
2673 -- We cannot rely on Original_Node to go back from the block
2674 -- node to the assignment node, because the assignment might
2675 -- already be a rewrite substitution.
2677 Discard_Node (Relocate_Node (Original_Assignment));
2678 Rewrite (Original_Assignment, Blk);
2681 elsif Nkind (Parent (N)) = N_Object_Declaration then
2683 -- A call to a function which returns an unconstrained type
2684 -- found in the expression initializing an object-declaration is
2685 -- expanded into a procedure call which must be added after the
2686 -- object declaration.
2688 if Is_Unc_Decl and Back_End_Inlining then
2689 Insert_Action_After (Parent (N), Blk);
2691 Set_Expression (Parent (N), Empty);
2692 Insert_After (Parent (N), Blk);
2695 elsif Is_Unc and then not Back_End_Inlining then
2696 Insert_Before (Parent (N), Blk);
2698 end Rewrite_Function_Call;
2700 ----------------------------
2701 -- Rewrite_Procedure_Call --
2702 ----------------------------
2704 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
2705 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2708 -- If there is a transient scope for N, this will be the scope of the
2709 -- actions for N, and the statements in Blk need to be within this
2710 -- scope. For example, they need to have visibility on the constant
2711 -- declarations created for the formals.
2713 -- If N needs no transient scope, and if there are no declarations in
2714 -- the inlined body, we can do a little optimization and insert the
2715 -- statements for the body directly after N, and rewrite N to a
2716 -- null statement, instead of rewriting N into a full-blown block
2719 if not Scope_Is_Transient
2720 and then Is_Empty_List (Declarations (Blk))
2722 Insert_List_After (N, Statements (HSS));
2723 Rewrite (N, Make_Null_Statement (Loc));
2727 end Rewrite_Procedure_Call;
2729 -------------------------
2730 -- Formal_Is_Used_Once --
2731 -------------------------
2733 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
2734 Use_Counter : Int := 0;
2736 function Count_Uses (N : Node_Id) return Traverse_Result;
2737 -- Traverse the tree and count the uses of the formal parameter.
2738 -- In this case, for optimization purposes, we do not need to
2739 -- continue the traversal once more than one use is encountered.
2745 function Count_Uses (N : Node_Id) return Traverse_Result is
2747 -- The original node is an identifier
2749 if Nkind (N) = N_Identifier
2750 and then Present (Entity (N))
2752 -- Original node's entity points to the one in the copied body
2754 and then Nkind (Entity (N)) = N_Identifier
2755 and then Present (Entity (Entity (N)))
2757 -- The entity of the copied node is the formal parameter
2759 and then Entity (Entity (N)) = Formal
2761 Use_Counter := Use_Counter + 1;
2763 if Use_Counter > 1 then
2765 -- Denote more than one use and abandon the traversal
2776 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
2778 -- Start of processing for Formal_Is_Used_Once
2781 Count_Formal_Uses (Orig_Bod);
2782 return Use_Counter = 1;
2783 end Formal_Is_Used_Once;
2785 -- Start of processing for Expand_Inlined_Call
2788 -- Initializations for old/new semantics
2790 if not Back_End_Inlining then
2791 Is_Unc := Is_Array_Type (Etype (Subp))
2792 and then not Is_Constrained (Etype (Subp));
2793 Is_Unc_Decl := False;
2795 Is_Unc := Returns_Unconstrained_Type (Subp)
2796 and then Optimization_Level > 0;
2797 Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration
2801 -- Check for an illegal attempt to inline a recursive procedure. If the
2802 -- subprogram has parameters this is detected when trying to supply a
2803 -- binding for parameters that already have one. For parameterless
2804 -- subprograms this must be done explicitly.
2806 if In_Open_Scopes (Subp) then
2808 ("cannot inline call to recursive subprogram?", N, Subp);
2809 Set_Is_Inlined (Subp, False);
2812 -- Skip inlining if this is not a true inlining since the attribute
2813 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
2814 -- true inlining, Orig_Bod has code rather than being an entity.
2816 elsif Nkind (Orig_Bod) in N_Entity then
2819 -- Skip inlining if the function returns an unconstrained type using
2820 -- an extended return statement since this part of the new inlining
2821 -- model which is not yet supported by the current implementation. ???
2825 Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
2826 N_Extended_Return_Statement
2827 and then not Back_End_Inlining
2832 if Nkind (Orig_Bod) = N_Defining_Identifier
2833 or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
2835 -- Subprogram is renaming_as_body. Calls occurring after the renaming
2836 -- can be replaced with calls to the renamed entity directly, because
2837 -- the subprograms are subtype conformant. If the renamed subprogram
2838 -- is an inherited operation, we must redo the expansion because
2839 -- implicit conversions may be needed. Similarly, if the renamed
2840 -- entity is inlined, expand the call for further optimizations.
2842 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
2844 if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then
2851 -- Register the call in the list of inlined calls
2853 Append_New_Elmt (N, To => Inlined_Calls);
2855 -- Use generic machinery to copy body of inlined subprogram, as if it
2856 -- were an instantiation, resetting source locations appropriately, so
2857 -- that nested inlined calls appear in the main unit.
2859 Save_Env (Subp, Empty);
2860 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
2864 if not Back_End_Inlining then
2869 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
2871 Make_Block_Statement (Loc,
2872 Declarations => Declarations (Bod),
2873 Handled_Statement_Sequence =>
2874 Handled_Statement_Sequence (Bod));
2876 if No (Declarations (Bod)) then
2877 Set_Declarations (Blk, New_List);
2880 -- When generating C code, declare _Result, which may be used to
2881 -- verify the return value.
2883 if Modify_Tree_For_C
2884 and then Nkind (N) = N_Procedure_Call_Statement
2885 and then Chars (Name (N)) = Name_uPostconditions
2887 Declare_Postconditions_Result;
2890 -- For the unconstrained case, capture the name of the local
2891 -- variable that holds the result. This must be the first
2892 -- declaration in the block, because its bounds cannot depend
2893 -- on local variables. Otherwise there is no way to declare the
2894 -- result outside of the block. Needless to say, in general the
2895 -- bounds will depend on the actuals in the call.
2897 -- If the context is an assignment statement, as is the case
2898 -- for the expansion of an extended return, the left-hand side
2899 -- provides bounds even if the return type is unconstrained.
2903 First_Decl : Node_Id;
2906 First_Decl := First (Declarations (Blk));
2908 if Nkind (First_Decl) /= N_Object_Declaration then
2912 if Nkind (Parent (N)) /= N_Assignment_Statement then
2913 Targ1 := Defining_Identifier (First_Decl);
2915 Targ1 := Name (Parent (N));
2932 Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
2934 Make_Block_Statement (Loc,
2935 Declarations => Declarations (Bod),
2936 Handled_Statement_Sequence =>
2937 Handled_Statement_Sequence (Bod));
2939 -- Inline a call to a function that returns an unconstrained type.
2940 -- The semantic analyzer checked that frontend-inlined functions
2941 -- returning unconstrained types have no declarations and have
2942 -- a single extended return statement. As part of its processing
2943 -- the function was split in two subprograms: a procedure P and
2944 -- a function F that has a block with a call to procedure P (see
2945 -- Split_Unconstrained_Function).
2951 (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
2955 Blk_Stmt : constant Node_Id :=
2956 First (Statements (Handled_Statement_Sequence (Orig_Bod)));
2957 First_Stmt : constant Node_Id :=
2958 First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
2959 Second_Stmt : constant Node_Id := Next (First_Stmt);
2963 (Nkind (First_Stmt) = N_Procedure_Call_Statement
2964 and then Nkind (Second_Stmt) = N_Simple_Return_Statement
2965 and then No (Next (Second_Stmt)));
2970 (Statements (Handled_Statement_Sequence (Orig_Bod))),
2971 Empty, Instantiating => True);
2974 -- Capture the name of the local variable that holds the
2975 -- result. This must be the first declaration in the block,
2976 -- because its bounds cannot depend on local variables.
2977 -- Otherwise there is no way to declare the result outside
2978 -- of the block. Needless to say, in general the bounds will
2979 -- depend on the actuals in the call.
2981 if Nkind (Parent (N)) /= N_Assignment_Statement then
2982 Targ1 := Defining_Identifier (First (Declarations (Blk)));
2984 -- If the context is an assignment statement, as is the case
2985 -- for the expansion of an extended return, the left-hand
2986 -- side provides bounds even if the return type is
2990 Targ1 := Name (Parent (N));
2995 if No (Declarations (Bod)) then
2996 Set_Declarations (Blk, New_List);
3001 -- If this is a derived function, establish the proper return type
3003 if Present (Orig_Subp) and then Orig_Subp /= Subp then
3004 Ret_Type := Etype (Orig_Subp);
3006 Ret_Type := Etype (Subp);
3009 -- Create temporaries for the actuals that are expressions, or that are
3010 -- scalars and require copying to preserve semantics.
3012 F := First_Formal (Subp);
3013 A := First_Actual (N);
3014 while Present (F) loop
3015 if Present (Renamed_Object (F)) then
3017 -- If expander is active, it is an error to try to inline a
3018 -- recursive program. In GNATprove mode, just indicate that the
3019 -- inlining will not happen, and mark the subprogram as not always
3022 if GNATprove_Mode then
3024 ("cannot inline call to recursive subprogram?", N, Subp);
3025 Set_Is_Inlined_Always (Subp, False);
3028 ("cannot inline call to recursive subprogram", N);
3034 -- Reset Last_Assignment for any parameters of mode out or in out, to
3035 -- prevent spurious warnings about overwriting for assignments to the
3036 -- formal in the inlined code.
3038 if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
3039 Set_Last_Assignment (Entity (A), Empty);
3042 -- If the argument may be a controlling argument in a call within
3043 -- the inlined body, we must preserve its classwide nature to insure
3044 -- that dynamic dispatching take place subsequently. If the formal
3045 -- has a constraint it must be preserved to retain the semantics of
3048 if Is_Class_Wide_Type (Etype (F))
3049 or else (Is_Access_Type (Etype (F))
3050 and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
3052 Temp_Typ := Etype (F);
3054 elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
3055 and then Etype (F) /= Base_Type (Etype (F))
3057 Temp_Typ := Etype (F);
3059 Temp_Typ := Etype (A);
3062 -- If the actual is a simple name or a literal, no need to
3063 -- create a temporary, object can be used directly.
3065 -- If the actual is a literal and the formal has its address taken,
3066 -- we cannot pass the literal itself as an argument, so its value
3067 -- must be captured in a temporary.
3069 if (Is_Entity_Name (A)
3071 (not Is_Scalar_Type (Etype (A))
3072 or else Ekind (Entity (A)) = E_Enumeration_Literal))
3074 -- When the actual is an identifier and the corresponding formal is
3075 -- used only once in the original body, the formal can be substituted
3076 -- directly with the actual parameter.
3078 or else (Nkind (A) = N_Identifier
3079 and then Formal_Is_Used_Once (F))
3082 (Nkind_In (A, N_Real_Literal,
3084 N_Character_Literal)
3085 and then not Address_Taken (F))
3087 if Etype (F) /= Etype (A) then
3089 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
3091 Set_Renamed_Object (F, A);
3095 Temp := Make_Temporary (Loc, 'C');
3097 -- If the actual for an in/in-out parameter is a view conversion,
3098 -- make it into an unchecked conversion, given that an untagged
3099 -- type conversion is not a proper object for a renaming.
3101 -- In-out conversions that involve real conversions have already
3102 -- been transformed in Expand_Actuals.
3104 if Nkind (A) = N_Type_Conversion
3105 and then Ekind (F) /= E_In_Parameter
3108 Make_Unchecked_Type_Conversion (Loc,
3109 Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
3110 Expression => Relocate_Node (Expression (A)));
3112 elsif Etype (F) /= Etype (A) then
3113 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
3114 Temp_Typ := Etype (F);
3117 New_A := Relocate_Node (A);
3120 Set_Sloc (New_A, Sloc (N));
3122 -- If the actual has a by-reference type, it cannot be copied,
3123 -- so its value is captured in a renaming declaration. Otherwise
3124 -- declare a local constant initialized with the actual.
3126 -- We also use a renaming declaration for expressions of an array
3127 -- type that is not bit-packed, both for efficiency reasons and to
3128 -- respect the semantics of the call: in most cases the original
3129 -- call will pass the parameter by reference, and thus the inlined
3130 -- code will have the same semantics.
3132 -- Finally, we need a renaming declaration in the case of limited
3133 -- types for which initialization cannot be by copy either.
3135 if Ekind (F) = E_In_Parameter
3136 and then not Is_By_Reference_Type (Etype (A))
3137 and then not Is_Limited_Type (Etype (A))
3139 (not Is_Array_Type (Etype (A))
3140 or else not Is_Object_Reference (A)
3141 or else Is_Bit_Packed_Array (Etype (A)))
3144 Make_Object_Declaration (Loc,
3145 Defining_Identifier => Temp,
3146 Constant_Present => True,
3147 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3148 Expression => New_A);
3151 Make_Object_Renaming_Declaration (Loc,
3152 Defining_Identifier => Temp,
3153 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
3157 Append (Decl, Decls);
3158 Set_Renamed_Object (F, Temp);
3165 -- Establish target of function call. If context is not assignment or
3166 -- declaration, create a temporary as a target. The declaration for the
3167 -- temporary may be subsequently optimized away if the body is a single
3168 -- expression, or if the left-hand side of the assignment is simple
3169 -- enough, i.e. an entity or an explicit dereference of one.
3171 if Ekind (Subp) = E_Function then
3172 if Nkind (Parent (N)) = N_Assignment_Statement
3173 and then Is_Entity_Name (Name (Parent (N)))
3175 Targ := Name (Parent (N));
3177 elsif Nkind (Parent (N)) = N_Assignment_Statement
3178 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
3179 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3181 Targ := Name (Parent (N));
3183 elsif Nkind (Parent (N)) = N_Assignment_Statement
3184 and then Nkind (Name (Parent (N))) = N_Selected_Component
3185 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3187 Targ := New_Copy_Tree (Name (Parent (N)));
3189 elsif Nkind (Parent (N)) = N_Object_Declaration
3190 and then Is_Limited_Type (Etype (Subp))
3192 Targ := Defining_Identifier (Parent (N));
3194 -- New semantics: In an object declaration avoid an extra copy
3195 -- of the result of a call to an inlined function that returns
3196 -- an unconstrained type
3198 elsif Back_End_Inlining
3199 and then Nkind (Parent (N)) = N_Object_Declaration
3202 Targ := Defining_Identifier (Parent (N));
3205 -- Replace call with temporary and create its declaration
3207 Temp := Make_Temporary (Loc, 'C');
3208 Set_Is_Internal (Temp);
3210 -- For the unconstrained case, the generated temporary has the
3211 -- same constrained declaration as the result variable. It may
3212 -- eventually be possible to remove that temporary and use the
3213 -- result variable directly.
3215 if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement
3218 Make_Object_Declaration (Loc,
3219 Defining_Identifier => Temp,
3220 Object_Definition =>
3221 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3223 Replace_Formals (Decl);
3227 Make_Object_Declaration (Loc,
3228 Defining_Identifier => Temp,
3229 Object_Definition => New_Occurrence_Of (Ret_Type, Loc));
3231 Set_Etype (Temp, Ret_Type);
3234 Set_No_Initialization (Decl);
3235 Append (Decl, Decls);
3236 Rewrite (N, New_Occurrence_Of (Temp, Loc));
3241 Insert_Actions (N, Decls);
3245 -- Special management for inlining a call to a function that returns
3246 -- an unconstrained type and initializes an object declaration: we
3247 -- avoid generating undesired extra calls and goto statements.
3250 -- function Func (...) return ...
3253 -- Result : String (1 .. 4);
3255 -- Proc (Result, ...);
3260 -- Result : String := Func (...);
3262 -- Replace this object declaration by:
3264 -- Result : String (1 .. 4);
3265 -- Proc (Result, ...);
3267 Remove_Homonym (Targ);
3270 Make_Object_Declaration
3272 Defining_Identifier => Targ,
3273 Object_Definition =>
3274 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3275 Replace_Formals (Decl);
3276 Rewrite (Parent (N), Decl);
3277 Analyze (Parent (N));
3279 -- Avoid spurious warnings since we know that this declaration is
3280 -- referenced by the procedure call.
3282 Set_Never_Set_In_Source (Targ, False);
3284 -- Remove the local declaration of the extended return stmt from the
3287 Remove (Parent (Targ1));
3289 -- Update the reference to the result (since we have rewriten the
3290 -- object declaration)
3293 Blk_Call_Stmt : Node_Id;
3296 -- Capture the call to the procedure
3299 First (Statements (Handled_Statement_Sequence (Blk)));
3301 (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement);
3303 Remove (First (Parameter_Associations (Blk_Call_Stmt)));
3304 Prepend_To (Parameter_Associations (Blk_Call_Stmt),
3305 New_Occurrence_Of (Targ, Loc));
3308 -- Remove the return statement
3311 (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3312 N_Simple_Return_Statement);
3314 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3317 -- Traverse the tree and replace formals with actuals or their thunks.
3318 -- Attach block to tree before analysis and rewriting.
3320 Replace_Formals (Blk);
3321 Set_Parent (Blk, N);
3323 if GNATprove_Mode then
3326 elsif not Comes_From_Source (Subp) or else Is_Predef then
3332 -- No action needed since return statement has been already removed
3336 elsif Present (Exit_Lab) then
3338 -- If the body was a single expression, the single return statement
3339 -- and the corresponding label are useless.
3343 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3346 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3348 Append (Lab_Decl, (Declarations (Blk)));
3349 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
3353 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3354 -- on conflicting private views that Gigi would ignore. If this is a
3355 -- predefined unit, analyze with checks off, as is done in the non-
3356 -- inlined run-time units.
3359 I_Flag : constant Boolean := In_Inlined_Body;
3362 In_Inlined_Body := True;
3366 Style : constant Boolean := Style_Check;
3369 Style_Check := False;
3371 -- Search for dispatching calls that use the Object.Operation
3372 -- notation using an Object that is a parameter of the inlined
3373 -- function. We reset the decoration of Operation to force
3374 -- the reanalysis of the inlined dispatching call because
3375 -- the actual object has been inlined.
3377 Reset_Dispatching_Calls (Blk);
3379 Analyze (Blk, Suppress => All_Checks);
3380 Style_Check := Style;
3387 In_Inlined_Body := I_Flag;
3390 if Ekind (Subp) = E_Procedure then
3391 Rewrite_Procedure_Call (N, Blk);
3394 Rewrite_Function_Call (N, Blk);
3399 -- For the unconstrained case, the replacement of the call has been
3400 -- made prior to the complete analysis of the generated declarations.
3401 -- Propagate the proper type now.
3404 if Nkind (N) = N_Identifier then
3405 Set_Etype (N, Etype (Entity (N)));
3407 Set_Etype (N, Etype (Targ1));
3414 -- Cleanup mapping between formals and actuals for other expansions
3416 F := First_Formal (Subp);
3417 while Present (F) loop
3418 Set_Renamed_Object (F, Empty);
3421 end Expand_Inlined_Call;
3423 --------------------------
3424 -- Get_Code_Unit_Entity --
3425 --------------------------
3427 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
3428 Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E));
3431 if Ekind (Unit) = E_Package_Body then
3432 Unit := Spec_Entity (Unit);
3436 end Get_Code_Unit_Entity;
3438 ------------------------------
3439 -- Has_Excluded_Declaration --
3440 ------------------------------
3442 function Has_Excluded_Declaration
3444 Decls : List_Id) return Boolean
3448 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
3449 -- Nested subprograms make a given body ineligible for inlining, but
3450 -- we make an exception for instantiations of unchecked conversion.
3451 -- The body has not been analyzed yet, so check the name, and verify
3452 -- that the visible entity with that name is the predefined unit.
3454 -----------------------------
3455 -- Is_Unchecked_Conversion --
3456 -----------------------------
3458 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
3459 Id : constant Node_Id := Name (D);
3463 if Nkind (Id) = N_Identifier
3464 and then Chars (Id) = Name_Unchecked_Conversion
3466 Conv := Current_Entity (Id);
3468 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
3469 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
3471 Conv := Current_Entity (Selector_Name (Id));
3476 return Present (Conv)
3477 and then Is_Predefined_File_Name
3478 (Unit_File_Name (Get_Source_Unit (Conv)))
3479 and then Is_Intrinsic_Subprogram (Conv);
3480 end Is_Unchecked_Conversion;
3482 -- Start of processing for Has_Excluded_Declaration
3485 -- No action needed if the check is not needed
3487 if not Check_Inlining_Restrictions then
3492 while Present (D) loop
3494 -- First declarations universally excluded
3496 if Nkind (D) = N_Package_Declaration then
3498 ("cannot inline & (nested package declaration)?", D, Subp);
3501 elsif Nkind (D) = N_Package_Instantiation then
3503 ("cannot inline & (nested package instantiation)?", D, Subp);
3507 -- Then declarations excluded only for front end inlining
3509 if Back_End_Inlining then
3512 elsif Nkind (D) = N_Task_Type_Declaration
3513 or else Nkind (D) = N_Single_Task_Declaration
3516 ("cannot inline & (nested task type declaration)?", D, Subp);
3519 elsif Nkind (D) = N_Protected_Type_Declaration
3520 or else Nkind (D) = N_Single_Protected_Declaration
3523 ("cannot inline & (nested protected type declaration)?",
3527 elsif Nkind (D) = N_Subprogram_Body then
3529 ("cannot inline & (nested subprogram)?", D, Subp);
3532 elsif Nkind (D) = N_Function_Instantiation
3533 and then not Is_Unchecked_Conversion (D)
3536 ("cannot inline & (nested function instantiation)?", D, Subp);
3539 elsif Nkind (D) = N_Procedure_Instantiation then
3541 ("cannot inline & (nested procedure instantiation)?", D, Subp);
3544 -- Subtype declarations with predicates will generate predicate
3545 -- functions, i.e. nested subprogram bodies, so inlining is not
3548 elsif Nkind (D) = N_Subtype_Declaration
3549 and then Present (Aspect_Specifications (D))
3556 A := First (Aspect_Specifications (D));
3557 while Present (A) loop
3558 A_Id := Get_Aspect_Id (Chars (Identifier (A)));
3560 if A_Id = Aspect_Predicate
3561 or else A_Id = Aspect_Static_Predicate
3562 or else A_Id = Aspect_Dynamic_Predicate
3565 ("cannot inline & (subtype declaration with "
3566 & "predicate)?", D, Subp);
3579 end Has_Excluded_Declaration;
3581 ----------------------------
3582 -- Has_Excluded_Statement --
3583 ----------------------------
3585 function Has_Excluded_Statement
3587 Stats : List_Id) return Boolean
3593 -- No action needed if the check is not needed
3595 if not Check_Inlining_Restrictions then
3600 while Present (S) loop
3601 if Nkind_In (S, N_Abort_Statement,
3602 N_Asynchronous_Select,
3603 N_Conditional_Entry_Call,
3604 N_Delay_Relative_Statement,
3605 N_Delay_Until_Statement,
3610 ("cannot inline & (non-allowed statement)?", S, Subp);
3613 elsif Nkind (S) = N_Block_Statement then
3614 if Present (Declarations (S))
3615 and then Has_Excluded_Declaration (Subp, Declarations (S))
3619 elsif Present (Handled_Statement_Sequence (S)) then
3620 if not Back_End_Inlining
3623 (Exception_Handlers (Handled_Statement_Sequence (S)))
3626 ("cannot inline& (exception handler)?",
3627 First (Exception_Handlers
3628 (Handled_Statement_Sequence (S))),
3632 elsif Has_Excluded_Statement
3633 (Subp, Statements (Handled_Statement_Sequence (S)))
3639 elsif Nkind (S) = N_Case_Statement then
3640 E := First (Alternatives (S));
3641 while Present (E) loop
3642 if Has_Excluded_Statement (Subp, Statements (E)) then
3649 elsif Nkind (S) = N_If_Statement then
3650 if Has_Excluded_Statement (Subp, Then_Statements (S)) then
3654 if Present (Elsif_Parts (S)) then
3655 E := First (Elsif_Parts (S));
3656 while Present (E) loop
3657 if Has_Excluded_Statement (Subp, Then_Statements (E)) then
3665 if Present (Else_Statements (S))
3666 and then Has_Excluded_Statement (Subp, Else_Statements (S))
3671 elsif Nkind (S) = N_Loop_Statement
3672 and then Has_Excluded_Statement (Subp, Statements (S))
3676 elsif Nkind (S) = N_Extended_Return_Statement then
3677 if Present (Handled_Statement_Sequence (S))
3679 Has_Excluded_Statement
3680 (Subp, Statements (Handled_Statement_Sequence (S)))
3684 elsif not Back_End_Inlining
3685 and then Present (Handled_Statement_Sequence (S))
3687 Present (Exception_Handlers
3688 (Handled_Statement_Sequence (S)))
3691 ("cannot inline& (exception handler)?",
3692 First (Exception_Handlers (Handled_Statement_Sequence (S))),
3702 end Has_Excluded_Statement;
3704 --------------------------
3705 -- Has_Initialized_Type --
3706 --------------------------
3708 function Has_Initialized_Type (E : Entity_Id) return Boolean is
3709 E_Body : constant Node_Id := Subprogram_Body (E);
3713 if No (E_Body) then -- imported subprogram
3717 Decl := First (Declarations (E_Body));
3718 while Present (Decl) loop
3719 if Nkind (Decl) = N_Full_Type_Declaration
3720 and then Present (Init_Proc (Defining_Identifier (Decl)))
3730 end Has_Initialized_Type;
3732 -----------------------
3733 -- Has_Single_Return --
3734 -----------------------
3736 function Has_Single_Return (N : Node_Id) return Boolean is
3737 Return_Statement : Node_Id := Empty;
3739 function Check_Return (N : Node_Id) return Traverse_Result;
3745 function Check_Return (N : Node_Id) return Traverse_Result is
3747 if Nkind (N) = N_Simple_Return_Statement then
3748 if Present (Expression (N))
3749 and then Is_Entity_Name (Expression (N))
3751 if No (Return_Statement) then
3752 Return_Statement := N;
3755 elsif Chars (Expression (N)) =
3756 Chars (Expression (Return_Statement))
3764 -- A return statement within an extended return is a noop
3767 elsif No (Expression (N))
3769 Nkind (Parent (Parent (N))) = N_Extended_Return_Statement
3774 -- Expression has wrong form
3779 -- We can only inline a build-in-place function if it has a single
3782 elsif Nkind (N) = N_Extended_Return_Statement then
3783 if No (Return_Statement) then
3784 Return_Statement := N;
3796 function Check_All_Returns is new Traverse_Func (Check_Return);
3798 -- Start of processing for Has_Single_Return
3801 if Check_All_Returns (N) /= OK then
3804 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
3808 return Present (Declarations (N))
3809 and then Present (First (Declarations (N)))
3810 and then Chars (Expression (Return_Statement)) =
3811 Chars (Defining_Identifier (First (Declarations (N))));
3813 end Has_Single_Return;
3815 -----------------------------
3816 -- In_Main_Unit_Or_Subunit --
3817 -----------------------------
3819 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is
3820 Comp : Node_Id := Cunit (Get_Code_Unit (E));
3823 -- Check whether the subprogram or package to inline is within the main
3824 -- unit or its spec or within a subunit. In either case there are no
3825 -- additional bodies to process. If the subprogram appears in a parent
3826 -- of the current unit, the check on whether inlining is possible is
3827 -- done in Analyze_Inlined_Bodies.
3829 while Nkind (Unit (Comp)) = N_Subunit loop
3830 Comp := Library_Unit (Comp);
3833 return Comp = Cunit (Main_Unit)
3834 or else Comp = Library_Unit (Cunit (Main_Unit));
3835 end In_Main_Unit_Or_Subunit;
3841 procedure Initialize is
3843 Pending_Descriptor.Init;
3844 Pending_Instantiations.Init;
3845 Inlined_Bodies.Init;
3849 for J in Hash_Headers'Range loop
3850 Hash_Headers (J) := No_Subp;
3853 Inlined_Calls := No_Elist;
3854 Backend_Calls := No_Elist;
3855 Backend_Inlined_Subps := No_Elist;
3856 Backend_Not_Inlined_Subps := No_Elist;
3859 ------------------------
3860 -- Instantiate_Bodies --
3861 ------------------------
3863 -- Generic bodies contain all the non-local references, so an
3864 -- instantiation does not need any more context than Standard
3865 -- itself, even if the instantiation appears in an inner scope.
3866 -- Generic associations have verified that the contract model is
3867 -- satisfied, so that any error that may occur in the analysis of
3868 -- the body is an internal error.
3870 procedure Instantiate_Bodies is
3872 Info : Pending_Body_Info;
3875 if Serious_Errors_Detected = 0 then
3876 Expander_Active := (Operating_Mode = Opt.Generate_Code);
3877 Push_Scope (Standard_Standard);
3878 To_Clean := New_Elmt_List;
3880 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
3884 -- A body instantiation may generate additional instantiations, so
3885 -- the following loop must scan to the end of a possibly expanding
3886 -- set (that's why we can't simply use a FOR loop here).
3889 while J <= Pending_Instantiations.Last
3890 and then Serious_Errors_Detected = 0
3892 Info := Pending_Instantiations.Table (J);
3894 -- If the instantiation node is absent, it has been removed
3895 -- as part of unreachable code.
3897 if No (Info.Inst_Node) then
3900 elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
3901 Instantiate_Package_Body (Info);
3902 Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
3905 Instantiate_Subprogram_Body (Info);
3911 -- Reset the table of instantiations. Additional instantiations
3912 -- may be added through inlining, when additional bodies are
3915 Pending_Instantiations.Init;
3917 -- We can now complete the cleanup actions of scopes that contain
3918 -- pending instantiations (skipped for generic units, since we
3919 -- never need any cleanups in generic units).
3922 and then not Is_Generic_Unit (Main_Unit_Entity)
3925 elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
3931 end Instantiate_Bodies;
3937 function Is_Nested (E : Entity_Id) return Boolean is
3942 while Scop /= Standard_Standard loop
3943 if Ekind (Scop) in Subprogram_Kind then
3946 elsif Ekind (Scop) = E_Task_Type
3947 or else Ekind (Scop) = E_Entry
3948 or else Ekind (Scop) = E_Entry_Family
3953 Scop := Scope (Scop);
3959 ------------------------
3960 -- List_Inlining_Info --
3961 ------------------------
3963 procedure List_Inlining_Info is
3969 if not Debug_Flag_Dot_J then
3973 -- Generate listing of calls inlined by the frontend
3975 if Present (Inlined_Calls) then
3977 Elmt := First_Elmt (Inlined_Calls);
3978 while Present (Elmt) loop
3981 if In_Extended_Main_Code_Unit (Nod) then
3985 Write_Str ("List of calls inlined by the frontend");
3992 Write_Location (Sloc (Nod));
4001 -- Generate listing of calls passed to the backend
4003 if Present (Backend_Calls) then
4006 Elmt := First_Elmt (Backend_Calls);
4007 while Present (Elmt) loop
4010 if In_Extended_Main_Code_Unit (Nod) then
4014 Write_Str ("List of inlined calls passed to the backend");
4021 Write_Location (Sloc (Nod));
4029 -- Generate listing of subprograms passed to the backend
4031 if Present (Backend_Inlined_Subps) and then Back_End_Inlining then
4034 Elmt := First_Elmt (Backend_Inlined_Subps);
4035 while Present (Elmt) loop
4042 ("List of inlined subprograms passed to the backend");
4049 Write_Name (Chars (Nod));
4051 Write_Location (Sloc (Nod));
4059 -- Generate listing of subprograms that cannot be inlined by the backend
4061 if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining then
4064 Elmt := First_Elmt (Backend_Not_Inlined_Subps);
4065 while Present (Elmt) loop
4072 ("List of subprograms that cannot be inlined by the backend");
4079 Write_Name (Chars (Nod));
4081 Write_Location (Sloc (Nod));
4088 end List_Inlining_Info;
4096 Pending_Instantiations.Locked := True;
4097 Inlined_Bodies.Locked := True;
4098 Successors.Locked := True;
4099 Inlined.Locked := True;
4100 Pending_Instantiations.Release;
4101 Inlined_Bodies.Release;
4106 --------------------------------
4107 -- Remove_Aspects_And_Pragmas --
4108 --------------------------------
4110 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id) is
4111 procedure Remove_Items (List : List_Id);
4112 -- Remove all useless aspects/pragmas from a particular list
4118 procedure Remove_Items (List : List_Id) is
4121 Next_Item : Node_Id;
4124 -- Traverse the list looking for an aspect specification or a pragma
4126 Item := First (List);
4127 while Present (Item) loop
4128 Next_Item := Next (Item);
4130 if Nkind (Item) = N_Aspect_Specification then
4131 Item_Id := Identifier (Item);
4132 elsif Nkind (Item) = N_Pragma then
4133 Item_Id := Pragma_Identifier (Item);
4138 if Present (Item_Id)
4139 and then Nam_In (Chars (Item_Id), Name_Contract_Cases,
4144 Name_Refined_Global,
4145 Name_Refined_Depends,
4158 -- Start of processing for Remove_Aspects_And_Pragmas
4161 Remove_Items (Aspect_Specifications (Body_Decl));
4162 Remove_Items (Declarations (Body_Decl));
4163 end Remove_Aspects_And_Pragmas;
4165 --------------------------
4166 -- Remove_Dead_Instance --
4167 --------------------------
4169 procedure Remove_Dead_Instance (N : Node_Id) is
4174 while J <= Pending_Instantiations.Last loop
4175 if Pending_Instantiations.Table (J).Inst_Node = N then
4176 Pending_Instantiations.Table (J).Inst_Node := Empty;
4182 end Remove_Dead_Instance;