1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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
201 -- a local variable that is the first declaration in the body of the
202 -- function. In that case the call can be replaced by that local
203 -- variable as is done 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.
490 -- Library-level functions must be handled specially, because there is
491 -- no enclosing package to retrieve. In this case, it is the body of
492 -- the function that will have to be loaded.
495 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
501 Inlined_Bodies.Increment_Last;
502 Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
505 pragma Assert (Ekind (Pack) = E_Package);
507 if Is_Generic_Instance (Pack) then
510 -- Do not inline the package if the subprogram is an init proc
511 -- or other internally generated subprogram, because in that
512 -- case the subprogram body appears in the same unit that
513 -- declares the type, and that body is visible to the back end.
514 -- Do not inline it either if it is in the main unit.
515 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
516 -- calls if the back-end takes care of inlining the call.
517 -- Note that Level in Inline_Package | Inline_Call here.
519 elsif ((Level = Inline_Call
520 and then Has_Pragma_Inline_Always (E)
521 and then Back_End_Inlining)
522 or else Level = Inline_Package)
523 and then not Is_Inlined (Pack)
524 and then not Is_Internal (E)
525 and then not In_Main_Unit_Or_Subunit (Pack)
527 Set_Is_Inlined (Pack);
528 Inlined_Bodies.Increment_Last;
529 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
533 -- Ensure that Analyze_Inlined_Bodies will be invoked after
534 -- completing the analysis of the current unit.
536 Inline_Processing_Required := True;
538 end Add_Inlined_Body;
540 ----------------------------
541 -- Add_Inlined_Subprogram --
542 ----------------------------
544 procedure Add_Inlined_Subprogram (E : Entity_Id) is
545 Decl : constant Node_Id := Parent (Declaration_Node (E));
546 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
548 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id);
549 -- Append Subp to the list of subprograms inlined by the backend
551 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id);
552 -- Append Subp to the list of subprograms that cannot be inlined by
555 -----------------------------------------
556 -- Register_Backend_Inlined_Subprogram --
557 -----------------------------------------
559 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is
561 Append_New_Elmt (Subp, To => Backend_Inlined_Subps);
562 end Register_Backend_Inlined_Subprogram;
564 ---------------------------------------------
565 -- Register_Backend_Not_Inlined_Subprogram --
566 ---------------------------------------------
568 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is
570 Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps);
571 end Register_Backend_Not_Inlined_Subprogram;
573 -- Start of processing for Add_Inlined_Subprogram
576 -- If the subprogram is to be inlined, and if its unit is known to be
577 -- inlined or is an instance whose body will be analyzed anyway or the
578 -- subprogram was generated as a body by the compiler (for example an
579 -- initialization procedure) or its declaration was provided along with
580 -- the body (for example an expression function), and if it is declared
581 -- at the library level not in the main unit, and if it can be inlined
582 -- by the back-end, then insert it in the list of inlined subprograms.
585 and then (Is_Inlined (Pack)
586 or else Is_Generic_Instance (Pack)
587 or else Nkind (Decl) = N_Subprogram_Body
588 or else Present (Corresponding_Body (Decl)))
589 and then not In_Main_Unit_Or_Subunit (E)
590 and then not Is_Nested (E)
591 and then not Has_Initialized_Type (E)
593 Register_Backend_Inlined_Subprogram (E);
595 if No (Last_Inlined) then
596 Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
598 Set_Next_Inlined_Subprogram (Last_Inlined, E);
604 Register_Backend_Not_Inlined_Subprogram (E);
606 end Add_Inlined_Subprogram;
608 --------------------------------
609 -- Add_Pending_Instantiation --
610 --------------------------------
612 procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is
614 -- Capture the body of the generic instantiation along with its context
615 -- for later processing by Instantiate_Bodies.
617 Pending_Instantiations.Append
618 ((Act_Decl => Act_Decl,
619 Config_Switches => Save_Config_Switches,
620 Current_Sem_Unit => Current_Sem_Unit,
621 Expander_Status => Expander_Active,
623 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
624 Scope_Suppress => Scope_Suppress,
625 Warnings => Save_Warnings));
626 end Add_Pending_Instantiation;
628 ------------------------
629 -- Add_Scope_To_Clean --
630 ------------------------
632 procedure Add_Scope_To_Clean (Inst : Entity_Id) is
633 Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
637 -- If the instance appears in a library-level package declaration,
638 -- all finalization is global, and nothing needs doing here.
640 if Scop = Standard_Standard then
644 -- If the instance is within a generic unit, no finalization code
645 -- can be generated. Note that at this point all bodies have been
646 -- analyzed, and the scope stack itself is not present, and the flag
647 -- Inside_A_Generic is not set.
654 while Present (S) and then S /= Standard_Standard loop
655 if Is_Generic_Unit (S) then
663 Elmt := First_Elmt (To_Clean);
664 while Present (Elmt) loop
665 if Node (Elmt) = Scop then
669 Elmt := Next_Elmt (Elmt);
672 Append_Elmt (Scop, To_Clean);
673 end Add_Scope_To_Clean;
679 function Add_Subp (E : Entity_Id) return Subp_Index is
680 Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
684 -- Initialize entry in Inlined table
686 procedure New_Entry is
688 Inlined.Increment_Last;
689 Inlined.Table (Inlined.Last).Name := E;
690 Inlined.Table (Inlined.Last).Next := No_Subp;
691 Inlined.Table (Inlined.Last).First_Succ := No_Succ;
692 Inlined.Table (Inlined.Last).Main_Call := False;
693 Inlined.Table (Inlined.Last).Processed := False;
696 -- Start of processing for Add_Subp
699 if Hash_Headers (Index) = No_Subp then
701 Hash_Headers (Index) := Inlined.Last;
705 J := Hash_Headers (Index);
706 while J /= No_Subp loop
707 if Inlined.Table (J).Name = E then
711 J := Inlined.Table (J).Next;
715 -- On exit, subprogram was not found. Enter in table. Index is
716 -- the current last entry on the hash chain.
719 Inlined.Table (Index).Next := Inlined.Last;
724 ----------------------------
725 -- Analyze_Inlined_Bodies --
726 ----------------------------
728 procedure Analyze_Inlined_Bodies is
735 type Pending_Index is new Nat;
737 package Pending_Inlined is new Table.Table (
738 Table_Component_Type => Subp_Index,
739 Table_Index_Type => Pending_Index,
740 Table_Low_Bound => 1,
741 Table_Initial => Alloc.Inlined_Initial,
742 Table_Increment => Alloc.Inlined_Increment,
743 Table_Name => "Pending_Inlined");
744 -- The workpile used to compute the transitive closure
746 -- Start of processing for Analyze_Inlined_Bodies
749 if Serious_Errors_Detected = 0 then
750 Push_Scope (Standard_Standard);
753 while J <= Inlined_Bodies.Last
754 and then Serious_Errors_Detected = 0
756 Pack := Inlined_Bodies.Table (J);
758 and then Scope (Pack) /= Standard_Standard
759 and then not Is_Child_Unit (Pack)
761 Pack := Scope (Pack);
764 Comp_Unit := Parent (Pack);
765 while Present (Comp_Unit)
766 and then Nkind (Comp_Unit) /= N_Compilation_Unit
768 Comp_Unit := Parent (Comp_Unit);
771 -- Load the body if it exists and contains inlineable entities,
772 -- unless it is the main unit, or is an instance whose body has
773 -- already been analyzed.
775 if Present (Comp_Unit)
776 and then Comp_Unit /= Cunit (Main_Unit)
777 and then Body_Required (Comp_Unit)
779 (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
781 (No (Corresponding_Body (Unit (Comp_Unit)))
782 and then Body_Needed_For_Inlining
783 (Defining_Entity (Unit (Comp_Unit)))))
786 Bname : constant Unit_Name_Type :=
787 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
792 if not Is_Loaded (Bname) then
793 Style_Check := False;
794 Load_Needed_Body (Comp_Unit, OK);
798 -- Warn that a body was not available for inlining
801 Error_Msg_Unit_1 := Bname;
803 ("one or more inlined subprograms accessed in $!??",
806 Get_File_Name (Bname, Subunit => False);
807 Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
815 if J > Inlined_Bodies.Last then
817 -- The analysis of required bodies may have produced additional
818 -- generic instantiations. To obtain further inlining, we need
819 -- to perform another round of generic body instantiations.
823 -- Symmetrically, the instantiation of required generic bodies
824 -- may have caused additional bodies to be inlined. To obtain
825 -- further inlining, we keep looping over the inlined bodies.
829 -- The list of inlined subprograms is an overestimate, because it
830 -- includes inlined functions called from functions that are compiled
831 -- as part of an inlined package, but are not themselves called. An
832 -- accurate computation of just those subprograms that are needed
833 -- requires that we perform a transitive closure over the call graph,
834 -- starting from calls in the main compilation unit.
836 for Index in Inlined.First .. Inlined.Last loop
837 if not Is_Called (Inlined.Table (Index).Name) then
839 -- This means that Add_Inlined_Body added the subprogram to the
840 -- table but wasn't able to handle its code unit. Do nothing.
842 Inlined.Table (Index).Processed := True;
844 elsif Inlined.Table (Index).Main_Call then
845 Pending_Inlined.Increment_Last;
846 Pending_Inlined.Table (Pending_Inlined.Last) := Index;
847 Inlined.Table (Index).Processed := True;
850 Set_Is_Called (Inlined.Table (Index).Name, False);
854 -- Iterate over the workpile until it is emptied, propagating the
855 -- Is_Called flag to the successors of the processed subprogram.
857 while Pending_Inlined.Last >= Pending_Inlined.First loop
858 Subp := Pending_Inlined.Table (Pending_Inlined.Last);
859 Pending_Inlined.Decrement_Last;
861 S := Inlined.Table (Subp).First_Succ;
863 while S /= No_Succ loop
864 Subp := Successors.Table (S).Subp;
866 if not Inlined.Table (Subp).Processed then
867 Set_Is_Called (Inlined.Table (Subp).Name);
868 Pending_Inlined.Increment_Last;
869 Pending_Inlined.Table (Pending_Inlined.Last) := Subp;
870 Inlined.Table (Subp).Processed := True;
873 S := Successors.Table (S).Next;
877 -- Finally add the called subprograms to the list of inlined
878 -- subprograms for the unit.
880 for Index in Inlined.First .. Inlined.Last loop
881 if Is_Called (Inlined.Table (Index).Name) then
882 Add_Inlined_Subprogram (Inlined.Table (Index).Name);
888 end Analyze_Inlined_Bodies;
890 --------------------------
891 -- Build_Body_To_Inline --
892 --------------------------
894 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
895 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
896 Analysis_Status : constant Boolean := Full_Analysis;
897 Original_Body : Node_Id;
898 Body_To_Analyze : Node_Id;
899 Max_Size : constant := 10;
901 function Has_Extended_Return return Boolean;
902 -- This function returns True if the subprogram has an extended return
905 function Has_Pending_Instantiation return Boolean;
906 -- If some enclosing body contains instantiations that appear before
907 -- the corresponding generic body, the enclosing body has a freeze node
908 -- so that it can be elaborated after the generic itself. This might
909 -- conflict with subsequent inlinings, so that it is unsafe to try to
910 -- inline in such a case.
912 function Has_Single_Return_In_GNATprove_Mode return Boolean;
913 -- This function is called only in GNATprove mode, and it returns
914 -- True if the subprogram has no return statement or a single return
915 -- statement as last statement. It returns False for subprogram with
916 -- a single return as last statement inside one or more blocks, as
917 -- inlining would generate gotos in that case as well (although the
918 -- goto is useless in that case).
920 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
921 -- If the body of the subprogram includes a call that returns an
922 -- unconstrained type, the secondary stack is involved, and it is
923 -- not worth inlining.
925 -------------------------
926 -- Has_Extended_Return --
927 -------------------------
929 function Has_Extended_Return return Boolean is
930 Body_To_Inline : constant Node_Id := N;
932 function Check_Return (N : Node_Id) return Traverse_Result;
933 -- Returns OK on node N if this is not an extended return statement
939 function Check_Return (N : Node_Id) return Traverse_Result is
942 when N_Extended_Return_Statement =>
945 -- Skip locally declared subprogram bodies inside the body to
946 -- inline, as the return statements inside those do not count.
948 when N_Subprogram_Body =>
949 if N = Body_To_Inline then
960 function Check_All_Returns is new Traverse_Func (Check_Return);
962 -- Start of processing for Has_Extended_Return
965 return Check_All_Returns (N) /= OK;
966 end Has_Extended_Return;
968 -------------------------------
969 -- Has_Pending_Instantiation --
970 -------------------------------
972 function Has_Pending_Instantiation return Boolean is
977 while Present (S) loop
978 if Is_Compilation_Unit (S)
979 or else Is_Child_Unit (S)
983 elsif Ekind (S) = E_Package
984 and then Has_Forward_Instantiation (S)
993 end Has_Pending_Instantiation;
995 -----------------------------------------
996 -- Has_Single_Return_In_GNATprove_Mode --
997 -----------------------------------------
999 function Has_Single_Return_In_GNATprove_Mode return Boolean is
1000 Body_To_Inline : constant Node_Id := N;
1001 Last_Statement : Node_Id := Empty;
1003 function Check_Return (N : Node_Id) return Traverse_Result;
1004 -- Returns OK on node N if this is not a return statement different
1005 -- from the last statement in the subprogram.
1011 function Check_Return (N : Node_Id) return Traverse_Result is
1014 when N_Extended_Return_Statement
1015 | N_Simple_Return_Statement
1017 if N = Last_Statement then
1023 -- Skip locally declared subprogram bodies inside the body to
1024 -- inline, as the return statements inside those do not count.
1026 when N_Subprogram_Body =>
1027 if N = Body_To_Inline then
1038 function Check_All_Returns is new Traverse_Func (Check_Return);
1040 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
1043 -- Retrieve the last statement
1045 Last_Statement := Last (Statements (Handled_Statement_Sequence (N)));
1047 -- Check that the last statement is the only possible return
1048 -- statement in the subprogram.
1050 return Check_All_Returns (N) = OK;
1051 end Has_Single_Return_In_GNATprove_Mode;
1053 --------------------------
1054 -- Uses_Secondary_Stack --
1055 --------------------------
1057 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
1058 function Check_Call (N : Node_Id) return Traverse_Result;
1059 -- Look for function calls that return an unconstrained type
1065 function Check_Call (N : Node_Id) return Traverse_Result is
1067 if Nkind (N) = N_Function_Call
1068 and then Is_Entity_Name (Name (N))
1069 and then Is_Composite_Type (Etype (Entity (Name (N))))
1070 and then not Is_Constrained (Etype (Entity (Name (N))))
1073 ("cannot inline & (call returns unconstrained type)?",
1081 function Check_Calls is new Traverse_Func (Check_Call);
1084 return Check_Calls (Bod) = Abandon;
1085 end Uses_Secondary_Stack;
1087 -- Start of processing for Build_Body_To_Inline
1090 -- Return immediately if done already
1092 if Nkind (Decl) = N_Subprogram_Declaration
1093 and then Present (Body_To_Inline (Decl))
1097 -- Subprograms that have return statements in the middle of the body are
1098 -- inlined with gotos. GNATprove does not currently support gotos, so
1099 -- we prevent such inlining.
1101 elsif GNATprove_Mode
1102 and then not Has_Single_Return_In_GNATprove_Mode
1104 Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
1107 -- Functions that return controlled types cannot currently be inlined
1108 -- because they require secondary stack handling; controlled actions
1109 -- may also interfere in complex ways with inlining.
1111 elsif Ekind (Spec_Id) = E_Function
1112 and then Needs_Finalization (Etype (Spec_Id))
1115 ("cannot inline & (controlled return type)?", N, Spec_Id);
1119 if Present (Declarations (N))
1120 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
1125 if Present (Handled_Statement_Sequence (N)) then
1126 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1128 ("cannot inline& (exception handler)?",
1129 First (Exception_Handlers (Handled_Statement_Sequence (N))),
1133 elsif Has_Excluded_Statement
1134 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
1140 -- We do not inline a subprogram that is too large, unless it is marked
1141 -- Inline_Always or we are in GNATprove mode. This pragma does not
1142 -- suppress the other checks on inlining (forbidden declarations,
1145 if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode)
1146 and then List_Length
1147 (Statements (Handled_Statement_Sequence (N))) > Max_Size
1149 Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id);
1153 if Has_Pending_Instantiation then
1155 ("cannot inline& (forward instance within enclosing body)?",
1160 -- Within an instance, the body to inline must be treated as a nested
1161 -- generic, so that the proper global references are preserved.
1163 -- Note that we do not do this at the library level, because it is not
1164 -- needed, and furthermore this causes trouble if front-end inlining
1165 -- is activated (-gnatN).
1167 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1168 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1169 Original_Body := Copy_Generic_Node (N, Empty, Instantiating => True);
1171 Original_Body := Copy_Separate_Tree (N);
1174 -- We need to capture references to the formals in order to substitute
1175 -- the actuals at the point of inlining, i.e. instantiation. To treat
1176 -- the formals as globals to the body to inline, we nest it within a
1177 -- dummy parameterless subprogram, declared within the real one. To
1178 -- avoid generating an internal name (which is never public, and which
1179 -- affects serial numbers of other generated names), we use an internal
1180 -- symbol that cannot conflict with user declarations.
1182 Set_Parameter_Specifications (Specification (Original_Body), No_List);
1183 Set_Defining_Unit_Name
1184 (Specification (Original_Body),
1185 Make_Defining_Identifier (Sloc (N), Name_uParent));
1186 Set_Corresponding_Spec (Original_Body, Empty);
1188 -- Remove all aspects/pragmas that have no meaning in an inlined body
1190 Remove_Aspects_And_Pragmas (Original_Body);
1193 Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
1195 -- Set return type of function, which is also global and does not need
1198 if Ekind (Spec_Id) = E_Function then
1199 Set_Result_Definition
1200 (Specification (Body_To_Analyze),
1201 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1204 if No (Declarations (N)) then
1205 Set_Declarations (N, New_List (Body_To_Analyze));
1207 Append (Body_To_Analyze, Declarations (N));
1210 -- The body to inline is preanalyzed. In GNATprove mode we must disable
1211 -- full analysis as well so that light expansion does not take place
1212 -- either, and name resolution is unaffected.
1214 Expander_Mode_Save_And_Set (False);
1215 Full_Analysis := False;
1217 Analyze (Body_To_Analyze);
1218 Push_Scope (Defining_Entity (Body_To_Analyze));
1219 Save_Global_References (Original_Body);
1221 Remove (Body_To_Analyze);
1223 Expander_Mode_Restore;
1224 Full_Analysis := Analysis_Status;
1226 -- Restore environment if previously saved
1228 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1232 -- Functions that return unconstrained composite types require
1233 -- secondary stack handling, and cannot currently be inlined, unless
1234 -- all return statements return a local variable that is the first
1235 -- local declaration in the body. We had to delay this check until
1236 -- the body of the function is analyzed since Has_Single_Return()
1237 -- requires a minimum decoration.
1239 if Ekind (Spec_Id) = E_Function
1240 and then not Is_Scalar_Type (Etype (Spec_Id))
1241 and then not Is_Access_Type (Etype (Spec_Id))
1242 and then not Is_Constrained (Etype (Spec_Id))
1244 if not Has_Single_Return (Body_To_Analyze)
1246 -- Skip inlining if the function returns an unconstrained type
1247 -- using an extended return statement, since this part of the
1248 -- new inlining model is not yet supported by the current
1249 -- implementation. ???
1251 or else (Returns_Unconstrained_Type (Spec_Id)
1252 and then Has_Extended_Return)
1255 ("cannot inline & (unconstrained return type)?", N, Spec_Id);
1259 -- If secondary stack is used, there is no point in inlining. We have
1260 -- already issued the warning in this case, so nothing to do.
1262 elsif Uses_Secondary_Stack (Body_To_Analyze) then
1266 Set_Body_To_Inline (Decl, Original_Body);
1267 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1268 Set_Is_Inlined (Spec_Id);
1269 end Build_Body_To_Inline;
1271 -------------------------------------------
1272 -- Call_Can_Be_Inlined_In_GNATprove_Mode --
1273 -------------------------------------------
1275 function Call_Can_Be_Inlined_In_GNATprove_Mode
1277 Subp : Entity_Id) return Boolean
1283 F := First_Formal (Subp);
1284 A := First_Actual (N);
1285 while Present (F) loop
1286 if Ekind (F) /= E_Out_Parameter
1287 and then not Same_Type (Etype (F), Etype (A))
1289 (Is_By_Reference_Type (Etype (A))
1290 or else Is_Limited_Type (Etype (A)))
1300 end Call_Can_Be_Inlined_In_GNATprove_Mode;
1302 --------------------------------------
1303 -- Can_Be_Inlined_In_GNATprove_Mode --
1304 --------------------------------------
1306 function Can_Be_Inlined_In_GNATprove_Mode
1307 (Spec_Id : Entity_Id;
1308 Body_Id : Entity_Id) return Boolean
1310 function Has_Formal_With_Discriminant_Dependent_Fields
1311 (Id : Entity_Id) return Boolean;
1312 -- Returns true if the subprogram has at least one formal parameter of
1313 -- an unconstrained record type with per-object constraints on component
1316 function Has_Some_Contract (Id : Entity_Id) return Boolean;
1317 -- Return True if subprogram Id has any contract. The presence of
1318 -- Extensions_Visible or Volatile_Function is also considered as a
1321 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
1322 -- Return True if subprogram Id defines a compilation unit
1323 -- Shouldn't this be in Sem_Aux???
1325 function In_Package_Spec (Id : Entity_Id) return Boolean;
1326 -- Return True if subprogram Id is defined in the package specification,
1327 -- either its visible or private part.
1329 ---------------------------------------------------
1330 -- Has_Formal_With_Discriminant_Dependent_Fields --
1331 ---------------------------------------------------
1333 function Has_Formal_With_Discriminant_Dependent_Fields
1334 (Id : Entity_Id) return Boolean
1336 function Has_Discriminant_Dependent_Component
1337 (Typ : Entity_Id) return Boolean;
1338 -- Determine whether unconstrained record type Typ has at least one
1339 -- component that depends on a discriminant.
1341 ------------------------------------------
1342 -- Has_Discriminant_Dependent_Component --
1343 ------------------------------------------
1345 function Has_Discriminant_Dependent_Component
1346 (Typ : Entity_Id) return Boolean
1351 -- Inspect all components of the record type looking for one that
1352 -- depends on a discriminant.
1354 Comp := First_Component (Typ);
1355 while Present (Comp) loop
1356 if Has_Discriminant_Dependent_Constraint (Comp) then
1360 Next_Component (Comp);
1364 end Has_Discriminant_Dependent_Component;
1368 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1370 Formal_Typ : Entity_Id;
1372 -- Start of processing for
1373 -- Has_Formal_With_Discriminant_Dependent_Fields
1376 -- Inspect all parameters of the subprogram looking for a formal
1377 -- of an unconstrained record type with at least one discriminant
1378 -- dependent component.
1380 Formal := First_Formal (Subp_Id);
1381 while Present (Formal) loop
1382 Formal_Typ := Etype (Formal);
1384 if Is_Record_Type (Formal_Typ)
1385 and then not Is_Constrained (Formal_Typ)
1386 and then Has_Discriminant_Dependent_Component (Formal_Typ)
1391 Next_Formal (Formal);
1395 end Has_Formal_With_Discriminant_Dependent_Fields;
1397 -----------------------
1398 -- Has_Some_Contract --
1399 -----------------------
1401 function Has_Some_Contract (Id : Entity_Id) return Boolean is
1405 -- A call to an expression function may precede the actual body which
1406 -- is inserted at the end of the enclosing declarations. Ensure that
1407 -- the related entity is decorated before inspecting the contract.
1409 if Is_Subprogram_Or_Generic_Subprogram (Id) then
1410 Items := Contract (Id);
1412 -- Note that Classifications is not Empty when Extensions_Visible
1413 -- or Volatile_Function is present, which causes such subprograms
1414 -- to be considered to have a contract here. This is fine as we
1415 -- want to avoid inlining these too.
1417 return Present (Items)
1418 and then (Present (Pre_Post_Conditions (Items)) or else
1419 Present (Contract_Test_Cases (Items)) or else
1420 Present (Classifications (Items)));
1424 end Has_Some_Contract;
1426 ---------------------
1427 -- In_Package_Spec --
1428 ---------------------
1430 function In_Package_Spec (Id : Entity_Id) return Boolean is
1431 P : constant Node_Id := Parent (Subprogram_Spec (Id));
1432 -- Parent of the subprogram's declaration
1435 return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
1436 end In_Package_Spec;
1438 ------------------------
1439 -- Is_Unit_Subprogram --
1440 ------------------------
1442 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1443 Decl : Node_Id := Parent (Parent (Id));
1445 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1446 Decl := Parent (Decl);
1449 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1450 end Is_Unit_Subprogram;
1452 -- Local declarations
1455 -- Procedure or function entity for the subprogram
1457 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1460 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1462 if Present (Spec_Id) then
1468 -- Only local subprograms without contracts are inlined in GNATprove
1469 -- mode, as these are the subprograms which a user is not interested in
1470 -- analyzing in isolation, but rather in the context of their call. This
1471 -- is a convenient convention, that could be changed for an explicit
1472 -- pragma/aspect one day.
1474 -- In a number of special cases, inlining is not desirable or not
1475 -- possible, see below.
1477 -- Do not inline unit-level subprograms
1479 if Is_Unit_Subprogram (Id) then
1482 -- Do not inline subprograms declared in package specs, because they are
1483 -- not local, i.e. can be called either from anywhere (if declared in
1484 -- visible part) or from the child units (if declared in private part).
1486 elsif In_Package_Spec (Id) then
1489 -- Do not inline subprograms declared in other units. This is important
1490 -- in particular for subprograms defined in the private part of a
1491 -- package spec, when analyzing one of its child packages, as otherwise
1492 -- we issue spurious messages about the impossibility to inline such
1495 elsif not In_Extended_Main_Code_Unit (Id) then
1498 -- Do not inline subprograms marked No_Return, possibly used for
1499 -- signaling errors, which GNATprove handles specially.
1501 elsif No_Return (Id) then
1504 -- Do not inline subprograms that have a contract on the spec or the
1505 -- body. Use the contract(s) instead in GNATprove. This also prevents
1506 -- inlining of subprograms with Extensions_Visible or Volatile_Function.
1508 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
1510 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
1514 -- Do not inline expression functions, which are directly inlined at the
1517 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
1519 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
1523 -- Do not inline generic subprogram instances. The visibility rules of
1524 -- generic instances plays badly with inlining.
1526 elsif Is_Generic_Instance (Spec_Id) then
1529 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1530 -- the subprogram body, a similar check is performed after the body
1531 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1533 elsif Present (Spec_Id)
1535 (No (SPARK_Pragma (Spec_Id))
1537 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
1541 -- Subprograms in generic instances are currently not inlined, to avoid
1542 -- problems with inlining of standard library subprograms.
1544 elsif Instantiation_Location (Sloc (Id)) /= No_Location then
1547 -- Do not inline subprograms and entries defined inside protected types,
1548 -- which typically are not helper subprograms, which also avoids getting
1549 -- spurious messages on calls that cannot be inlined.
1551 elsif Within_Protected_Type (Id) then
1554 -- Do not inline predicate functions (treated specially by GNATprove)
1556 elsif Is_Predicate_Function (Id) then
1559 -- Do not inline subprograms with a parameter of an unconstrained
1560 -- record type if it has discrimiant dependent fields. Indeed, with
1561 -- such parameters, the frontend cannot always ensure type compliance
1562 -- in record component accesses (in particular with records containing
1565 elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
1568 -- Otherwise, this is a subprogram declared inside the private part of a
1569 -- package, or inside a package body, or locally in a subprogram, and it
1570 -- does not have any contract. Inline it.
1575 end Can_Be_Inlined_In_GNATprove_Mode;
1581 procedure Cannot_Inline
1585 Is_Serious : Boolean := False)
1588 -- In GNATprove mode, inlining is the technical means by which the
1589 -- higher-level goal of contextual analysis is reached, so issue
1590 -- messages about failure to apply contextual analysis to a
1591 -- subprogram, rather than failure to inline it.
1594 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
1597 Len1 : constant Positive :=
1598 String (String'("cannot inline"))'Length;
1599 Len2 : constant Positive :=
1600 String (String'("info: no contextual analysis of"))'Length;
1602 New_Msg : String (1 .. Msg'Length + Len2 - Len1);
1605 New_Msg (1 .. Len2) := "info: no contextual analysis of";
1606 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
1607 Msg (Msg'First + Len1 .. Msg'Last);
1608 Cannot_Inline (New_Msg, N, Subp, Is_Serious);
1613 pragma Assert (Msg (Msg'Last) = '?');
1615 -- Legacy front-end inlining model
1617 if not Back_End_Inlining then
1619 -- Do not emit warning if this is a predefined unit which is not
1620 -- the main unit. With validity checks enabled, some predefined
1621 -- subprograms may contain nested subprograms and become ineligible
1624 if Is_Predefined_Unit (Get_Source_Unit (Subp))
1625 and then not In_Extended_Main_Source_Unit (Subp)
1629 -- In GNATprove mode, issue a warning when -gnatd_f is set, and
1630 -- indicate that the subprogram is not always inlined by setting
1631 -- flag Is_Inlined_Always to False.
1633 elsif GNATprove_Mode then
1634 Set_Is_Inlined_Always (Subp, False);
1636 if Debug_Flag_Underscore_F then
1637 Error_Msg_NE (Msg, N, Subp);
1640 elsif Has_Pragma_Inline_Always (Subp) then
1642 -- Remove last character (question mark) to make this into an
1643 -- error, because the Inline_Always pragma cannot be obeyed.
1645 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1647 elsif Ineffective_Inline_Warnings then
1648 Error_Msg_NE (Msg & "p?", N, Subp);
1651 -- New semantics relying on back-end inlining
1653 elsif Is_Serious then
1655 -- Remove last character (question mark) to make this into an error.
1657 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1659 -- In GNATprove mode, issue a warning when -gnatd_f is set, and
1660 -- indicate that the subprogram is not always inlined by setting
1661 -- flag Is_Inlined_Always to False.
1663 elsif GNATprove_Mode then
1664 Set_Is_Inlined_Always (Subp, False);
1666 if Debug_Flag_Underscore_F then
1667 Error_Msg_NE (Msg, N, Subp);
1672 -- Do not emit warning if this is a predefined unit which is not
1673 -- the main unit. This behavior is currently provided for backward
1674 -- compatibility but it will be removed when we enforce the
1675 -- strictness of the new rules.
1677 if Is_Predefined_Unit (Get_Source_Unit (Subp))
1678 and then not In_Extended_Main_Source_Unit (Subp)
1682 elsif Has_Pragma_Inline_Always (Subp) then
1684 -- Emit a warning if this is a call to a runtime subprogram
1685 -- which is located inside a generic. Previously this call
1686 -- was silently skipped.
1688 if Is_Generic_Instance (Subp) then
1690 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
1692 if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then
1693 Set_Is_Inlined (Subp, False);
1694 Error_Msg_NE (Msg & "p?", N, Subp);
1700 -- Remove last character (question mark) to make this into an
1701 -- error, because the Inline_Always pragma cannot be obeyed.
1703 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1706 Set_Is_Inlined (Subp, False);
1708 if Ineffective_Inline_Warnings then
1709 Error_Msg_NE (Msg & "p?", N, Subp);
1715 --------------------------------------------
1716 -- Check_And_Split_Unconstrained_Function --
1717 --------------------------------------------
1719 procedure Check_And_Split_Unconstrained_Function
1721 Spec_Id : Entity_Id;
1722 Body_Id : Entity_Id)
1724 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
1725 -- Use generic machinery to build an unexpanded body for the subprogram.
1726 -- This body is subsequently used for inline expansions at call sites.
1728 procedure Build_Return_Object_Formal
1732 -- Create a formal parameter for return object declaration Obj_Decl of
1733 -- an extended return statement and add it to list Formals.
1735 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
1736 -- Return true if we generate code for the function body N, the function
1737 -- body N has no local declarations and its unique statement is a single
1738 -- extended return statement with a handled statements sequence.
1740 procedure Copy_Formals
1742 Subp_Id : Entity_Id;
1744 -- Create new formal parameters from the formal parameters of subprogram
1745 -- Subp_Id and add them to list Formals.
1747 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id;
1748 -- Create a copy of return object declaration Obj_Decl of an extended
1749 -- return statement.
1751 procedure Split_Unconstrained_Function
1753 Spec_Id : Entity_Id);
1754 -- N is an inlined function body that returns an unconstrained type and
1755 -- has a single extended return statement. Split N in two subprograms:
1756 -- a procedure P' and a function F'. The formals of P' duplicate the
1757 -- formals of N plus an extra formal which is used to return a value;
1758 -- its body is composed by the declarations and list of statements
1759 -- of the extended return statement of N.
1761 --------------------------
1762 -- Build_Body_To_Inline --
1763 --------------------------
1765 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
1766 procedure Generate_Subprogram_Body
1768 Body_To_Inline : out Node_Id);
1769 -- Generate a parameterless duplicate of subprogram body N. Note that
1770 -- occurrences of pragmas referencing the formals are removed since
1771 -- they have no meaning when the body is inlined and the formals are
1772 -- rewritten (the analysis of the non-inlined body will handle these
1773 -- pragmas). A new internal name is associated with Body_To_Inline.
1775 ------------------------------
1776 -- Generate_Subprogram_Body --
1777 ------------------------------
1779 procedure Generate_Subprogram_Body
1781 Body_To_Inline : out Node_Id)
1784 -- Within an instance, the body to inline must be treated as a
1785 -- nested generic so that proper global references are preserved.
1787 -- Note that we do not do this at the library level, because it
1788 -- is not needed, and furthermore this causes trouble if front
1789 -- end inlining is activated (-gnatN).
1792 and then Scope (Current_Scope) /= Standard_Standard
1795 Copy_Generic_Node (N, Empty, Instantiating => True);
1797 -- ??? Shouldn't this use New_Copy_Tree? What about global
1798 -- references captured in the body to inline?
1800 Body_To_Inline := Copy_Separate_Tree (N);
1803 -- Remove aspects/pragmas that have no meaning in an inlined body
1805 Remove_Aspects_And_Pragmas (Body_To_Inline);
1807 -- We need to capture references to the formals in order
1808 -- to substitute the actuals at the point of inlining, i.e.
1809 -- instantiation. To treat the formals as globals to the body to
1810 -- inline, we nest it within a dummy parameterless subprogram,
1811 -- declared within the real one.
1813 Set_Parameter_Specifications
1814 (Specification (Body_To_Inline), No_List);
1816 -- A new internal name is associated with Body_To_Inline to avoid
1817 -- conflicts when the non-inlined body N is analyzed.
1819 Set_Defining_Unit_Name (Specification (Body_To_Inline),
1820 Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P')));
1821 Set_Corresponding_Spec (Body_To_Inline, Empty);
1822 end Generate_Subprogram_Body;
1826 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1827 Original_Body : Node_Id;
1828 Body_To_Analyze : Node_Id;
1831 pragma Assert (Current_Scope = Spec_Id);
1833 -- Within an instance, the body to inline must be treated as a nested
1834 -- generic, so that the proper global references are preserved. We
1835 -- do not do this at the library level, because it is not needed, and
1836 -- furthermore this causes trouble if front-end inlining is activated
1840 and then Scope (Current_Scope) /= Standard_Standard
1842 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1845 -- Capture references to formals in order to substitute the actuals
1846 -- at the point of inlining or instantiation. To treat the formals
1847 -- as globals to the body to inline, nest the body within a dummy
1848 -- parameterless subprogram, declared within the real one.
1850 Generate_Subprogram_Body (N, Original_Body);
1852 Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
1854 -- Set return type of function, which is also global and does not
1855 -- need to be resolved.
1857 if Ekind (Spec_Id) = E_Function then
1858 Set_Result_Definition (Specification (Body_To_Analyze),
1859 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1862 if No (Declarations (N)) then
1863 Set_Declarations (N, New_List (Body_To_Analyze));
1865 Append_To (Declarations (N), Body_To_Analyze);
1868 Preanalyze (Body_To_Analyze);
1870 Push_Scope (Defining_Entity (Body_To_Analyze));
1871 Save_Global_References (Original_Body);
1873 Remove (Body_To_Analyze);
1875 -- Restore environment if previously saved
1878 and then Scope (Current_Scope) /= Standard_Standard
1883 pragma Assert (No (Body_To_Inline (Decl)));
1884 Set_Body_To_Inline (Decl, Original_Body);
1885 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1886 end Build_Body_To_Inline;
1888 --------------------------------
1889 -- Build_Return_Object_Formal --
1890 --------------------------------
1892 procedure Build_Return_Object_Formal
1897 Obj_Def : constant Node_Id := Object_Definition (Obj_Decl);
1898 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
1902 -- Build the type definition of the formal parameter. The use of
1903 -- New_Copy_Tree ensures that global references preserved in the
1904 -- case of generics.
1906 if Is_Entity_Name (Obj_Def) then
1907 Typ_Def := New_Copy_Tree (Obj_Def);
1909 Typ_Def := New_Copy_Tree (Subtype_Mark (Obj_Def));
1914 -- Obj_Id : [out] Typ_Def
1916 -- Mode OUT should not be used when the return object is declared as
1917 -- a constant. Check the definition of the object declaration because
1918 -- the object has not been analyzed yet.
1921 Make_Parameter_Specification (Loc,
1922 Defining_Identifier =>
1923 Make_Defining_Identifier (Loc, Chars (Obj_Id)),
1924 In_Present => False,
1925 Out_Present => not Constant_Present (Obj_Decl),
1926 Null_Exclusion_Present => False,
1927 Parameter_Type => Typ_Def));
1928 end Build_Return_Object_Formal;
1930 --------------------------------------
1931 -- Can_Split_Unconstrained_Function --
1932 --------------------------------------
1934 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is
1935 Stmt : constant Node_Id :=
1936 First (Statements (Handled_Statement_Sequence (N)));
1940 -- No user defined declarations allowed in the function except inside
1941 -- the unique return statement; implicit labels are the only allowed
1944 Decl := First (Declarations (N));
1945 while Present (Decl) loop
1946 if Nkind (Decl) /= N_Implicit_Label_Declaration then
1953 -- We only split the inlined function when we are generating the code
1954 -- of its body; otherwise we leave duplicated split subprograms in
1955 -- the tree which (if referenced) generate wrong references at link
1958 return In_Extended_Main_Code_Unit (N)
1959 and then Present (Stmt)
1960 and then Nkind (Stmt) = N_Extended_Return_Statement
1961 and then No (Next (Stmt))
1962 and then Present (Handled_Statement_Sequence (Stmt));
1963 end Can_Split_Unconstrained_Function;
1969 procedure Copy_Formals
1971 Subp_Id : Entity_Id;
1978 Formal := First_Formal (Subp_Id);
1979 while Present (Formal) loop
1980 Spec := Parent (Formal);
1982 -- Create an exact copy of the formal parameter. The use of
1983 -- New_Copy_Tree ensures that global references are preserved
1984 -- in case of generics.
1987 Make_Parameter_Specification (Loc,
1988 Defining_Identifier =>
1989 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
1990 In_Present => In_Present (Spec),
1991 Out_Present => Out_Present (Spec),
1992 Null_Exclusion_Present => Null_Exclusion_Present (Spec),
1994 New_Copy_Tree (Parameter_Type (Spec)),
1995 Expression => New_Copy_Tree (Expression (Spec))));
1997 Next_Formal (Formal);
2001 ------------------------
2002 -- Copy_Return_Object --
2003 ------------------------
2005 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id is
2006 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2009 -- The use of New_Copy_Tree ensures that global references are
2010 -- preserved in case of generics.
2013 Make_Object_Declaration (Sloc (Obj_Decl),
2014 Defining_Identifier =>
2015 Make_Defining_Identifier (Sloc (Obj_Id), Chars (Obj_Id)),
2016 Aliased_Present => Aliased_Present (Obj_Decl),
2017 Constant_Present => Constant_Present (Obj_Decl),
2018 Null_Exclusion_Present => Null_Exclusion_Present (Obj_Decl),
2019 Object_Definition =>
2020 New_Copy_Tree (Object_Definition (Obj_Decl)),
2021 Expression => New_Copy_Tree (Expression (Obj_Decl)));
2022 end Copy_Return_Object;
2024 ----------------------------------
2025 -- Split_Unconstrained_Function --
2026 ----------------------------------
2028 procedure Split_Unconstrained_Function
2030 Spec_Id : Entity_Id)
2032 Loc : constant Source_Ptr := Sloc (N);
2033 Ret_Stmt : constant Node_Id :=
2034 First (Statements (Handled_Statement_Sequence (N)));
2035 Ret_Obj : constant Node_Id :=
2036 First (Return_Object_Declarations (Ret_Stmt));
2038 procedure Build_Procedure
2039 (Proc_Id : out Entity_Id;
2040 Decl_List : out List_Id);
2041 -- Build a procedure containing the statements found in the extended
2042 -- return statement of the unconstrained function body N.
2044 ---------------------
2045 -- Build_Procedure --
2046 ---------------------
2048 procedure Build_Procedure
2049 (Proc_Id : out Entity_Id;
2050 Decl_List : out List_Id)
2052 Formals : constant List_Id := New_List;
2053 Subp_Name : constant Name_Id := New_Internal_Name ('F');
2055 Body_Decls : List_Id := No_List;
2057 Proc_Body : Node_Id;
2058 Proc_Spec : Node_Id;
2061 -- Create formal parameters for the return object and all formals
2062 -- of the unconstrained function in order to pass their values to
2065 Build_Return_Object_Formal
2067 Obj_Decl => Ret_Obj,
2068 Formals => Formals);
2073 Formals => Formals);
2075 Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name);
2078 Make_Procedure_Specification (Loc,
2079 Defining_Unit_Name => Proc_Id,
2080 Parameter_Specifications => Formals);
2082 Decl_List := New_List;
2084 Append_To (Decl_List,
2085 Make_Subprogram_Declaration (Loc, Proc_Spec));
2087 -- Can_Convert_Unconstrained_Function checked that the function
2088 -- has no local declarations except implicit label declarations.
2089 -- Copy these declarations to the built procedure.
2091 if Present (Declarations (N)) then
2092 Body_Decls := New_List;
2094 Decl := First (Declarations (N));
2095 while Present (Decl) loop
2096 pragma Assert (Nkind (Decl) = N_Implicit_Label_Declaration);
2098 Append_To (Body_Decls,
2099 Make_Implicit_Label_Declaration (Loc,
2100 Make_Defining_Identifier (Loc,
2101 Chars => Chars (Defining_Identifier (Decl))),
2102 Label_Construct => Empty));
2108 pragma Assert (Present (Handled_Statement_Sequence (Ret_Stmt)));
2111 Make_Subprogram_Body (Loc,
2112 Specification => Copy_Subprogram_Spec (Proc_Spec),
2113 Declarations => Body_Decls,
2114 Handled_Statement_Sequence =>
2115 New_Copy_Tree (Handled_Statement_Sequence (Ret_Stmt)));
2117 Set_Defining_Unit_Name (Specification (Proc_Body),
2118 Make_Defining_Identifier (Loc, Subp_Name));
2120 Append_To (Decl_List, Proc_Body);
2121 end Build_Procedure;
2125 New_Obj : constant Node_Id := Copy_Return_Object (Ret_Obj);
2127 Proc_Call : Node_Id;
2128 Proc_Id : Entity_Id;
2130 -- Start of processing for Split_Unconstrained_Function
2133 -- Build the associated procedure, analyze it and insert it before
2134 -- the function body N.
2137 Scope : constant Entity_Id := Current_Scope;
2138 Decl_List : List_Id;
2141 Build_Procedure (Proc_Id, Decl_List);
2142 Insert_Actions (N, Decl_List);
2143 Set_Is_Inlined (Proc_Id);
2147 -- Build the call to the generated procedure
2150 Actual_List : constant List_Id := New_List;
2154 Append_To (Actual_List,
2155 New_Occurrence_Of (Defining_Identifier (New_Obj), Loc));
2157 Formal := First_Formal (Spec_Id);
2158 while Present (Formal) loop
2159 Append_To (Actual_List, New_Occurrence_Of (Formal, Loc));
2161 -- Avoid spurious warning on unreferenced formals
2163 Set_Referenced (Formal);
2164 Next_Formal (Formal);
2168 Make_Procedure_Call_Statement (Loc,
2169 Name => New_Occurrence_Of (Proc_Id, Loc),
2170 Parameter_Associations => Actual_List);
2178 -- Proc (New_Obj, ...);
2183 Make_Block_Statement (Loc,
2184 Declarations => New_List (New_Obj),
2185 Handled_Statement_Sequence =>
2186 Make_Handled_Sequence_Of_Statements (Loc,
2187 Statements => New_List (
2191 Make_Simple_Return_Statement (Loc,
2194 (Defining_Identifier (New_Obj), Loc)))));
2196 Rewrite (Ret_Stmt, Blk_Stmt);
2197 end Split_Unconstrained_Function;
2201 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2203 -- Start of processing for Check_And_Split_Unconstrained_Function
2206 pragma Assert (Back_End_Inlining
2207 and then Ekind (Spec_Id) = E_Function
2208 and then Returns_Unconstrained_Type (Spec_Id)
2209 and then Comes_From_Source (Body_Id)
2210 and then (Has_Pragma_Inline_Always (Spec_Id)
2211 or else Optimization_Level > 0));
2213 -- This routine must not be used in GNATprove mode since GNATprove
2214 -- relies on frontend inlining
2216 pragma Assert (not GNATprove_Mode);
2218 -- No need to split the function if we cannot generate the code
2220 if Serious_Errors_Detected /= 0 then
2224 -- No action needed in stubs since the attribute Body_To_Inline
2227 if Nkind (Decl) = N_Subprogram_Body_Stub then
2230 -- Cannot build the body to inline if the attribute is already set.
2231 -- This attribute may have been set if this is a subprogram renaming
2232 -- declarations (see Freeze.Build_Renamed_Body).
2234 elsif Present (Body_To_Inline (Decl)) then
2237 -- Check excluded declarations
2239 elsif Present (Declarations (N))
2240 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
2244 -- Check excluded statements. There is no need to protect us against
2245 -- exception handlers since they are supported by the GCC backend.
2247 elsif Present (Handled_Statement_Sequence (N))
2248 and then Has_Excluded_Statement
2249 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
2254 -- Build the body to inline only if really needed
2256 if Can_Split_Unconstrained_Function (N) then
2257 Split_Unconstrained_Function (N, Spec_Id);
2258 Build_Body_To_Inline (N, Spec_Id);
2259 Set_Is_Inlined (Spec_Id);
2261 end Check_And_Split_Unconstrained_Function;
2263 -------------------------------------
2264 -- Check_Package_Body_For_Inlining --
2265 -------------------------------------
2267 procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
2268 Bname : Unit_Name_Type;
2273 -- Legacy implementation (relying on frontend inlining)
2275 if not Back_End_Inlining
2276 and then Is_Compilation_Unit (P)
2277 and then not Is_Generic_Instance (P)
2279 Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
2281 E := First_Entity (P);
2282 while Present (E) loop
2283 if Has_Pragma_Inline_Always (E)
2284 or else (Has_Pragma_Inline (E) and Front_End_Inlining)
2286 if not Is_Loaded (Bname) then
2287 Load_Needed_Body (N, OK);
2291 -- Check we are not trying to inline a parent whose body
2292 -- depends on a child, when we are compiling the body of
2293 -- the child. Otherwise we have a potential elaboration
2294 -- circularity with inlined subprograms and with
2295 -- Taft-Amendment types.
2298 Comp : Node_Id; -- Body just compiled
2299 Child_Spec : Entity_Id; -- Spec of main unit
2300 Ent : Entity_Id; -- For iteration
2301 With_Clause : Node_Id; -- Context of body.
2304 if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
2305 and then Present (Body_Entity (P))
2309 ((Unit (Library_Unit (Cunit (Main_Unit)))));
2312 Parent (Unit_Declaration_Node (Body_Entity (P)));
2314 -- Check whether the context of the body just
2315 -- compiled includes a child of itself, and that
2316 -- child is the spec of the main compilation.
2318 With_Clause := First (Context_Items (Comp));
2319 while Present (With_Clause) loop
2320 if Nkind (With_Clause) = N_With_Clause
2322 Scope (Entity (Name (With_Clause))) = P
2324 Entity (Name (With_Clause)) = Child_Spec
2326 Error_Msg_Node_2 := Child_Spec;
2328 ("body of & depends on child unit&??",
2331 ("\subprograms in body cannot be inlined??",
2334 -- Disable further inlining from this unit,
2335 -- and keep Taft-amendment types incomplete.
2337 Ent := First_Entity (P);
2338 while Present (Ent) loop
2340 and then Has_Completion_In_Body (Ent)
2342 Set_Full_View (Ent, Empty);
2344 elsif Is_Subprogram (Ent) then
2345 Set_Is_Inlined (Ent, False);
2359 elsif Ineffective_Inline_Warnings then
2360 Error_Msg_Unit_1 := Bname;
2362 ("unable to inline subprograms defined in $??", P);
2363 Error_Msg_N ("\body not found??", P);
2374 end Check_Package_Body_For_Inlining;
2376 --------------------
2377 -- Cleanup_Scopes --
2378 --------------------
2380 procedure Cleanup_Scopes is
2386 Elmt := First_Elmt (To_Clean);
2387 while Present (Elmt) loop
2388 Scop := Node (Elmt);
2390 if Ekind (Scop) = E_Entry then
2391 Scop := Protected_Body_Subprogram (Scop);
2393 elsif Is_Subprogram (Scop)
2394 and then Is_Protected_Type (Scope (Scop))
2395 and then Present (Protected_Body_Subprogram (Scop))
2397 -- If a protected operation contains an instance, its cleanup
2398 -- operations have been delayed, and the subprogram has been
2399 -- rewritten in the expansion of the enclosing protected body. It
2400 -- is the corresponding subprogram that may require the cleanup
2401 -- operations, so propagate the information that triggers cleanup
2405 (Protected_Body_Subprogram (Scop),
2406 Uses_Sec_Stack (Scop));
2408 Scop := Protected_Body_Subprogram (Scop);
2411 if Ekind (Scop) = E_Block then
2412 Decl := Parent (Block_Node (Scop));
2415 Decl := Unit_Declaration_Node (Scop);
2417 if Nkind_In (Decl, N_Subprogram_Declaration,
2418 N_Task_Type_Declaration,
2419 N_Subprogram_Body_Stub)
2421 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
2426 Expand_Cleanup_Actions (Decl);
2429 Elmt := Next_Elmt (Elmt);
2433 -------------------------
2434 -- Expand_Inlined_Call --
2435 -------------------------
2437 procedure Expand_Inlined_Call
2440 Orig_Subp : Entity_Id)
2442 Decls : constant List_Id := New_List;
2443 Is_Predef : constant Boolean :=
2444 Is_Predefined_Unit (Get_Source_Unit (Subp));
2445 Loc : constant Source_Ptr := Sloc (N);
2446 Orig_Bod : constant Node_Id :=
2447 Body_To_Inline (Unit_Declaration_Node (Subp));
2449 Uses_Back_End : constant Boolean :=
2450 Back_End_Inlining and then Optimization_Level > 0;
2451 -- The back-end expansion is used if the target supports back-end
2452 -- inlining and some level of optimixation is required; otherwise
2453 -- the inlining takes place fully as a tree expansion.
2457 Exit_Lab : Entity_Id := Empty;
2460 Lab_Decl : Node_Id := Empty;
2464 Ret_Type : Entity_Id;
2466 Temp_Typ : Entity_Id;
2469 Is_Unc_Decl : Boolean;
2470 -- If the type returned by the function is unconstrained and the call
2471 -- can be inlined, special processing is required.
2473 Return_Object : Entity_Id := Empty;
2474 -- Entity in declaration in an extended_return_statement
2476 Targ : Node_Id := Empty;
2477 -- The target of the call. If context is an assignment statement then
2478 -- this is the left-hand side of the assignment, else it is a temporary
2479 -- to which the return value is assigned prior to rewriting the call.
2481 Targ1 : Node_Id := Empty;
2482 -- A separate target used when the return type is unconstrained
2484 procedure Declare_Postconditions_Result;
2485 -- When generating C code, declare _Result, which may be used in the
2486 -- inlined _Postconditions procedure to verify the return value.
2488 procedure Make_Exit_Label;
2489 -- Build declaration for exit label to be used in Return statements,
2490 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2491 -- declaration). Does nothing if Exit_Lab already set.
2493 procedure Make_Loop_Labels_Unique (HSS : Node_Id);
2494 -- When compiling for CCG and performing front-end inlining, replace
2495 -- loop names and references to them so that they do not conflict with
2496 -- homographs in the current subprogram.
2498 function Process_Formals (N : Node_Id) return Traverse_Result;
2499 -- Replace occurrence of a formal with the corresponding actual, or the
2500 -- thunk generated for it. Replace a return statement with an assignment
2501 -- to the target of the call, with appropriate conversions if needed.
2503 function Process_Formals_In_Aspects (N : Node_Id) return Traverse_Result;
2504 -- Because aspects are linked indirectly to the rest of the tree,
2505 -- replacement of formals appearing in aspect specifications must
2506 -- be performed in a separate pass, using an instantiation of the
2507 -- previous subprogram over aspect specifications reachable from N.
2509 function Process_Sloc (Nod : Node_Id) return Traverse_Result;
2510 -- If the call being expanded is that of an internal subprogram, set the
2511 -- sloc of the generated block to that of the call itself, so that the
2512 -- expansion is skipped by the "next" command in gdb. Same processing
2513 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2514 -- Debug_Generated_Code is true, suppress this change to simplify our
2515 -- own development. Same in GNATprove mode, to ensure that warnings and
2516 -- diagnostics point to the proper location.
2518 procedure Reset_Dispatching_Calls (N : Node_Id);
2519 -- In subtree N search for occurrences of dispatching calls that use the
2520 -- Ada 2005 Object.Operation notation and the object is a formal of the
2521 -- inlined subprogram. Reset the entity associated with Operation in all
2522 -- the found occurrences.
2524 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
2525 -- If the function body is a single expression, replace call with
2526 -- expression, else insert block appropriately.
2528 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
2529 -- If procedure body has no local variables, inline body without
2530 -- creating block, otherwise rewrite call with block.
2532 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
2533 -- Determine whether a formal parameter is used only once in Orig_Bod
2535 -----------------------------------
2536 -- Declare_Postconditions_Result --
2537 -----------------------------------
2539 procedure Declare_Postconditions_Result is
2540 Enclosing_Subp : constant Entity_Id := Scope (Subp);
2545 and then Is_Subprogram (Enclosing_Subp)
2546 and then Present (Postconditions_Proc (Enclosing_Subp)));
2548 if Ekind (Enclosing_Subp) = E_Function then
2549 if Nkind (First (Parameter_Associations (N))) in
2550 N_Numeric_Or_String_Literal
2552 Append_To (Declarations (Blk),
2553 Make_Object_Declaration (Loc,
2554 Defining_Identifier =>
2555 Make_Defining_Identifier (Loc, Name_uResult),
2556 Constant_Present => True,
2557 Object_Definition =>
2558 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2560 New_Copy_Tree (First (Parameter_Associations (N)))));
2562 Append_To (Declarations (Blk),
2563 Make_Object_Renaming_Declaration (Loc,
2564 Defining_Identifier =>
2565 Make_Defining_Identifier (Loc, Name_uResult),
2567 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2569 New_Copy_Tree (First (Parameter_Associations (N)))));
2572 end Declare_Postconditions_Result;
2574 ---------------------
2575 -- Make_Exit_Label --
2576 ---------------------
2578 procedure Make_Exit_Label is
2579 Lab_Ent : Entity_Id;
2581 if No (Exit_Lab) then
2582 Lab_Ent := Make_Temporary (Loc, 'L');
2583 Lab_Id := New_Occurrence_Of (Lab_Ent, Loc);
2584 Exit_Lab := Make_Label (Loc, Lab_Id);
2586 Make_Implicit_Label_Declaration (Loc,
2587 Defining_Identifier => Lab_Ent,
2588 Label_Construct => Exit_Lab);
2590 end Make_Exit_Label;
2592 -----------------------------
2593 -- Make_Loop_Labels_Unique --
2594 -----------------------------
2596 procedure Make_Loop_Labels_Unique (HSS : Node_Id) is
2597 function Process_Loop (N : Node_Id) return Traverse_Result;
2603 function Process_Loop (N : Node_Id) return Traverse_Result is
2607 if Nkind (N) = N_Loop_Statement
2608 and then Present (Identifier (N))
2610 -- Create new external name for loop and update the
2611 -- corresponding entity.
2613 Id := Entity (Identifier (N));
2614 Set_Chars (Id, New_External_Name (Chars (Id), 'L', -1));
2615 Set_Chars (Identifier (N), Chars (Id));
2617 elsif Nkind (N) = N_Exit_Statement
2618 and then Present (Name (N))
2620 -- The exit statement must name an enclosing loop, whose name
2621 -- has already been updated.
2623 Set_Chars (Name (N), Chars (Entity (Name (N))));
2629 procedure Update_Loop_Names is new Traverse_Proc (Process_Loop);
2635 -- Start of processing for Make_Loop_Labels_Unique
2638 if Modify_Tree_For_C then
2639 Stmt := First (Statements (HSS));
2640 while Present (Stmt) loop
2641 Update_Loop_Names (Stmt);
2645 end Make_Loop_Labels_Unique;
2647 ---------------------
2648 -- Process_Formals --
2649 ---------------------
2651 function Process_Formals (N : Node_Id) return Traverse_Result is
2657 if Is_Entity_Name (N) and then Present (Entity (N)) then
2660 if Is_Formal (E) and then Scope (E) = Subp then
2661 A := Renamed_Object (E);
2663 -- Rewrite the occurrence of the formal into an occurrence of
2664 -- the actual. Also establish visibility on the proper view of
2665 -- the actual's subtype for the body's context (if the actual's
2666 -- subtype is private at the call point but its full view is
2667 -- visible to the body, then the inlined tree here must be
2668 -- analyzed with the full view).
2670 if Is_Entity_Name (A) then
2671 Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N)));
2672 Check_Private_View (N);
2674 elsif Nkind (A) = N_Defining_Identifier then
2675 Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
2676 Check_Private_View (N);
2681 Rewrite (N, New_Copy (A));
2687 elsif Is_Entity_Name (N)
2688 and then Present (Return_Object)
2689 and then Chars (N) = Chars (Return_Object)
2691 -- Occurrence within an extended return statement. The return
2692 -- object is local to the body been inlined, and thus the generic
2693 -- copy is not analyzed yet, so we match by name, and replace it
2694 -- with target of call.
2696 if Nkind (Targ) = N_Defining_Identifier then
2697 Rewrite (N, New_Occurrence_Of (Targ, Loc));
2699 Rewrite (N, New_Copy_Tree (Targ));
2704 elsif Nkind (N) = N_Simple_Return_Statement then
2705 if No (Expression (N)) then
2706 Num_Ret := Num_Ret + 1;
2709 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2712 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
2713 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
2715 -- Function body is a single expression. No need for
2721 Num_Ret := Num_Ret + 1;
2725 -- Because of the presence of private types, the views of the
2726 -- expression and the context may be different, so place
2727 -- a type conversion to the context type to avoid spurious
2728 -- errors, e.g. when the expression is a numeric literal and
2729 -- the context is private. If the expression is an aggregate,
2730 -- use a qualified expression, because an aggregate is not a
2731 -- legal argument of a conversion. Ditto for numeric, character
2732 -- and string literals, and attributes that yield a universal
2733 -- type, because those must be resolved to a specific type.
2735 if Nkind_In (Expression (N), N_Aggregate,
2736 N_Character_Literal,
2739 or else Yields_Universal_Type (Expression (N))
2742 Make_Qualified_Expression (Sloc (N),
2743 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2744 Expression => Relocate_Node (Expression (N)));
2746 -- Use an unchecked type conversion between access types, for
2747 -- which a type conversion would not always be valid, as no
2748 -- check may result from the conversion.
2750 elsif Is_Access_Type (Ret_Type) then
2752 Unchecked_Convert_To
2753 (Ret_Type, Relocate_Node (Expression (N)));
2755 -- Otherwise use a type conversion, which may trigger a check
2759 Make_Type_Conversion (Sloc (N),
2760 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2761 Expression => Relocate_Node (Expression (N)));
2764 if Nkind (Targ) = N_Defining_Identifier then
2766 Make_Assignment_Statement (Loc,
2767 Name => New_Occurrence_Of (Targ, Loc),
2768 Expression => Ret));
2771 Make_Assignment_Statement (Loc,
2772 Name => New_Copy (Targ),
2773 Expression => Ret));
2776 Set_Assignment_OK (Name (N));
2778 if Present (Exit_Lab) then
2780 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2786 -- An extended return becomes a block whose first statement is the
2787 -- assignment of the initial expression of the return object to the
2788 -- target of the call itself.
2790 elsif Nkind (N) = N_Extended_Return_Statement then
2792 Return_Decl : constant Entity_Id :=
2793 First (Return_Object_Declarations (N));
2797 Return_Object := Defining_Identifier (Return_Decl);
2799 if Present (Expression (Return_Decl)) then
2800 if Nkind (Targ) = N_Defining_Identifier then
2802 Make_Assignment_Statement (Loc,
2803 Name => New_Occurrence_Of (Targ, Loc),
2804 Expression => Expression (Return_Decl));
2807 Make_Assignment_Statement (Loc,
2808 Name => New_Copy (Targ),
2809 Expression => Expression (Return_Decl));
2812 Set_Assignment_OK (Name (Assign));
2814 if No (Handled_Statement_Sequence (N)) then
2815 Set_Handled_Statement_Sequence (N,
2816 Make_Handled_Sequence_Of_Statements (Loc,
2817 Statements => New_List));
2821 Statements (Handled_Statement_Sequence (N)));
2825 Make_Block_Statement (Loc,
2826 Handled_Statement_Sequence =>
2827 Handled_Statement_Sequence (N)));
2832 -- Remove pragma Unreferenced since it may refer to formals that
2833 -- are not visible in the inlined body, and in any case we will
2834 -- not be posting warnings on the inlined body so it is unneeded.
2836 elsif Nkind (N) = N_Pragma
2837 and then Pragma_Name (N) = Name_Unreferenced
2839 Rewrite (N, Make_Null_Statement (Sloc (N)));
2845 end Process_Formals;
2847 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
2849 --------------------------------
2850 -- Process_Formals_In_Aspects --
2851 --------------------------------
2853 function Process_Formals_In_Aspects
2854 (N : Node_Id) return Traverse_Result
2859 if Has_Aspects (N) then
2860 A := First (Aspect_Specifications (N));
2861 while Present (A) loop
2862 Replace_Formals (Expression (A));
2868 end Process_Formals_In_Aspects;
2870 procedure Replace_Formals_In_Aspects is
2871 new Traverse_Proc (Process_Formals_In_Aspects);
2877 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
2879 if not Debug_Generated_Code then
2880 Set_Sloc (Nod, Sloc (N));
2881 Set_Comes_From_Source (Nod, False);
2887 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
2889 ------------------------------
2890 -- Reset_Dispatching_Calls --
2891 ------------------------------
2893 procedure Reset_Dispatching_Calls (N : Node_Id) is
2895 function Do_Reset (N : Node_Id) return Traverse_Result;
2896 -- Comment required ???
2902 function Do_Reset (N : Node_Id) return Traverse_Result is
2904 if Nkind (N) = N_Procedure_Call_Statement
2905 and then Nkind (Name (N)) = N_Selected_Component
2906 and then Nkind (Prefix (Name (N))) = N_Identifier
2907 and then Is_Formal (Entity (Prefix (Name (N))))
2908 and then Is_Dispatching_Operation
2909 (Entity (Selector_Name (Name (N))))
2911 Set_Entity (Selector_Name (Name (N)), Empty);
2917 function Do_Reset_Calls is new Traverse_Func (Do_Reset);
2921 Dummy : constant Traverse_Result := Do_Reset_Calls (N);
2922 pragma Unreferenced (Dummy);
2924 -- Start of processing for Reset_Dispatching_Calls
2928 end Reset_Dispatching_Calls;
2930 ---------------------------
2931 -- Rewrite_Function_Call --
2932 ---------------------------
2934 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
2935 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2936 Fst : constant Node_Id := First (Statements (HSS));
2939 Make_Loop_Labels_Unique (HSS);
2941 -- Optimize simple case: function body is a single return statement,
2942 -- which has been expanded into an assignment.
2944 if Is_Empty_List (Declarations (Blk))
2945 and then Nkind (Fst) = N_Assignment_Statement
2946 and then No (Next (Fst))
2948 -- The function call may have been rewritten as the temporary
2949 -- that holds the result of the call, in which case remove the
2950 -- now useless declaration.
2952 if Nkind (N) = N_Identifier
2953 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2955 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
2958 Rewrite (N, Expression (Fst));
2960 elsif Nkind (N) = N_Identifier
2961 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2963 -- The block assigns the result of the call to the temporary
2965 Insert_After (Parent (Entity (N)), Blk);
2967 -- If the context is an assignment, and the left-hand side is free of
2968 -- side-effects, the replacement is also safe.
2969 -- Can this be generalized further???
2971 elsif Nkind (Parent (N)) = N_Assignment_Statement
2973 (Is_Entity_Name (Name (Parent (N)))
2975 (Nkind (Name (Parent (N))) = N_Explicit_Dereference
2976 and then Is_Entity_Name (Prefix (Name (Parent (N)))))
2979 (Nkind (Name (Parent (N))) = N_Selected_Component
2980 and then Is_Entity_Name (Prefix (Name (Parent (N))))))
2982 -- Replace assignment with the block
2985 Original_Assignment : constant Node_Id := Parent (N);
2988 -- Preserve the original assignment node to keep the complete
2989 -- assignment subtree consistent enough for Analyze_Assignment
2990 -- to proceed (specifically, the original Lhs node must still
2991 -- have an assignment statement as its parent).
2993 -- We cannot rely on Original_Node to go back from the block
2994 -- node to the assignment node, because the assignment might
2995 -- already be a rewrite substitution.
2997 Discard_Node (Relocate_Node (Original_Assignment));
2998 Rewrite (Original_Assignment, Blk);
3001 elsif Nkind (Parent (N)) = N_Object_Declaration then
3003 -- A call to a function which returns an unconstrained type
3004 -- found in the expression initializing an object-declaration is
3005 -- expanded into a procedure call which must be added after the
3006 -- object declaration.
3008 if Is_Unc_Decl and Back_End_Inlining then
3009 Insert_Action_After (Parent (N), Blk);
3011 Set_Expression (Parent (N), Empty);
3012 Insert_After (Parent (N), Blk);
3015 elsif Is_Unc and then not Back_End_Inlining then
3016 Insert_Before (Parent (N), Blk);
3018 end Rewrite_Function_Call;
3020 ----------------------------
3021 -- Rewrite_Procedure_Call --
3022 ----------------------------
3024 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
3025 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
3028 Make_Loop_Labels_Unique (HSS);
3030 -- If there is a transient scope for N, this will be the scope of the
3031 -- actions for N, and the statements in Blk need to be within this
3032 -- scope. For example, they need to have visibility on the constant
3033 -- declarations created for the formals.
3035 -- If N needs no transient scope, and if there are no declarations in
3036 -- the inlined body, we can do a little optimization and insert the
3037 -- statements for the body directly after N, and rewrite N to a
3038 -- null statement, instead of rewriting N into a full-blown block
3041 if not Scope_Is_Transient
3042 and then Is_Empty_List (Declarations (Blk))
3044 Insert_List_After (N, Statements (HSS));
3045 Rewrite (N, Make_Null_Statement (Loc));
3049 end Rewrite_Procedure_Call;
3051 -------------------------
3052 -- Formal_Is_Used_Once --
3053 -------------------------
3055 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
3056 Use_Counter : Int := 0;
3058 function Count_Uses (N : Node_Id) return Traverse_Result;
3059 -- Traverse the tree and count the uses of the formal parameter.
3060 -- In this case, for optimization purposes, we do not need to
3061 -- continue the traversal once more than one use is encountered.
3067 function Count_Uses (N : Node_Id) return Traverse_Result is
3069 -- The original node is an identifier
3071 if Nkind (N) = N_Identifier
3072 and then Present (Entity (N))
3074 -- Original node's entity points to the one in the copied body
3076 and then Nkind (Entity (N)) = N_Identifier
3077 and then Present (Entity (Entity (N)))
3079 -- The entity of the copied node is the formal parameter
3081 and then Entity (Entity (N)) = Formal
3083 Use_Counter := Use_Counter + 1;
3085 if Use_Counter > 1 then
3087 -- Denote more than one use and abandon the traversal
3098 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
3100 -- Start of processing for Formal_Is_Used_Once
3103 Count_Formal_Uses (Orig_Bod);
3104 return Use_Counter = 1;
3105 end Formal_Is_Used_Once;
3107 -- Start of processing for Expand_Inlined_Call
3110 -- Initializations for old/new semantics
3112 if not Uses_Back_End then
3113 Is_Unc := Is_Array_Type (Etype (Subp))
3114 and then not Is_Constrained (Etype (Subp));
3115 Is_Unc_Decl := False;
3117 Is_Unc := Returns_Unconstrained_Type (Subp)
3118 and then Optimization_Level > 0;
3119 Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration
3123 -- Check for an illegal attempt to inline a recursive procedure. If the
3124 -- subprogram has parameters this is detected when trying to supply a
3125 -- binding for parameters that already have one. For parameterless
3126 -- subprograms this must be done explicitly.
3128 if In_Open_Scopes (Subp) then
3130 ("cannot inline call to recursive subprogram?", N, Subp);
3131 Set_Is_Inlined (Subp, False);
3134 -- Skip inlining if this is not a true inlining since the attribute
3135 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
3136 -- true inlining, Orig_Bod has code rather than being an entity.
3138 elsif Nkind (Orig_Bod) in N_Entity then
3142 if Nkind (Orig_Bod) = N_Defining_Identifier
3143 or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
3145 -- Subprogram is renaming_as_body. Calls occurring after the renaming
3146 -- can be replaced with calls to the renamed entity directly, because
3147 -- the subprograms are subtype conformant. If the renamed subprogram
3148 -- is an inherited operation, we must redo the expansion because
3149 -- implicit conversions may be needed. Similarly, if the renamed
3150 -- entity is inlined, expand the call for further optimizations.
3152 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
3154 if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then
3161 -- Register the call in the list of inlined calls
3163 Append_New_Elmt (N, To => Inlined_Calls);
3165 -- Use generic machinery to copy body of inlined subprogram, as if it
3166 -- were an instantiation, resetting source locations appropriately, so
3167 -- that nested inlined calls appear in the main unit.
3169 Save_Env (Subp, Empty);
3170 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
3174 if not Uses_Back_End then
3179 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3181 Make_Block_Statement (Loc,
3182 Declarations => Declarations (Bod),
3183 Handled_Statement_Sequence =>
3184 Handled_Statement_Sequence (Bod));
3186 if No (Declarations (Bod)) then
3187 Set_Declarations (Blk, New_List);
3190 -- When generating C code, declare _Result, which may be used to
3191 -- verify the return value.
3193 if Modify_Tree_For_C
3194 and then Nkind (N) = N_Procedure_Call_Statement
3195 and then Chars (Name (N)) = Name_uPostconditions
3197 Declare_Postconditions_Result;
3200 -- For the unconstrained case, capture the name of the local
3201 -- variable that holds the result. This must be the first
3202 -- declaration in the block, because its bounds cannot depend
3203 -- on local variables. Otherwise there is no way to declare the
3204 -- result outside of the block. Needless to say, in general the
3205 -- bounds will depend on the actuals in the call.
3207 -- If the context is an assignment statement, as is the case
3208 -- for the expansion of an extended return, the left-hand side
3209 -- provides bounds even if the return type is unconstrained.
3213 First_Decl : Node_Id;
3216 First_Decl := First (Declarations (Blk));
3218 -- If the body is a single extended return statement,the
3219 -- resulting block is a nested block.
3221 if No (First_Decl) then
3223 First (Statements (Handled_Statement_Sequence (Blk)));
3225 if Nkind (First_Decl) = N_Block_Statement then
3226 First_Decl := First (Declarations (First_Decl));
3230 -- No front-end inlining possible
3232 if Nkind (First_Decl) /= N_Object_Declaration then
3236 if Nkind (Parent (N)) /= N_Assignment_Statement then
3237 Targ1 := Defining_Identifier (First_Decl);
3239 Targ1 := Name (Parent (N));
3256 Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3258 Make_Block_Statement (Loc,
3259 Declarations => Declarations (Bod),
3260 Handled_Statement_Sequence =>
3261 Handled_Statement_Sequence (Bod));
3263 -- Inline a call to a function that returns an unconstrained type.
3264 -- The semantic analyzer checked that frontend-inlined functions
3265 -- returning unconstrained types have no declarations and have
3266 -- a single extended return statement. As part of its processing
3267 -- the function was split into two subprograms: a procedure P' and
3268 -- a function F' that has a block with a call to procedure P' (see
3269 -- Split_Unconstrained_Function).
3275 (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
3279 Blk_Stmt : constant Node_Id :=
3280 First (Statements (Handled_Statement_Sequence (Orig_Bod)));
3281 First_Stmt : constant Node_Id :=
3282 First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
3283 Second_Stmt : constant Node_Id := Next (First_Stmt);
3287 (Nkind (First_Stmt) = N_Procedure_Call_Statement
3288 and then Nkind (Second_Stmt) = N_Simple_Return_Statement
3289 and then No (Next (Second_Stmt)));
3294 (Statements (Handled_Statement_Sequence (Orig_Bod))),
3295 Empty, Instantiating => True);
3298 -- Capture the name of the local variable that holds the
3299 -- result. This must be the first declaration in the block,
3300 -- because its bounds cannot depend on local variables.
3301 -- Otherwise there is no way to declare the result outside
3302 -- of the block. Needless to say, in general the bounds will
3303 -- depend on the actuals in the call.
3305 if Nkind (Parent (N)) /= N_Assignment_Statement then
3306 Targ1 := Defining_Identifier (First (Declarations (Blk)));
3308 -- If the context is an assignment statement, as is the case
3309 -- for the expansion of an extended return, the left-hand
3310 -- side provides bounds even if the return type is
3314 Targ1 := Name (Parent (N));
3319 if No (Declarations (Bod)) then
3320 Set_Declarations (Blk, New_List);
3325 -- If this is a derived function, establish the proper return type
3327 if Present (Orig_Subp) and then Orig_Subp /= Subp then
3328 Ret_Type := Etype (Orig_Subp);
3330 Ret_Type := Etype (Subp);
3333 -- Create temporaries for the actuals that are expressions, or that are
3334 -- scalars and require copying to preserve semantics.
3336 F := First_Formal (Subp);
3337 A := First_Actual (N);
3338 while Present (F) loop
3339 if Present (Renamed_Object (F)) then
3341 -- If expander is active, it is an error to try to inline a
3342 -- recursive program. In GNATprove mode, just indicate that the
3343 -- inlining will not happen, and mark the subprogram as not always
3346 if GNATprove_Mode then
3348 ("cannot inline call to recursive subprogram?", N, Subp);
3349 Set_Is_Inlined_Always (Subp, False);
3352 ("cannot inline call to recursive subprogram", N);
3358 -- Reset Last_Assignment for any parameters of mode out or in out, to
3359 -- prevent spurious warnings about overwriting for assignments to the
3360 -- formal in the inlined code.
3362 if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
3363 Set_Last_Assignment (Entity (A), Empty);
3366 -- If the argument may be a controlling argument in a call within
3367 -- the inlined body, we must preserve its classwide nature to insure
3368 -- that dynamic dispatching take place subsequently. If the formal
3369 -- has a constraint it must be preserved to retain the semantics of
3372 if Is_Class_Wide_Type (Etype (F))
3373 or else (Is_Access_Type (Etype (F))
3374 and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
3376 Temp_Typ := Etype (F);
3378 elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
3379 and then Etype (F) /= Base_Type (Etype (F))
3380 and then Is_Constrained (Etype (F))
3382 Temp_Typ := Etype (F);
3385 Temp_Typ := Etype (A);
3388 -- If the actual is a simple name or a literal, no need to
3389 -- create a temporary, object can be used directly.
3391 -- If the actual is a literal and the formal has its address taken,
3392 -- we cannot pass the literal itself as an argument, so its value
3393 -- must be captured in a temporary. Skip this optimization in
3394 -- GNATprove mode, to make sure any check on a type conversion
3397 if (Is_Entity_Name (A)
3399 (not Is_Scalar_Type (Etype (A))
3400 or else Ekind (Entity (A)) = E_Enumeration_Literal)
3401 and then not GNATprove_Mode)
3403 -- When the actual is an identifier and the corresponding formal is
3404 -- used only once in the original body, the formal can be substituted
3405 -- directly with the actual parameter. Skip this optimization in
3406 -- GNATprove mode, to make sure any check on a type conversion
3410 (Nkind (A) = N_Identifier
3411 and then Formal_Is_Used_Once (F)
3412 and then not GNATprove_Mode)
3415 (Nkind_In (A, N_Real_Literal,
3417 N_Character_Literal)
3418 and then not Address_Taken (F))
3420 if Etype (F) /= Etype (A) then
3422 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
3424 Set_Renamed_Object (F, A);
3428 Temp := Make_Temporary (Loc, 'C');
3430 -- If the actual for an in/in-out parameter is a view conversion,
3431 -- make it into an unchecked conversion, given that an untagged
3432 -- type conversion is not a proper object for a renaming.
3434 -- In-out conversions that involve real conversions have already
3435 -- been transformed in Expand_Actuals.
3437 if Nkind (A) = N_Type_Conversion
3438 and then Ekind (F) /= E_In_Parameter
3441 Make_Unchecked_Type_Conversion (Loc,
3442 Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
3443 Expression => Relocate_Node (Expression (A)));
3445 -- In GNATprove mode, keep the most precise type of the actual for
3446 -- the temporary variable, when the formal type is unconstrained.
3447 -- Otherwise, the AST may contain unexpected assignment statements
3448 -- to a temporary variable of unconstrained type renaming a local
3449 -- variable of constrained type, which is not expected by
3452 elsif Etype (F) /= Etype (A)
3453 and then (not GNATprove_Mode or else Is_Constrained (Etype (F)))
3455 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
3456 Temp_Typ := Etype (F);
3459 New_A := Relocate_Node (A);
3462 Set_Sloc (New_A, Sloc (N));
3464 -- If the actual has a by-reference type, it cannot be copied,
3465 -- so its value is captured in a renaming declaration. Otherwise
3466 -- declare a local constant initialized with the actual.
3468 -- We also use a renaming declaration for expressions of an array
3469 -- type that is not bit-packed, both for efficiency reasons and to
3470 -- respect the semantics of the call: in most cases the original
3471 -- call will pass the parameter by reference, and thus the inlined
3472 -- code will have the same semantics.
3474 -- Finally, we need a renaming declaration in the case of limited
3475 -- types for which initialization cannot be by copy either.
3477 if Ekind (F) = E_In_Parameter
3478 and then not Is_By_Reference_Type (Etype (A))
3479 and then not Is_Limited_Type (Etype (A))
3481 (not Is_Array_Type (Etype (A))
3482 or else not Is_Object_Reference (A)
3483 or else Is_Bit_Packed_Array (Etype (A)))
3486 Make_Object_Declaration (Loc,
3487 Defining_Identifier => Temp,
3488 Constant_Present => True,
3489 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3490 Expression => New_A);
3493 -- In GNATprove mode, make an explicit copy of input
3494 -- parameters when formal and actual types differ, to make
3495 -- sure any check on the type conversion will be issued.
3496 -- The legality of the copy is ensured by calling first
3497 -- Call_Can_Be_Inlined_In_GNATprove_Mode.
3500 and then Ekind (F) /= E_Out_Parameter
3501 and then not Same_Type (Etype (F), Etype (A))
3503 pragma Assert (not Is_By_Reference_Type (Etype (A)));
3504 pragma Assert (not Is_Limited_Type (Etype (A)));
3507 Make_Object_Declaration (Loc,
3508 Defining_Identifier => Make_Temporary (Loc, 'C'),
3509 Constant_Present => True,
3510 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3511 Expression => New_Copy_Tree (New_A)));
3515 Make_Object_Renaming_Declaration (Loc,
3516 Defining_Identifier => Temp,
3517 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
3521 Append (Decl, Decls);
3522 Set_Renamed_Object (F, Temp);
3529 -- Establish target of function call. If context is not assignment or
3530 -- declaration, create a temporary as a target. The declaration for the
3531 -- temporary may be subsequently optimized away if the body is a single
3532 -- expression, or if the left-hand side of the assignment is simple
3533 -- enough, i.e. an entity or an explicit dereference of one.
3535 if Ekind (Subp) = E_Function then
3536 if Nkind (Parent (N)) = N_Assignment_Statement
3537 and then Is_Entity_Name (Name (Parent (N)))
3539 Targ := Name (Parent (N));
3541 elsif Nkind (Parent (N)) = N_Assignment_Statement
3542 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
3543 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3545 Targ := Name (Parent (N));
3547 elsif Nkind (Parent (N)) = N_Assignment_Statement
3548 and then Nkind (Name (Parent (N))) = N_Selected_Component
3549 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3551 Targ := New_Copy_Tree (Name (Parent (N)));
3553 elsif Nkind (Parent (N)) = N_Object_Declaration
3554 and then Is_Limited_Type (Etype (Subp))
3556 Targ := Defining_Identifier (Parent (N));
3558 -- New semantics: In an object declaration avoid an extra copy
3559 -- of the result of a call to an inlined function that returns
3560 -- an unconstrained type
3563 and then Nkind (Parent (N)) = N_Object_Declaration
3566 Targ := Defining_Identifier (Parent (N));
3569 -- Replace call with temporary and create its declaration
3571 Temp := Make_Temporary (Loc, 'C');
3572 Set_Is_Internal (Temp);
3574 -- For the unconstrained case, the generated temporary has the
3575 -- same constrained declaration as the result variable. It may
3576 -- eventually be possible to remove that temporary and use the
3577 -- result variable directly.
3579 if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement
3582 Make_Object_Declaration (Loc,
3583 Defining_Identifier => Temp,
3584 Object_Definition =>
3585 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3587 Replace_Formals (Decl);
3591 Make_Object_Declaration (Loc,
3592 Defining_Identifier => Temp,
3593 Object_Definition => New_Occurrence_Of (Ret_Type, Loc));
3595 Set_Etype (Temp, Ret_Type);
3598 Set_No_Initialization (Decl);
3599 Append (Decl, Decls);
3600 Rewrite (N, New_Occurrence_Of (Temp, Loc));
3605 Insert_Actions (N, Decls);
3609 -- Special management for inlining a call to a function that returns
3610 -- an unconstrained type and initializes an object declaration: we
3611 -- avoid generating undesired extra calls and goto statements.
3614 -- function Func (...) return String is
3617 -- Result : String (1 .. 4);
3619 -- Proc (Result, ...);
3624 -- Result : String := Func (...);
3626 -- Replace this object declaration by:
3628 -- Result : String (1 .. 4);
3629 -- Proc (Result, ...);
3631 Remove_Homonym (Targ);
3634 Make_Object_Declaration
3636 Defining_Identifier => Targ,
3637 Object_Definition =>
3638 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3639 Replace_Formals (Decl);
3640 Rewrite (Parent (N), Decl);
3641 Analyze (Parent (N));
3643 -- Avoid spurious warnings since we know that this declaration is
3644 -- referenced by the procedure call.
3646 Set_Never_Set_In_Source (Targ, False);
3648 -- Remove the local declaration of the extended return stmt from the
3651 Remove (Parent (Targ1));
3653 -- Update the reference to the result (since we have rewriten the
3654 -- object declaration)
3657 Blk_Call_Stmt : Node_Id;
3660 -- Capture the call to the procedure
3663 First (Statements (Handled_Statement_Sequence (Blk)));
3665 (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement);
3667 Remove (First (Parameter_Associations (Blk_Call_Stmt)));
3668 Prepend_To (Parameter_Associations (Blk_Call_Stmt),
3669 New_Occurrence_Of (Targ, Loc));
3672 -- Remove the return statement
3675 (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3676 N_Simple_Return_Statement);
3678 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3681 -- Traverse the tree and replace formals with actuals or their thunks.
3682 -- Attach block to tree before analysis and rewriting.
3684 Replace_Formals (Blk);
3685 Replace_Formals_In_Aspects (Blk);
3686 Set_Parent (Blk, N);
3688 if GNATprove_Mode then
3691 elsif not Comes_From_Source (Subp) or else Is_Predef then
3697 -- No action needed since return statement has been already removed
3701 elsif Present (Exit_Lab) then
3703 -- If there's a single return statement at the end of the subprogram,
3704 -- the corresponding goto statement and the corresponding label are
3709 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3712 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3714 Append (Lab_Decl, (Declarations (Blk)));
3715 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
3719 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3720 -- on conflicting private views that Gigi would ignore. If this is a
3721 -- predefined unit, analyze with checks off, as is done in the non-
3722 -- inlined run-time units.
3725 I_Flag : constant Boolean := In_Inlined_Body;
3728 In_Inlined_Body := True;
3732 Style : constant Boolean := Style_Check;
3735 Style_Check := False;
3737 -- Search for dispatching calls that use the Object.Operation
3738 -- notation using an Object that is a parameter of the inlined
3739 -- function. We reset the decoration of Operation to force
3740 -- the reanalysis of the inlined dispatching call because
3741 -- the actual object has been inlined.
3743 Reset_Dispatching_Calls (Blk);
3745 Analyze (Blk, Suppress => All_Checks);
3746 Style_Check := Style;
3753 In_Inlined_Body := I_Flag;
3756 if Ekind (Subp) = E_Procedure then
3757 Rewrite_Procedure_Call (N, Blk);
3760 Rewrite_Function_Call (N, Blk);
3765 -- For the unconstrained case, the replacement of the call has been
3766 -- made prior to the complete analysis of the generated declarations.
3767 -- Propagate the proper type now.
3770 if Nkind (N) = N_Identifier then
3771 Set_Etype (N, Etype (Entity (N)));
3773 Set_Etype (N, Etype (Targ1));
3780 -- Cleanup mapping between formals and actuals for other expansions
3782 F := First_Formal (Subp);
3783 while Present (F) loop
3784 Set_Renamed_Object (F, Empty);
3787 end Expand_Inlined_Call;
3789 --------------------------
3790 -- Get_Code_Unit_Entity --
3791 --------------------------
3793 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
3794 Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E));
3797 if Ekind (Unit) = E_Package_Body then
3798 Unit := Spec_Entity (Unit);
3802 end Get_Code_Unit_Entity;
3804 ------------------------------
3805 -- Has_Excluded_Declaration --
3806 ------------------------------
3808 function Has_Excluded_Declaration
3810 Decls : List_Id) return Boolean
3814 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
3815 -- Nested subprograms make a given body ineligible for inlining, but
3816 -- we make an exception for instantiations of unchecked conversion.
3817 -- The body has not been analyzed yet, so check the name, and verify
3818 -- that the visible entity with that name is the predefined unit.
3820 -----------------------------
3821 -- Is_Unchecked_Conversion --
3822 -----------------------------
3824 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
3825 Id : constant Node_Id := Name (D);
3829 if Nkind (Id) = N_Identifier
3830 and then Chars (Id) = Name_Unchecked_Conversion
3832 Conv := Current_Entity (Id);
3834 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
3835 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
3837 Conv := Current_Entity (Selector_Name (Id));
3842 return Present (Conv)
3843 and then Is_Predefined_Unit (Get_Source_Unit (Conv))
3844 and then Is_Intrinsic_Subprogram (Conv);
3845 end Is_Unchecked_Conversion;
3847 -- Start of processing for Has_Excluded_Declaration
3850 -- No action needed if the check is not needed
3852 if not Check_Inlining_Restrictions then
3857 while Present (D) loop
3859 -- First declarations universally excluded
3861 if Nkind (D) = N_Package_Declaration then
3863 ("cannot inline & (nested package declaration)?", D, Subp);
3866 elsif Nkind (D) = N_Package_Instantiation then
3868 ("cannot inline & (nested package instantiation)?", D, Subp);
3872 -- Then declarations excluded only for front-end inlining
3874 if Back_End_Inlining then
3877 elsif Nkind (D) = N_Task_Type_Declaration
3878 or else Nkind (D) = N_Single_Task_Declaration
3881 ("cannot inline & (nested task type declaration)?", D, Subp);
3884 elsif Nkind (D) = N_Protected_Type_Declaration
3885 or else Nkind (D) = N_Single_Protected_Declaration
3888 ("cannot inline & (nested protected type declaration)?",
3892 elsif Nkind (D) = N_Subprogram_Body then
3894 ("cannot inline & (nested subprogram)?", D, Subp);
3897 elsif Nkind (D) = N_Function_Instantiation
3898 and then not Is_Unchecked_Conversion (D)
3901 ("cannot inline & (nested function instantiation)?", D, Subp);
3904 elsif Nkind (D) = N_Procedure_Instantiation then
3906 ("cannot inline & (nested procedure instantiation)?", D, Subp);
3909 -- Subtype declarations with predicates will generate predicate
3910 -- functions, i.e. nested subprogram bodies, so inlining is not
3913 elsif Nkind (D) = N_Subtype_Declaration
3914 and then Present (Aspect_Specifications (D))
3921 A := First (Aspect_Specifications (D));
3922 while Present (A) loop
3923 A_Id := Get_Aspect_Id (Chars (Identifier (A)));
3925 if A_Id = Aspect_Predicate
3926 or else A_Id = Aspect_Static_Predicate
3927 or else A_Id = Aspect_Dynamic_Predicate
3930 ("cannot inline & (subtype declaration with "
3931 & "predicate)?", D, Subp);
3944 end Has_Excluded_Declaration;
3946 ----------------------------
3947 -- Has_Excluded_Statement --
3948 ----------------------------
3950 function Has_Excluded_Statement
3952 Stats : List_Id) return Boolean
3958 -- No action needed if the check is not needed
3960 if not Check_Inlining_Restrictions then
3965 while Present (S) loop
3966 if Nkind_In (S, N_Abort_Statement,
3967 N_Asynchronous_Select,
3968 N_Conditional_Entry_Call,
3969 N_Delay_Relative_Statement,
3970 N_Delay_Until_Statement,
3975 ("cannot inline & (non-allowed statement)?", S, Subp);
3978 elsif Nkind (S) = N_Block_Statement then
3979 if Present (Declarations (S))
3980 and then Has_Excluded_Declaration (Subp, Declarations (S))
3984 elsif Present (Handled_Statement_Sequence (S)) then
3985 if not Back_End_Inlining
3988 (Exception_Handlers (Handled_Statement_Sequence (S)))
3991 ("cannot inline& (exception handler)?",
3992 First (Exception_Handlers
3993 (Handled_Statement_Sequence (S))),
3997 elsif Has_Excluded_Statement
3998 (Subp, Statements (Handled_Statement_Sequence (S)))
4004 elsif Nkind (S) = N_Case_Statement then
4005 E := First (Alternatives (S));
4006 while Present (E) loop
4007 if Has_Excluded_Statement (Subp, Statements (E)) then
4014 elsif Nkind (S) = N_If_Statement then
4015 if Has_Excluded_Statement (Subp, Then_Statements (S)) then
4019 if Present (Elsif_Parts (S)) then
4020 E := First (Elsif_Parts (S));
4021 while Present (E) loop
4022 if Has_Excluded_Statement (Subp, Then_Statements (E)) then
4030 if Present (Else_Statements (S))
4031 and then Has_Excluded_Statement (Subp, Else_Statements (S))
4036 elsif Nkind (S) = N_Loop_Statement
4037 and then Has_Excluded_Statement (Subp, Statements (S))
4041 elsif Nkind (S) = N_Extended_Return_Statement then
4042 if Present (Handled_Statement_Sequence (S))
4044 Has_Excluded_Statement
4045 (Subp, Statements (Handled_Statement_Sequence (S)))
4049 elsif not Back_End_Inlining
4050 and then Present (Handled_Statement_Sequence (S))
4052 Present (Exception_Handlers
4053 (Handled_Statement_Sequence (S)))
4056 ("cannot inline& (exception handler)?",
4057 First (Exception_Handlers (Handled_Statement_Sequence (S))),
4067 end Has_Excluded_Statement;
4069 --------------------------
4070 -- Has_Initialized_Type --
4071 --------------------------
4073 function Has_Initialized_Type (E : Entity_Id) return Boolean is
4074 E_Body : constant Node_Id := Subprogram_Body (E);
4078 if No (E_Body) then -- imported subprogram
4082 Decl := First (Declarations (E_Body));
4083 while Present (Decl) loop
4084 if Nkind (Decl) = N_Full_Type_Declaration
4085 and then Present (Init_Proc (Defining_Identifier (Decl)))
4095 end Has_Initialized_Type;
4097 -----------------------
4098 -- Has_Single_Return --
4099 -----------------------
4101 function Has_Single_Return (N : Node_Id) return Boolean is
4102 Return_Statement : Node_Id := Empty;
4104 function Check_Return (N : Node_Id) return Traverse_Result;
4110 function Check_Return (N : Node_Id) return Traverse_Result is
4112 if Nkind (N) = N_Simple_Return_Statement then
4113 if Present (Expression (N))
4114 and then Is_Entity_Name (Expression (N))
4116 pragma Assert (Present (Entity (Expression (N))));
4118 if No (Return_Statement) then
4119 Return_Statement := N;
4124 (Present (Entity (Expression (Return_Statement))));
4126 if Entity (Expression (N)) =
4127 Entity (Expression (Return_Statement))
4135 -- A return statement within an extended return is a noop after
4138 elsif No (Expression (N))
4139 and then Nkind (Parent (Parent (N))) =
4140 N_Extended_Return_Statement
4145 -- Expression has wrong form
4150 -- We can only inline a build-in-place function if it has a single
4153 elsif Nkind (N) = N_Extended_Return_Statement then
4154 if No (Return_Statement) then
4155 Return_Statement := N;
4167 function Check_All_Returns is new Traverse_Func (Check_Return);
4169 -- Start of processing for Has_Single_Return
4172 if Check_All_Returns (N) /= OK then
4175 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
4180 Present (Declarations (N))
4181 and then Present (First (Declarations (N)))
4182 and then Entity (Expression (Return_Statement)) =
4183 Defining_Identifier (First (Declarations (N)));
4185 end Has_Single_Return;
4187 -----------------------------
4188 -- In_Main_Unit_Or_Subunit --
4189 -----------------------------
4191 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is
4192 Comp : Node_Id := Cunit (Get_Code_Unit (E));
4195 -- Check whether the subprogram or package to inline is within the main
4196 -- unit or its spec or within a subunit. In either case there are no
4197 -- additional bodies to process. If the subprogram appears in a parent
4198 -- of the current unit, the check on whether inlining is possible is
4199 -- done in Analyze_Inlined_Bodies.
4201 while Nkind (Unit (Comp)) = N_Subunit loop
4202 Comp := Library_Unit (Comp);
4205 return Comp = Cunit (Main_Unit)
4206 or else Comp = Library_Unit (Cunit (Main_Unit));
4207 end In_Main_Unit_Or_Subunit;
4213 procedure Initialize is
4215 Pending_Descriptor.Init;
4216 Pending_Instantiations.Init;
4217 Inlined_Bodies.Init;
4221 for J in Hash_Headers'Range loop
4222 Hash_Headers (J) := No_Subp;
4225 Inlined_Calls := No_Elist;
4226 Backend_Calls := No_Elist;
4227 Backend_Inlined_Subps := No_Elist;
4228 Backend_Not_Inlined_Subps := No_Elist;
4231 ------------------------
4232 -- Instantiate_Bodies --
4233 ------------------------
4235 -- Generic bodies contain all the non-local references, so an
4236 -- instantiation does not need any more context than Standard
4237 -- itself, even if the instantiation appears in an inner scope.
4238 -- Generic associations have verified that the contract model is
4239 -- satisfied, so that any error that may occur in the analysis of
4240 -- the body is an internal error.
4242 procedure Instantiate_Bodies is
4244 Info : Pending_Body_Info;
4247 if Serious_Errors_Detected = 0 then
4248 Expander_Active := (Operating_Mode = Opt.Generate_Code);
4249 Push_Scope (Standard_Standard);
4250 To_Clean := New_Elmt_List;
4252 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
4256 -- A body instantiation may generate additional instantiations, so
4257 -- the following loop must scan to the end of a possibly expanding
4258 -- set (that's why we can't simply use a FOR loop here).
4261 while J <= Pending_Instantiations.Last
4262 and then Serious_Errors_Detected = 0
4264 Info := Pending_Instantiations.Table (J);
4266 -- If the instantiation node is absent, it has been removed
4267 -- as part of unreachable code.
4269 if No (Info.Inst_Node) then
4272 elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
4273 Instantiate_Package_Body (Info);
4274 Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
4277 Instantiate_Subprogram_Body (Info);
4283 -- Reset the table of instantiations. Additional instantiations
4284 -- may be added through inlining, when additional bodies are
4287 Pending_Instantiations.Init;
4289 -- We can now complete the cleanup actions of scopes that contain
4290 -- pending instantiations (skipped for generic units, since we
4291 -- never need any cleanups in generic units).
4294 and then not Is_Generic_Unit (Main_Unit_Entity)
4297 elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
4303 end Instantiate_Bodies;
4309 function Is_Nested (E : Entity_Id) return Boolean is
4314 while Scop /= Standard_Standard loop
4315 if Ekind (Scop) in Subprogram_Kind then
4318 elsif Ekind (Scop) = E_Task_Type
4319 or else Ekind (Scop) = E_Entry
4320 or else Ekind (Scop) = E_Entry_Family
4325 Scop := Scope (Scop);
4331 ------------------------
4332 -- List_Inlining_Info --
4333 ------------------------
4335 procedure List_Inlining_Info is
4341 if not Debug_Flag_Dot_J then
4345 -- Generate listing of calls inlined by the frontend
4347 if Present (Inlined_Calls) then
4349 Elmt := First_Elmt (Inlined_Calls);
4350 while Present (Elmt) loop
4353 if In_Extended_Main_Code_Unit (Nod) then
4357 Write_Str ("List of calls inlined by the frontend");
4364 Write_Location (Sloc (Nod));
4373 -- Generate listing of calls passed to the backend
4375 if Present (Backend_Calls) then
4378 Elmt := First_Elmt (Backend_Calls);
4379 while Present (Elmt) loop
4382 if In_Extended_Main_Code_Unit (Nod) then
4386 Write_Str ("List of inlined calls passed to the backend");
4393 Write_Location (Sloc (Nod));
4401 -- Generate listing of subprograms passed to the backend
4403 if Present (Backend_Inlined_Subps) and then Back_End_Inlining then
4406 Elmt := First_Elmt (Backend_Inlined_Subps);
4407 while Present (Elmt) loop
4414 ("List of inlined subprograms passed to the backend");
4421 Write_Name (Chars (Nod));
4423 Write_Location (Sloc (Nod));
4431 -- Generate listing of subprograms that cannot be inlined by the backend
4433 if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining then
4436 Elmt := First_Elmt (Backend_Not_Inlined_Subps);
4437 while Present (Elmt) loop
4444 ("List of subprograms that cannot be inlined by the backend");
4451 Write_Name (Chars (Nod));
4453 Write_Location (Sloc (Nod));
4460 end List_Inlining_Info;
4468 Pending_Instantiations.Release;
4469 Pending_Instantiations.Locked := True;
4470 Inlined_Bodies.Release;
4471 Inlined_Bodies.Locked := True;
4473 Successors.Locked := True;
4475 Inlined.Locked := True;
4478 --------------------------------
4479 -- Remove_Aspects_And_Pragmas --
4480 --------------------------------
4482 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id) is
4483 procedure Remove_Items (List : List_Id);
4484 -- Remove all useless aspects/pragmas from a particular list
4490 procedure Remove_Items (List : List_Id) is
4493 Next_Item : Node_Id;
4496 -- Traverse the list looking for an aspect specification or a pragma
4498 Item := First (List);
4499 while Present (Item) loop
4500 Next_Item := Next (Item);
4502 if Nkind (Item) = N_Aspect_Specification then
4503 Item_Id := Identifier (Item);
4504 elsif Nkind (Item) = N_Pragma then
4505 Item_Id := Pragma_Identifier (Item);
4510 if Present (Item_Id)
4511 and then Nam_In (Chars (Item_Id), Name_Contract_Cases,
4516 Name_Refined_Global,
4517 Name_Refined_Depends,
4531 -- Start of processing for Remove_Aspects_And_Pragmas
4534 Remove_Items (Aspect_Specifications (Body_Decl));
4535 Remove_Items (Declarations (Body_Decl));
4537 -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear
4538 -- in the body of the subprogram.
4540 Remove_Items (Statements (Handled_Statement_Sequence (Body_Decl)));
4541 end Remove_Aspects_And_Pragmas;
4543 --------------------------
4544 -- Remove_Dead_Instance --
4545 --------------------------
4547 procedure Remove_Dead_Instance (N : Node_Id) is
4552 while J <= Pending_Instantiations.Last loop
4553 if Pending_Instantiations.Table (J).Inst_Node = N then
4554 Pending_Instantiations.Table (J).Inst_Node := Empty;
4560 end Remove_Dead_Instance;