1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, 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 Is_Non_Loading_Expression_Function
302 (Id : Entity_Id) return Boolean;
303 -- Determine whether arbitrary entity Id denotes a subprogram which is
306 -- * An expression function
308 -- * A function completed by an expression function where both the
309 -- spec and body are in the same context.
311 function Must_Inline return Inline_Level_Type;
312 -- Inlining is only done if the call statement N is in the main unit,
313 -- or within the body of another inlined subprogram.
315 ----------------------------------------
316 -- Is_Non_Loading_Expression_Function --
317 ----------------------------------------
319 function Is_Non_Loading_Expression_Function
320 (Id : Entity_Id) return Boolean
327 -- A stand-alone expression function is transformed into a spec-body
328 -- pair in-place. Since both the spec and body are in the same list,
329 -- the inlining of such an expression function does not need to load
332 if Is_Expression_Function (Id) then
335 -- A function may be completed by an expression function
337 elsif Ekind (Id) = E_Function then
338 Spec_Decl := Unit_Declaration_Node (Id);
340 if Nkind (Spec_Decl) = N_Subprogram_Declaration then
341 Body_Id := Corresponding_Body (Spec_Decl);
343 if Present (Body_Id) then
344 Body_Decl := Unit_Declaration_Node (Body_Id);
346 -- The inlining of a completing expression function does
347 -- not need to load anything extra when both the spec and
348 -- body are in the same context.
351 Was_Expression_Function (Body_Decl)
352 and then Parent (Spec_Decl) = Parent (Body_Decl);
358 end Is_Non_Loading_Expression_Function;
364 function Must_Inline return Inline_Level_Type is
369 -- Check if call is in main unit
371 Scop := Current_Scope;
373 -- Do not try to inline if scope is standard. This could happen, for
374 -- example, for a call to Add_Global_Declaration, and it causes
375 -- trouble to try to inline at this level.
377 if Scop = Standard_Standard then
381 -- Otherwise lookup scope stack to outer scope
383 while Scope (Scop) /= Standard_Standard
384 and then not Is_Child_Unit (Scop)
386 Scop := Scope (Scop);
389 Comp := Parent (Scop);
390 while Nkind (Comp) /= N_Compilation_Unit loop
391 Comp := Parent (Comp);
394 -- If the call is in the main unit, inline the call and compile the
395 -- package of the subprogram to find more calls to be inlined.
397 if Comp = Cunit (Main_Unit)
398 or else Comp = Library_Unit (Cunit (Main_Unit))
401 return Inline_Package;
404 -- The call is not in the main unit. See if it is in some subprogram
405 -- that can be inlined outside its unit. If so, inline the call and,
406 -- if the inlining level is set to 1, stop there; otherwise also
407 -- compile the package as above.
409 Scop := Current_Scope;
410 while Scope (Scop) /= Standard_Standard
411 and then not Is_Child_Unit (Scop)
413 if Is_Overloadable (Scop)
414 and then Is_Inlined (Scop)
415 and then not Is_Nested (Scop)
419 if Inline_Level = 1 then
422 return Inline_Package;
426 Scop := Scope (Scop);
432 Level : Inline_Level_Type;
434 -- Start of processing for Add_Inlined_Body
437 Append_New_Elmt (N, To => Backend_Calls);
439 -- Skip subprograms that cannot be inlined outside their unit
441 if Is_Abstract_Subprogram (E)
442 or else Convention (E) = Convention_Protected
443 or else Is_Nested (E)
448 -- Find out whether the call must be inlined. Unless the result is
449 -- Dont_Inline, Must_Inline also creates an edge for the call in the
450 -- callgraph; however, it will not be activated until after Is_Called
451 -- is set on the subprogram.
453 Level := Must_Inline;
455 if Level = Dont_Inline then
459 -- If the call was generated by the compiler and is to a subprogram in
460 -- a run-time unit, we need to suppress debugging information for it,
461 -- so that the code that is eventually inlined will not affect the
462 -- debugging of the program. We do not do it if the call comes from
463 -- source because, even if the call is inlined, the user may expect it
464 -- to be present in the debugging information.
466 if not Comes_From_Source (N)
467 and then In_Extended_Main_Source_Unit (N)
468 and then Is_Predefined_Unit (Get_Source_Unit (E))
470 Set_Needs_Debug_Info (E, False);
473 -- If the subprogram is an expression function, or is completed by one
474 -- where both the spec and body are in the same context, then there is
475 -- no need to load any package body since the body of the function is
478 if Is_Non_Loading_Expression_Function (E) then
483 -- Find unit containing E, and add to list of inlined bodies if needed.
484 -- If the body is already present, no need to load any other unit. This
485 -- is the case for an initialization procedure, which appears in the
486 -- package declaration that contains the type. It is also the case if
487 -- the body has already been analyzed. Finally, if the unit enclosing
488 -- E is an instance, the instance body will be analyzed in any case,
489 -- and there is no need to add the enclosing unit (whose body might not
492 -- Library-level functions must be handled specially, because there is
493 -- no enclosing package to retrieve. In this case, it is the body of
494 -- the function that will have to be loaded.
497 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
502 Inlined_Bodies.Increment_Last;
503 Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
505 elsif Ekind (Pack) = E_Package then
508 if Is_Generic_Instance (Pack) then
511 -- Do not inline the package if the subprogram is an init proc
512 -- or other internally generated subprogram, because in that
513 -- case the subprogram body appears in the same unit that
514 -- declares the type, and that body is visible to the back end.
515 -- Do not inline it either if it is in the main unit.
516 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
517 -- calls if the back-end takes care of inlining the call.
518 -- Note that Level in Inline_Package | Inline_Call here.
520 elsif ((Level = Inline_Call
521 and then Has_Pragma_Inline_Always (E)
522 and then Back_End_Inlining)
523 or else Level = Inline_Package)
524 and then not Is_Inlined (Pack)
525 and then not Is_Internal (E)
526 and then not In_Main_Unit_Or_Subunit (Pack)
528 Set_Is_Inlined (Pack);
529 Inlined_Bodies.Increment_Last;
530 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
534 -- Ensure that Analyze_Inlined_Bodies will be invoked after
535 -- completing the analysis of the current unit.
537 Inline_Processing_Required := True;
539 end Add_Inlined_Body;
541 ----------------------------
542 -- Add_Inlined_Subprogram --
543 ----------------------------
545 procedure Add_Inlined_Subprogram (E : Entity_Id) is
546 Decl : constant Node_Id := Parent (Declaration_Node (E));
547 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
549 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id);
550 -- Append Subp to the list of subprograms inlined by the backend
552 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id);
553 -- Append Subp to the list of subprograms that cannot be inlined by
556 -----------------------------------------
557 -- Register_Backend_Inlined_Subprogram --
558 -----------------------------------------
560 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is
562 Append_New_Elmt (Subp, To => Backend_Inlined_Subps);
563 end Register_Backend_Inlined_Subprogram;
565 ---------------------------------------------
566 -- Register_Backend_Not_Inlined_Subprogram --
567 ---------------------------------------------
569 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is
571 Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps);
572 end Register_Backend_Not_Inlined_Subprogram;
574 -- Start of processing for Add_Inlined_Subprogram
577 -- If the subprogram is to be inlined, and if its unit is known to be
578 -- inlined or is an instance whose body will be analyzed anyway or the
579 -- subprogram was generated as a body by the compiler (for example an
580 -- initialization procedure) or its declaration was provided along with
581 -- the body (for example an expression function), and if it is declared
582 -- at the library level not in the main unit, and if it can be inlined
583 -- by the back-end, then insert it in the list of inlined subprograms.
586 and then (Is_Inlined (Pack)
587 or else Is_Generic_Instance (Pack)
588 or else Nkind (Decl) = N_Subprogram_Body
589 or else Present (Corresponding_Body (Decl)))
590 and then not In_Main_Unit_Or_Subunit (E)
591 and then not Is_Nested (E)
592 and then not Has_Initialized_Type (E)
594 Register_Backend_Inlined_Subprogram (E);
596 if No (Last_Inlined) then
597 Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
599 Set_Next_Inlined_Subprogram (Last_Inlined, E);
605 Register_Backend_Not_Inlined_Subprogram (E);
607 end Add_Inlined_Subprogram;
609 ------------------------
610 -- Add_Scope_To_Clean --
611 ------------------------
613 procedure Add_Scope_To_Clean (Inst : Entity_Id) is
614 Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
618 -- If the instance appears in a library-level package declaration,
619 -- all finalization is global, and nothing needs doing here.
621 if Scop = Standard_Standard then
625 -- If the instance is within a generic unit, no finalization code
626 -- can be generated. Note that at this point all bodies have been
627 -- analyzed, and the scope stack itself is not present, and the flag
628 -- Inside_A_Generic is not set.
635 while Present (S) and then S /= Standard_Standard loop
636 if Is_Generic_Unit (S) then
644 Elmt := First_Elmt (To_Clean);
645 while Present (Elmt) loop
646 if Node (Elmt) = Scop then
650 Elmt := Next_Elmt (Elmt);
653 Append_Elmt (Scop, To_Clean);
654 end Add_Scope_To_Clean;
660 function Add_Subp (E : Entity_Id) return Subp_Index is
661 Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
665 -- Initialize entry in Inlined table
667 procedure New_Entry is
669 Inlined.Increment_Last;
670 Inlined.Table (Inlined.Last).Name := E;
671 Inlined.Table (Inlined.Last).Next := No_Subp;
672 Inlined.Table (Inlined.Last).First_Succ := No_Succ;
673 Inlined.Table (Inlined.Last).Main_Call := False;
674 Inlined.Table (Inlined.Last).Processed := False;
677 -- Start of processing for Add_Subp
680 if Hash_Headers (Index) = No_Subp then
682 Hash_Headers (Index) := Inlined.Last;
686 J := Hash_Headers (Index);
687 while J /= No_Subp loop
688 if Inlined.Table (J).Name = E then
692 J := Inlined.Table (J).Next;
696 -- On exit, subprogram was not found. Enter in table. Index is
697 -- the current last entry on the hash chain.
700 Inlined.Table (Index).Next := Inlined.Last;
705 ----------------------------
706 -- Analyze_Inlined_Bodies --
707 ----------------------------
709 procedure Analyze_Inlined_Bodies is
716 type Pending_Index is new Nat;
718 package Pending_Inlined is new Table.Table (
719 Table_Component_Type => Subp_Index,
720 Table_Index_Type => Pending_Index,
721 Table_Low_Bound => 1,
722 Table_Initial => Alloc.Inlined_Initial,
723 Table_Increment => Alloc.Inlined_Increment,
724 Table_Name => "Pending_Inlined");
725 -- The workpile used to compute the transitive closure
727 -- Start of processing for Analyze_Inlined_Bodies
730 if Serious_Errors_Detected = 0 then
731 Push_Scope (Standard_Standard);
734 while J <= Inlined_Bodies.Last
735 and then Serious_Errors_Detected = 0
737 Pack := Inlined_Bodies.Table (J);
739 and then Scope (Pack) /= Standard_Standard
740 and then not Is_Child_Unit (Pack)
742 Pack := Scope (Pack);
745 Comp_Unit := Parent (Pack);
746 while Present (Comp_Unit)
747 and then Nkind (Comp_Unit) /= N_Compilation_Unit
749 Comp_Unit := Parent (Comp_Unit);
752 -- Load the body if it exists and contains inlineable entities,
753 -- unless it is the main unit, or is an instance whose body has
754 -- already been analyzed.
756 if Present (Comp_Unit)
757 and then Comp_Unit /= Cunit (Main_Unit)
758 and then Body_Required (Comp_Unit)
760 (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
762 (No (Corresponding_Body (Unit (Comp_Unit)))
763 and then Body_Needed_For_Inlining
764 (Defining_Entity (Unit (Comp_Unit)))))
767 Bname : constant Unit_Name_Type :=
768 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
773 if not Is_Loaded (Bname) then
774 Style_Check := False;
775 Load_Needed_Body (Comp_Unit, OK);
779 -- Warn that a body was not available for inlining
782 Error_Msg_Unit_1 := Bname;
784 ("one or more inlined subprograms accessed in $!??",
787 Get_File_Name (Bname, Subunit => False);
788 Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
796 if J > Inlined_Bodies.Last then
798 -- The analysis of required bodies may have produced additional
799 -- generic instantiations. To obtain further inlining, we need
800 -- to perform another round of generic body instantiations.
804 -- Symmetrically, the instantiation of required generic bodies
805 -- may have caused additional bodies to be inlined. To obtain
806 -- further inlining, we keep looping over the inlined bodies.
810 -- The list of inlined subprograms is an overestimate, because it
811 -- includes inlined functions called from functions that are compiled
812 -- as part of an inlined package, but are not themselves called. An
813 -- accurate computation of just those subprograms that are needed
814 -- requires that we perform a transitive closure over the call graph,
815 -- starting from calls in the main compilation unit.
817 for Index in Inlined.First .. Inlined.Last loop
818 if not Is_Called (Inlined.Table (Index).Name) then
820 -- This means that Add_Inlined_Body added the subprogram to the
821 -- table but wasn't able to handle its code unit. Do nothing.
823 Inlined.Table (Index).Processed := True;
825 elsif Inlined.Table (Index).Main_Call then
826 Pending_Inlined.Increment_Last;
827 Pending_Inlined.Table (Pending_Inlined.Last) := Index;
828 Inlined.Table (Index).Processed := True;
831 Set_Is_Called (Inlined.Table (Index).Name, False);
835 -- Iterate over the workpile until it is emptied, propagating the
836 -- Is_Called flag to the successors of the processed subprogram.
838 while Pending_Inlined.Last >= Pending_Inlined.First loop
839 Subp := Pending_Inlined.Table (Pending_Inlined.Last);
840 Pending_Inlined.Decrement_Last;
842 S := Inlined.Table (Subp).First_Succ;
844 while S /= No_Succ loop
845 Subp := Successors.Table (S).Subp;
847 if not Inlined.Table (Subp).Processed then
848 Set_Is_Called (Inlined.Table (Subp).Name);
849 Pending_Inlined.Increment_Last;
850 Pending_Inlined.Table (Pending_Inlined.Last) := Subp;
851 Inlined.Table (Subp).Processed := True;
854 S := Successors.Table (S).Next;
858 -- Finally add the called subprograms to the list of inlined
859 -- subprograms for the unit.
861 for Index in Inlined.First .. Inlined.Last loop
862 if Is_Called (Inlined.Table (Index).Name) then
863 Add_Inlined_Subprogram (Inlined.Table (Index).Name);
869 end Analyze_Inlined_Bodies;
871 --------------------------
872 -- Build_Body_To_Inline --
873 --------------------------
875 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
876 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
877 Analysis_Status : constant Boolean := Full_Analysis;
878 Original_Body : Node_Id;
879 Body_To_Analyze : Node_Id;
880 Max_Size : constant := 10;
882 function Has_Extended_Return return Boolean;
883 -- This function returns True if the subprogram has an extended return
886 function Has_Pending_Instantiation return Boolean;
887 -- If some enclosing body contains instantiations that appear before
888 -- the corresponding generic body, the enclosing body has a freeze node
889 -- so that it can be elaborated after the generic itself. This might
890 -- conflict with subsequent inlinings, so that it is unsafe to try to
891 -- inline in such a case.
893 function Has_Single_Return_In_GNATprove_Mode return Boolean;
894 -- This function is called only in GNATprove mode, and it returns
895 -- True if the subprogram has no return statement or a single return
896 -- statement as last statement. It returns False for subprogram with
897 -- a single return as last statement inside one or more blocks, as
898 -- inlining would generate gotos in that case as well (although the
899 -- goto is useless in that case).
901 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
902 -- If the body of the subprogram includes a call that returns an
903 -- unconstrained type, the secondary stack is involved, and it
904 -- is not worth inlining.
906 -------------------------
907 -- Has_Extended_Return --
908 -------------------------
910 function Has_Extended_Return return Boolean is
911 Body_To_Inline : constant Node_Id := N;
913 function Check_Return (N : Node_Id) return Traverse_Result;
914 -- Returns OK on node N if this is not an extended return statement
920 function Check_Return (N : Node_Id) return Traverse_Result is
923 when N_Extended_Return_Statement =>
926 -- Skip locally declared subprogram bodies inside the body to
927 -- inline, as the return statements inside those do not count.
929 when N_Subprogram_Body =>
930 if N = Body_To_Inline then
941 function Check_All_Returns is new Traverse_Func (Check_Return);
943 -- Start of processing for Has_Extended_Return
946 return Check_All_Returns (N) /= OK;
947 end Has_Extended_Return;
949 -------------------------------
950 -- Has_Pending_Instantiation --
951 -------------------------------
953 function Has_Pending_Instantiation return Boolean is
958 while Present (S) loop
959 if Is_Compilation_Unit (S)
960 or else Is_Child_Unit (S)
964 elsif Ekind (S) = E_Package
965 and then Has_Forward_Instantiation (S)
974 end Has_Pending_Instantiation;
976 -----------------------------------------
977 -- Has_Single_Return_In_GNATprove_Mode --
978 -----------------------------------------
980 function Has_Single_Return_In_GNATprove_Mode return Boolean is
981 Body_To_Inline : constant Node_Id := N;
982 Last_Statement : Node_Id := Empty;
984 function Check_Return (N : Node_Id) return Traverse_Result;
985 -- Returns OK on node N if this is not a return statement different
986 -- from the last statement in the subprogram.
992 function Check_Return (N : Node_Id) return Traverse_Result is
995 when N_Extended_Return_Statement
996 | N_Simple_Return_Statement
998 if N = Last_Statement then
1004 -- Skip locally declared subprogram bodies inside the body to
1005 -- inline, as the return statements inside those do not count.
1007 when N_Subprogram_Body =>
1008 if N = Body_To_Inline then
1019 function Check_All_Returns is new Traverse_Func (Check_Return);
1021 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
1024 -- Retrieve the last statement
1026 Last_Statement := Last (Statements (Handled_Statement_Sequence (N)));
1028 -- Check that the last statement is the only possible return
1029 -- statement in the subprogram.
1031 return Check_All_Returns (N) = OK;
1032 end Has_Single_Return_In_GNATprove_Mode;
1034 --------------------------
1035 -- Uses_Secondary_Stack --
1036 --------------------------
1038 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
1039 function Check_Call (N : Node_Id) return Traverse_Result;
1040 -- Look for function calls that return an unconstrained type
1046 function Check_Call (N : Node_Id) return Traverse_Result is
1048 if Nkind (N) = N_Function_Call
1049 and then Is_Entity_Name (Name (N))
1050 and then Is_Composite_Type (Etype (Entity (Name (N))))
1051 and then not Is_Constrained (Etype (Entity (Name (N))))
1054 ("cannot inline & (call returns unconstrained type)?",
1062 function Check_Calls is new Traverse_Func (Check_Call);
1065 return Check_Calls (Bod) = Abandon;
1066 end Uses_Secondary_Stack;
1068 -- Start of processing for Build_Body_To_Inline
1071 -- Return immediately if done already
1073 if Nkind (Decl) = N_Subprogram_Declaration
1074 and then Present (Body_To_Inline (Decl))
1078 -- Subprograms that have return statements in the middle of the body are
1079 -- inlined with gotos. GNATprove does not currently support gotos, so
1080 -- we prevent such inlining.
1082 elsif GNATprove_Mode
1083 and then not Has_Single_Return_In_GNATprove_Mode
1085 Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
1088 -- Functions that return unconstrained composite types require
1089 -- secondary stack handling, and cannot currently be inlined, unless
1090 -- all return statements return a local variable that is the first
1091 -- local declaration in the body.
1093 elsif Ekind (Spec_Id) = E_Function
1094 and then not Is_Scalar_Type (Etype (Spec_Id))
1095 and then not Is_Access_Type (Etype (Spec_Id))
1096 and then not Is_Constrained (Etype (Spec_Id))
1098 if not Has_Single_Return (N)
1100 -- Skip inlining if the function returns an unconstrained type
1101 -- using an extended return statement, since this part of the
1102 -- new inlining model is not yet supported by the current
1103 -- implementation. ???
1105 or else (Returns_Unconstrained_Type (Spec_Id)
1106 and then Has_Extended_Return)
1109 ("cannot inline & (unconstrained return type)?", N, Spec_Id);
1113 -- Ditto for functions that return controlled types, where controlled
1114 -- actions interfere in complex ways with inlining.
1116 elsif Ekind (Spec_Id) = E_Function
1117 and then Needs_Finalization (Etype (Spec_Id))
1120 ("cannot inline & (controlled return type)?", N, Spec_Id);
1124 if Present (Declarations (N))
1125 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
1130 if Present (Handled_Statement_Sequence (N)) then
1131 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1133 ("cannot inline& (exception handler)?",
1134 First (Exception_Handlers (Handled_Statement_Sequence (N))),
1138 elsif Has_Excluded_Statement
1139 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
1145 -- We do not inline a subprogram that is too large, unless it is marked
1146 -- Inline_Always or we are in GNATprove mode. This pragma does not
1147 -- suppress the other checks on inlining (forbidden declarations,
1150 if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode)
1151 and then List_Length
1152 (Statements (Handled_Statement_Sequence (N))) > Max_Size
1154 Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id);
1158 if Has_Pending_Instantiation then
1160 ("cannot inline& (forward instance within enclosing body)?",
1165 -- Within an instance, the body to inline must be treated as a nested
1166 -- generic, so that the proper global references are preserved.
1168 -- Note that we do not do this at the library level, because it is not
1169 -- needed, and furthermore this causes trouble if front-end inlining
1170 -- is activated (-gnatN).
1172 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1173 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1174 Original_Body := Copy_Generic_Node (N, Empty, Instantiating => True);
1176 Original_Body := Copy_Separate_Tree (N);
1179 -- We need to capture references to the formals in order to substitute
1180 -- the actuals at the point of inlining, i.e. instantiation. To treat
1181 -- the formals as globals to the body to inline, we nest it within a
1182 -- dummy parameterless subprogram, declared within the real one. To
1183 -- avoid generating an internal name (which is never public, and which
1184 -- affects serial numbers of other generated names), we use an internal
1185 -- symbol that cannot conflict with user declarations.
1187 Set_Parameter_Specifications (Specification (Original_Body), No_List);
1188 Set_Defining_Unit_Name
1189 (Specification (Original_Body),
1190 Make_Defining_Identifier (Sloc (N), Name_uParent));
1191 Set_Corresponding_Spec (Original_Body, Empty);
1193 -- Remove all aspects/pragmas that have no meaning in an inlined body
1195 Remove_Aspects_And_Pragmas (Original_Body);
1198 Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
1200 -- Set return type of function, which is also global and does not need
1203 if Ekind (Spec_Id) = E_Function then
1204 Set_Result_Definition
1205 (Specification (Body_To_Analyze),
1206 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1209 if No (Declarations (N)) then
1210 Set_Declarations (N, New_List (Body_To_Analyze));
1212 Append (Body_To_Analyze, Declarations (N));
1215 -- The body to inline is preanalyzed. In GNATprove mode we must disable
1216 -- full analysis as well so that light expansion does not take place
1217 -- either, and name resolution is unaffected.
1219 Expander_Mode_Save_And_Set (False);
1220 Full_Analysis := False;
1222 Analyze (Body_To_Analyze);
1223 Push_Scope (Defining_Entity (Body_To_Analyze));
1224 Save_Global_References (Original_Body);
1226 Remove (Body_To_Analyze);
1228 Expander_Mode_Restore;
1229 Full_Analysis := Analysis_Status;
1231 -- Restore environment if previously saved
1233 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1237 -- If secondary stack is used, there is no point in inlining. We have
1238 -- already issued the warning in this case, so nothing to do.
1240 if Uses_Secondary_Stack (Body_To_Analyze) then
1244 Set_Body_To_Inline (Decl, Original_Body);
1245 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1246 Set_Is_Inlined (Spec_Id);
1247 end Build_Body_To_Inline;
1249 -------------------------------------------
1250 -- Call_Can_Be_Inlined_In_GNATprove_Mode --
1251 -------------------------------------------
1253 function Call_Can_Be_Inlined_In_GNATprove_Mode
1255 Subp : Entity_Id) return Boolean
1261 F := First_Formal (Subp);
1262 A := First_Actual (N);
1263 while Present (F) loop
1264 if Ekind (F) /= E_Out_Parameter
1265 and then not Same_Type (Etype (F), Etype (A))
1267 (Is_By_Reference_Type (Etype (A))
1268 or else Is_Limited_Type (Etype (A)))
1278 end Call_Can_Be_Inlined_In_GNATprove_Mode;
1280 --------------------------------------
1281 -- Can_Be_Inlined_In_GNATprove_Mode --
1282 --------------------------------------
1284 function Can_Be_Inlined_In_GNATprove_Mode
1285 (Spec_Id : Entity_Id;
1286 Body_Id : Entity_Id) return Boolean
1288 function Has_Formal_With_Discriminant_Dependent_Fields
1289 (Id : Entity_Id) return Boolean;
1290 -- Returns true if the subprogram has at least one formal parameter of
1291 -- an unconstrained record type with per-object constraints on component
1294 function Has_Some_Contract (Id : Entity_Id) return Boolean;
1295 -- Return True if subprogram Id has any contract. The presence of
1296 -- Extensions_Visible or Volatile_Function is also considered as a
1299 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
1300 -- Return True if subprogram Id defines a compilation unit
1301 -- Shouldn't this be in Sem_Aux???
1303 function In_Package_Spec (Id : Entity_Id) return Boolean;
1304 -- Return True if subprogram Id is defined in the package specification,
1305 -- either its visible or private part.
1307 ---------------------------------------------------
1308 -- Has_Formal_With_Discriminant_Dependent_Fields --
1309 ---------------------------------------------------
1311 function Has_Formal_With_Discriminant_Dependent_Fields
1312 (Id : Entity_Id) return Boolean
1314 function Has_Discriminant_Dependent_Component
1315 (Typ : Entity_Id) return Boolean;
1316 -- Determine whether unconstrained record type Typ has at least one
1317 -- component that depends on a discriminant.
1319 ------------------------------------------
1320 -- Has_Discriminant_Dependent_Component --
1321 ------------------------------------------
1323 function Has_Discriminant_Dependent_Component
1324 (Typ : Entity_Id) return Boolean
1329 -- Inspect all components of the record type looking for one that
1330 -- depends on a discriminant.
1332 Comp := First_Component (Typ);
1333 while Present (Comp) loop
1334 if Has_Discriminant_Dependent_Constraint (Comp) then
1338 Next_Component (Comp);
1342 end Has_Discriminant_Dependent_Component;
1346 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1348 Formal_Typ : Entity_Id;
1350 -- Start of processing for
1351 -- Has_Formal_With_Discriminant_Dependent_Fields
1354 -- Inspect all parameters of the subprogram looking for a formal
1355 -- of an unconstrained record type with at least one discriminant
1356 -- dependent component.
1358 Formal := First_Formal (Subp_Id);
1359 while Present (Formal) loop
1360 Formal_Typ := Etype (Formal);
1362 if Is_Record_Type (Formal_Typ)
1363 and then not Is_Constrained (Formal_Typ)
1364 and then Has_Discriminant_Dependent_Component (Formal_Typ)
1369 Next_Formal (Formal);
1373 end Has_Formal_With_Discriminant_Dependent_Fields;
1375 -----------------------
1376 -- Has_Some_Contract --
1377 -----------------------
1379 function Has_Some_Contract (Id : Entity_Id) return Boolean is
1383 -- A call to an expression function may precede the actual body which
1384 -- is inserted at the end of the enclosing declarations. Ensure that
1385 -- the related entity is decorated before inspecting the contract.
1387 if Is_Subprogram_Or_Generic_Subprogram (Id) then
1388 Items := Contract (Id);
1390 -- Note that Classifications is not Empty when Extensions_Visible
1391 -- or Volatile_Function is present, which causes such subprograms
1392 -- to be considered to have a contract here. This is fine as we
1393 -- want to avoid inlining these too.
1395 return Present (Items)
1396 and then (Present (Pre_Post_Conditions (Items)) or else
1397 Present (Contract_Test_Cases (Items)) or else
1398 Present (Classifications (Items)));
1402 end Has_Some_Contract;
1404 ---------------------
1405 -- In_Package_Spec --
1406 ---------------------
1408 function In_Package_Spec (Id : Entity_Id) return Boolean is
1409 P : constant Node_Id := Parent (Subprogram_Spec (Id));
1410 -- Parent of the subprogram's declaration
1413 return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
1414 end In_Package_Spec;
1416 ------------------------
1417 -- Is_Unit_Subprogram --
1418 ------------------------
1420 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1421 Decl : Node_Id := Parent (Parent (Id));
1423 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1424 Decl := Parent (Decl);
1427 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1428 end Is_Unit_Subprogram;
1430 -- Local declarations
1433 -- Procedure or function entity for the subprogram
1435 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1438 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1440 if Present (Spec_Id) then
1446 -- Only local subprograms without contracts are inlined in GNATprove
1447 -- mode, as these are the subprograms which a user is not interested in
1448 -- analyzing in isolation, but rather in the context of their call. This
1449 -- is a convenient convention, that could be changed for an explicit
1450 -- pragma/aspect one day.
1452 -- In a number of special cases, inlining is not desirable or not
1453 -- possible, see below.
1455 -- Do not inline unit-level subprograms
1457 if Is_Unit_Subprogram (Id) then
1460 -- Do not inline subprograms declared in package specs, because they are
1461 -- not local, i.e. can be called either from anywhere (if declared in
1462 -- visible part) or from the child units (if declared in private part).
1464 elsif In_Package_Spec (Id) then
1467 -- Do not inline subprograms declared in other units. This is important
1468 -- in particular for subprograms defined in the private part of a
1469 -- package spec, when analyzing one of its child packages, as otherwise
1470 -- we issue spurious messages about the impossibility to inline such
1473 elsif not In_Extended_Main_Code_Unit (Id) then
1476 -- Do not inline subprograms marked No_Return, possibly used for
1477 -- signaling errors, which GNATprove handles specially.
1479 elsif No_Return (Id) then
1482 -- Do not inline subprograms that have a contract on the spec or the
1483 -- body. Use the contract(s) instead in GNATprove. This also prevents
1484 -- inlining of subprograms with Extensions_Visible or Volatile_Function.
1486 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
1488 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
1492 -- Do not inline expression functions, which are directly inlined at the
1495 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
1497 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
1501 -- Do not inline generic subprogram instances. The visibility rules of
1502 -- generic instances plays badly with inlining.
1504 elsif Is_Generic_Instance (Spec_Id) then
1507 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1508 -- the subprogram body, a similar check is performed after the body
1509 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1511 elsif Present (Spec_Id)
1513 (No (SPARK_Pragma (Spec_Id))
1515 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
1519 -- Subprograms in generic instances are currently not inlined, to avoid
1520 -- problems with inlining of standard library subprograms.
1522 elsif Instantiation_Location (Sloc (Id)) /= No_Location then
1525 -- Do not inline subprograms and entries defined inside protected types,
1526 -- which typically are not helper subprograms, which also avoids getting
1527 -- spurious messages on calls that cannot be inlined.
1529 elsif Within_Protected_Type (Id) then
1532 -- Do not inline predicate functions (treated specially by GNATprove)
1534 elsif Is_Predicate_Function (Id) then
1537 -- Do not inline subprograms with a parameter of an unconstrained
1538 -- record type if it has discrimiant dependent fields. Indeed, with
1539 -- such parameters, the frontend cannot always ensure type compliance
1540 -- in record component accesses (in particular with records containing
1543 elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
1546 -- Otherwise, this is a subprogram declared inside the private part of a
1547 -- package, or inside a package body, or locally in a subprogram, and it
1548 -- does not have any contract. Inline it.
1553 end Can_Be_Inlined_In_GNATprove_Mode;
1559 procedure Cannot_Inline
1563 Is_Serious : Boolean := False)
1566 -- In GNATprove mode, inlining is the technical means by which the
1567 -- higher-level goal of contextual analysis is reached, so issue
1568 -- messages about failure to apply contextual analysis to a
1569 -- subprogram, rather than failure to inline it.
1572 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
1575 Len1 : constant Positive :=
1576 String (String'("cannot inline"))'Length;
1577 Len2 : constant Positive :=
1578 String (String'("info: no contextual analysis of"))'Length;
1580 New_Msg : String (1 .. Msg'Length + Len2 - Len1);
1583 New_Msg (1 .. Len2) := "info: no contextual analysis of";
1584 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
1585 Msg (Msg'First + Len1 .. Msg'Last);
1586 Cannot_Inline (New_Msg, N, Subp, Is_Serious);
1591 pragma Assert (Msg (Msg'Last) = '?');
1593 -- Legacy front-end inlining model
1595 if not Back_End_Inlining then
1597 -- Do not emit warning if this is a predefined unit which is not
1598 -- the main unit. With validity checks enabled, some predefined
1599 -- subprograms may contain nested subprograms and become ineligible
1602 if Is_Predefined_Unit (Get_Source_Unit (Subp))
1603 and then not In_Extended_Main_Source_Unit (Subp)
1607 -- In GNATprove mode, issue a warning, and indicate that the
1608 -- subprogram is not always inlined by setting flag Is_Inlined_Always
1611 elsif GNATprove_Mode then
1612 Set_Is_Inlined_Always (Subp, False);
1613 Error_Msg_NE (Msg & "p?", N, Subp);
1615 elsif Has_Pragma_Inline_Always (Subp) then
1617 -- Remove last character (question mark) to make this into an
1618 -- error, because the Inline_Always pragma cannot be obeyed.
1620 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1622 elsif Ineffective_Inline_Warnings then
1623 Error_Msg_NE (Msg & "p?", N, Subp);
1626 -- New semantics relying on back-end inlining
1628 elsif Is_Serious then
1630 -- Remove last character (question mark) to make this into an error.
1632 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1634 -- In GNATprove mode, issue a warning, and indicate that the subprogram
1635 -- is not always inlined by setting flag Is_Inlined_Always to False.
1637 elsif GNATprove_Mode then
1638 Set_Is_Inlined_Always (Subp, False);
1639 Error_Msg_NE (Msg & "p?", N, Subp);
1643 -- Do not emit warning if this is a predefined unit which is not
1644 -- the main unit. This behavior is currently provided for backward
1645 -- compatibility but it will be removed when we enforce the
1646 -- strictness of the new rules.
1648 if Is_Predefined_Unit (Get_Source_Unit (Subp))
1649 and then not In_Extended_Main_Source_Unit (Subp)
1653 elsif Has_Pragma_Inline_Always (Subp) then
1655 -- Emit a warning if this is a call to a runtime subprogram
1656 -- which is located inside a generic. Previously this call
1657 -- was silently skipped.
1659 if Is_Generic_Instance (Subp) then
1661 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
1663 if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then
1664 Set_Is_Inlined (Subp, False);
1665 Error_Msg_NE (Msg & "p?", N, Subp);
1671 -- Remove last character (question mark) to make this into an
1672 -- error, because the Inline_Always pragma cannot be obeyed.
1674 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1677 Set_Is_Inlined (Subp, False);
1679 if Ineffective_Inline_Warnings then
1680 Error_Msg_NE (Msg & "p?", N, Subp);
1686 --------------------------------------------
1687 -- Check_And_Split_Unconstrained_Function --
1688 --------------------------------------------
1690 procedure Check_And_Split_Unconstrained_Function
1692 Spec_Id : Entity_Id;
1693 Body_Id : Entity_Id)
1695 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
1696 -- Use generic machinery to build an unexpanded body for the subprogram.
1697 -- This body is subsequently used for inline expansions at call sites.
1699 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
1700 -- Return true if we generate code for the function body N, the function
1701 -- body N has no local declarations and its unique statement is a single
1702 -- extended return statement with a handled statements sequence.
1704 procedure Split_Unconstrained_Function
1706 Spec_Id : Entity_Id);
1707 -- N is an inlined function body that returns an unconstrained type and
1708 -- has a single extended return statement. Split N in two subprograms:
1709 -- a procedure P' and a function F'. The formals of P' duplicate the
1710 -- formals of N plus an extra formal which is used to return a value;
1711 -- its body is composed by the declarations and list of statements
1712 -- of the extended return statement of N.
1714 --------------------------
1715 -- Build_Body_To_Inline --
1716 --------------------------
1718 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
1719 procedure Generate_Subprogram_Body
1721 Body_To_Inline : out Node_Id);
1722 -- Generate a parameterless duplicate of subprogram body N. Note that
1723 -- occurrences of pragmas referencing the formals are removed since
1724 -- they have no meaning when the body is inlined and the formals are
1725 -- rewritten (the analysis of the non-inlined body will handle these
1726 -- pragmas). A new internal name is associated with Body_To_Inline.
1728 ------------------------------
1729 -- Generate_Subprogram_Body --
1730 ------------------------------
1732 procedure Generate_Subprogram_Body
1734 Body_To_Inline : out Node_Id)
1737 -- Within an instance, the body to inline must be treated as a
1738 -- nested generic so that proper global references are preserved.
1740 -- Note that we do not do this at the library level, because it
1741 -- is not needed, and furthermore this causes trouble if front
1742 -- end inlining is activated (-gnatN).
1745 and then Scope (Current_Scope) /= Standard_Standard
1748 Copy_Generic_Node (N, Empty, Instantiating => True);
1750 Body_To_Inline := Copy_Separate_Tree (N);
1753 -- Remove aspects/pragmas that have no meaning in an inlined body
1755 Remove_Aspects_And_Pragmas (Body_To_Inline);
1757 -- We need to capture references to the formals in order
1758 -- to substitute the actuals at the point of inlining, i.e.
1759 -- instantiation. To treat the formals as globals to the body to
1760 -- inline, we nest it within a dummy parameterless subprogram,
1761 -- declared within the real one.
1763 Set_Parameter_Specifications
1764 (Specification (Body_To_Inline), No_List);
1766 -- A new internal name is associated with Body_To_Inline to avoid
1767 -- conflicts when the non-inlined body N is analyzed.
1769 Set_Defining_Unit_Name (Specification (Body_To_Inline),
1770 Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P')));
1771 Set_Corresponding_Spec (Body_To_Inline, Empty);
1772 end Generate_Subprogram_Body;
1776 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1777 Original_Body : Node_Id;
1778 Body_To_Analyze : Node_Id;
1781 pragma Assert (Current_Scope = Spec_Id);
1783 -- Within an instance, the body to inline must be treated as a nested
1784 -- generic, so that the proper global references are preserved. We
1785 -- do not do this at the library level, because it is not needed, and
1786 -- furthermore this causes trouble if front-end inlining is activated
1790 and then Scope (Current_Scope) /= Standard_Standard
1792 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1795 -- Capture references to formals in order to substitute the actuals
1796 -- at the point of inlining or instantiation. To treat the formals
1797 -- as globals to the body to inline, nest the body within a dummy
1798 -- parameterless subprogram, declared within the real one.
1800 Generate_Subprogram_Body (N, Original_Body);
1802 Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
1804 -- Set return type of function, which is also global and does not
1805 -- need to be resolved.
1807 if Ekind (Spec_Id) = E_Function then
1808 Set_Result_Definition (Specification (Body_To_Analyze),
1809 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1812 if No (Declarations (N)) then
1813 Set_Declarations (N, New_List (Body_To_Analyze));
1815 Append_To (Declarations (N), Body_To_Analyze);
1818 Preanalyze (Body_To_Analyze);
1820 Push_Scope (Defining_Entity (Body_To_Analyze));
1821 Save_Global_References (Original_Body);
1823 Remove (Body_To_Analyze);
1825 -- Restore environment if previously saved
1828 and then Scope (Current_Scope) /= Standard_Standard
1833 pragma Assert (No (Body_To_Inline (Decl)));
1834 Set_Body_To_Inline (Decl, Original_Body);
1835 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1836 end Build_Body_To_Inline;
1838 --------------------------------------
1839 -- Can_Split_Unconstrained_Function --
1840 --------------------------------------
1842 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is
1843 Ret_Node : constant Node_Id :=
1844 First (Statements (Handled_Statement_Sequence (N)));
1848 -- No user defined declarations allowed in the function except inside
1849 -- the unique return statement; implicit labels are the only allowed
1852 if not Is_Empty_List (Declarations (N)) then
1853 D := First (Declarations (N));
1854 while Present (D) loop
1855 if Nkind (D) /= N_Implicit_Label_Declaration then
1863 -- We only split the inlined function when we are generating the code
1864 -- of its body; otherwise we leave duplicated split subprograms in
1865 -- the tree which (if referenced) generate wrong references at link
1868 return In_Extended_Main_Code_Unit (N)
1869 and then Present (Ret_Node)
1870 and then Nkind (Ret_Node) = N_Extended_Return_Statement
1871 and then No (Next (Ret_Node))
1872 and then Present (Handled_Statement_Sequence (Ret_Node));
1873 end Can_Split_Unconstrained_Function;
1875 ----------------------------------
1876 -- Split_Unconstrained_Function --
1877 ----------------------------------
1879 procedure Split_Unconstrained_Function
1881 Spec_Id : Entity_Id)
1883 Loc : constant Source_Ptr := Sloc (N);
1884 Ret_Node : constant Node_Id :=
1885 First (Statements (Handled_Statement_Sequence (N)));
1886 Ret_Obj : constant Node_Id :=
1887 First (Return_Object_Declarations (Ret_Node));
1889 procedure Build_Procedure
1890 (Proc_Id : out Entity_Id;
1891 Decl_List : out List_Id);
1892 -- Build a procedure containing the statements found in the extended
1893 -- return statement of the unconstrained function body N.
1895 ---------------------
1896 -- Build_Procedure --
1897 ---------------------
1899 procedure Build_Procedure
1900 (Proc_Id : out Entity_Id;
1901 Decl_List : out List_Id)
1904 Formal_List : constant List_Id := New_List;
1905 Proc_Spec : Node_Id;
1906 Proc_Body : Node_Id;
1907 Subp_Name : constant Name_Id := New_Internal_Name ('F');
1908 Body_Decl_List : List_Id := No_List;
1909 Param_Type : Node_Id;
1912 if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then
1914 New_Copy (Object_Definition (Ret_Obj));
1917 New_Copy (Subtype_Mark (Object_Definition (Ret_Obj)));
1920 Append_To (Formal_List,
1921 Make_Parameter_Specification (Loc,
1922 Defining_Identifier =>
1923 Make_Defining_Identifier (Loc,
1924 Chars => Chars (Defining_Identifier (Ret_Obj))),
1925 In_Present => False,
1926 Out_Present => True,
1927 Null_Exclusion_Present => False,
1928 Parameter_Type => Param_Type));
1930 Formal := First_Formal (Spec_Id);
1932 -- Note that we copy the parameter type rather than creating
1933 -- a reference to it, because it may be a class-wide entity
1934 -- that will not be retrieved by name.
1936 while Present (Formal) loop
1937 Append_To (Formal_List,
1938 Make_Parameter_Specification (Loc,
1939 Defining_Identifier =>
1940 Make_Defining_Identifier (Sloc (Formal),
1941 Chars => Chars (Formal)),
1942 In_Present => In_Present (Parent (Formal)),
1943 Out_Present => Out_Present (Parent (Formal)),
1944 Null_Exclusion_Present =>
1945 Null_Exclusion_Present (Parent (Formal)),
1947 New_Copy_Tree (Parameter_Type (Parent (Formal))),
1949 Copy_Separate_Tree (Expression (Parent (Formal)))));
1951 Next_Formal (Formal);
1954 Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name);
1957 Make_Procedure_Specification (Loc,
1958 Defining_Unit_Name => Proc_Id,
1959 Parameter_Specifications => Formal_List);
1961 Decl_List := New_List;
1963 Append_To (Decl_List,
1964 Make_Subprogram_Declaration (Loc, Proc_Spec));
1966 -- Can_Convert_Unconstrained_Function checked that the function
1967 -- has no local declarations except implicit label declarations.
1968 -- Copy these declarations to the built procedure.
1970 if Present (Declarations (N)) then
1971 Body_Decl_List := New_List;
1978 D := First (Declarations (N));
1979 while Present (D) loop
1980 pragma Assert (Nkind (D) = N_Implicit_Label_Declaration);
1983 Make_Implicit_Label_Declaration (Loc,
1984 Make_Defining_Identifier (Loc,
1985 Chars => Chars (Defining_Identifier (D))),
1986 Label_Construct => Empty);
1987 Append_To (Body_Decl_List, New_D);
1994 pragma Assert (Present (Handled_Statement_Sequence (Ret_Node)));
1997 Make_Subprogram_Body (Loc,
1998 Specification => Copy_Separate_Tree (Proc_Spec),
1999 Declarations => Body_Decl_List,
2000 Handled_Statement_Sequence =>
2001 Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node)));
2003 Set_Defining_Unit_Name (Specification (Proc_Body),
2004 Make_Defining_Identifier (Loc, Subp_Name));
2006 Append_To (Decl_List, Proc_Body);
2007 end Build_Procedure;
2011 New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj);
2013 Proc_Id : Entity_Id;
2014 Proc_Call : Node_Id;
2016 -- Start of processing for Split_Unconstrained_Function
2019 -- Build the associated procedure, analyze it and insert it before
2020 -- the function body N.
2023 Scope : constant Entity_Id := Current_Scope;
2024 Decl_List : List_Id;
2027 Build_Procedure (Proc_Id, Decl_List);
2028 Insert_Actions (N, Decl_List);
2029 Set_Is_Inlined (Proc_Id);
2033 -- Build the call to the generated procedure
2036 Actual_List : constant List_Id := New_List;
2040 Append_To (Actual_List,
2041 New_Occurrence_Of (Defining_Identifier (New_Obj), Loc));
2043 Formal := First_Formal (Spec_Id);
2044 while Present (Formal) loop
2045 Append_To (Actual_List, New_Occurrence_Of (Formal, Loc));
2047 -- Avoid spurious warning on unreferenced formals
2049 Set_Referenced (Formal);
2050 Next_Formal (Formal);
2054 Make_Procedure_Call_Statement (Loc,
2055 Name => New_Occurrence_Of (Proc_Id, Loc),
2056 Parameter_Associations => Actual_List);
2064 -- Proc (New_Obj, ...);
2069 Make_Block_Statement (Loc,
2070 Declarations => New_List (New_Obj),
2071 Handled_Statement_Sequence =>
2072 Make_Handled_Sequence_Of_Statements (Loc,
2073 Statements => New_List (
2077 Make_Simple_Return_Statement (Loc,
2080 (Defining_Identifier (New_Obj), Loc)))));
2082 Rewrite (Ret_Node, Blk_Stmt);
2083 end Split_Unconstrained_Function;
2087 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2089 -- Start of processing for Check_And_Split_Unconstrained_Function
2092 pragma Assert (Back_End_Inlining
2093 and then Ekind (Spec_Id) = E_Function
2094 and then Returns_Unconstrained_Type (Spec_Id)
2095 and then Comes_From_Source (Body_Id)
2096 and then (Has_Pragma_Inline_Always (Spec_Id)
2097 or else Optimization_Level > 0));
2099 -- This routine must not be used in GNATprove mode since GNATprove
2100 -- relies on frontend inlining
2102 pragma Assert (not GNATprove_Mode);
2104 -- No need to split the function if we cannot generate the code
2106 if Serious_Errors_Detected /= 0 then
2110 -- No action needed in stubs since the attribute Body_To_Inline
2113 if Nkind (Decl) = N_Subprogram_Body_Stub then
2116 -- Cannot build the body to inline if the attribute is already set.
2117 -- This attribute may have been set if this is a subprogram renaming
2118 -- declarations (see Freeze.Build_Renamed_Body).
2120 elsif Present (Body_To_Inline (Decl)) then
2123 -- Check excluded declarations
2125 elsif Present (Declarations (N))
2126 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
2130 -- Check excluded statements. There is no need to protect us against
2131 -- exception handlers since they are supported by the GCC backend.
2133 elsif Present (Handled_Statement_Sequence (N))
2134 and then Has_Excluded_Statement
2135 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
2140 -- Build the body to inline only if really needed
2142 if Can_Split_Unconstrained_Function (N) then
2143 Split_Unconstrained_Function (N, Spec_Id);
2144 Build_Body_To_Inline (N, Spec_Id);
2145 Set_Is_Inlined (Spec_Id);
2147 end Check_And_Split_Unconstrained_Function;
2149 -------------------------------------
2150 -- Check_Package_Body_For_Inlining --
2151 -------------------------------------
2153 procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
2154 Bname : Unit_Name_Type;
2159 -- Legacy implementation (relying on frontend inlining)
2161 if not Back_End_Inlining
2162 and then Is_Compilation_Unit (P)
2163 and then not Is_Generic_Instance (P)
2165 Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
2167 E := First_Entity (P);
2168 while Present (E) loop
2169 if Has_Pragma_Inline_Always (E)
2170 or else (Has_Pragma_Inline (E) and Front_End_Inlining)
2172 if not Is_Loaded (Bname) then
2173 Load_Needed_Body (N, OK);
2177 -- Check we are not trying to inline a parent whose body
2178 -- depends on a child, when we are compiling the body of
2179 -- the child. Otherwise we have a potential elaboration
2180 -- circularity with inlined subprograms and with
2181 -- Taft-Amendment types.
2184 Comp : Node_Id; -- Body just compiled
2185 Child_Spec : Entity_Id; -- Spec of main unit
2186 Ent : Entity_Id; -- For iteration
2187 With_Clause : Node_Id; -- Context of body.
2190 if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
2191 and then Present (Body_Entity (P))
2195 ((Unit (Library_Unit (Cunit (Main_Unit)))));
2198 Parent (Unit_Declaration_Node (Body_Entity (P)));
2200 -- Check whether the context of the body just
2201 -- compiled includes a child of itself, and that
2202 -- child is the spec of the main compilation.
2204 With_Clause := First (Context_Items (Comp));
2205 while Present (With_Clause) loop
2206 if Nkind (With_Clause) = N_With_Clause
2208 Scope (Entity (Name (With_Clause))) = P
2210 Entity (Name (With_Clause)) = Child_Spec
2212 Error_Msg_Node_2 := Child_Spec;
2214 ("body of & depends on child unit&??",
2217 ("\subprograms in body cannot be inlined??",
2220 -- Disable further inlining from this unit,
2221 -- and keep Taft-amendment types incomplete.
2223 Ent := First_Entity (P);
2224 while Present (Ent) loop
2226 and then Has_Completion_In_Body (Ent)
2228 Set_Full_View (Ent, Empty);
2230 elsif Is_Subprogram (Ent) then
2231 Set_Is_Inlined (Ent, False);
2245 elsif Ineffective_Inline_Warnings then
2246 Error_Msg_Unit_1 := Bname;
2248 ("unable to inline subprograms defined in $??", P);
2249 Error_Msg_N ("\body not found??", P);
2260 end Check_Package_Body_For_Inlining;
2262 --------------------
2263 -- Cleanup_Scopes --
2264 --------------------
2266 procedure Cleanup_Scopes is
2272 Elmt := First_Elmt (To_Clean);
2273 while Present (Elmt) loop
2274 Scop := Node (Elmt);
2276 if Ekind (Scop) = E_Entry then
2277 Scop := Protected_Body_Subprogram (Scop);
2279 elsif Is_Subprogram (Scop)
2280 and then Is_Protected_Type (Scope (Scop))
2281 and then Present (Protected_Body_Subprogram (Scop))
2283 -- If a protected operation contains an instance, its cleanup
2284 -- operations have been delayed, and the subprogram has been
2285 -- rewritten in the expansion of the enclosing protected body. It
2286 -- is the corresponding subprogram that may require the cleanup
2287 -- operations, so propagate the information that triggers cleanup
2291 (Protected_Body_Subprogram (Scop),
2292 Uses_Sec_Stack (Scop));
2294 Scop := Protected_Body_Subprogram (Scop);
2297 if Ekind (Scop) = E_Block then
2298 Decl := Parent (Block_Node (Scop));
2301 Decl := Unit_Declaration_Node (Scop);
2303 if Nkind_In (Decl, N_Subprogram_Declaration,
2304 N_Task_Type_Declaration,
2305 N_Subprogram_Body_Stub)
2307 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
2312 Expand_Cleanup_Actions (Decl);
2315 Elmt := Next_Elmt (Elmt);
2319 -------------------------
2320 -- Expand_Inlined_Call --
2321 -------------------------
2323 procedure Expand_Inlined_Call
2326 Orig_Subp : Entity_Id)
2328 Decls : constant List_Id := New_List;
2329 Is_Predef : constant Boolean :=
2330 Is_Predefined_Unit (Get_Source_Unit (Subp));
2331 Loc : constant Source_Ptr := Sloc (N);
2332 Orig_Bod : constant Node_Id :=
2333 Body_To_Inline (Unit_Declaration_Node (Subp));
2335 Uses_Back_End : constant Boolean :=
2336 Back_End_Inlining and then Optimization_Level > 0;
2337 -- The back-end expansion is used if the target supports back-end
2338 -- inlining and some level of optimixation is required; otherwise
2339 -- the inlining takes place fully as a tree expansion.
2343 Exit_Lab : Entity_Id := Empty;
2346 Lab_Decl : Node_Id := Empty;
2350 Ret_Type : Entity_Id;
2352 Temp_Typ : Entity_Id;
2355 Is_Unc_Decl : Boolean;
2356 -- If the type returned by the function is unconstrained and the call
2357 -- can be inlined, special processing is required.
2359 Return_Object : Entity_Id := Empty;
2360 -- Entity in declaration in an extended_return_statement
2362 Targ : Node_Id := Empty;
2363 -- The target of the call. If context is an assignment statement then
2364 -- this is the left-hand side of the assignment, else it is a temporary
2365 -- to which the return value is assigned prior to rewriting the call.
2367 Targ1 : Node_Id := Empty;
2368 -- A separate target used when the return type is unconstrained
2370 procedure Declare_Postconditions_Result;
2371 -- When generating C code, declare _Result, which may be used in the
2372 -- inlined _Postconditions procedure to verify the return value.
2374 procedure Make_Exit_Label;
2375 -- Build declaration for exit label to be used in Return statements,
2376 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2377 -- declaration). Does nothing if Exit_Lab already set.
2379 function Process_Formals (N : Node_Id) return Traverse_Result;
2380 -- Replace occurrence of a formal with the corresponding actual, or the
2381 -- thunk generated for it. Replace a return statement with an assignment
2382 -- to the target of the call, with appropriate conversions if needed.
2384 function Process_Sloc (Nod : Node_Id) return Traverse_Result;
2385 -- If the call being expanded is that of an internal subprogram, set the
2386 -- sloc of the generated block to that of the call itself, so that the
2387 -- expansion is skipped by the "next" command in gdb. Same processing
2388 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2389 -- Debug_Generated_Code is true, suppress this change to simplify our
2390 -- own development. Same in GNATprove mode, to ensure that warnings and
2391 -- diagnostics point to the proper location.
2393 procedure Reset_Dispatching_Calls (N : Node_Id);
2394 -- In subtree N search for occurrences of dispatching calls that use the
2395 -- Ada 2005 Object.Operation notation and the object is a formal of the
2396 -- inlined subprogram. Reset the entity associated with Operation in all
2397 -- the found occurrences.
2399 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
2400 -- If the function body is a single expression, replace call with
2401 -- expression, else insert block appropriately.
2403 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
2404 -- If procedure body has no local variables, inline body without
2405 -- creating block, otherwise rewrite call with block.
2407 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
2408 -- Determine whether a formal parameter is used only once in Orig_Bod
2410 -----------------------------------
2411 -- Declare_Postconditions_Result --
2412 -----------------------------------
2414 procedure Declare_Postconditions_Result is
2415 Enclosing_Subp : constant Entity_Id := Scope (Subp);
2420 and then Is_Subprogram (Enclosing_Subp)
2421 and then Present (Postconditions_Proc (Enclosing_Subp)));
2423 if Ekind (Enclosing_Subp) = E_Function then
2424 if Nkind (First (Parameter_Associations (N))) in
2425 N_Numeric_Or_String_Literal
2427 Append_To (Declarations (Blk),
2428 Make_Object_Declaration (Loc,
2429 Defining_Identifier =>
2430 Make_Defining_Identifier (Loc, Name_uResult),
2431 Constant_Present => True,
2432 Object_Definition =>
2433 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2435 New_Copy_Tree (First (Parameter_Associations (N)))));
2437 Append_To (Declarations (Blk),
2438 Make_Object_Renaming_Declaration (Loc,
2439 Defining_Identifier =>
2440 Make_Defining_Identifier (Loc, Name_uResult),
2442 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2444 New_Copy_Tree (First (Parameter_Associations (N)))));
2447 end Declare_Postconditions_Result;
2449 ---------------------
2450 -- Make_Exit_Label --
2451 ---------------------
2453 procedure Make_Exit_Label is
2454 Lab_Ent : Entity_Id;
2456 if No (Exit_Lab) then
2457 Lab_Ent := Make_Temporary (Loc, 'L');
2458 Lab_Id := New_Occurrence_Of (Lab_Ent, Loc);
2459 Exit_Lab := Make_Label (Loc, Lab_Id);
2461 Make_Implicit_Label_Declaration (Loc,
2462 Defining_Identifier => Lab_Ent,
2463 Label_Construct => Exit_Lab);
2465 end Make_Exit_Label;
2467 ---------------------
2468 -- Process_Formals --
2469 ---------------------
2471 function Process_Formals (N : Node_Id) return Traverse_Result is
2477 if Is_Entity_Name (N) and then Present (Entity (N)) then
2480 if Is_Formal (E) and then Scope (E) = Subp then
2481 A := Renamed_Object (E);
2483 -- Rewrite the occurrence of the formal into an occurrence of
2484 -- the actual. Also establish visibility on the proper view of
2485 -- the actual's subtype for the body's context (if the actual's
2486 -- subtype is private at the call point but its full view is
2487 -- visible to the body, then the inlined tree here must be
2488 -- analyzed with the full view).
2490 if Is_Entity_Name (A) then
2491 Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N)));
2492 Check_Private_View (N);
2494 elsif Nkind (A) = N_Defining_Identifier then
2495 Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
2496 Check_Private_View (N);
2501 Rewrite (N, New_Copy (A));
2507 elsif Is_Entity_Name (N)
2508 and then Present (Return_Object)
2509 and then Chars (N) = Chars (Return_Object)
2511 -- Occurrence within an extended return statement. The return
2512 -- object is local to the body been inlined, and thus the generic
2513 -- copy is not analyzed yet, so we match by name, and replace it
2514 -- with target of call.
2516 if Nkind (Targ) = N_Defining_Identifier then
2517 Rewrite (N, New_Occurrence_Of (Targ, Loc));
2519 Rewrite (N, New_Copy_Tree (Targ));
2524 elsif Nkind (N) = N_Simple_Return_Statement then
2525 if No (Expression (N)) then
2526 Num_Ret := Num_Ret + 1;
2529 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2532 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
2533 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
2535 -- Function body is a single expression. No need for
2541 Num_Ret := Num_Ret + 1;
2545 -- Because of the presence of private types, the views of the
2546 -- expression and the context may be different, so place
2547 -- a type conversion to the context type to avoid spurious
2548 -- errors, e.g. when the expression is a numeric literal and
2549 -- the context is private. If the expression is an aggregate,
2550 -- use a qualified expression, because an aggregate is not a
2551 -- legal argument of a conversion. Ditto for numeric, character
2552 -- and string literals, and attributes that yield a universal
2553 -- type, because those must be resolved to a specific type.
2555 if Nkind_In (Expression (N), N_Aggregate,
2556 N_Character_Literal,
2559 or else Yields_Universal_Type (Expression (N))
2562 Make_Qualified_Expression (Sloc (N),
2563 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2564 Expression => Relocate_Node (Expression (N)));
2566 -- Use an unchecked type conversion between access types, for
2567 -- which a type conversion would not always be valid, as no
2568 -- check may result from the conversion.
2570 elsif Is_Access_Type (Ret_Type) then
2572 Unchecked_Convert_To
2573 (Ret_Type, Relocate_Node (Expression (N)));
2575 -- Otherwise use a type conversion, which may trigger a check
2579 Make_Type_Conversion (Sloc (N),
2580 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2581 Expression => Relocate_Node (Expression (N)));
2584 if Nkind (Targ) = N_Defining_Identifier then
2586 Make_Assignment_Statement (Loc,
2587 Name => New_Occurrence_Of (Targ, Loc),
2588 Expression => Ret));
2591 Make_Assignment_Statement (Loc,
2592 Name => New_Copy (Targ),
2593 Expression => Ret));
2596 Set_Assignment_OK (Name (N));
2598 if Present (Exit_Lab) then
2600 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2606 -- An extended return becomes a block whose first statement is the
2607 -- assignment of the initial expression of the return object to the
2608 -- target of the call itself.
2610 elsif Nkind (N) = N_Extended_Return_Statement then
2612 Return_Decl : constant Entity_Id :=
2613 First (Return_Object_Declarations (N));
2617 Return_Object := Defining_Identifier (Return_Decl);
2619 if Present (Expression (Return_Decl)) then
2620 if Nkind (Targ) = N_Defining_Identifier then
2622 Make_Assignment_Statement (Loc,
2623 Name => New_Occurrence_Of (Targ, Loc),
2624 Expression => Expression (Return_Decl));
2627 Make_Assignment_Statement (Loc,
2628 Name => New_Copy (Targ),
2629 Expression => Expression (Return_Decl));
2632 Set_Assignment_OK (Name (Assign));
2634 if No (Handled_Statement_Sequence (N)) then
2635 Set_Handled_Statement_Sequence (N,
2636 Make_Handled_Sequence_Of_Statements (Loc,
2637 Statements => New_List));
2641 Statements (Handled_Statement_Sequence (N)));
2645 Make_Block_Statement (Loc,
2646 Handled_Statement_Sequence =>
2647 Handled_Statement_Sequence (N)));
2652 -- Remove pragma Unreferenced since it may refer to formals that
2653 -- are not visible in the inlined body, and in any case we will
2654 -- not be posting warnings on the inlined body so it is unneeded.
2656 elsif Nkind (N) = N_Pragma
2657 and then Pragma_Name (N) = Name_Unreferenced
2659 Rewrite (N, Make_Null_Statement (Sloc (N)));
2665 end Process_Formals;
2667 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
2673 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
2675 if not Debug_Generated_Code then
2676 Set_Sloc (Nod, Sloc (N));
2677 Set_Comes_From_Source (Nod, False);
2683 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
2685 ------------------------------
2686 -- Reset_Dispatching_Calls --
2687 ------------------------------
2689 procedure Reset_Dispatching_Calls (N : Node_Id) is
2691 function Do_Reset (N : Node_Id) return Traverse_Result;
2692 -- Comment required ???
2698 function Do_Reset (N : Node_Id) return Traverse_Result is
2700 if Nkind (N) = N_Procedure_Call_Statement
2701 and then Nkind (Name (N)) = N_Selected_Component
2702 and then Nkind (Prefix (Name (N))) = N_Identifier
2703 and then Is_Formal (Entity (Prefix (Name (N))))
2704 and then Is_Dispatching_Operation
2705 (Entity (Selector_Name (Name (N))))
2707 Set_Entity (Selector_Name (Name (N)), Empty);
2713 function Do_Reset_Calls is new Traverse_Func (Do_Reset);
2717 Dummy : constant Traverse_Result := Do_Reset_Calls (N);
2718 pragma Unreferenced (Dummy);
2720 -- Start of processing for Reset_Dispatching_Calls
2724 end Reset_Dispatching_Calls;
2726 ---------------------------
2727 -- Rewrite_Function_Call --
2728 ---------------------------
2730 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
2731 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2732 Fst : constant Node_Id := First (Statements (HSS));
2735 -- Optimize simple case: function body is a single return statement,
2736 -- which has been expanded into an assignment.
2738 if Is_Empty_List (Declarations (Blk))
2739 and then Nkind (Fst) = N_Assignment_Statement
2740 and then No (Next (Fst))
2742 -- The function call may have been rewritten as the temporary
2743 -- that holds the result of the call, in which case remove the
2744 -- now useless declaration.
2746 if Nkind (N) = N_Identifier
2747 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2749 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
2752 Rewrite (N, Expression (Fst));
2754 elsif Nkind (N) = N_Identifier
2755 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2757 -- The block assigns the result of the call to the temporary
2759 Insert_After (Parent (Entity (N)), Blk);
2761 -- If the context is an assignment, and the left-hand side is free of
2762 -- side-effects, the replacement is also safe.
2763 -- Can this be generalized further???
2765 elsif Nkind (Parent (N)) = N_Assignment_Statement
2767 (Is_Entity_Name (Name (Parent (N)))
2769 (Nkind (Name (Parent (N))) = N_Explicit_Dereference
2770 and then Is_Entity_Name (Prefix (Name (Parent (N)))))
2773 (Nkind (Name (Parent (N))) = N_Selected_Component
2774 and then Is_Entity_Name (Prefix (Name (Parent (N))))))
2776 -- Replace assignment with the block
2779 Original_Assignment : constant Node_Id := Parent (N);
2782 -- Preserve the original assignment node to keep the complete
2783 -- assignment subtree consistent enough for Analyze_Assignment
2784 -- to proceed (specifically, the original Lhs node must still
2785 -- have an assignment statement as its parent).
2787 -- We cannot rely on Original_Node to go back from the block
2788 -- node to the assignment node, because the assignment might
2789 -- already be a rewrite substitution.
2791 Discard_Node (Relocate_Node (Original_Assignment));
2792 Rewrite (Original_Assignment, Blk);
2795 elsif Nkind (Parent (N)) = N_Object_Declaration then
2797 -- A call to a function which returns an unconstrained type
2798 -- found in the expression initializing an object-declaration is
2799 -- expanded into a procedure call which must be added after the
2800 -- object declaration.
2802 if Is_Unc_Decl and Back_End_Inlining then
2803 Insert_Action_After (Parent (N), Blk);
2805 Set_Expression (Parent (N), Empty);
2806 Insert_After (Parent (N), Blk);
2809 elsif Is_Unc and then not Back_End_Inlining then
2810 Insert_Before (Parent (N), Blk);
2812 end Rewrite_Function_Call;
2814 ----------------------------
2815 -- Rewrite_Procedure_Call --
2816 ----------------------------
2818 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
2819 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2822 -- If there is a transient scope for N, this will be the scope of the
2823 -- actions for N, and the statements in Blk need to be within this
2824 -- scope. For example, they need to have visibility on the constant
2825 -- declarations created for the formals.
2827 -- If N needs no transient scope, and if there are no declarations in
2828 -- the inlined body, we can do a little optimization and insert the
2829 -- statements for the body directly after N, and rewrite N to a
2830 -- null statement, instead of rewriting N into a full-blown block
2833 if not Scope_Is_Transient
2834 and then Is_Empty_List (Declarations (Blk))
2836 Insert_List_After (N, Statements (HSS));
2837 Rewrite (N, Make_Null_Statement (Loc));
2841 end Rewrite_Procedure_Call;
2843 -------------------------
2844 -- Formal_Is_Used_Once --
2845 -------------------------
2847 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
2848 Use_Counter : Int := 0;
2850 function Count_Uses (N : Node_Id) return Traverse_Result;
2851 -- Traverse the tree and count the uses of the formal parameter.
2852 -- In this case, for optimization purposes, we do not need to
2853 -- continue the traversal once more than one use is encountered.
2859 function Count_Uses (N : Node_Id) return Traverse_Result is
2861 -- The original node is an identifier
2863 if Nkind (N) = N_Identifier
2864 and then Present (Entity (N))
2866 -- Original node's entity points to the one in the copied body
2868 and then Nkind (Entity (N)) = N_Identifier
2869 and then Present (Entity (Entity (N)))
2871 -- The entity of the copied node is the formal parameter
2873 and then Entity (Entity (N)) = Formal
2875 Use_Counter := Use_Counter + 1;
2877 if Use_Counter > 1 then
2879 -- Denote more than one use and abandon the traversal
2890 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
2892 -- Start of processing for Formal_Is_Used_Once
2895 Count_Formal_Uses (Orig_Bod);
2896 return Use_Counter = 1;
2897 end Formal_Is_Used_Once;
2899 -- Start of processing for Expand_Inlined_Call
2902 -- Initializations for old/new semantics
2904 if not Uses_Back_End then
2905 Is_Unc := Is_Array_Type (Etype (Subp))
2906 and then not Is_Constrained (Etype (Subp));
2907 Is_Unc_Decl := False;
2909 Is_Unc := Returns_Unconstrained_Type (Subp)
2910 and then Optimization_Level > 0;
2911 Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration
2915 -- Check for an illegal attempt to inline a recursive procedure. If the
2916 -- subprogram has parameters this is detected when trying to supply a
2917 -- binding for parameters that already have one. For parameterless
2918 -- subprograms this must be done explicitly.
2920 if In_Open_Scopes (Subp) then
2922 ("cannot inline call to recursive subprogram?", N, Subp);
2923 Set_Is_Inlined (Subp, False);
2926 -- Skip inlining if this is not a true inlining since the attribute
2927 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
2928 -- true inlining, Orig_Bod has code rather than being an entity.
2930 elsif Nkind (Orig_Bod) in N_Entity then
2934 if Nkind (Orig_Bod) = N_Defining_Identifier
2935 or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
2937 -- Subprogram is renaming_as_body. Calls occurring after the renaming
2938 -- can be replaced with calls to the renamed entity directly, because
2939 -- the subprograms are subtype conformant. If the renamed subprogram
2940 -- is an inherited operation, we must redo the expansion because
2941 -- implicit conversions may be needed. Similarly, if the renamed
2942 -- entity is inlined, expand the call for further optimizations.
2944 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
2946 if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then
2953 -- Register the call in the list of inlined calls
2955 Append_New_Elmt (N, To => Inlined_Calls);
2957 -- Use generic machinery to copy body of inlined subprogram, as if it
2958 -- were an instantiation, resetting source locations appropriately, so
2959 -- that nested inlined calls appear in the main unit.
2961 Save_Env (Subp, Empty);
2962 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
2966 if not Uses_Back_End then
2971 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
2973 Make_Block_Statement (Loc,
2974 Declarations => Declarations (Bod),
2975 Handled_Statement_Sequence =>
2976 Handled_Statement_Sequence (Bod));
2978 if No (Declarations (Bod)) then
2979 Set_Declarations (Blk, New_List);
2982 -- When generating C code, declare _Result, which may be used to
2983 -- verify the return value.
2985 if Modify_Tree_For_C
2986 and then Nkind (N) = N_Procedure_Call_Statement
2987 and then Chars (Name (N)) = Name_uPostconditions
2989 Declare_Postconditions_Result;
2992 -- For the unconstrained case, capture the name of the local
2993 -- variable that holds the result. This must be the first
2994 -- declaration in the block, because its bounds cannot depend
2995 -- on local variables. Otherwise there is no way to declare the
2996 -- result outside of the block. Needless to say, in general the
2997 -- bounds will depend on the actuals in the call.
2999 -- If the context is an assignment statement, as is the case
3000 -- for the expansion of an extended return, the left-hand side
3001 -- provides bounds even if the return type is unconstrained.
3005 First_Decl : Node_Id;
3008 First_Decl := First (Declarations (Blk));
3010 -- If the body is a single extended return statement,the
3011 -- resulting block is a nested block.
3013 if No (First_Decl) then
3015 First (Statements (Handled_Statement_Sequence (Blk)));
3017 if Nkind (First_Decl) = N_Block_Statement then
3018 First_Decl := First (Declarations (First_Decl));
3022 -- No front-end inlining possible
3024 if Nkind (First_Decl) /= N_Object_Declaration then
3028 if Nkind (Parent (N)) /= N_Assignment_Statement then
3029 Targ1 := Defining_Identifier (First_Decl);
3031 Targ1 := Name (Parent (N));
3048 Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3050 Make_Block_Statement (Loc,
3051 Declarations => Declarations (Bod),
3052 Handled_Statement_Sequence =>
3053 Handled_Statement_Sequence (Bod));
3055 -- Inline a call to a function that returns an unconstrained type.
3056 -- The semantic analyzer checked that frontend-inlined functions
3057 -- returning unconstrained types have no declarations and have
3058 -- a single extended return statement. As part of its processing
3059 -- the function was split into two subprograms: a procedure P' and
3060 -- a function F' that has a block with a call to procedure P' (see
3061 -- Split_Unconstrained_Function).
3067 (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
3071 Blk_Stmt : constant Node_Id :=
3072 First (Statements (Handled_Statement_Sequence (Orig_Bod)));
3073 First_Stmt : constant Node_Id :=
3074 First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
3075 Second_Stmt : constant Node_Id := Next (First_Stmt);
3079 (Nkind (First_Stmt) = N_Procedure_Call_Statement
3080 and then Nkind (Second_Stmt) = N_Simple_Return_Statement
3081 and then No (Next (Second_Stmt)));
3086 (Statements (Handled_Statement_Sequence (Orig_Bod))),
3087 Empty, Instantiating => True);
3090 -- Capture the name of the local variable that holds the
3091 -- result. This must be the first declaration in the block,
3092 -- because its bounds cannot depend on local variables.
3093 -- Otherwise there is no way to declare the result outside
3094 -- of the block. Needless to say, in general the bounds will
3095 -- depend on the actuals in the call.
3097 if Nkind (Parent (N)) /= N_Assignment_Statement then
3098 Targ1 := Defining_Identifier (First (Declarations (Blk)));
3100 -- If the context is an assignment statement, as is the case
3101 -- for the expansion of an extended return, the left-hand
3102 -- side provides bounds even if the return type is
3106 Targ1 := Name (Parent (N));
3111 if No (Declarations (Bod)) then
3112 Set_Declarations (Blk, New_List);
3117 -- If this is a derived function, establish the proper return type
3119 if Present (Orig_Subp) and then Orig_Subp /= Subp then
3120 Ret_Type := Etype (Orig_Subp);
3122 Ret_Type := Etype (Subp);
3125 -- Create temporaries for the actuals that are expressions, or that are
3126 -- scalars and require copying to preserve semantics.
3128 F := First_Formal (Subp);
3129 A := First_Actual (N);
3130 while Present (F) loop
3131 if Present (Renamed_Object (F)) then
3133 -- If expander is active, it is an error to try to inline a
3134 -- recursive program. In GNATprove mode, just indicate that the
3135 -- inlining will not happen, and mark the subprogram as not always
3138 if GNATprove_Mode then
3140 ("cannot inline call to recursive subprogram?", N, Subp);
3141 Set_Is_Inlined_Always (Subp, False);
3144 ("cannot inline call to recursive subprogram", N);
3150 -- Reset Last_Assignment for any parameters of mode out or in out, to
3151 -- prevent spurious warnings about overwriting for assignments to the
3152 -- formal in the inlined code.
3154 if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
3155 Set_Last_Assignment (Entity (A), Empty);
3158 -- If the argument may be a controlling argument in a call within
3159 -- the inlined body, we must preserve its classwide nature to insure
3160 -- that dynamic dispatching take place subsequently. If the formal
3161 -- has a constraint it must be preserved to retain the semantics of
3164 if Is_Class_Wide_Type (Etype (F))
3165 or else (Is_Access_Type (Etype (F))
3166 and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
3168 Temp_Typ := Etype (F);
3170 elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
3171 and then Etype (F) /= Base_Type (Etype (F))
3172 and then Is_Constrained (Etype (F))
3174 Temp_Typ := Etype (F);
3177 Temp_Typ := Etype (A);
3180 -- If the actual is a simple name or a literal, no need to
3181 -- create a temporary, object can be used directly.
3183 -- If the actual is a literal and the formal has its address taken,
3184 -- we cannot pass the literal itself as an argument, so its value
3185 -- must be captured in a temporary. Skip this optimization in
3186 -- GNATprove mode, to make sure any check on a type conversion
3189 if (Is_Entity_Name (A)
3191 (not Is_Scalar_Type (Etype (A))
3192 or else Ekind (Entity (A)) = E_Enumeration_Literal)
3193 and then not GNATprove_Mode)
3195 -- When the actual is an identifier and the corresponding formal is
3196 -- used only once in the original body, the formal can be substituted
3197 -- directly with the actual parameter. Skip this optimization in
3198 -- GNATprove mode, to make sure any check on a type conversion
3202 (Nkind (A) = N_Identifier
3203 and then Formal_Is_Used_Once (F)
3204 and then not GNATprove_Mode)
3207 (Nkind_In (A, N_Real_Literal,
3209 N_Character_Literal)
3210 and then not Address_Taken (F))
3212 if Etype (F) /= Etype (A) then
3214 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
3216 Set_Renamed_Object (F, A);
3220 Temp := Make_Temporary (Loc, 'C');
3222 -- If the actual for an in/in-out parameter is a view conversion,
3223 -- make it into an unchecked conversion, given that an untagged
3224 -- type conversion is not a proper object for a renaming.
3226 -- In-out conversions that involve real conversions have already
3227 -- been transformed in Expand_Actuals.
3229 if Nkind (A) = N_Type_Conversion
3230 and then Ekind (F) /= E_In_Parameter
3233 Make_Unchecked_Type_Conversion (Loc,
3234 Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
3235 Expression => Relocate_Node (Expression (A)));
3237 -- In GNATprove mode, keep the most precise type of the actual for
3238 -- the temporary variable, when the formal type is unconstrained.
3239 -- Otherwise, the AST may contain unexpected assignment statements
3240 -- to a temporary variable of unconstrained type renaming a local
3241 -- variable of constrained type, which is not expected by
3244 elsif Etype (F) /= Etype (A)
3245 and then (not GNATprove_Mode or else Is_Constrained (Etype (F)))
3247 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
3248 Temp_Typ := Etype (F);
3251 New_A := Relocate_Node (A);
3254 Set_Sloc (New_A, Sloc (N));
3256 -- If the actual has a by-reference type, it cannot be copied,
3257 -- so its value is captured in a renaming declaration. Otherwise
3258 -- declare a local constant initialized with the actual.
3260 -- We also use a renaming declaration for expressions of an array
3261 -- type that is not bit-packed, both for efficiency reasons and to
3262 -- respect the semantics of the call: in most cases the original
3263 -- call will pass the parameter by reference, and thus the inlined
3264 -- code will have the same semantics.
3266 -- Finally, we need a renaming declaration in the case of limited
3267 -- types for which initialization cannot be by copy either.
3269 if Ekind (F) = E_In_Parameter
3270 and then not Is_By_Reference_Type (Etype (A))
3271 and then not Is_Limited_Type (Etype (A))
3273 (not Is_Array_Type (Etype (A))
3274 or else not Is_Object_Reference (A)
3275 or else Is_Bit_Packed_Array (Etype (A)))
3278 Make_Object_Declaration (Loc,
3279 Defining_Identifier => Temp,
3280 Constant_Present => True,
3281 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3282 Expression => New_A);
3285 -- In GNATprove mode, make an explicit copy of input
3286 -- parameters when formal and actual types differ, to make
3287 -- sure any check on the type conversion will be issued.
3288 -- The legality of the copy is ensured by calling first
3289 -- Call_Can_Be_Inlined_In_GNATprove_Mode.
3292 and then Ekind (F) /= E_Out_Parameter
3293 and then not Same_Type (Etype (F), Etype (A))
3295 pragma Assert (not (Is_By_Reference_Type (Etype (A))));
3296 pragma Assert (not (Is_Limited_Type (Etype (A))));
3299 Make_Object_Declaration (Loc,
3300 Defining_Identifier => Make_Temporary (Loc, 'C'),
3301 Constant_Present => True,
3302 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3303 Expression => New_Copy_Tree (New_A)));
3307 Make_Object_Renaming_Declaration (Loc,
3308 Defining_Identifier => Temp,
3309 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
3313 Append (Decl, Decls);
3314 Set_Renamed_Object (F, Temp);
3321 -- Establish target of function call. If context is not assignment or
3322 -- declaration, create a temporary as a target. The declaration for the
3323 -- temporary may be subsequently optimized away if the body is a single
3324 -- expression, or if the left-hand side of the assignment is simple
3325 -- enough, i.e. an entity or an explicit dereference of one.
3327 if Ekind (Subp) = E_Function then
3328 if Nkind (Parent (N)) = N_Assignment_Statement
3329 and then Is_Entity_Name (Name (Parent (N)))
3331 Targ := Name (Parent (N));
3333 elsif Nkind (Parent (N)) = N_Assignment_Statement
3334 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
3335 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3337 Targ := Name (Parent (N));
3339 elsif Nkind (Parent (N)) = N_Assignment_Statement
3340 and then Nkind (Name (Parent (N))) = N_Selected_Component
3341 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3343 Targ := New_Copy_Tree (Name (Parent (N)));
3345 elsif Nkind (Parent (N)) = N_Object_Declaration
3346 and then Is_Limited_Type (Etype (Subp))
3348 Targ := Defining_Identifier (Parent (N));
3350 -- New semantics: In an object declaration avoid an extra copy
3351 -- of the result of a call to an inlined function that returns
3352 -- an unconstrained type
3355 and then Nkind (Parent (N)) = N_Object_Declaration
3358 Targ := Defining_Identifier (Parent (N));
3361 -- Replace call with temporary and create its declaration
3363 Temp := Make_Temporary (Loc, 'C');
3364 Set_Is_Internal (Temp);
3366 -- For the unconstrained case, the generated temporary has the
3367 -- same constrained declaration as the result variable. It may
3368 -- eventually be possible to remove that temporary and use the
3369 -- result variable directly.
3371 if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement
3374 Make_Object_Declaration (Loc,
3375 Defining_Identifier => Temp,
3376 Object_Definition =>
3377 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3379 Replace_Formals (Decl);
3383 Make_Object_Declaration (Loc,
3384 Defining_Identifier => Temp,
3385 Object_Definition => New_Occurrence_Of (Ret_Type, Loc));
3387 Set_Etype (Temp, Ret_Type);
3390 Set_No_Initialization (Decl);
3391 Append (Decl, Decls);
3392 Rewrite (N, New_Occurrence_Of (Temp, Loc));
3397 Insert_Actions (N, Decls);
3401 -- Special management for inlining a call to a function that returns
3402 -- an unconstrained type and initializes an object declaration: we
3403 -- avoid generating undesired extra calls and goto statements.
3406 -- function Func (...) return String is
3409 -- Result : String (1 .. 4);
3411 -- Proc (Result, ...);
3416 -- Result : String := Func (...);
3418 -- Replace this object declaration by:
3420 -- Result : String (1 .. 4);
3421 -- Proc (Result, ...);
3423 Remove_Homonym (Targ);
3426 Make_Object_Declaration
3428 Defining_Identifier => Targ,
3429 Object_Definition =>
3430 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3431 Replace_Formals (Decl);
3432 Rewrite (Parent (N), Decl);
3433 Analyze (Parent (N));
3435 -- Avoid spurious warnings since we know that this declaration is
3436 -- referenced by the procedure call.
3438 Set_Never_Set_In_Source (Targ, False);
3440 -- Remove the local declaration of the extended return stmt from the
3443 Remove (Parent (Targ1));
3445 -- Update the reference to the result (since we have rewriten the
3446 -- object declaration)
3449 Blk_Call_Stmt : Node_Id;
3452 -- Capture the call to the procedure
3455 First (Statements (Handled_Statement_Sequence (Blk)));
3457 (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement);
3459 Remove (First (Parameter_Associations (Blk_Call_Stmt)));
3460 Prepend_To (Parameter_Associations (Blk_Call_Stmt),
3461 New_Occurrence_Of (Targ, Loc));
3464 -- Remove the return statement
3467 (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3468 N_Simple_Return_Statement);
3470 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3473 -- Traverse the tree and replace formals with actuals or their thunks.
3474 -- Attach block to tree before analysis and rewriting.
3476 Replace_Formals (Blk);
3477 Set_Parent (Blk, N);
3479 if GNATprove_Mode then
3482 elsif not Comes_From_Source (Subp) or else Is_Predef then
3488 -- No action needed since return statement has been already removed
3492 elsif Present (Exit_Lab) then
3494 -- If there's a single return statement at the end of the subprogram,
3495 -- the corresponding goto statement and the corresponding label are
3500 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3503 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3505 Append (Lab_Decl, (Declarations (Blk)));
3506 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
3510 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3511 -- on conflicting private views that Gigi would ignore. If this is a
3512 -- predefined unit, analyze with checks off, as is done in the non-
3513 -- inlined run-time units.
3516 I_Flag : constant Boolean := In_Inlined_Body;
3519 In_Inlined_Body := True;
3523 Style : constant Boolean := Style_Check;
3526 Style_Check := False;
3528 -- Search for dispatching calls that use the Object.Operation
3529 -- notation using an Object that is a parameter of the inlined
3530 -- function. We reset the decoration of Operation to force
3531 -- the reanalysis of the inlined dispatching call because
3532 -- the actual object has been inlined.
3534 Reset_Dispatching_Calls (Blk);
3536 Analyze (Blk, Suppress => All_Checks);
3537 Style_Check := Style;
3544 In_Inlined_Body := I_Flag;
3547 if Ekind (Subp) = E_Procedure then
3548 Rewrite_Procedure_Call (N, Blk);
3551 Rewrite_Function_Call (N, Blk);
3556 -- For the unconstrained case, the replacement of the call has been
3557 -- made prior to the complete analysis of the generated declarations.
3558 -- Propagate the proper type now.
3561 if Nkind (N) = N_Identifier then
3562 Set_Etype (N, Etype (Entity (N)));
3564 Set_Etype (N, Etype (Targ1));
3571 -- Cleanup mapping between formals and actuals for other expansions
3573 F := First_Formal (Subp);
3574 while Present (F) loop
3575 Set_Renamed_Object (F, Empty);
3578 end Expand_Inlined_Call;
3580 --------------------------
3581 -- Get_Code_Unit_Entity --
3582 --------------------------
3584 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
3585 Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E));
3588 if Ekind (Unit) = E_Package_Body then
3589 Unit := Spec_Entity (Unit);
3593 end Get_Code_Unit_Entity;
3595 ------------------------------
3596 -- Has_Excluded_Declaration --
3597 ------------------------------
3599 function Has_Excluded_Declaration
3601 Decls : List_Id) return Boolean
3605 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
3606 -- Nested subprograms make a given body ineligible for inlining, but
3607 -- we make an exception for instantiations of unchecked conversion.
3608 -- The body has not been analyzed yet, so check the name, and verify
3609 -- that the visible entity with that name is the predefined unit.
3611 -----------------------------
3612 -- Is_Unchecked_Conversion --
3613 -----------------------------
3615 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
3616 Id : constant Node_Id := Name (D);
3620 if Nkind (Id) = N_Identifier
3621 and then Chars (Id) = Name_Unchecked_Conversion
3623 Conv := Current_Entity (Id);
3625 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
3626 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
3628 Conv := Current_Entity (Selector_Name (Id));
3633 return Present (Conv)
3634 and then Is_Predefined_Unit (Get_Source_Unit (Conv))
3635 and then Is_Intrinsic_Subprogram (Conv);
3636 end Is_Unchecked_Conversion;
3638 -- Start of processing for Has_Excluded_Declaration
3641 -- No action needed if the check is not needed
3643 if not Check_Inlining_Restrictions then
3648 while Present (D) loop
3650 -- First declarations universally excluded
3652 if Nkind (D) = N_Package_Declaration then
3654 ("cannot inline & (nested package declaration)?", D, Subp);
3657 elsif Nkind (D) = N_Package_Instantiation then
3659 ("cannot inline & (nested package instantiation)?", D, Subp);
3663 -- Then declarations excluded only for front-end inlining
3665 if Back_End_Inlining then
3668 elsif Nkind (D) = N_Task_Type_Declaration
3669 or else Nkind (D) = N_Single_Task_Declaration
3672 ("cannot inline & (nested task type declaration)?", D, Subp);
3675 elsif Nkind (D) = N_Protected_Type_Declaration
3676 or else Nkind (D) = N_Single_Protected_Declaration
3679 ("cannot inline & (nested protected type declaration)?",
3683 elsif Nkind (D) = N_Subprogram_Body then
3685 ("cannot inline & (nested subprogram)?", D, Subp);
3688 elsif Nkind (D) = N_Function_Instantiation
3689 and then not Is_Unchecked_Conversion (D)
3692 ("cannot inline & (nested function instantiation)?", D, Subp);
3695 elsif Nkind (D) = N_Procedure_Instantiation then
3697 ("cannot inline & (nested procedure instantiation)?", D, Subp);
3700 -- Subtype declarations with predicates will generate predicate
3701 -- functions, i.e. nested subprogram bodies, so inlining is not
3704 elsif Nkind (D) = N_Subtype_Declaration
3705 and then Present (Aspect_Specifications (D))
3712 A := First (Aspect_Specifications (D));
3713 while Present (A) loop
3714 A_Id := Get_Aspect_Id (Chars (Identifier (A)));
3716 if A_Id = Aspect_Predicate
3717 or else A_Id = Aspect_Static_Predicate
3718 or else A_Id = Aspect_Dynamic_Predicate
3721 ("cannot inline & (subtype declaration with "
3722 & "predicate)?", D, Subp);
3735 end Has_Excluded_Declaration;
3737 ----------------------------
3738 -- Has_Excluded_Statement --
3739 ----------------------------
3741 function Has_Excluded_Statement
3743 Stats : List_Id) return Boolean
3749 -- No action needed if the check is not needed
3751 if not Check_Inlining_Restrictions then
3756 while Present (S) loop
3757 if Nkind_In (S, N_Abort_Statement,
3758 N_Asynchronous_Select,
3759 N_Conditional_Entry_Call,
3760 N_Delay_Relative_Statement,
3761 N_Delay_Until_Statement,
3766 ("cannot inline & (non-allowed statement)?", S, Subp);
3769 elsif Nkind (S) = N_Block_Statement then
3770 if Present (Declarations (S))
3771 and then Has_Excluded_Declaration (Subp, Declarations (S))
3775 elsif Present (Handled_Statement_Sequence (S)) then
3776 if not Back_End_Inlining
3779 (Exception_Handlers (Handled_Statement_Sequence (S)))
3782 ("cannot inline& (exception handler)?",
3783 First (Exception_Handlers
3784 (Handled_Statement_Sequence (S))),
3788 elsif Has_Excluded_Statement
3789 (Subp, Statements (Handled_Statement_Sequence (S)))
3795 elsif Nkind (S) = N_Case_Statement then
3796 E := First (Alternatives (S));
3797 while Present (E) loop
3798 if Has_Excluded_Statement (Subp, Statements (E)) then
3805 elsif Nkind (S) = N_If_Statement then
3806 if Has_Excluded_Statement (Subp, Then_Statements (S)) then
3810 if Present (Elsif_Parts (S)) then
3811 E := First (Elsif_Parts (S));
3812 while Present (E) loop
3813 if Has_Excluded_Statement (Subp, Then_Statements (E)) then
3821 if Present (Else_Statements (S))
3822 and then Has_Excluded_Statement (Subp, Else_Statements (S))
3827 elsif Nkind (S) = N_Loop_Statement
3828 and then Has_Excluded_Statement (Subp, Statements (S))
3832 elsif Nkind (S) = N_Extended_Return_Statement then
3833 if Present (Handled_Statement_Sequence (S))
3835 Has_Excluded_Statement
3836 (Subp, Statements (Handled_Statement_Sequence (S)))
3840 elsif not Back_End_Inlining
3841 and then Present (Handled_Statement_Sequence (S))
3843 Present (Exception_Handlers
3844 (Handled_Statement_Sequence (S)))
3847 ("cannot inline& (exception handler)?",
3848 First (Exception_Handlers (Handled_Statement_Sequence (S))),
3858 end Has_Excluded_Statement;
3860 --------------------------
3861 -- Has_Initialized_Type --
3862 --------------------------
3864 function Has_Initialized_Type (E : Entity_Id) return Boolean is
3865 E_Body : constant Node_Id := Subprogram_Body (E);
3869 if No (E_Body) then -- imported subprogram
3873 Decl := First (Declarations (E_Body));
3874 while Present (Decl) loop
3875 if Nkind (Decl) = N_Full_Type_Declaration
3876 and then Present (Init_Proc (Defining_Identifier (Decl)))
3886 end Has_Initialized_Type;
3888 -----------------------
3889 -- Has_Single_Return --
3890 -----------------------
3892 function Has_Single_Return (N : Node_Id) return Boolean is
3893 Return_Statement : Node_Id := Empty;
3895 function Check_Return (N : Node_Id) return Traverse_Result;
3901 function Check_Return (N : Node_Id) return Traverse_Result is
3903 if Nkind (N) = N_Simple_Return_Statement then
3904 if Present (Expression (N))
3905 and then Is_Entity_Name (Expression (N))
3907 if No (Return_Statement) then
3908 Return_Statement := N;
3911 elsif Chars (Expression (N)) =
3912 Chars (Expression (Return_Statement))
3920 -- A return statement within an extended return is a noop
3923 elsif No (Expression (N))
3925 Nkind (Parent (Parent (N))) = N_Extended_Return_Statement
3930 -- Expression has wrong form
3935 -- We can only inline a build-in-place function if it has a single
3938 elsif Nkind (N) = N_Extended_Return_Statement then
3939 if No (Return_Statement) then
3940 Return_Statement := N;
3952 function Check_All_Returns is new Traverse_Func (Check_Return);
3954 -- Start of processing for Has_Single_Return
3957 if Check_All_Returns (N) /= OK then
3960 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
3964 return Present (Declarations (N))
3965 and then Present (First (Declarations (N)))
3966 and then Chars (Expression (Return_Statement)) =
3967 Chars (Defining_Identifier (First (Declarations (N))));
3969 end Has_Single_Return;
3971 -----------------------------
3972 -- In_Main_Unit_Or_Subunit --
3973 -----------------------------
3975 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is
3976 Comp : Node_Id := Cunit (Get_Code_Unit (E));
3979 -- Check whether the subprogram or package to inline is within the main
3980 -- unit or its spec or within a subunit. In either case there are no
3981 -- additional bodies to process. If the subprogram appears in a parent
3982 -- of the current unit, the check on whether inlining is possible is
3983 -- done in Analyze_Inlined_Bodies.
3985 while Nkind (Unit (Comp)) = N_Subunit loop
3986 Comp := Library_Unit (Comp);
3989 return Comp = Cunit (Main_Unit)
3990 or else Comp = Library_Unit (Cunit (Main_Unit));
3991 end In_Main_Unit_Or_Subunit;
3997 procedure Initialize is
3999 Pending_Descriptor.Init;
4000 Pending_Instantiations.Init;
4001 Inlined_Bodies.Init;
4005 for J in Hash_Headers'Range loop
4006 Hash_Headers (J) := No_Subp;
4009 Inlined_Calls := No_Elist;
4010 Backend_Calls := No_Elist;
4011 Backend_Inlined_Subps := No_Elist;
4012 Backend_Not_Inlined_Subps := No_Elist;
4015 ------------------------
4016 -- Instantiate_Bodies --
4017 ------------------------
4019 -- Generic bodies contain all the non-local references, so an
4020 -- instantiation does not need any more context than Standard
4021 -- itself, even if the instantiation appears in an inner scope.
4022 -- Generic associations have verified that the contract model is
4023 -- satisfied, so that any error that may occur in the analysis of
4024 -- the body is an internal error.
4026 procedure Instantiate_Bodies is
4028 Info : Pending_Body_Info;
4031 if Serious_Errors_Detected = 0 then
4032 Expander_Active := (Operating_Mode = Opt.Generate_Code);
4033 Push_Scope (Standard_Standard);
4034 To_Clean := New_Elmt_List;
4036 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
4040 -- A body instantiation may generate additional instantiations, so
4041 -- the following loop must scan to the end of a possibly expanding
4042 -- set (that's why we can't simply use a FOR loop here).
4045 while J <= Pending_Instantiations.Last
4046 and then Serious_Errors_Detected = 0
4048 Info := Pending_Instantiations.Table (J);
4050 -- If the instantiation node is absent, it has been removed
4051 -- as part of unreachable code.
4053 if No (Info.Inst_Node) then
4056 elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
4057 Instantiate_Package_Body (Info);
4058 Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
4061 Instantiate_Subprogram_Body (Info);
4067 -- Reset the table of instantiations. Additional instantiations
4068 -- may be added through inlining, when additional bodies are
4071 Pending_Instantiations.Init;
4073 -- We can now complete the cleanup actions of scopes that contain
4074 -- pending instantiations (skipped for generic units, since we
4075 -- never need any cleanups in generic units).
4078 and then not Is_Generic_Unit (Main_Unit_Entity)
4081 elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
4087 end Instantiate_Bodies;
4093 function Is_Nested (E : Entity_Id) return Boolean is
4098 while Scop /= Standard_Standard loop
4099 if Ekind (Scop) in Subprogram_Kind then
4102 elsif Ekind (Scop) = E_Task_Type
4103 or else Ekind (Scop) = E_Entry
4104 or else Ekind (Scop) = E_Entry_Family
4109 Scop := Scope (Scop);
4115 ------------------------
4116 -- List_Inlining_Info --
4117 ------------------------
4119 procedure List_Inlining_Info is
4125 if not Debug_Flag_Dot_J then
4129 -- Generate listing of calls inlined by the frontend
4131 if Present (Inlined_Calls) then
4133 Elmt := First_Elmt (Inlined_Calls);
4134 while Present (Elmt) loop
4137 if In_Extended_Main_Code_Unit (Nod) then
4141 Write_Str ("List of calls inlined by the frontend");
4148 Write_Location (Sloc (Nod));
4157 -- Generate listing of calls passed to the backend
4159 if Present (Backend_Calls) then
4162 Elmt := First_Elmt (Backend_Calls);
4163 while Present (Elmt) loop
4166 if In_Extended_Main_Code_Unit (Nod) then
4170 Write_Str ("List of inlined calls passed to the backend");
4177 Write_Location (Sloc (Nod));
4185 -- Generate listing of subprograms passed to the backend
4187 if Present (Backend_Inlined_Subps) and then Back_End_Inlining then
4190 Elmt := First_Elmt (Backend_Inlined_Subps);
4191 while Present (Elmt) loop
4198 ("List of inlined subprograms passed to the backend");
4205 Write_Name (Chars (Nod));
4207 Write_Location (Sloc (Nod));
4215 -- Generate listing of subprograms that cannot be inlined by the backend
4217 if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining then
4220 Elmt := First_Elmt (Backend_Not_Inlined_Subps);
4221 while Present (Elmt) loop
4228 ("List of subprograms that cannot be inlined by the backend");
4235 Write_Name (Chars (Nod));
4237 Write_Location (Sloc (Nod));
4244 end List_Inlining_Info;
4252 Pending_Instantiations.Release;
4253 Pending_Instantiations.Locked := True;
4254 Inlined_Bodies.Release;
4255 Inlined_Bodies.Locked := True;
4257 Successors.Locked := True;
4259 Inlined.Locked := True;
4262 --------------------------------
4263 -- Remove_Aspects_And_Pragmas --
4264 --------------------------------
4266 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id) is
4267 procedure Remove_Items (List : List_Id);
4268 -- Remove all useless aspects/pragmas from a particular list
4274 procedure Remove_Items (List : List_Id) is
4277 Next_Item : Node_Id;
4280 -- Traverse the list looking for an aspect specification or a pragma
4282 Item := First (List);
4283 while Present (Item) loop
4284 Next_Item := Next (Item);
4286 if Nkind (Item) = N_Aspect_Specification then
4287 Item_Id := Identifier (Item);
4288 elsif Nkind (Item) = N_Pragma then
4289 Item_Id := Pragma_Identifier (Item);
4294 if Present (Item_Id)
4295 and then Nam_In (Chars (Item_Id), Name_Contract_Cases,
4300 Name_Refined_Global,
4301 Name_Refined_Depends,
4315 -- Start of processing for Remove_Aspects_And_Pragmas
4318 Remove_Items (Aspect_Specifications (Body_Decl));
4319 Remove_Items (Declarations (Body_Decl));
4321 -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear
4322 -- in the body of the subprogram.
4324 Remove_Items (Statements (Handled_Statement_Sequence (Body_Decl)));
4325 end Remove_Aspects_And_Pragmas;
4327 --------------------------
4328 -- Remove_Dead_Instance --
4329 --------------------------
4331 procedure Remove_Dead_Instance (N : Node_Id) is
4336 while J <= Pending_Instantiations.Last loop
4337 if Pending_Instantiations.Table (J).Inst_Node = N then
4338 Pending_Instantiations.Table (J).Inst_Node := Empty;
4344 end Remove_Dead_Instance;