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 ------------------------------------------------------------------------------
27 with Aspects; use Aspects;
28 with Atree; use Atree;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Expander; use Expander;
34 with Exp_Ch6; use Exp_Ch6;
35 with Exp_Ch7; use Exp_Ch7;
36 with Exp_Tss; use Exp_Tss;
37 with Exp_Util; use Exp_Util;
38 with Fname; use Fname;
39 with Fname.UF; use Fname.UF;
41 with Namet; use Namet;
42 with Nmake; use Nmake;
43 with Nlists; use Nlists;
44 with Output; use Output;
45 with Sem_Aux; use Sem_Aux;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Ch10; use Sem_Ch10;
48 with Sem_Ch12; use Sem_Ch12;
49 with Sem_Prag; use Sem_Prag;
50 with Sem_Util; use Sem_Util;
51 with Sinfo; use Sinfo;
52 with Sinput; use Sinput;
53 with Snames; use Snames;
54 with Stand; use Stand;
56 with Tbuild; use Tbuild;
57 with Uintp; use Uintp;
58 with Uname; use Uname;
62 package body Inline is
64 Check_Inlining_Restrictions : constant Boolean := True;
65 -- In the following cases the frontend rejects inlining because they
66 -- are not handled well by the backend. This variable facilitates
67 -- disabling these restrictions to evaluate future versions of the
68 -- GCC backend in which some of the restrictions may be supported.
70 -- - subprograms that have:
71 -- - nested subprograms
73 -- - package declarations
74 -- - task or protected object declarations
75 -- - some of the following statements:
77 -- - asynchronous-select
78 -- - conditional-entry-call
84 Inlined_Calls : Elist_Id;
85 -- List of frontend inlined calls
87 Backend_Calls : Elist_Id;
88 -- List of inline calls passed to the backend
90 Backend_Instances : Elist_Id;
91 -- List of instances inlined for the backend
93 Backend_Inlined_Subps : Elist_Id;
94 -- List of subprograms inlined by the backend
96 Backend_Not_Inlined_Subps : Elist_Id;
97 -- List of subprograms that cannot be inlined by the backend
99 -----------------------------
100 -- Pending_Instantiations --
101 -----------------------------
103 -- We make entries in this table for the pending instantiations of generic
104 -- bodies that are created during semantic analysis. After the analysis is
105 -- complete, calling Instantiate_Bodies performs the actual instantiations.
107 package Pending_Instantiations is new Table.Table (
108 Table_Component_Type => Pending_Body_Info,
109 Table_Index_Type => Int,
110 Table_Low_Bound => 0,
111 Table_Initial => Alloc.Pending_Instantiations_Initial,
112 Table_Increment => Alloc.Pending_Instantiations_Increment,
113 Table_Name => "Pending_Instantiations");
115 -------------------------------------
116 -- Called_Pending_Instantiations --
117 -------------------------------------
119 -- With back-end inlining, the pending instantiations that are not in the
120 -- main unit or subunit are performed only after a call to the subprogram
121 -- instance, or to a subprogram within the package instance, is inlined.
122 -- Since such a call can be within a subsequent pending instantiation,
123 -- we make entries in this table that stores the index of these "called"
124 -- pending instantiations and perform them when the table is populated.
126 package Called_Pending_Instantiations is new Table.Table (
127 Table_Component_Type => Int,
128 Table_Index_Type => Int,
129 Table_Low_Bound => 0,
130 Table_Initial => Alloc.Pending_Instantiations_Initial,
131 Table_Increment => Alloc.Pending_Instantiations_Increment,
132 Table_Name => "Called_Pending_Instantiations");
134 ---------------------------------
135 -- To_Pending_Instantiations --
136 ---------------------------------
138 -- With back-end inlining, we also need to have a map from the pending
139 -- instantiations to their index in the Pending_Instantiations table.
141 Node_Table_Size : constant := 257;
142 -- Number of headers in hash table
144 subtype Node_Header_Num is Integer range 0 .. Node_Table_Size - 1;
145 -- Range of headers in hash table
147 function Node_Hash (Id : Node_Id) return Node_Header_Num;
148 -- Simple hash function for Node_Ids
150 package To_Pending_Instantiations is new GNAT.Htable.Simple_HTable
151 (Header_Num => Node_Header_Num,
162 function Node_Hash (Id : Node_Id) return Node_Header_Num is
164 return Node_Header_Num (Id mod Node_Table_Size);
171 -- Inlined functions are actually placed in line by the backend if the
172 -- corresponding bodies are available (i.e. compiled). Whenever we find
173 -- a call to an inlined subprogram, we add the name of the enclosing
174 -- compilation unit to a worklist. After all compilation, and after
175 -- expansion of generic bodies, we traverse the list of pending bodies
176 -- and compile them as well.
178 package Inlined_Bodies is new Table.Table (
179 Table_Component_Type => Entity_Id,
180 Table_Index_Type => Int,
181 Table_Low_Bound => 0,
182 Table_Initial => Alloc.Inlined_Bodies_Initial,
183 Table_Increment => Alloc.Inlined_Bodies_Increment,
184 Table_Name => "Inlined_Bodies");
186 -----------------------
187 -- Inline Processing --
188 -----------------------
190 -- For each call to an inlined subprogram, we make entries in a table
191 -- that stores caller and callee, and indicates the call direction from
192 -- one to the other. We also record the compilation unit that contains
193 -- the callee. After analyzing the bodies of all such compilation units,
194 -- we compute the transitive closure of inlined subprograms called from
195 -- the main compilation unit and make it available to the code generator
196 -- in no particular order, thus allowing cycles in the call graph.
198 Last_Inlined : Entity_Id := Empty;
200 -- For each entry in the table we keep a list of successors in topological
201 -- order, i.e. callers of the current subprogram.
203 type Subp_Index is new Nat;
204 No_Subp : constant Subp_Index := 0;
206 -- The subprogram entities are hashed into the Inlined table
208 Num_Hash_Headers : constant := 512;
210 Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1)
213 type Succ_Index is new Nat;
214 No_Succ : constant Succ_Index := 0;
216 type Succ_Info is record
221 -- The following table stores list elements for the successor lists. These
222 -- lists cannot be chained directly through entries in the Inlined table,
223 -- because a given subprogram can appear in several such lists.
225 package Successors is new Table.Table (
226 Table_Component_Type => Succ_Info,
227 Table_Index_Type => Succ_Index,
228 Table_Low_Bound => 1,
229 Table_Initial => Alloc.Successors_Initial,
230 Table_Increment => Alloc.Successors_Increment,
231 Table_Name => "Successors");
233 type Subp_Info is record
234 Name : Entity_Id := Empty;
235 Next : Subp_Index := No_Subp;
236 First_Succ : Succ_Index := No_Succ;
237 Main_Call : Boolean := False;
238 Processed : Boolean := False;
241 package Inlined is new Table.Table (
242 Table_Component_Type => Subp_Info,
243 Table_Index_Type => Subp_Index,
244 Table_Low_Bound => 1,
245 Table_Initial => Alloc.Inlined_Initial,
246 Table_Increment => Alloc.Inlined_Increment,
247 Table_Name => "Inlined");
249 -----------------------
250 -- Local Subprograms --
251 -----------------------
253 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty);
254 -- Make two entries in Inlined table, for an inlined subprogram being
255 -- called, and for the inlined subprogram that contains the call. If
256 -- the call is in the main compilation unit, Caller is Empty.
258 procedure Add_Inlined_Instance (E : Entity_Id);
259 -- Add instance E to the list of of inlined instances for the unit
261 procedure Add_Inlined_Subprogram (E : Entity_Id);
262 -- Add subprogram E to the list of inlined subprograms for the unit
264 function Add_Subp (E : Entity_Id) return Subp_Index;
265 -- Make entry in Inlined table for subprogram E, or return table index
266 -- that already holds E.
268 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id;
269 pragma Inline (Get_Code_Unit_Entity);
270 -- Return the entity node for the unit containing E. Always return the spec
273 function Has_Initialized_Type (E : Entity_Id) return Boolean;
274 -- If a candidate for inlining contains type declarations for types with
275 -- nontrivial initialization procedures, they are not worth inlining.
277 function Has_Single_Return (N : Node_Id) return Boolean;
278 -- In general we cannot inline functions that return unconstrained type.
279 -- However, we can handle such functions if all return statements return
280 -- a local variable that is the first declaration in the body of the
281 -- function. In that case the call can be replaced by that local
282 -- variable as is done for other inlined calls.
284 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean;
285 -- Return True if E is in the main unit or its spec or in a subunit
287 function Is_Nested (E : Entity_Id) return Boolean;
288 -- If the function is nested inside some other function, it will always
289 -- be compiled if that function is, so don't add it to the inline list.
290 -- We cannot compile a nested function outside the scope of the containing
291 -- function anyway. This is also the case if the function is defined in a
292 -- task body or within an entry (for example, an initialization procedure).
294 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id);
295 -- Remove all aspects and/or pragmas that have no meaning in inlined body
296 -- Body_Decl. The analysis of these items is performed on the non-inlined
297 -- body. The items currently removed are:
310 ------------------------------
311 -- Deferred Cleanup Actions --
312 ------------------------------
314 -- The cleanup actions for scopes that contain instantiations is delayed
315 -- until after expansion of those instantiations, because they may contain
316 -- finalizable objects or tasks that affect the cleanup code. A scope
317 -- that contains instantiations only needs to be finalized once, even
318 -- if it contains more than one instance. We keep a list of scopes
319 -- that must still be finalized, and call cleanup_actions after all
320 -- the instantiations have been completed.
324 procedure Add_Scope_To_Clean (Inst : Entity_Id);
325 -- Build set of scopes on which cleanup actions must be performed
327 procedure Cleanup_Scopes;
328 -- Complete cleanup actions on scopes that need it
334 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
335 P1 : constant Subp_Index := Add_Subp (Called);
340 if Present (Caller) then
341 P2 := Add_Subp (Caller);
343 -- Add P1 to the list of successors of P2, if not already there.
344 -- Note that P2 may contain more than one call to P1, and only
345 -- one needs to be recorded.
347 J := Inlined.Table (P2).First_Succ;
348 while J /= No_Succ loop
349 if Successors.Table (J).Subp = P1 then
353 J := Successors.Table (J).Next;
356 -- On exit, make a successor entry for P1
358 Successors.Increment_Last;
359 Successors.Table (Successors.Last).Subp := P1;
360 Successors.Table (Successors.Last).Next :=
361 Inlined.Table (P2).First_Succ;
362 Inlined.Table (P2).First_Succ := Successors.Last;
364 Inlined.Table (P1).Main_Call := True;
368 ----------------------
369 -- Add_Inlined_Body --
370 ----------------------
372 procedure Add_Inlined_Body (E : Entity_Id; N : Node_Id) is
374 type Inline_Level_Type is (Dont_Inline, Inline_Call, Inline_Package);
375 -- Level of inlining for the call: Dont_Inline means no inlining,
376 -- Inline_Call means that only the call is considered for inlining,
377 -- Inline_Package means that the call is considered for inlining and
378 -- its package compiled and scanned for more inlining opportunities.
380 function Is_Non_Loading_Expression_Function
381 (Id : Entity_Id) return Boolean;
382 -- Determine whether arbitrary entity Id denotes a subprogram which is
385 -- * An expression function
387 -- * A function completed by an expression function where both the
388 -- spec and body are in the same context.
390 function Must_Inline return Inline_Level_Type;
391 -- Inlining is only done if the call statement N is in the main unit,
392 -- or within the body of another inlined subprogram.
394 ----------------------------------------
395 -- Is_Non_Loading_Expression_Function --
396 ----------------------------------------
398 function Is_Non_Loading_Expression_Function
399 (Id : Entity_Id) return Boolean
406 -- A stand-alone expression function is transformed into a spec-body
407 -- pair in-place. Since both the spec and body are in the same list,
408 -- the inlining of such an expression function does not need to load
411 if Is_Expression_Function (Id) then
414 -- A function may be completed by an expression function
416 elsif Ekind (Id) = E_Function then
417 Spec_Decl := Unit_Declaration_Node (Id);
419 if Nkind (Spec_Decl) = N_Subprogram_Declaration then
420 Body_Id := Corresponding_Body (Spec_Decl);
422 if Present (Body_Id) then
423 Body_Decl := Unit_Declaration_Node (Body_Id);
425 -- The inlining of a completing expression function does
426 -- not need to load anything extra when both the spec and
427 -- body are in the same context.
430 Was_Expression_Function (Body_Decl)
431 and then Parent (Spec_Decl) = Parent (Body_Decl);
437 end Is_Non_Loading_Expression_Function;
443 function Must_Inline return Inline_Level_Type is
448 -- Check if call is in main unit
450 Scop := Current_Scope;
452 -- Do not try to inline if scope is standard. This could happen, for
453 -- example, for a call to Add_Global_Declaration, and it causes
454 -- trouble to try to inline at this level.
456 if Scop = Standard_Standard then
460 -- Otherwise lookup scope stack to outer scope
462 while Scope (Scop) /= Standard_Standard
463 and then not Is_Child_Unit (Scop)
465 Scop := Scope (Scop);
468 Comp := Parent (Scop);
469 while Nkind (Comp) /= N_Compilation_Unit loop
470 Comp := Parent (Comp);
473 -- If the call is in the main unit, inline the call and compile the
474 -- package of the subprogram to find more calls to be inlined.
476 if Comp = Cunit (Main_Unit)
477 or else Comp = Library_Unit (Cunit (Main_Unit))
480 return Inline_Package;
483 -- The call is not in the main unit. See if it is in some subprogram
484 -- that can be inlined outside its unit. If so, inline the call and,
485 -- if the inlining level is set to 1, stop there; otherwise also
486 -- compile the package as above.
488 Scop := Current_Scope;
489 while Scope (Scop) /= Standard_Standard
490 and then not Is_Child_Unit (Scop)
492 if Is_Overloadable (Scop)
493 and then Is_Inlined (Scop)
494 and then not Is_Nested (Scop)
498 if Inline_Level = 1 then
501 return Inline_Package;
505 Scop := Scope (Scop);
513 Level : Inline_Level_Type;
515 -- Start of processing for Add_Inlined_Body
518 Append_New_Elmt (N, To => Backend_Calls);
520 -- Skip subprograms that cannot or need not be inlined outside their
521 -- unit or parent subprogram.
523 if Is_Abstract_Subprogram (E)
524 or else Convention (E) = Convention_Protected
525 or else In_Main_Unit_Or_Subunit (E)
526 or else Is_Nested (E)
531 -- Find out whether the call must be inlined. Unless the result is
532 -- Dont_Inline, Must_Inline also creates an edge for the call in the
533 -- callgraph; however, it will not be activated until after Is_Called
534 -- is set on the subprogram.
536 Level := Must_Inline;
538 if Level = Dont_Inline then
542 -- If a previous call to the subprogram has been inlined, nothing to do
544 if Is_Called (E) then
548 -- If the subprogram is an instance, then inline the instance
550 if Is_Generic_Instance (E) then
551 Add_Inlined_Instance (E);
554 -- Mark the subprogram as called
558 -- If the call was generated by the compiler and is to a subprogram in
559 -- a run-time unit, we need to suppress debugging information for it,
560 -- so that the code that is eventually inlined will not affect the
561 -- debugging of the program. We do not do it if the call comes from
562 -- source because, even if the call is inlined, the user may expect it
563 -- to be present in the debugging information.
565 if not Comes_From_Source (N)
566 and then In_Extended_Main_Source_Unit (N)
567 and then Is_Predefined_Unit (Get_Source_Unit (E))
569 Set_Needs_Debug_Info (E, False);
572 -- If the subprogram is an expression function, or is completed by one
573 -- where both the spec and body are in the same context, then there is
574 -- no need to load any package body since the body of the function is
577 if Is_Non_Loading_Expression_Function (E) then
581 -- Find unit containing E, and add to list of inlined bodies if needed.
582 -- Library-level functions must be handled specially, because there is
583 -- no enclosing package to retrieve. In this case, it is the body of
584 -- the function that will have to be loaded.
587 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
591 Inlined_Bodies.Increment_Last;
592 Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
595 pragma Assert (Ekind (Pack) = E_Package);
597 -- If the subprogram is within an instance, inline the instance
599 if Comes_From_Source (E) then
602 while Present (Inst) and then Inst /= Standard_Standard loop
603 exit when Is_Generic_Instance (Inst);
604 Inst := Scope (Inst);
608 and then Is_Generic_Instance (Inst)
609 and then not Is_Called (Inst)
611 Inst_Decl := Unit_Declaration_Node (Inst);
613 -- Do not inline the instance if the body already exists,
614 -- or the instance node is simply missing.
616 if Present (Corresponding_Body (Inst_Decl))
617 or else (Nkind (Parent (Inst_Decl)) /= N_Compilation_Unit
618 and then No (Next (Inst_Decl)))
620 Set_Is_Called (Inst);
622 Add_Inlined_Instance (Inst);
627 -- If the unit containing E is an instance, nothing more to do
629 if Is_Generic_Instance (Pack) then
632 -- Do not inline the package if the subprogram is an init proc
633 -- or other internally generated subprogram, because in that
634 -- case the subprogram body appears in the same unit that
635 -- declares the type, and that body is visible to the back end.
636 -- Do not inline it either if it is in the main unit.
637 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
638 -- calls if the back end takes care of inlining the call.
639 -- Note that Level is in Inline_Call | Inline_Package here.
641 elsif ((Level = Inline_Call
642 and then Has_Pragma_Inline_Always (E)
643 and then Back_End_Inlining)
644 or else Level = Inline_Package)
645 and then not Is_Inlined (Pack)
646 and then not Is_Internal (E)
647 and then not In_Main_Unit_Or_Subunit (Pack)
649 Set_Is_Inlined (Pack);
650 Inlined_Bodies.Increment_Last;
651 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
655 -- Ensure that Analyze_Inlined_Bodies will be invoked after
656 -- completing the analysis of the current unit.
658 Inline_Processing_Required := True;
660 end Add_Inlined_Body;
662 --------------------------
663 -- Add_Inlined_Instance --
664 --------------------------
666 procedure Add_Inlined_Instance (E : Entity_Id) is
667 Decl_Node : constant Node_Id := Unit_Declaration_Node (E);
671 -- This machinery is only used with back-end inlining
673 if not Back_End_Inlining then
677 -- Register the instance in the list
679 Append_New_Elmt (Decl_Node, To => Backend_Instances);
681 -- Retrieve the index of its corresponding pending instantiation
682 -- and mark this corresponding pending instantiation as needed.
684 Index := To_Pending_Instantiations.Get (Decl_Node);
686 Called_Pending_Instantiations.Append (Index);
688 pragma Assert (False);
693 end Add_Inlined_Instance;
695 ----------------------------
696 -- Add_Inlined_Subprogram --
697 ----------------------------
699 procedure Add_Inlined_Subprogram (E : Entity_Id) is
700 Decl : constant Node_Id := Parent (Declaration_Node (E));
701 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
703 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id);
704 -- Append Subp to the list of subprograms inlined by the backend
706 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id);
707 -- Append Subp to the list of subprograms that cannot be inlined by
710 -----------------------------------------
711 -- Register_Backend_Inlined_Subprogram --
712 -----------------------------------------
714 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is
716 Append_New_Elmt (Subp, To => Backend_Inlined_Subps);
717 end Register_Backend_Inlined_Subprogram;
719 ---------------------------------------------
720 -- Register_Backend_Not_Inlined_Subprogram --
721 ---------------------------------------------
723 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is
725 Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps);
726 end Register_Backend_Not_Inlined_Subprogram;
728 -- Start of processing for Add_Inlined_Subprogram
731 -- We can inline the subprogram if its unit is known to be inlined or is
732 -- an instance whose body will be analyzed anyway or the subprogram was
733 -- generated as a body by the compiler (for example an initialization
734 -- procedure) or its declaration was provided along with the body (for
735 -- example an expression function) and it does not declare types with
736 -- nontrivial initialization procedures.
738 if (Is_Inlined (Pack)
739 or else Is_Generic_Instance (Pack)
740 or else Nkind (Decl) = N_Subprogram_Body
741 or else Present (Corresponding_Body (Decl)))
742 and then not Has_Initialized_Type (E)
744 Register_Backend_Inlined_Subprogram (E);
746 if No (Last_Inlined) then
747 Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
749 Set_Next_Inlined_Subprogram (Last_Inlined, E);
755 Register_Backend_Not_Inlined_Subprogram (E);
757 end Add_Inlined_Subprogram;
759 --------------------------------
760 -- Add_Pending_Instantiation --
761 --------------------------------
763 procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is
764 Act_Decl_Id : Entity_Id;
768 -- Here is a defense against a ludicrous number of instantiations
769 -- caused by a circular set of instantiation attempts.
771 if Pending_Instantiations.Last + 1 >= Maximum_Instantiations then
772 Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations);
773 Error_Msg_N ("too many instantiations, exceeds max of^", Inst);
774 Error_Msg_N ("\limit can be changed using -gnateinn switch", Inst);
775 raise Unrecoverable_Error;
778 -- Capture the body of the generic instantiation along with its context
779 -- for later processing by Instantiate_Bodies.
781 Pending_Instantiations.Append
782 ((Act_Decl => Act_Decl,
783 Config_Switches => Save_Config_Switches,
784 Current_Sem_Unit => Current_Sem_Unit,
785 Expander_Status => Expander_Active,
787 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
788 Scope_Suppress => Scope_Suppress,
789 Warnings => Save_Warnings));
791 -- With back-end inlining, also associate the index to the instantiation
793 if Back_End_Inlining then
794 Act_Decl_Id := Defining_Entity (Act_Decl);
795 Index := Pending_Instantiations.Last;
797 To_Pending_Instantiations.Set (Act_Decl, Index);
799 -- If an instantiation is in the main unit or subunit, or is a nested
800 -- subprogram, then its body is needed as per the analysis done in
801 -- Analyze_Package_Instantiation & Analyze_Subprogram_Instantiation.
803 if In_Main_Unit_Or_Subunit (Act_Decl_Id)
804 or else (Is_Subprogram (Act_Decl_Id)
805 and then Is_Nested (Act_Decl_Id))
807 Called_Pending_Instantiations.Append (Index);
809 Set_Is_Called (Act_Decl_Id);
812 end Add_Pending_Instantiation;
814 ------------------------
815 -- Add_Scope_To_Clean --
816 ------------------------
818 procedure Add_Scope_To_Clean (Inst : Entity_Id) is
819 Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
823 -- If the instance appears in a library-level package declaration,
824 -- all finalization is global, and nothing needs doing here.
826 if Scop = Standard_Standard then
830 -- If the instance is within a generic unit, no finalization code
831 -- can be generated. Note that at this point all bodies have been
832 -- analyzed, and the scope stack itself is not present, and the flag
833 -- Inside_A_Generic is not set.
840 while Present (S) and then S /= Standard_Standard loop
841 if Is_Generic_Unit (S) then
849 Elmt := First_Elmt (To_Clean);
850 while Present (Elmt) loop
851 if Node (Elmt) = Scop then
855 Elmt := Next_Elmt (Elmt);
858 Append_Elmt (Scop, To_Clean);
859 end Add_Scope_To_Clean;
865 function Add_Subp (E : Entity_Id) return Subp_Index is
866 Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
870 -- Initialize entry in Inlined table
872 procedure New_Entry is
874 Inlined.Increment_Last;
875 Inlined.Table (Inlined.Last).Name := E;
876 Inlined.Table (Inlined.Last).Next := No_Subp;
877 Inlined.Table (Inlined.Last).First_Succ := No_Succ;
878 Inlined.Table (Inlined.Last).Main_Call := False;
879 Inlined.Table (Inlined.Last).Processed := False;
882 -- Start of processing for Add_Subp
885 if Hash_Headers (Index) = No_Subp then
887 Hash_Headers (Index) := Inlined.Last;
891 J := Hash_Headers (Index);
892 while J /= No_Subp loop
893 if Inlined.Table (J).Name = E then
897 J := Inlined.Table (J).Next;
901 -- On exit, subprogram was not found. Enter in table. Index is
902 -- the current last entry on the hash chain.
905 Inlined.Table (Index).Next := Inlined.Last;
910 ----------------------------
911 -- Analyze_Inlined_Bodies --
912 ----------------------------
914 procedure Analyze_Inlined_Bodies is
921 type Pending_Index is new Nat;
923 package Pending_Inlined is new Table.Table (
924 Table_Component_Type => Subp_Index,
925 Table_Index_Type => Pending_Index,
926 Table_Low_Bound => 1,
927 Table_Initial => Alloc.Inlined_Initial,
928 Table_Increment => Alloc.Inlined_Increment,
929 Table_Name => "Pending_Inlined");
930 -- The workpile used to compute the transitive closure
932 -- Start of processing for Analyze_Inlined_Bodies
935 if Serious_Errors_Detected = 0 then
936 Push_Scope (Standard_Standard);
939 while J <= Inlined_Bodies.Last
940 and then Serious_Errors_Detected = 0
942 Pack := Inlined_Bodies.Table (J);
944 and then Scope (Pack) /= Standard_Standard
945 and then not Is_Child_Unit (Pack)
947 Pack := Scope (Pack);
950 Comp_Unit := Parent (Pack);
951 while Present (Comp_Unit)
952 and then Nkind (Comp_Unit) /= N_Compilation_Unit
954 Comp_Unit := Parent (Comp_Unit);
957 -- Load the body if it exists and contains inlineable entities,
958 -- unless it is the main unit, or is an instance whose body has
959 -- already been analyzed.
961 if Present (Comp_Unit)
962 and then Comp_Unit /= Cunit (Main_Unit)
963 and then Body_Required (Comp_Unit)
965 (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
967 (No (Corresponding_Body (Unit (Comp_Unit)))
968 and then Body_Needed_For_Inlining
969 (Defining_Entity (Unit (Comp_Unit)))))
972 Bname : constant Unit_Name_Type :=
973 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
978 if not Is_Loaded (Bname) then
979 Style_Check := False;
980 Load_Needed_Body (Comp_Unit, OK);
984 -- Warn that a body was not available for inlining
987 Error_Msg_Unit_1 := Bname;
989 ("one or more inlined subprograms accessed in $!??",
992 Get_File_Name (Bname, Subunit => False);
993 Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
1001 if J > Inlined_Bodies.Last then
1003 -- The analysis of required bodies may have produced additional
1004 -- generic instantiations. To obtain further inlining, we need
1005 -- to perform another round of generic body instantiations.
1009 -- Symmetrically, the instantiation of required generic bodies
1010 -- may have caused additional bodies to be inlined. To obtain
1011 -- further inlining, we keep looping over the inlined bodies.
1015 -- The list of inlined subprograms is an overestimate, because it
1016 -- includes inlined functions called from functions that are compiled
1017 -- as part of an inlined package, but are not themselves called. An
1018 -- accurate computation of just those subprograms that are needed
1019 -- requires that we perform a transitive closure over the call graph,
1020 -- starting from calls in the main compilation unit.
1022 for Index in Inlined.First .. Inlined.Last loop
1023 if not Is_Called (Inlined.Table (Index).Name) then
1025 -- This means that Add_Inlined_Body added the subprogram to the
1026 -- table but wasn't able to handle its code unit. Do nothing.
1028 Inlined.Table (Index).Processed := True;
1030 elsif Inlined.Table (Index).Main_Call then
1031 Pending_Inlined.Increment_Last;
1032 Pending_Inlined.Table (Pending_Inlined.Last) := Index;
1033 Inlined.Table (Index).Processed := True;
1036 Set_Is_Called (Inlined.Table (Index).Name, False);
1040 -- Iterate over the workpile until it is emptied, propagating the
1041 -- Is_Called flag to the successors of the processed subprogram.
1043 while Pending_Inlined.Last >= Pending_Inlined.First loop
1044 Subp := Pending_Inlined.Table (Pending_Inlined.Last);
1045 Pending_Inlined.Decrement_Last;
1047 S := Inlined.Table (Subp).First_Succ;
1049 while S /= No_Succ loop
1050 Subp := Successors.Table (S).Subp;
1052 if not Inlined.Table (Subp).Processed then
1053 Set_Is_Called (Inlined.Table (Subp).Name);
1054 Pending_Inlined.Increment_Last;
1055 Pending_Inlined.Table (Pending_Inlined.Last) := Subp;
1056 Inlined.Table (Subp).Processed := True;
1059 S := Successors.Table (S).Next;
1063 -- Finally add the called subprograms to the list of inlined
1064 -- subprograms for the unit.
1066 for Index in Inlined.First .. Inlined.Last loop
1067 if Is_Called (Inlined.Table (Index).Name) then
1068 Add_Inlined_Subprogram (Inlined.Table (Index).Name);
1074 end Analyze_Inlined_Bodies;
1076 --------------------------
1077 -- Build_Body_To_Inline --
1078 --------------------------
1080 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
1081 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1082 Analysis_Status : constant Boolean := Full_Analysis;
1083 Original_Body : Node_Id;
1084 Body_To_Analyze : Node_Id;
1085 Max_Size : constant := 10;
1087 function Has_Extended_Return return Boolean;
1088 -- This function returns True if the subprogram has an extended return
1091 function Has_Pending_Instantiation return Boolean;
1092 -- If some enclosing body contains instantiations that appear before
1093 -- the corresponding generic body, the enclosing body has a freeze node
1094 -- so that it can be elaborated after the generic itself. This might
1095 -- conflict with subsequent inlinings, so that it is unsafe to try to
1096 -- inline in such a case.
1098 function Has_Single_Return_In_GNATprove_Mode return Boolean;
1099 -- This function is called only in GNATprove mode, and it returns
1100 -- True if the subprogram has no return statement or a single return
1101 -- statement as last statement. It returns False for subprogram with
1102 -- a single return as last statement inside one or more blocks, as
1103 -- inlining would generate gotos in that case as well (although the
1104 -- goto is useless in that case).
1106 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
1107 -- If the body of the subprogram includes a call that returns an
1108 -- unconstrained type, the secondary stack is involved, and it is
1109 -- not worth inlining.
1111 -------------------------
1112 -- Has_Extended_Return --
1113 -------------------------
1115 function Has_Extended_Return return Boolean is
1116 Body_To_Inline : constant Node_Id := N;
1118 function Check_Return (N : Node_Id) return Traverse_Result;
1119 -- Returns OK on node N if this is not an extended return statement
1125 function Check_Return (N : Node_Id) return Traverse_Result is
1128 when N_Extended_Return_Statement =>
1131 -- Skip locally declared subprogram bodies inside the body to
1132 -- inline, as the return statements inside those do not count.
1134 when N_Subprogram_Body =>
1135 if N = Body_To_Inline then
1146 function Check_All_Returns is new Traverse_Func (Check_Return);
1148 -- Start of processing for Has_Extended_Return
1151 return Check_All_Returns (N) /= OK;
1152 end Has_Extended_Return;
1154 -------------------------------
1155 -- Has_Pending_Instantiation --
1156 -------------------------------
1158 function Has_Pending_Instantiation return Boolean is
1163 while Present (S) loop
1164 if Is_Compilation_Unit (S)
1165 or else Is_Child_Unit (S)
1169 elsif Ekind (S) = E_Package
1170 and then Has_Forward_Instantiation (S)
1179 end Has_Pending_Instantiation;
1181 -----------------------------------------
1182 -- Has_Single_Return_In_GNATprove_Mode --
1183 -----------------------------------------
1185 function Has_Single_Return_In_GNATprove_Mode return Boolean is
1186 Body_To_Inline : constant Node_Id := N;
1187 Last_Statement : Node_Id := Empty;
1189 function Check_Return (N : Node_Id) return Traverse_Result;
1190 -- Returns OK on node N if this is not a return statement different
1191 -- from the last statement in the subprogram.
1197 function Check_Return (N : Node_Id) return Traverse_Result is
1200 when N_Extended_Return_Statement
1201 | N_Simple_Return_Statement
1203 if N = Last_Statement then
1209 -- Skip locally declared subprogram bodies inside the body to
1210 -- inline, as the return statements inside those do not count.
1212 when N_Subprogram_Body =>
1213 if N = Body_To_Inline then
1224 function Check_All_Returns is new Traverse_Func (Check_Return);
1226 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
1229 -- Retrieve the last statement
1231 Last_Statement := Last (Statements (Handled_Statement_Sequence (N)));
1233 -- Check that the last statement is the only possible return
1234 -- statement in the subprogram.
1236 return Check_All_Returns (N) = OK;
1237 end Has_Single_Return_In_GNATprove_Mode;
1239 --------------------------
1240 -- Uses_Secondary_Stack --
1241 --------------------------
1243 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
1244 function Check_Call (N : Node_Id) return Traverse_Result;
1245 -- Look for function calls that return an unconstrained type
1251 function Check_Call (N : Node_Id) return Traverse_Result is
1253 if Nkind (N) = N_Function_Call
1254 and then Is_Entity_Name (Name (N))
1255 and then Is_Composite_Type (Etype (Entity (Name (N))))
1256 and then not Is_Constrained (Etype (Entity (Name (N))))
1259 ("cannot inline & (call returns unconstrained type)?",
1267 function Check_Calls is new Traverse_Func (Check_Call);
1270 return Check_Calls (Bod) = Abandon;
1271 end Uses_Secondary_Stack;
1273 -- Start of processing for Build_Body_To_Inline
1276 -- Return immediately if done already
1278 if Nkind (Decl) = N_Subprogram_Declaration
1279 and then Present (Body_To_Inline (Decl))
1283 -- Subprograms that have return statements in the middle of the body are
1284 -- inlined with gotos. GNATprove does not currently support gotos, so
1285 -- we prevent such inlining.
1287 elsif GNATprove_Mode
1288 and then not Has_Single_Return_In_GNATprove_Mode
1290 Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
1293 -- Functions that return controlled types cannot currently be inlined
1294 -- because they require secondary stack handling; controlled actions
1295 -- may also interfere in complex ways with inlining.
1297 elsif Ekind (Spec_Id) = E_Function
1298 and then Needs_Finalization (Etype (Spec_Id))
1301 ("cannot inline & (controlled return type)?", N, Spec_Id);
1305 if Present (Declarations (N))
1306 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
1311 if Present (Handled_Statement_Sequence (N)) then
1312 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1314 ("cannot inline& (exception handler)?",
1315 First (Exception_Handlers (Handled_Statement_Sequence (N))),
1319 elsif Has_Excluded_Statement
1320 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
1326 -- We do not inline a subprogram that is too large, unless it is marked
1327 -- Inline_Always or we are in GNATprove mode. This pragma does not
1328 -- suppress the other checks on inlining (forbidden declarations,
1331 if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode)
1332 and then List_Length
1333 (Statements (Handled_Statement_Sequence (N))) > Max_Size
1335 Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id);
1339 if Has_Pending_Instantiation then
1341 ("cannot inline& (forward instance within enclosing body)?",
1346 -- Within an instance, the body to inline must be treated as a nested
1347 -- generic, so that the proper global references are preserved.
1349 -- Note that we do not do this at the library level, because it is not
1350 -- needed, and furthermore this causes trouble if front-end inlining
1351 -- is activated (-gnatN).
1353 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1354 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1355 Original_Body := Copy_Generic_Node (N, Empty, Instantiating => True);
1357 Original_Body := Copy_Separate_Tree (N);
1360 -- We need to capture references to the formals in order to substitute
1361 -- the actuals at the point of inlining, i.e. instantiation. To treat
1362 -- the formals as globals to the body to inline, we nest it within a
1363 -- dummy parameterless subprogram, declared within the real one. To
1364 -- avoid generating an internal name (which is never public, and which
1365 -- affects serial numbers of other generated names), we use an internal
1366 -- symbol that cannot conflict with user declarations.
1368 Set_Parameter_Specifications (Specification (Original_Body), No_List);
1369 Set_Defining_Unit_Name
1370 (Specification (Original_Body),
1371 Make_Defining_Identifier (Sloc (N), Name_uParent));
1372 Set_Corresponding_Spec (Original_Body, Empty);
1374 -- Remove all aspects/pragmas that have no meaning in an inlined body
1376 Remove_Aspects_And_Pragmas (Original_Body);
1379 Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
1381 -- Set return type of function, which is also global and does not need
1384 if Ekind (Spec_Id) = E_Function then
1385 Set_Result_Definition
1386 (Specification (Body_To_Analyze),
1387 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1390 if No (Declarations (N)) then
1391 Set_Declarations (N, New_List (Body_To_Analyze));
1393 Append (Body_To_Analyze, Declarations (N));
1396 -- The body to inline is preanalyzed. In GNATprove mode we must disable
1397 -- full analysis as well so that light expansion does not take place
1398 -- either, and name resolution is unaffected.
1400 Expander_Mode_Save_And_Set (False);
1401 Full_Analysis := False;
1403 Analyze (Body_To_Analyze);
1404 Push_Scope (Defining_Entity (Body_To_Analyze));
1405 Save_Global_References (Original_Body);
1407 Remove (Body_To_Analyze);
1409 Expander_Mode_Restore;
1410 Full_Analysis := Analysis_Status;
1412 -- Restore environment if previously saved
1414 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1418 -- Functions that return unconstrained composite types require
1419 -- secondary stack handling, and cannot currently be inlined, unless
1420 -- all return statements return a local variable that is the first
1421 -- local declaration in the body. We had to delay this check until
1422 -- the body of the function is analyzed since Has_Single_Return()
1423 -- requires a minimum decoration.
1425 if Ekind (Spec_Id) = E_Function
1426 and then not Is_Scalar_Type (Etype (Spec_Id))
1427 and then not Is_Access_Type (Etype (Spec_Id))
1428 and then not Is_Constrained (Etype (Spec_Id))
1430 if not Has_Single_Return (Body_To_Analyze)
1432 -- Skip inlining if the function returns an unconstrained type
1433 -- using an extended return statement, since this part of the
1434 -- new inlining model is not yet supported by the current
1435 -- implementation. ???
1437 or else (Returns_Unconstrained_Type (Spec_Id)
1438 and then Has_Extended_Return)
1441 ("cannot inline & (unconstrained return type)?", N, Spec_Id);
1445 -- If secondary stack is used, there is no point in inlining. We have
1446 -- already issued the warning in this case, so nothing to do.
1448 elsif Uses_Secondary_Stack (Body_To_Analyze) then
1452 Set_Body_To_Inline (Decl, Original_Body);
1453 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1454 Set_Is_Inlined (Spec_Id);
1455 end Build_Body_To_Inline;
1457 -------------------------------------------
1458 -- Call_Can_Be_Inlined_In_GNATprove_Mode --
1459 -------------------------------------------
1461 function Call_Can_Be_Inlined_In_GNATprove_Mode
1463 Subp : Entity_Id) return Boolean
1469 F := First_Formal (Subp);
1470 A := First_Actual (N);
1471 while Present (F) loop
1472 if Ekind (F) /= E_Out_Parameter
1473 and then not Same_Type (Etype (F), Etype (A))
1475 (Is_By_Reference_Type (Etype (A))
1476 or else Is_Limited_Type (Etype (A)))
1486 end Call_Can_Be_Inlined_In_GNATprove_Mode;
1488 --------------------------------------
1489 -- Can_Be_Inlined_In_GNATprove_Mode --
1490 --------------------------------------
1492 function Can_Be_Inlined_In_GNATprove_Mode
1493 (Spec_Id : Entity_Id;
1494 Body_Id : Entity_Id) return Boolean
1496 function Has_Formal_With_Discriminant_Dependent_Fields
1497 (Id : Entity_Id) return Boolean;
1498 -- Returns true if the subprogram has at least one formal parameter of
1499 -- an unconstrained record type with per-object constraints on component
1502 function Has_Some_Contract (Id : Entity_Id) return Boolean;
1503 -- Return True if subprogram Id has any contract. The presence of
1504 -- Extensions_Visible or Volatile_Function is also considered as a
1507 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
1508 -- Return True if subprogram Id defines a compilation unit
1509 -- Shouldn't this be in Sem_Aux???
1511 function In_Package_Spec (Id : Entity_Id) return Boolean;
1512 -- Return True if subprogram Id is defined in the package specification,
1513 -- either its visible or private part.
1515 ---------------------------------------------------
1516 -- Has_Formal_With_Discriminant_Dependent_Fields --
1517 ---------------------------------------------------
1519 function Has_Formal_With_Discriminant_Dependent_Fields
1520 (Id : Entity_Id) return Boolean
1522 function Has_Discriminant_Dependent_Component
1523 (Typ : Entity_Id) return Boolean;
1524 -- Determine whether unconstrained record type Typ has at least one
1525 -- component that depends on a discriminant.
1527 ------------------------------------------
1528 -- Has_Discriminant_Dependent_Component --
1529 ------------------------------------------
1531 function Has_Discriminant_Dependent_Component
1532 (Typ : Entity_Id) return Boolean
1537 -- Inspect all components of the record type looking for one that
1538 -- depends on a discriminant.
1540 Comp := First_Component (Typ);
1541 while Present (Comp) loop
1542 if Has_Discriminant_Dependent_Constraint (Comp) then
1546 Next_Component (Comp);
1550 end Has_Discriminant_Dependent_Component;
1554 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1556 Formal_Typ : Entity_Id;
1558 -- Start of processing for
1559 -- Has_Formal_With_Discriminant_Dependent_Fields
1562 -- Inspect all parameters of the subprogram looking for a formal
1563 -- of an unconstrained record type with at least one discriminant
1564 -- dependent component.
1566 Formal := First_Formal (Subp_Id);
1567 while Present (Formal) loop
1568 Formal_Typ := Etype (Formal);
1570 if Is_Record_Type (Formal_Typ)
1571 and then not Is_Constrained (Formal_Typ)
1572 and then Has_Discriminant_Dependent_Component (Formal_Typ)
1577 Next_Formal (Formal);
1581 end Has_Formal_With_Discriminant_Dependent_Fields;
1583 -----------------------
1584 -- Has_Some_Contract --
1585 -----------------------
1587 function Has_Some_Contract (Id : Entity_Id) return Boolean is
1591 -- A call to an expression function may precede the actual body which
1592 -- is inserted at the end of the enclosing declarations. Ensure that
1593 -- the related entity is decorated before inspecting the contract.
1595 if Is_Subprogram_Or_Generic_Subprogram (Id) then
1596 Items := Contract (Id);
1598 -- Note that Classifications is not Empty when Extensions_Visible
1599 -- or Volatile_Function is present, which causes such subprograms
1600 -- to be considered to have a contract here. This is fine as we
1601 -- want to avoid inlining these too.
1603 return Present (Items)
1604 and then (Present (Pre_Post_Conditions (Items)) or else
1605 Present (Contract_Test_Cases (Items)) or else
1606 Present (Classifications (Items)));
1610 end Has_Some_Contract;
1612 ---------------------
1613 -- In_Package_Spec --
1614 ---------------------
1616 function In_Package_Spec (Id : Entity_Id) return Boolean is
1617 P : constant Node_Id := Parent (Subprogram_Spec (Id));
1618 -- Parent of the subprogram's declaration
1621 return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
1622 end In_Package_Spec;
1624 ------------------------
1625 -- Is_Unit_Subprogram --
1626 ------------------------
1628 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1629 Decl : Node_Id := Parent (Parent (Id));
1631 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1632 Decl := Parent (Decl);
1635 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1636 end Is_Unit_Subprogram;
1638 -- Local declarations
1641 -- Procedure or function entity for the subprogram
1643 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1646 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1648 if Present (Spec_Id) then
1654 -- Only local subprograms without contracts are inlined in GNATprove
1655 -- mode, as these are the subprograms which a user is not interested in
1656 -- analyzing in isolation, but rather in the context of their call. This
1657 -- is a convenient convention, that could be changed for an explicit
1658 -- pragma/aspect one day.
1660 -- In a number of special cases, inlining is not desirable or not
1661 -- possible, see below.
1663 -- Do not inline unit-level subprograms
1665 if Is_Unit_Subprogram (Id) then
1668 -- Do not inline subprograms declared in package specs, because they are
1669 -- not local, i.e. can be called either from anywhere (if declared in
1670 -- visible part) or from the child units (if declared in private part).
1672 elsif In_Package_Spec (Id) then
1675 -- Do not inline subprograms declared in other units. This is important
1676 -- in particular for subprograms defined in the private part of a
1677 -- package spec, when analyzing one of its child packages, as otherwise
1678 -- we issue spurious messages about the impossibility to inline such
1681 elsif not In_Extended_Main_Code_Unit (Id) then
1684 -- Do not inline subprograms marked No_Return, possibly used for
1685 -- signaling errors, which GNATprove handles specially.
1687 elsif No_Return (Id) then
1690 -- Do not inline subprograms that have a contract on the spec or the
1691 -- body. Use the contract(s) instead in GNATprove. This also prevents
1692 -- inlining of subprograms with Extensions_Visible or Volatile_Function.
1694 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
1696 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
1700 -- Do not inline expression functions, which are directly inlined at the
1703 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
1705 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
1709 -- Do not inline generic subprogram instances. The visibility rules of
1710 -- generic instances plays badly with inlining.
1712 elsif Is_Generic_Instance (Spec_Id) then
1715 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1716 -- the subprogram body, a similar check is performed after the body
1717 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1719 elsif Present (Spec_Id)
1721 (No (SPARK_Pragma (Spec_Id))
1723 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
1727 -- Subprograms in generic instances are currently not inlined, to avoid
1728 -- problems with inlining of standard library subprograms.
1730 elsif Instantiation_Location (Sloc (Id)) /= No_Location then
1733 -- Do not inline subprograms and entries defined inside protected types,
1734 -- which typically are not helper subprograms, which also avoids getting
1735 -- spurious messages on calls that cannot be inlined.
1737 elsif Within_Protected_Type (Id) then
1740 -- Do not inline predicate functions (treated specially by GNATprove)
1742 elsif Is_Predicate_Function (Id) then
1745 -- Do not inline subprograms with a parameter of an unconstrained
1746 -- record type if it has discrimiant dependent fields. Indeed, with
1747 -- such parameters, the frontend cannot always ensure type compliance
1748 -- in record component accesses (in particular with records containing
1751 elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
1754 -- Otherwise, this is a subprogram declared inside the private part of a
1755 -- package, or inside a package body, or locally in a subprogram, and it
1756 -- does not have any contract. Inline it.
1761 end Can_Be_Inlined_In_GNATprove_Mode;
1767 procedure Cannot_Inline
1771 Is_Serious : Boolean := False)
1774 -- In GNATprove mode, inlining is the technical means by which the
1775 -- higher-level goal of contextual analysis is reached, so issue
1776 -- messages about failure to apply contextual analysis to a
1777 -- subprogram, rather than failure to inline it.
1780 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
1783 Len1 : constant Positive :=
1784 String (String'("cannot inline"))'Length;
1785 Len2 : constant Positive :=
1786 String (String'("info: no contextual analysis of"))'Length;
1788 New_Msg : String (1 .. Msg'Length + Len2 - Len1);
1791 New_Msg (1 .. Len2) := "info: no contextual analysis of";
1792 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
1793 Msg (Msg'First + Len1 .. Msg'Last);
1794 Cannot_Inline (New_Msg, N, Subp, Is_Serious);
1799 pragma Assert (Msg (Msg'Last) = '?');
1801 -- Legacy front-end inlining model
1803 if not Back_End_Inlining then
1805 -- Do not emit warning if this is a predefined unit which is not
1806 -- the main unit. With validity checks enabled, some predefined
1807 -- subprograms may contain nested subprograms and become ineligible
1810 if Is_Predefined_Unit (Get_Source_Unit (Subp))
1811 and then not In_Extended_Main_Source_Unit (Subp)
1815 -- In GNATprove mode, issue a warning when -gnatd_f is set, and
1816 -- indicate that the subprogram is not always inlined by setting
1817 -- flag Is_Inlined_Always to False.
1819 elsif GNATprove_Mode then
1820 Set_Is_Inlined_Always (Subp, False);
1822 if Debug_Flag_Underscore_F then
1823 Error_Msg_NE (Msg, N, Subp);
1826 elsif Has_Pragma_Inline_Always (Subp) then
1828 -- Remove last character (question mark) to make this into an
1829 -- error, because the Inline_Always pragma cannot be obeyed.
1831 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1833 elsif Ineffective_Inline_Warnings then
1834 Error_Msg_NE (Msg & "p?", N, Subp);
1837 -- New semantics relying on back-end inlining
1839 elsif Is_Serious then
1841 -- Remove last character (question mark) to make this into an error.
1843 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1845 -- In GNATprove mode, issue a warning when -gnatd_f is set, and
1846 -- indicate that the subprogram is not always inlined by setting
1847 -- flag Is_Inlined_Always to False.
1849 elsif GNATprove_Mode then
1850 Set_Is_Inlined_Always (Subp, False);
1852 if Debug_Flag_Underscore_F then
1853 Error_Msg_NE (Msg, N, Subp);
1858 -- Do not emit warning if this is a predefined unit which is not
1859 -- the main unit. This behavior is currently provided for backward
1860 -- compatibility but it will be removed when we enforce the
1861 -- strictness of the new rules.
1863 if Is_Predefined_Unit (Get_Source_Unit (Subp))
1864 and then not In_Extended_Main_Source_Unit (Subp)
1868 elsif Has_Pragma_Inline_Always (Subp) then
1870 -- Emit a warning if this is a call to a runtime subprogram
1871 -- which is located inside a generic. Previously this call
1872 -- was silently skipped.
1874 if Is_Generic_Instance (Subp) then
1876 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
1878 if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then
1879 Set_Is_Inlined (Subp, False);
1880 Error_Msg_NE (Msg & "p?", N, Subp);
1886 -- Remove last character (question mark) to make this into an
1887 -- error, because the Inline_Always pragma cannot be obeyed.
1889 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1892 Set_Is_Inlined (Subp, False);
1894 if Ineffective_Inline_Warnings then
1895 Error_Msg_NE (Msg & "p?", N, Subp);
1901 --------------------------------------------
1902 -- Check_And_Split_Unconstrained_Function --
1903 --------------------------------------------
1905 procedure Check_And_Split_Unconstrained_Function
1907 Spec_Id : Entity_Id;
1908 Body_Id : Entity_Id)
1910 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
1911 -- Use generic machinery to build an unexpanded body for the subprogram.
1912 -- This body is subsequently used for inline expansions at call sites.
1914 procedure Build_Return_Object_Formal
1918 -- Create a formal parameter for return object declaration Obj_Decl of
1919 -- an extended return statement and add it to list Formals.
1921 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
1922 -- Return true if we generate code for the function body N, the function
1923 -- body N has no local declarations and its unique statement is a single
1924 -- extended return statement with a handled statements sequence.
1926 procedure Copy_Formals
1928 Subp_Id : Entity_Id;
1930 -- Create new formal parameters from the formal parameters of subprogram
1931 -- Subp_Id and add them to list Formals.
1933 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id;
1934 -- Create a copy of return object declaration Obj_Decl of an extended
1935 -- return statement.
1937 procedure Split_Unconstrained_Function
1939 Spec_Id : Entity_Id);
1940 -- N is an inlined function body that returns an unconstrained type and
1941 -- has a single extended return statement. Split N in two subprograms:
1942 -- a procedure P' and a function F'. The formals of P' duplicate the
1943 -- formals of N plus an extra formal which is used to return a value;
1944 -- its body is composed by the declarations and list of statements
1945 -- of the extended return statement of N.
1947 --------------------------
1948 -- Build_Body_To_Inline --
1949 --------------------------
1951 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
1952 procedure Generate_Subprogram_Body
1954 Body_To_Inline : out Node_Id);
1955 -- Generate a parameterless duplicate of subprogram body N. Note that
1956 -- occurrences of pragmas referencing the formals are removed since
1957 -- they have no meaning when the body is inlined and the formals are
1958 -- rewritten (the analysis of the non-inlined body will handle these
1959 -- pragmas). A new internal name is associated with Body_To_Inline.
1961 ------------------------------
1962 -- Generate_Subprogram_Body --
1963 ------------------------------
1965 procedure Generate_Subprogram_Body
1967 Body_To_Inline : out Node_Id)
1970 -- Within an instance, the body to inline must be treated as a
1971 -- nested generic so that proper global references are preserved.
1973 -- Note that we do not do this at the library level, because it
1974 -- is not needed, and furthermore this causes trouble if front
1975 -- end inlining is activated (-gnatN).
1978 and then Scope (Current_Scope) /= Standard_Standard
1981 Copy_Generic_Node (N, Empty, Instantiating => True);
1983 -- ??? Shouldn't this use New_Copy_Tree? What about global
1984 -- references captured in the body to inline?
1986 Body_To_Inline := Copy_Separate_Tree (N);
1989 -- Remove aspects/pragmas that have no meaning in an inlined body
1991 Remove_Aspects_And_Pragmas (Body_To_Inline);
1993 -- We need to capture references to the formals in order
1994 -- to substitute the actuals at the point of inlining, i.e.
1995 -- instantiation. To treat the formals as globals to the body to
1996 -- inline, we nest it within a dummy parameterless subprogram,
1997 -- declared within the real one.
1999 Set_Parameter_Specifications
2000 (Specification (Body_To_Inline), No_List);
2002 -- A new internal name is associated with Body_To_Inline to avoid
2003 -- conflicts when the non-inlined body N is analyzed.
2005 Set_Defining_Unit_Name (Specification (Body_To_Inline),
2006 Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P')));
2007 Set_Corresponding_Spec (Body_To_Inline, Empty);
2008 end Generate_Subprogram_Body;
2012 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2013 Original_Body : Node_Id;
2014 Body_To_Analyze : Node_Id;
2016 -- Start of processing for Build_Body_To_Inline
2019 pragma Assert (Current_Scope = Spec_Id);
2021 -- Within an instance, the body to inline must be treated as a nested
2022 -- generic, so that the proper global references are preserved. We
2023 -- do not do this at the library level, because it is not needed, and
2024 -- furthermore this causes trouble if front-end inlining is activated
2028 and then Scope (Current_Scope) /= Standard_Standard
2030 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
2033 -- Capture references to formals in order to substitute the actuals
2034 -- at the point of inlining or instantiation. To treat the formals
2035 -- as globals to the body to inline, nest the body within a dummy
2036 -- parameterless subprogram, declared within the real one.
2038 Generate_Subprogram_Body (N, Original_Body);
2040 Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
2042 -- Set return type of function, which is also global and does not
2043 -- need to be resolved.
2045 if Ekind (Spec_Id) = E_Function then
2046 Set_Result_Definition (Specification (Body_To_Analyze),
2047 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
2050 if No (Declarations (N)) then
2051 Set_Declarations (N, New_List (Body_To_Analyze));
2053 Append_To (Declarations (N), Body_To_Analyze);
2056 Preanalyze (Body_To_Analyze);
2058 Push_Scope (Defining_Entity (Body_To_Analyze));
2059 Save_Global_References (Original_Body);
2061 Remove (Body_To_Analyze);
2063 -- Restore environment if previously saved
2066 and then Scope (Current_Scope) /= Standard_Standard
2071 pragma Assert (No (Body_To_Inline (Decl)));
2072 Set_Body_To_Inline (Decl, Original_Body);
2073 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
2074 end Build_Body_To_Inline;
2076 --------------------------------
2077 -- Build_Return_Object_Formal --
2078 --------------------------------
2080 procedure Build_Return_Object_Formal
2085 Obj_Def : constant Node_Id := Object_Definition (Obj_Decl);
2086 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2090 -- Build the type definition of the formal parameter. The use of
2091 -- New_Copy_Tree ensures that global references preserved in the
2092 -- case of generics.
2094 if Is_Entity_Name (Obj_Def) then
2095 Typ_Def := New_Copy_Tree (Obj_Def);
2097 Typ_Def := New_Copy_Tree (Subtype_Mark (Obj_Def));
2102 -- Obj_Id : [out] Typ_Def
2104 -- Mode OUT should not be used when the return object is declared as
2105 -- a constant. Check the definition of the object declaration because
2106 -- the object has not been analyzed yet.
2109 Make_Parameter_Specification (Loc,
2110 Defining_Identifier =>
2111 Make_Defining_Identifier (Loc, Chars (Obj_Id)),
2112 In_Present => False,
2113 Out_Present => not Constant_Present (Obj_Decl),
2114 Null_Exclusion_Present => False,
2115 Parameter_Type => Typ_Def));
2116 end Build_Return_Object_Formal;
2118 --------------------------------------
2119 -- Can_Split_Unconstrained_Function --
2120 --------------------------------------
2122 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is
2123 Stmt : constant Node_Id :=
2124 First (Statements (Handled_Statement_Sequence (N)));
2128 -- No user defined declarations allowed in the function except inside
2129 -- the unique return statement; implicit labels are the only allowed
2132 Decl := First (Declarations (N));
2133 while Present (Decl) loop
2134 if Nkind (Decl) /= N_Implicit_Label_Declaration then
2141 -- We only split the inlined function when we are generating the code
2142 -- of its body; otherwise we leave duplicated split subprograms in
2143 -- the tree which (if referenced) generate wrong references at link
2146 return In_Extended_Main_Code_Unit (N)
2147 and then Present (Stmt)
2148 and then Nkind (Stmt) = N_Extended_Return_Statement
2149 and then No (Next (Stmt))
2150 and then Present (Handled_Statement_Sequence (Stmt));
2151 end Can_Split_Unconstrained_Function;
2157 procedure Copy_Formals
2159 Subp_Id : Entity_Id;
2166 Formal := First_Formal (Subp_Id);
2167 while Present (Formal) loop
2168 Spec := Parent (Formal);
2170 -- Create an exact copy of the formal parameter. The use of
2171 -- New_Copy_Tree ensures that global references are preserved
2172 -- in case of generics.
2175 Make_Parameter_Specification (Loc,
2176 Defining_Identifier =>
2177 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
2178 In_Present => In_Present (Spec),
2179 Out_Present => Out_Present (Spec),
2180 Null_Exclusion_Present => Null_Exclusion_Present (Spec),
2182 New_Copy_Tree (Parameter_Type (Spec)),
2183 Expression => New_Copy_Tree (Expression (Spec))));
2185 Next_Formal (Formal);
2189 ------------------------
2190 -- Copy_Return_Object --
2191 ------------------------
2193 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id is
2194 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2197 -- The use of New_Copy_Tree ensures that global references are
2198 -- preserved in case of generics.
2201 Make_Object_Declaration (Sloc (Obj_Decl),
2202 Defining_Identifier =>
2203 Make_Defining_Identifier (Sloc (Obj_Id), Chars (Obj_Id)),
2204 Aliased_Present => Aliased_Present (Obj_Decl),
2205 Constant_Present => Constant_Present (Obj_Decl),
2206 Null_Exclusion_Present => Null_Exclusion_Present (Obj_Decl),
2207 Object_Definition =>
2208 New_Copy_Tree (Object_Definition (Obj_Decl)),
2209 Expression => New_Copy_Tree (Expression (Obj_Decl)));
2210 end Copy_Return_Object;
2212 ----------------------------------
2213 -- Split_Unconstrained_Function --
2214 ----------------------------------
2216 procedure Split_Unconstrained_Function
2218 Spec_Id : Entity_Id)
2220 Loc : constant Source_Ptr := Sloc (N);
2221 Ret_Stmt : constant Node_Id :=
2222 First (Statements (Handled_Statement_Sequence (N)));
2223 Ret_Obj : constant Node_Id :=
2224 First (Return_Object_Declarations (Ret_Stmt));
2226 procedure Build_Procedure
2227 (Proc_Id : out Entity_Id;
2228 Decl_List : out List_Id);
2229 -- Build a procedure containing the statements found in the extended
2230 -- return statement of the unconstrained function body N.
2232 ---------------------
2233 -- Build_Procedure --
2234 ---------------------
2236 procedure Build_Procedure
2237 (Proc_Id : out Entity_Id;
2238 Decl_List : out List_Id)
2240 Formals : constant List_Id := New_List;
2241 Subp_Name : constant Name_Id := New_Internal_Name ('F');
2243 Body_Decls : List_Id := No_List;
2245 Proc_Body : Node_Id;
2246 Proc_Spec : Node_Id;
2249 -- Create formal parameters for the return object and all formals
2250 -- of the unconstrained function in order to pass their values to
2253 Build_Return_Object_Formal
2255 Obj_Decl => Ret_Obj,
2256 Formals => Formals);
2261 Formals => Formals);
2263 Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name);
2266 Make_Procedure_Specification (Loc,
2267 Defining_Unit_Name => Proc_Id,
2268 Parameter_Specifications => Formals);
2270 Decl_List := New_List;
2272 Append_To (Decl_List,
2273 Make_Subprogram_Declaration (Loc, Proc_Spec));
2275 -- Can_Convert_Unconstrained_Function checked that the function
2276 -- has no local declarations except implicit label declarations.
2277 -- Copy these declarations to the built procedure.
2279 if Present (Declarations (N)) then
2280 Body_Decls := New_List;
2282 Decl := First (Declarations (N));
2283 while Present (Decl) loop
2284 pragma Assert (Nkind (Decl) = N_Implicit_Label_Declaration);
2286 Append_To (Body_Decls,
2287 Make_Implicit_Label_Declaration (Loc,
2288 Make_Defining_Identifier (Loc,
2289 Chars => Chars (Defining_Identifier (Decl))),
2290 Label_Construct => Empty));
2296 pragma Assert (Present (Handled_Statement_Sequence (Ret_Stmt)));
2299 Make_Subprogram_Body (Loc,
2300 Specification => Copy_Subprogram_Spec (Proc_Spec),
2301 Declarations => Body_Decls,
2302 Handled_Statement_Sequence =>
2303 New_Copy_Tree (Handled_Statement_Sequence (Ret_Stmt)));
2305 Set_Defining_Unit_Name (Specification (Proc_Body),
2306 Make_Defining_Identifier (Loc, Subp_Name));
2308 Append_To (Decl_List, Proc_Body);
2309 end Build_Procedure;
2313 New_Obj : constant Node_Id := Copy_Return_Object (Ret_Obj);
2315 Proc_Call : Node_Id;
2316 Proc_Id : Entity_Id;
2318 -- Start of processing for Split_Unconstrained_Function
2321 -- Build the associated procedure, analyze it and insert it before
2322 -- the function body N.
2325 Scope : constant Entity_Id := Current_Scope;
2326 Decl_List : List_Id;
2329 Build_Procedure (Proc_Id, Decl_List);
2330 Insert_Actions (N, Decl_List);
2331 Set_Is_Inlined (Proc_Id);
2335 -- Build the call to the generated procedure
2338 Actual_List : constant List_Id := New_List;
2342 Append_To (Actual_List,
2343 New_Occurrence_Of (Defining_Identifier (New_Obj), Loc));
2345 Formal := First_Formal (Spec_Id);
2346 while Present (Formal) loop
2347 Append_To (Actual_List, New_Occurrence_Of (Formal, Loc));
2349 -- Avoid spurious warning on unreferenced formals
2351 Set_Referenced (Formal);
2352 Next_Formal (Formal);
2356 Make_Procedure_Call_Statement (Loc,
2357 Name => New_Occurrence_Of (Proc_Id, Loc),
2358 Parameter_Associations => Actual_List);
2366 -- Proc (New_Obj, ...);
2371 Make_Block_Statement (Loc,
2372 Declarations => New_List (New_Obj),
2373 Handled_Statement_Sequence =>
2374 Make_Handled_Sequence_Of_Statements (Loc,
2375 Statements => New_List (
2379 Make_Simple_Return_Statement (Loc,
2382 (Defining_Identifier (New_Obj), Loc)))));
2384 Rewrite (Ret_Stmt, Blk_Stmt);
2385 end Split_Unconstrained_Function;
2389 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2391 -- Start of processing for Check_And_Split_Unconstrained_Function
2394 pragma Assert (Back_End_Inlining
2395 and then Ekind (Spec_Id) = E_Function
2396 and then Returns_Unconstrained_Type (Spec_Id)
2397 and then Comes_From_Source (Body_Id)
2398 and then (Has_Pragma_Inline_Always (Spec_Id)
2399 or else Optimization_Level > 0));
2401 -- This routine must not be used in GNATprove mode since GNATprove
2402 -- relies on frontend inlining
2404 pragma Assert (not GNATprove_Mode);
2406 -- No need to split the function if we cannot generate the code
2408 if Serious_Errors_Detected /= 0 then
2412 -- No action needed in stubs since the attribute Body_To_Inline
2415 if Nkind (Decl) = N_Subprogram_Body_Stub then
2418 -- Cannot build the body to inline if the attribute is already set.
2419 -- This attribute may have been set if this is a subprogram renaming
2420 -- declarations (see Freeze.Build_Renamed_Body).
2422 elsif Present (Body_To_Inline (Decl)) then
2425 -- Do not generate a body to inline for protected functions, because the
2426 -- transformation generates a call to a protected procedure, causing
2427 -- spurious errors. We don't inline protected operations anyway, so
2428 -- this is no loss. We might as well ignore intrinsics and foreign
2429 -- conventions as well -- just allow Ada conventions.
2431 elsif not (Convention (Spec_Id) = Convention_Ada
2432 or else Convention (Spec_Id) = Convention_Ada_Pass_By_Copy
2433 or else Convention (Spec_Id) = Convention_Ada_Pass_By_Reference)
2437 -- Check excluded declarations
2439 elsif Present (Declarations (N))
2440 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
2444 -- Check excluded statements. There is no need to protect us against
2445 -- exception handlers since they are supported by the GCC backend.
2447 elsif Present (Handled_Statement_Sequence (N))
2448 and then Has_Excluded_Statement
2449 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
2454 -- Build the body to inline only if really needed
2456 if Can_Split_Unconstrained_Function (N) then
2457 Split_Unconstrained_Function (N, Spec_Id);
2458 Build_Body_To_Inline (N, Spec_Id);
2459 Set_Is_Inlined (Spec_Id);
2461 end Check_And_Split_Unconstrained_Function;
2463 -------------------------------------
2464 -- Check_Package_Body_For_Inlining --
2465 -------------------------------------
2467 procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
2468 Bname : Unit_Name_Type;
2473 -- Legacy implementation (relying on frontend inlining)
2475 if not Back_End_Inlining
2476 and then Is_Compilation_Unit (P)
2477 and then not Is_Generic_Instance (P)
2479 Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
2481 E := First_Entity (P);
2482 while Present (E) loop
2483 if Has_Pragma_Inline_Always (E)
2484 or else (Has_Pragma_Inline (E) and Front_End_Inlining)
2486 if not Is_Loaded (Bname) then
2487 Load_Needed_Body (N, OK);
2491 -- Check we are not trying to inline a parent whose body
2492 -- depends on a child, when we are compiling the body of
2493 -- the child. Otherwise we have a potential elaboration
2494 -- circularity with inlined subprograms and with
2495 -- Taft-Amendment types.
2498 Comp : Node_Id; -- Body just compiled
2499 Child_Spec : Entity_Id; -- Spec of main unit
2500 Ent : Entity_Id; -- For iteration
2501 With_Clause : Node_Id; -- Context of body.
2504 if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
2505 and then Present (Body_Entity (P))
2509 ((Unit (Library_Unit (Cunit (Main_Unit)))));
2512 Parent (Unit_Declaration_Node (Body_Entity (P)));
2514 -- Check whether the context of the body just
2515 -- compiled includes a child of itself, and that
2516 -- child is the spec of the main compilation.
2518 With_Clause := First (Context_Items (Comp));
2519 while Present (With_Clause) loop
2520 if Nkind (With_Clause) = N_With_Clause
2522 Scope (Entity (Name (With_Clause))) = P
2524 Entity (Name (With_Clause)) = Child_Spec
2526 Error_Msg_Node_2 := Child_Spec;
2528 ("body of & depends on child unit&??",
2531 ("\subprograms in body cannot be inlined??",
2534 -- Disable further inlining from this unit,
2535 -- and keep Taft-amendment types incomplete.
2537 Ent := First_Entity (P);
2538 while Present (Ent) loop
2540 and then Has_Completion_In_Body (Ent)
2542 Set_Full_View (Ent, Empty);
2544 elsif Is_Subprogram (Ent) then
2545 Set_Is_Inlined (Ent, False);
2559 elsif Ineffective_Inline_Warnings then
2560 Error_Msg_Unit_1 := Bname;
2562 ("unable to inline subprograms defined in $??", P);
2563 Error_Msg_N ("\body not found??", P);
2574 end Check_Package_Body_For_Inlining;
2576 --------------------
2577 -- Cleanup_Scopes --
2578 --------------------
2580 procedure Cleanup_Scopes is
2586 Elmt := First_Elmt (To_Clean);
2587 while Present (Elmt) loop
2588 Scop := Node (Elmt);
2590 if Ekind (Scop) = E_Entry then
2591 Scop := Protected_Body_Subprogram (Scop);
2593 elsif Is_Subprogram (Scop)
2594 and then Is_Protected_Type (Scope (Scop))
2595 and then Present (Protected_Body_Subprogram (Scop))
2597 -- If a protected operation contains an instance, its cleanup
2598 -- operations have been delayed, and the subprogram has been
2599 -- rewritten in the expansion of the enclosing protected body. It
2600 -- is the corresponding subprogram that may require the cleanup
2601 -- operations, so propagate the information that triggers cleanup
2605 (Protected_Body_Subprogram (Scop),
2606 Uses_Sec_Stack (Scop));
2608 Scop := Protected_Body_Subprogram (Scop);
2611 if Ekind (Scop) = E_Block then
2612 Decl := Parent (Block_Node (Scop));
2615 Decl := Unit_Declaration_Node (Scop);
2617 if Nkind_In (Decl, N_Subprogram_Declaration,
2618 N_Task_Type_Declaration,
2619 N_Subprogram_Body_Stub)
2621 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
2626 Expand_Cleanup_Actions (Decl);
2629 Elmt := Next_Elmt (Elmt);
2633 -------------------------
2634 -- Expand_Inlined_Call --
2635 -------------------------
2637 procedure Expand_Inlined_Call
2640 Orig_Subp : Entity_Id)
2642 Decls : constant List_Id := New_List;
2643 Is_Predef : constant Boolean :=
2644 Is_Predefined_Unit (Get_Source_Unit (Subp));
2645 Loc : constant Source_Ptr := Sloc (N);
2646 Orig_Bod : constant Node_Id :=
2647 Body_To_Inline (Unit_Declaration_Node (Subp));
2649 Uses_Back_End : constant Boolean :=
2650 Back_End_Inlining and then Optimization_Level > 0;
2651 -- The back-end expansion is used if the target supports back-end
2652 -- inlining and some level of optimixation is required; otherwise
2653 -- the inlining takes place fully as a tree expansion.
2657 Exit_Lab : Entity_Id := Empty;
2660 Lab_Decl : Node_Id := Empty;
2664 Ret_Type : Entity_Id;
2666 Temp_Typ : Entity_Id;
2669 Is_Unc_Decl : Boolean;
2670 -- If the type returned by the function is unconstrained and the call
2671 -- can be inlined, special processing is required.
2673 Return_Object : Entity_Id := Empty;
2674 -- Entity in declaration in an extended_return_statement
2676 Targ : Node_Id := Empty;
2677 -- The target of the call. If context is an assignment statement then
2678 -- this is the left-hand side of the assignment, else it is a temporary
2679 -- to which the return value is assigned prior to rewriting the call.
2681 Targ1 : Node_Id := Empty;
2682 -- A separate target used when the return type is unconstrained
2684 procedure Declare_Postconditions_Result;
2685 -- When generating C code, declare _Result, which may be used in the
2686 -- inlined _Postconditions procedure to verify the return value.
2688 procedure Make_Exit_Label;
2689 -- Build declaration for exit label to be used in Return statements,
2690 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2691 -- declaration). Does nothing if Exit_Lab already set.
2693 procedure Make_Loop_Labels_Unique (HSS : Node_Id);
2694 -- When compiling for CCG and performing front-end inlining, replace
2695 -- loop names and references to them so that they do not conflict with
2696 -- homographs in the current subprogram.
2698 function Process_Formals (N : Node_Id) return Traverse_Result;
2699 -- Replace occurrence of a formal with the corresponding actual, or the
2700 -- thunk generated for it. Replace a return statement with an assignment
2701 -- to the target of the call, with appropriate conversions if needed.
2703 function Process_Formals_In_Aspects (N : Node_Id) return Traverse_Result;
2704 -- Because aspects are linked indirectly to the rest of the tree,
2705 -- replacement of formals appearing in aspect specifications must
2706 -- be performed in a separate pass, using an instantiation of the
2707 -- previous subprogram over aspect specifications reachable from N.
2709 function Process_Sloc (Nod : Node_Id) return Traverse_Result;
2710 -- If the call being expanded is that of an internal subprogram, set the
2711 -- sloc of the generated block to that of the call itself, so that the
2712 -- expansion is skipped by the "next" command in gdb. Same processing
2713 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2714 -- Debug_Generated_Code is true, suppress this change to simplify our
2715 -- own development. Same in GNATprove mode, to ensure that warnings and
2716 -- diagnostics point to the proper location.
2718 procedure Reset_Dispatching_Calls (N : Node_Id);
2719 -- In subtree N search for occurrences of dispatching calls that use the
2720 -- Ada 2005 Object.Operation notation and the object is a formal of the
2721 -- inlined subprogram. Reset the entity associated with Operation in all
2722 -- the found occurrences.
2724 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
2725 -- If the function body is a single expression, replace call with
2726 -- expression, else insert block appropriately.
2728 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
2729 -- If procedure body has no local variables, inline body without
2730 -- creating block, otherwise rewrite call with block.
2732 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
2733 -- Determine whether a formal parameter is used only once in Orig_Bod
2735 -----------------------------------
2736 -- Declare_Postconditions_Result --
2737 -----------------------------------
2739 procedure Declare_Postconditions_Result is
2740 Enclosing_Subp : constant Entity_Id := Scope (Subp);
2745 and then Is_Subprogram (Enclosing_Subp)
2746 and then Present (Postconditions_Proc (Enclosing_Subp)));
2748 if Ekind (Enclosing_Subp) = E_Function then
2749 if Nkind (First (Parameter_Associations (N))) in
2750 N_Numeric_Or_String_Literal
2752 Append_To (Declarations (Blk),
2753 Make_Object_Declaration (Loc,
2754 Defining_Identifier =>
2755 Make_Defining_Identifier (Loc, Name_uResult),
2756 Constant_Present => True,
2757 Object_Definition =>
2758 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2760 New_Copy_Tree (First (Parameter_Associations (N)))));
2762 Append_To (Declarations (Blk),
2763 Make_Object_Renaming_Declaration (Loc,
2764 Defining_Identifier =>
2765 Make_Defining_Identifier (Loc, Name_uResult),
2767 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2769 New_Copy_Tree (First (Parameter_Associations (N)))));
2772 end Declare_Postconditions_Result;
2774 ---------------------
2775 -- Make_Exit_Label --
2776 ---------------------
2778 procedure Make_Exit_Label is
2779 Lab_Ent : Entity_Id;
2781 if No (Exit_Lab) then
2782 Lab_Ent := Make_Temporary (Loc, 'L');
2783 Lab_Id := New_Occurrence_Of (Lab_Ent, Loc);
2784 Exit_Lab := Make_Label (Loc, Lab_Id);
2786 Make_Implicit_Label_Declaration (Loc,
2787 Defining_Identifier => Lab_Ent,
2788 Label_Construct => Exit_Lab);
2790 end Make_Exit_Label;
2792 -----------------------------
2793 -- Make_Loop_Labels_Unique --
2794 -----------------------------
2796 procedure Make_Loop_Labels_Unique (HSS : Node_Id) is
2797 function Process_Loop (N : Node_Id) return Traverse_Result;
2803 function Process_Loop (N : Node_Id) return Traverse_Result is
2807 if Nkind (N) = N_Loop_Statement
2808 and then Present (Identifier (N))
2810 -- Create new external name for loop and update the
2811 -- corresponding entity.
2813 Id := Entity (Identifier (N));
2814 Set_Chars (Id, New_External_Name (Chars (Id), 'L', -1));
2815 Set_Chars (Identifier (N), Chars (Id));
2817 elsif Nkind (N) = N_Exit_Statement
2818 and then Present (Name (N))
2820 -- The exit statement must name an enclosing loop, whose name
2821 -- has already been updated.
2823 Set_Chars (Name (N), Chars (Entity (Name (N))));
2829 procedure Update_Loop_Names is new Traverse_Proc (Process_Loop);
2835 -- Start of processing for Make_Loop_Labels_Unique
2838 if Modify_Tree_For_C then
2839 Stmt := First (Statements (HSS));
2840 while Present (Stmt) loop
2841 Update_Loop_Names (Stmt);
2845 end Make_Loop_Labels_Unique;
2847 ---------------------
2848 -- Process_Formals --
2849 ---------------------
2851 function Process_Formals (N : Node_Id) return Traverse_Result is
2857 if Is_Entity_Name (N) and then Present (Entity (N)) then
2860 if Is_Formal (E) and then Scope (E) = Subp then
2861 A := Renamed_Object (E);
2863 -- Rewrite the occurrence of the formal into an occurrence of
2864 -- the actual. Also establish visibility on the proper view of
2865 -- the actual's subtype for the body's context (if the actual's
2866 -- subtype is private at the call point but its full view is
2867 -- visible to the body, then the inlined tree here must be
2868 -- analyzed with the full view).
2870 if Is_Entity_Name (A) then
2871 Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N)));
2872 Check_Private_View (N);
2874 elsif Nkind (A) = N_Defining_Identifier then
2875 Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
2876 Check_Private_View (N);
2881 Rewrite (N, New_Copy (A));
2887 elsif Is_Entity_Name (N)
2888 and then Present (Return_Object)
2889 and then Chars (N) = Chars (Return_Object)
2891 -- Occurrence within an extended return statement. The return
2892 -- object is local to the body been inlined, and thus the generic
2893 -- copy is not analyzed yet, so we match by name, and replace it
2894 -- with target of call.
2896 if Nkind (Targ) = N_Defining_Identifier then
2897 Rewrite (N, New_Occurrence_Of (Targ, Loc));
2899 Rewrite (N, New_Copy_Tree (Targ));
2904 elsif Nkind (N) = N_Simple_Return_Statement then
2905 if No (Expression (N)) then
2906 Num_Ret := Num_Ret + 1;
2909 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2912 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
2913 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
2915 -- Function body is a single expression. No need for
2921 Num_Ret := Num_Ret + 1;
2925 -- Because of the presence of private types, the views of the
2926 -- expression and the context may be different, so place
2927 -- a type conversion to the context type to avoid spurious
2928 -- errors, e.g. when the expression is a numeric literal and
2929 -- the context is private. If the expression is an aggregate,
2930 -- use a qualified expression, because an aggregate is not a
2931 -- legal argument of a conversion. Ditto for numeric, character
2932 -- and string literals, and attributes that yield a universal
2933 -- type, because those must be resolved to a specific type.
2935 if Nkind_In (Expression (N), N_Aggregate,
2936 N_Character_Literal,
2939 or else Yields_Universal_Type (Expression (N))
2942 Make_Qualified_Expression (Sloc (N),
2943 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2944 Expression => Relocate_Node (Expression (N)));
2946 -- Use an unchecked type conversion between access types, for
2947 -- which a type conversion would not always be valid, as no
2948 -- check may result from the conversion.
2950 elsif Is_Access_Type (Ret_Type) then
2952 Unchecked_Convert_To
2953 (Ret_Type, Relocate_Node (Expression (N)));
2955 -- Otherwise use a type conversion, which may trigger a check
2959 Make_Type_Conversion (Sloc (N),
2960 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2961 Expression => Relocate_Node (Expression (N)));
2964 if Nkind (Targ) = N_Defining_Identifier then
2966 Make_Assignment_Statement (Loc,
2967 Name => New_Occurrence_Of (Targ, Loc),
2968 Expression => Ret));
2971 Make_Assignment_Statement (Loc,
2972 Name => New_Copy (Targ),
2973 Expression => Ret));
2976 Set_Assignment_OK (Name (N));
2978 if Present (Exit_Lab) then
2980 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2986 -- An extended return becomes a block whose first statement is the
2987 -- assignment of the initial expression of the return object to the
2988 -- target of the call itself.
2990 elsif Nkind (N) = N_Extended_Return_Statement then
2992 Return_Decl : constant Entity_Id :=
2993 First (Return_Object_Declarations (N));
2997 Return_Object := Defining_Identifier (Return_Decl);
2999 if Present (Expression (Return_Decl)) then
3000 if Nkind (Targ) = N_Defining_Identifier then
3002 Make_Assignment_Statement (Loc,
3003 Name => New_Occurrence_Of (Targ, Loc),
3004 Expression => Expression (Return_Decl));
3007 Make_Assignment_Statement (Loc,
3008 Name => New_Copy (Targ),
3009 Expression => Expression (Return_Decl));
3012 Set_Assignment_OK (Name (Assign));
3014 if No (Handled_Statement_Sequence (N)) then
3015 Set_Handled_Statement_Sequence (N,
3016 Make_Handled_Sequence_Of_Statements (Loc,
3017 Statements => New_List));
3021 Statements (Handled_Statement_Sequence (N)));
3025 Make_Block_Statement (Loc,
3026 Handled_Statement_Sequence =>
3027 Handled_Statement_Sequence (N)));
3032 -- Remove pragma Unreferenced since it may refer to formals that
3033 -- are not visible in the inlined body, and in any case we will
3034 -- not be posting warnings on the inlined body so it is unneeded.
3036 elsif Nkind (N) = N_Pragma
3037 and then Pragma_Name (N) = Name_Unreferenced
3039 Rewrite (N, Make_Null_Statement (Sloc (N)));
3045 end Process_Formals;
3047 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
3049 --------------------------------
3050 -- Process_Formals_In_Aspects --
3051 --------------------------------
3053 function Process_Formals_In_Aspects
3054 (N : Node_Id) return Traverse_Result
3059 if Has_Aspects (N) then
3060 A := First (Aspect_Specifications (N));
3061 while Present (A) loop
3062 Replace_Formals (Expression (A));
3068 end Process_Formals_In_Aspects;
3070 procedure Replace_Formals_In_Aspects is
3071 new Traverse_Proc (Process_Formals_In_Aspects);
3077 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
3079 if not Debug_Generated_Code then
3080 Set_Sloc (Nod, Sloc (N));
3081 Set_Comes_From_Source (Nod, False);
3087 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
3089 ------------------------------
3090 -- Reset_Dispatching_Calls --
3091 ------------------------------
3093 procedure Reset_Dispatching_Calls (N : Node_Id) is
3095 function Do_Reset (N : Node_Id) return Traverse_Result;
3096 -- Comment required ???
3102 function Do_Reset (N : Node_Id) return Traverse_Result is
3104 if Nkind (N) = N_Procedure_Call_Statement
3105 and then Nkind (Name (N)) = N_Selected_Component
3106 and then Nkind (Prefix (Name (N))) = N_Identifier
3107 and then Is_Formal (Entity (Prefix (Name (N))))
3108 and then Is_Dispatching_Operation
3109 (Entity (Selector_Name (Name (N))))
3111 Set_Entity (Selector_Name (Name (N)), Empty);
3117 function Do_Reset_Calls is new Traverse_Func (Do_Reset);
3121 Dummy : constant Traverse_Result := Do_Reset_Calls (N);
3122 pragma Unreferenced (Dummy);
3124 -- Start of processing for Reset_Dispatching_Calls
3128 end Reset_Dispatching_Calls;
3130 ---------------------------
3131 -- Rewrite_Function_Call --
3132 ---------------------------
3134 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
3135 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
3136 Fst : constant Node_Id := First (Statements (HSS));
3139 Make_Loop_Labels_Unique (HSS);
3141 -- Optimize simple case: function body is a single return statement,
3142 -- which has been expanded into an assignment.
3144 if Is_Empty_List (Declarations (Blk))
3145 and then Nkind (Fst) = N_Assignment_Statement
3146 and then No (Next (Fst))
3148 -- The function call may have been rewritten as the temporary
3149 -- that holds the result of the call, in which case remove the
3150 -- now useless declaration.
3152 if Nkind (N) = N_Identifier
3153 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
3155 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
3158 Rewrite (N, Expression (Fst));
3160 elsif Nkind (N) = N_Identifier
3161 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
3163 -- The block assigns the result of the call to the temporary
3165 Insert_After (Parent (Entity (N)), Blk);
3167 -- If the context is an assignment, and the left-hand side is free of
3168 -- side-effects, the replacement is also safe.
3169 -- Can this be generalized further???
3171 elsif Nkind (Parent (N)) = N_Assignment_Statement
3173 (Is_Entity_Name (Name (Parent (N)))
3175 (Nkind (Name (Parent (N))) = N_Explicit_Dereference
3176 and then Is_Entity_Name (Prefix (Name (Parent (N)))))
3179 (Nkind (Name (Parent (N))) = N_Selected_Component
3180 and then Is_Entity_Name (Prefix (Name (Parent (N))))))
3182 -- Replace assignment with the block
3185 Original_Assignment : constant Node_Id := Parent (N);
3188 -- Preserve the original assignment node to keep the complete
3189 -- assignment subtree consistent enough for Analyze_Assignment
3190 -- to proceed (specifically, the original Lhs node must still
3191 -- have an assignment statement as its parent).
3193 -- We cannot rely on Original_Node to go back from the block
3194 -- node to the assignment node, because the assignment might
3195 -- already be a rewrite substitution.
3197 Discard_Node (Relocate_Node (Original_Assignment));
3198 Rewrite (Original_Assignment, Blk);
3201 elsif Nkind (Parent (N)) = N_Object_Declaration then
3203 -- A call to a function which returns an unconstrained type
3204 -- found in the expression initializing an object-declaration is
3205 -- expanded into a procedure call which must be added after the
3206 -- object declaration.
3208 if Is_Unc_Decl and Back_End_Inlining then
3209 Insert_Action_After (Parent (N), Blk);
3211 Set_Expression (Parent (N), Empty);
3212 Insert_After (Parent (N), Blk);
3215 elsif Is_Unc and then not Back_End_Inlining then
3216 Insert_Before (Parent (N), Blk);
3218 end Rewrite_Function_Call;
3220 ----------------------------
3221 -- Rewrite_Procedure_Call --
3222 ----------------------------
3224 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
3225 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
3228 Make_Loop_Labels_Unique (HSS);
3230 -- If there is a transient scope for N, this will be the scope of the
3231 -- actions for N, and the statements in Blk need to be within this
3232 -- scope. For example, they need to have visibility on the constant
3233 -- declarations created for the formals.
3235 -- If N needs no transient scope, and if there are no declarations in
3236 -- the inlined body, we can do a little optimization and insert the
3237 -- statements for the body directly after N, and rewrite N to a
3238 -- null statement, instead of rewriting N into a full-blown block
3241 if not Scope_Is_Transient
3242 and then Is_Empty_List (Declarations (Blk))
3244 Insert_List_After (N, Statements (HSS));
3245 Rewrite (N, Make_Null_Statement (Loc));
3249 end Rewrite_Procedure_Call;
3251 -------------------------
3252 -- Formal_Is_Used_Once --
3253 -------------------------
3255 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
3256 Use_Counter : Int := 0;
3258 function Count_Uses (N : Node_Id) return Traverse_Result;
3259 -- Traverse the tree and count the uses of the formal parameter.
3260 -- In this case, for optimization purposes, we do not need to
3261 -- continue the traversal once more than one use is encountered.
3267 function Count_Uses (N : Node_Id) return Traverse_Result is
3269 -- The original node is an identifier
3271 if Nkind (N) = N_Identifier
3272 and then Present (Entity (N))
3274 -- Original node's entity points to the one in the copied body
3276 and then Nkind (Entity (N)) = N_Identifier
3277 and then Present (Entity (Entity (N)))
3279 -- The entity of the copied node is the formal parameter
3281 and then Entity (Entity (N)) = Formal
3283 Use_Counter := Use_Counter + 1;
3285 if Use_Counter > 1 then
3287 -- Denote more than one use and abandon the traversal
3298 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
3300 -- Start of processing for Formal_Is_Used_Once
3303 Count_Formal_Uses (Orig_Bod);
3304 return Use_Counter = 1;
3305 end Formal_Is_Used_Once;
3307 -- Start of processing for Expand_Inlined_Call
3310 -- Initializations for old/new semantics
3312 if not Uses_Back_End then
3313 Is_Unc := Is_Array_Type (Etype (Subp))
3314 and then not Is_Constrained (Etype (Subp));
3315 Is_Unc_Decl := False;
3317 Is_Unc := Returns_Unconstrained_Type (Subp)
3318 and then Optimization_Level > 0;
3319 Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration
3323 -- Check for an illegal attempt to inline a recursive procedure. If the
3324 -- subprogram has parameters this is detected when trying to supply a
3325 -- binding for parameters that already have one. For parameterless
3326 -- subprograms this must be done explicitly.
3328 if In_Open_Scopes (Subp) then
3330 ("cannot inline call to recursive subprogram?", N, Subp);
3331 Set_Is_Inlined (Subp, False);
3334 -- Skip inlining if this is not a true inlining since the attribute
3335 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
3336 -- true inlining, Orig_Bod has code rather than being an entity.
3338 elsif Nkind (Orig_Bod) in N_Entity then
3342 if Nkind (Orig_Bod) = N_Defining_Identifier
3343 or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
3345 -- Subprogram is renaming_as_body. Calls occurring after the renaming
3346 -- can be replaced with calls to the renamed entity directly, because
3347 -- the subprograms are subtype conformant. If the renamed subprogram
3348 -- is an inherited operation, we must redo the expansion because
3349 -- implicit conversions may be needed. Similarly, if the renamed
3350 -- entity is inlined, expand the call for further optimizations.
3352 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
3354 if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then
3361 -- Register the call in the list of inlined calls
3363 Append_New_Elmt (N, To => Inlined_Calls);
3365 -- Use generic machinery to copy body of inlined subprogram, as if it
3366 -- were an instantiation, resetting source locations appropriately, so
3367 -- that nested inlined calls appear in the main unit.
3369 Save_Env (Subp, Empty);
3370 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
3374 if not Uses_Back_End then
3379 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3381 Make_Block_Statement (Loc,
3382 Declarations => Declarations (Bod),
3383 Handled_Statement_Sequence =>
3384 Handled_Statement_Sequence (Bod));
3386 if No (Declarations (Bod)) then
3387 Set_Declarations (Blk, New_List);
3390 -- When generating C code, declare _Result, which may be used to
3391 -- verify the return value.
3393 if Modify_Tree_For_C
3394 and then Nkind (N) = N_Procedure_Call_Statement
3395 and then Chars (Name (N)) = Name_uPostconditions
3397 Declare_Postconditions_Result;
3400 -- For the unconstrained case, capture the name of the local
3401 -- variable that holds the result. This must be the first
3402 -- declaration in the block, because its bounds cannot depend
3403 -- on local variables. Otherwise there is no way to declare the
3404 -- result outside of the block. Needless to say, in general the
3405 -- bounds will depend on the actuals in the call.
3407 -- If the context is an assignment statement, as is the case
3408 -- for the expansion of an extended return, the left-hand side
3409 -- provides bounds even if the return type is unconstrained.
3413 First_Decl : Node_Id;
3416 First_Decl := First (Declarations (Blk));
3418 -- If the body is a single extended return statement,the
3419 -- resulting block is a nested block.
3421 if No (First_Decl) then
3423 First (Statements (Handled_Statement_Sequence (Blk)));
3425 if Nkind (First_Decl) = N_Block_Statement then
3426 First_Decl := First (Declarations (First_Decl));
3430 -- No front-end inlining possible
3432 if Nkind (First_Decl) /= N_Object_Declaration then
3436 if Nkind (Parent (N)) /= N_Assignment_Statement then
3437 Targ1 := Defining_Identifier (First_Decl);
3439 Targ1 := Name (Parent (N));
3456 Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3458 Make_Block_Statement (Loc,
3459 Declarations => Declarations (Bod),
3460 Handled_Statement_Sequence =>
3461 Handled_Statement_Sequence (Bod));
3463 -- Inline a call to a function that returns an unconstrained type.
3464 -- The semantic analyzer checked that frontend-inlined functions
3465 -- returning unconstrained types have no declarations and have
3466 -- a single extended return statement. As part of its processing
3467 -- the function was split into two subprograms: a procedure P' and
3468 -- a function F' that has a block with a call to procedure P' (see
3469 -- Split_Unconstrained_Function).
3475 (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
3479 Blk_Stmt : constant Node_Id :=
3480 First (Statements (Handled_Statement_Sequence (Orig_Bod)));
3481 First_Stmt : constant Node_Id :=
3482 First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
3483 Second_Stmt : constant Node_Id := Next (First_Stmt);
3487 (Nkind (First_Stmt) = N_Procedure_Call_Statement
3488 and then Nkind (Second_Stmt) = N_Simple_Return_Statement
3489 and then No (Next (Second_Stmt)));
3494 (Statements (Handled_Statement_Sequence (Orig_Bod))),
3495 Empty, Instantiating => True);
3498 -- Capture the name of the local variable that holds the
3499 -- result. This must be the first declaration in the block,
3500 -- because its bounds cannot depend on local variables.
3501 -- Otherwise there is no way to declare the result outside
3502 -- of the block. Needless to say, in general the bounds will
3503 -- depend on the actuals in the call.
3505 if Nkind (Parent (N)) /= N_Assignment_Statement then
3506 Targ1 := Defining_Identifier (First (Declarations (Blk)));
3508 -- If the context is an assignment statement, as is the case
3509 -- for the expansion of an extended return, the left-hand
3510 -- side provides bounds even if the return type is
3514 Targ1 := Name (Parent (N));
3519 if No (Declarations (Bod)) then
3520 Set_Declarations (Blk, New_List);
3525 -- If this is a derived function, establish the proper return type
3527 if Present (Orig_Subp) and then Orig_Subp /= Subp then
3528 Ret_Type := Etype (Orig_Subp);
3530 Ret_Type := Etype (Subp);
3533 -- Create temporaries for the actuals that are expressions, or that are
3534 -- scalars and require copying to preserve semantics.
3536 F := First_Formal (Subp);
3537 A := First_Actual (N);
3538 while Present (F) loop
3539 if Present (Renamed_Object (F)) then
3541 -- If expander is active, it is an error to try to inline a
3542 -- recursive program. In GNATprove mode, just indicate that the
3543 -- inlining will not happen, and mark the subprogram as not always
3546 if GNATprove_Mode then
3548 ("cannot inline call to recursive subprogram?", N, Subp);
3549 Set_Is_Inlined_Always (Subp, False);
3552 ("cannot inline call to recursive subprogram", N);
3558 -- Reset Last_Assignment for any parameters of mode out or in out, to
3559 -- prevent spurious warnings about overwriting for assignments to the
3560 -- formal in the inlined code.
3562 if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
3563 Set_Last_Assignment (Entity (A), Empty);
3566 -- If the argument may be a controlling argument in a call within
3567 -- the inlined body, we must preserve its classwide nature to insure
3568 -- that dynamic dispatching take place subsequently. If the formal
3569 -- has a constraint it must be preserved to retain the semantics of
3572 if Is_Class_Wide_Type (Etype (F))
3573 or else (Is_Access_Type (Etype (F))
3574 and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
3576 Temp_Typ := Etype (F);
3578 elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
3579 and then Etype (F) /= Base_Type (Etype (F))
3580 and then Is_Constrained (Etype (F))
3582 Temp_Typ := Etype (F);
3585 Temp_Typ := Etype (A);
3588 -- If the actual is a simple name or a literal, no need to
3589 -- create a temporary, object can be used directly.
3591 -- If the actual is a literal and the formal has its address taken,
3592 -- we cannot pass the literal itself as an argument, so its value
3593 -- must be captured in a temporary. Skip this optimization in
3594 -- GNATprove mode, to make sure any check on a type conversion
3597 if (Is_Entity_Name (A)
3599 (not Is_Scalar_Type (Etype (A))
3600 or else Ekind (Entity (A)) = E_Enumeration_Literal)
3601 and then not GNATprove_Mode)
3603 -- When the actual is an identifier and the corresponding formal is
3604 -- used only once in the original body, the formal can be substituted
3605 -- directly with the actual parameter. Skip this optimization in
3606 -- GNATprove mode, to make sure any check on a type conversion
3610 (Nkind (A) = N_Identifier
3611 and then Formal_Is_Used_Once (F)
3612 and then not GNATprove_Mode)
3615 (Nkind_In (A, N_Real_Literal,
3617 N_Character_Literal)
3618 and then not Address_Taken (F))
3620 if Etype (F) /= Etype (A) then
3622 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
3624 Set_Renamed_Object (F, A);
3628 Temp := Make_Temporary (Loc, 'C');
3630 -- If the actual for an in/in-out parameter is a view conversion,
3631 -- make it into an unchecked conversion, given that an untagged
3632 -- type conversion is not a proper object for a renaming.
3634 -- In-out conversions that involve real conversions have already
3635 -- been transformed in Expand_Actuals.
3637 if Nkind (A) = N_Type_Conversion
3638 and then Ekind (F) /= E_In_Parameter
3641 Make_Unchecked_Type_Conversion (Loc,
3642 Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
3643 Expression => Relocate_Node (Expression (A)));
3645 -- In GNATprove mode, keep the most precise type of the actual for
3646 -- the temporary variable, when the formal type is unconstrained.
3647 -- Otherwise, the AST may contain unexpected assignment statements
3648 -- to a temporary variable of unconstrained type renaming a local
3649 -- variable of constrained type, which is not expected by
3652 elsif Etype (F) /= Etype (A)
3653 and then (not GNATprove_Mode or else Is_Constrained (Etype (F)))
3655 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
3656 Temp_Typ := Etype (F);
3659 New_A := Relocate_Node (A);
3662 Set_Sloc (New_A, Sloc (N));
3664 -- If the actual has a by-reference type, it cannot be copied,
3665 -- so its value is captured in a renaming declaration. Otherwise
3666 -- declare a local constant initialized with the actual.
3668 -- We also use a renaming declaration for expressions of an array
3669 -- type that is not bit-packed, both for efficiency reasons and to
3670 -- respect the semantics of the call: in most cases the original
3671 -- call will pass the parameter by reference, and thus the inlined
3672 -- code will have the same semantics.
3674 -- Finally, we need a renaming declaration in the case of limited
3675 -- types for which initialization cannot be by copy either.
3677 if Ekind (F) = E_In_Parameter
3678 and then not Is_By_Reference_Type (Etype (A))
3679 and then not Is_Limited_Type (Etype (A))
3681 (not Is_Array_Type (Etype (A))
3682 or else not Is_Object_Reference (A)
3683 or else Is_Bit_Packed_Array (Etype (A)))
3686 Make_Object_Declaration (Loc,
3687 Defining_Identifier => Temp,
3688 Constant_Present => True,
3689 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3690 Expression => New_A);
3693 -- In GNATprove mode, make an explicit copy of input
3694 -- parameters when formal and actual types differ, to make
3695 -- sure any check on the type conversion will be issued.
3696 -- The legality of the copy is ensured by calling first
3697 -- Call_Can_Be_Inlined_In_GNATprove_Mode.
3700 and then Ekind (F) /= E_Out_Parameter
3701 and then not Same_Type (Etype (F), Etype (A))
3703 pragma Assert (not Is_By_Reference_Type (Etype (A)));
3704 pragma Assert (not Is_Limited_Type (Etype (A)));
3707 Make_Object_Declaration (Loc,
3708 Defining_Identifier => Make_Temporary (Loc, 'C'),
3709 Constant_Present => True,
3710 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3711 Expression => New_Copy_Tree (New_A)));
3715 Make_Object_Renaming_Declaration (Loc,
3716 Defining_Identifier => Temp,
3717 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
3721 Append (Decl, Decls);
3722 Set_Renamed_Object (F, Temp);
3729 -- Establish target of function call. If context is not assignment or
3730 -- declaration, create a temporary as a target. The declaration for the
3731 -- temporary may be subsequently optimized away if the body is a single
3732 -- expression, or if the left-hand side of the assignment is simple
3733 -- enough, i.e. an entity or an explicit dereference of one.
3735 if Ekind (Subp) = E_Function then
3736 if Nkind (Parent (N)) = N_Assignment_Statement
3737 and then Is_Entity_Name (Name (Parent (N)))
3739 Targ := Name (Parent (N));
3741 elsif Nkind (Parent (N)) = N_Assignment_Statement
3742 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
3743 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3745 Targ := Name (Parent (N));
3747 elsif Nkind (Parent (N)) = N_Assignment_Statement
3748 and then Nkind (Name (Parent (N))) = N_Selected_Component
3749 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3751 Targ := New_Copy_Tree (Name (Parent (N)));
3753 elsif Nkind (Parent (N)) = N_Object_Declaration
3754 and then Is_Limited_Type (Etype (Subp))
3756 Targ := Defining_Identifier (Parent (N));
3758 -- New semantics: In an object declaration avoid an extra copy
3759 -- of the result of a call to an inlined function that returns
3760 -- an unconstrained type
3763 and then Nkind (Parent (N)) = N_Object_Declaration
3766 Targ := Defining_Identifier (Parent (N));
3769 -- Replace call with temporary and create its declaration
3771 Temp := Make_Temporary (Loc, 'C');
3772 Set_Is_Internal (Temp);
3774 -- For the unconstrained case, the generated temporary has the
3775 -- same constrained declaration as the result variable. It may
3776 -- eventually be possible to remove that temporary and use the
3777 -- result variable directly.
3779 if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement
3782 Make_Object_Declaration (Loc,
3783 Defining_Identifier => Temp,
3784 Object_Definition =>
3785 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3787 Replace_Formals (Decl);
3791 Make_Object_Declaration (Loc,
3792 Defining_Identifier => Temp,
3793 Object_Definition => New_Occurrence_Of (Ret_Type, Loc));
3795 Set_Etype (Temp, Ret_Type);
3798 Set_No_Initialization (Decl);
3799 Append (Decl, Decls);
3800 Rewrite (N, New_Occurrence_Of (Temp, Loc));
3805 Insert_Actions (N, Decls);
3809 -- Special management for inlining a call to a function that returns
3810 -- an unconstrained type and initializes an object declaration: we
3811 -- avoid generating undesired extra calls and goto statements.
3814 -- function Func (...) return String is
3817 -- Result : String (1 .. 4);
3819 -- Proc (Result, ...);
3824 -- Result : String := Func (...);
3826 -- Replace this object declaration by:
3828 -- Result : String (1 .. 4);
3829 -- Proc (Result, ...);
3831 Remove_Homonym (Targ);
3834 Make_Object_Declaration
3836 Defining_Identifier => Targ,
3837 Object_Definition =>
3838 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3839 Replace_Formals (Decl);
3840 Rewrite (Parent (N), Decl);
3841 Analyze (Parent (N));
3843 -- Avoid spurious warnings since we know that this declaration is
3844 -- referenced by the procedure call.
3846 Set_Never_Set_In_Source (Targ, False);
3848 -- Remove the local declaration of the extended return stmt from the
3851 Remove (Parent (Targ1));
3853 -- Update the reference to the result (since we have rewriten the
3854 -- object declaration)
3857 Blk_Call_Stmt : Node_Id;
3860 -- Capture the call to the procedure
3863 First (Statements (Handled_Statement_Sequence (Blk)));
3865 (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement);
3867 Remove (First (Parameter_Associations (Blk_Call_Stmt)));
3868 Prepend_To (Parameter_Associations (Blk_Call_Stmt),
3869 New_Occurrence_Of (Targ, Loc));
3872 -- Remove the return statement
3875 (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3876 N_Simple_Return_Statement);
3878 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3881 -- Traverse the tree and replace formals with actuals or their thunks.
3882 -- Attach block to tree before analysis and rewriting.
3884 Replace_Formals (Blk);
3885 Replace_Formals_In_Aspects (Blk);
3886 Set_Parent (Blk, N);
3888 if GNATprove_Mode then
3891 elsif not Comes_From_Source (Subp) or else Is_Predef then
3897 -- No action needed since return statement has been already removed
3901 elsif Present (Exit_Lab) then
3903 -- If there's a single return statement at the end of the subprogram,
3904 -- the corresponding goto statement and the corresponding label are
3909 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3912 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3914 Append (Lab_Decl, (Declarations (Blk)));
3915 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
3919 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3920 -- on conflicting private views that Gigi would ignore. If this is a
3921 -- predefined unit, analyze with checks off, as is done in the non-
3922 -- inlined run-time units.
3925 I_Flag : constant Boolean := In_Inlined_Body;
3928 In_Inlined_Body := True;
3932 Style : constant Boolean := Style_Check;
3935 Style_Check := False;
3937 -- Search for dispatching calls that use the Object.Operation
3938 -- notation using an Object that is a parameter of the inlined
3939 -- function. We reset the decoration of Operation to force
3940 -- the reanalysis of the inlined dispatching call because
3941 -- the actual object has been inlined.
3943 Reset_Dispatching_Calls (Blk);
3945 Analyze (Blk, Suppress => All_Checks);
3946 Style_Check := Style;
3953 In_Inlined_Body := I_Flag;
3956 if Ekind (Subp) = E_Procedure then
3957 Rewrite_Procedure_Call (N, Blk);
3960 Rewrite_Function_Call (N, Blk);
3965 -- For the unconstrained case, the replacement of the call has been
3966 -- made prior to the complete analysis of the generated declarations.
3967 -- Propagate the proper type now.
3970 if Nkind (N) = N_Identifier then
3971 Set_Etype (N, Etype (Entity (N)));
3973 Set_Etype (N, Etype (Targ1));
3980 -- Cleanup mapping between formals and actuals for other expansions
3982 F := First_Formal (Subp);
3983 while Present (F) loop
3984 Set_Renamed_Object (F, Empty);
3987 end Expand_Inlined_Call;
3989 --------------------------
3990 -- Get_Code_Unit_Entity --
3991 --------------------------
3993 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
3994 Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E));
3997 if Ekind (Unit) = E_Package_Body then
3998 Unit := Spec_Entity (Unit);
4002 end Get_Code_Unit_Entity;
4004 ------------------------------
4005 -- Has_Excluded_Declaration --
4006 ------------------------------
4008 function Has_Excluded_Declaration
4010 Decls : List_Id) return Boolean
4014 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
4015 -- Nested subprograms make a given body ineligible for inlining, but
4016 -- we make an exception for instantiations of unchecked conversion.
4017 -- The body has not been analyzed yet, so check the name, and verify
4018 -- that the visible entity with that name is the predefined unit.
4020 -----------------------------
4021 -- Is_Unchecked_Conversion --
4022 -----------------------------
4024 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
4025 Id : constant Node_Id := Name (D);
4029 if Nkind (Id) = N_Identifier
4030 and then Chars (Id) = Name_Unchecked_Conversion
4032 Conv := Current_Entity (Id);
4034 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
4035 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
4037 Conv := Current_Entity (Selector_Name (Id));
4042 return Present (Conv)
4043 and then Is_Predefined_Unit (Get_Source_Unit (Conv))
4044 and then Is_Intrinsic_Subprogram (Conv);
4045 end Is_Unchecked_Conversion;
4047 -- Start of processing for Has_Excluded_Declaration
4050 -- No action needed if the check is not needed
4052 if not Check_Inlining_Restrictions then
4057 while Present (D) loop
4059 -- First declarations universally excluded
4061 if Nkind (D) = N_Package_Declaration then
4063 ("cannot inline & (nested package declaration)?", D, Subp);
4066 elsif Nkind (D) = N_Package_Instantiation then
4068 ("cannot inline & (nested package instantiation)?", D, Subp);
4072 -- Then declarations excluded only for front-end inlining
4074 if Back_End_Inlining then
4077 elsif Nkind (D) = N_Task_Type_Declaration
4078 or else Nkind (D) = N_Single_Task_Declaration
4081 ("cannot inline & (nested task type declaration)?", D, Subp);
4084 elsif Nkind (D) = N_Protected_Type_Declaration
4085 or else Nkind (D) = N_Single_Protected_Declaration
4088 ("cannot inline & (nested protected type declaration)?",
4092 elsif Nkind (D) = N_Subprogram_Body then
4094 ("cannot inline & (nested subprogram)?", D, Subp);
4097 elsif Nkind (D) = N_Function_Instantiation
4098 and then not Is_Unchecked_Conversion (D)
4101 ("cannot inline & (nested function instantiation)?", D, Subp);
4104 elsif Nkind (D) = N_Procedure_Instantiation then
4106 ("cannot inline & (nested procedure instantiation)?", D, Subp);
4109 -- Subtype declarations with predicates will generate predicate
4110 -- functions, i.e. nested subprogram bodies, so inlining is not
4113 elsif Nkind (D) = N_Subtype_Declaration
4114 and then Present (Aspect_Specifications (D))
4121 A := First (Aspect_Specifications (D));
4122 while Present (A) loop
4123 A_Id := Get_Aspect_Id (Chars (Identifier (A)));
4125 if A_Id = Aspect_Predicate
4126 or else A_Id = Aspect_Static_Predicate
4127 or else A_Id = Aspect_Dynamic_Predicate
4130 ("cannot inline & (subtype declaration with "
4131 & "predicate)?", D, Subp);
4144 end Has_Excluded_Declaration;
4146 ----------------------------
4147 -- Has_Excluded_Statement --
4148 ----------------------------
4150 function Has_Excluded_Statement
4152 Stats : List_Id) return Boolean
4158 -- No action needed if the check is not needed
4160 if not Check_Inlining_Restrictions then
4165 while Present (S) loop
4166 if Nkind_In (S, N_Abort_Statement,
4167 N_Asynchronous_Select,
4168 N_Conditional_Entry_Call,
4169 N_Delay_Relative_Statement,
4170 N_Delay_Until_Statement,
4175 ("cannot inline & (non-allowed statement)?", S, Subp);
4178 elsif Nkind (S) = N_Block_Statement then
4179 if Present (Declarations (S))
4180 and then Has_Excluded_Declaration (Subp, Declarations (S))
4184 elsif Present (Handled_Statement_Sequence (S)) then
4185 if not Back_End_Inlining
4188 (Exception_Handlers (Handled_Statement_Sequence (S)))
4191 ("cannot inline& (exception handler)?",
4192 First (Exception_Handlers
4193 (Handled_Statement_Sequence (S))),
4197 elsif Has_Excluded_Statement
4198 (Subp, Statements (Handled_Statement_Sequence (S)))
4204 elsif Nkind (S) = N_Case_Statement then
4205 E := First (Alternatives (S));
4206 while Present (E) loop
4207 if Has_Excluded_Statement (Subp, Statements (E)) then
4214 elsif Nkind (S) = N_If_Statement then
4215 if Has_Excluded_Statement (Subp, Then_Statements (S)) then
4219 if Present (Elsif_Parts (S)) then
4220 E := First (Elsif_Parts (S));
4221 while Present (E) loop
4222 if Has_Excluded_Statement (Subp, Then_Statements (E)) then
4230 if Present (Else_Statements (S))
4231 and then Has_Excluded_Statement (Subp, Else_Statements (S))
4236 elsif Nkind (S) = N_Loop_Statement
4237 and then Has_Excluded_Statement (Subp, Statements (S))
4241 elsif Nkind (S) = N_Extended_Return_Statement then
4242 if Present (Handled_Statement_Sequence (S))
4244 Has_Excluded_Statement
4245 (Subp, Statements (Handled_Statement_Sequence (S)))
4249 elsif not Back_End_Inlining
4250 and then Present (Handled_Statement_Sequence (S))
4252 Present (Exception_Handlers
4253 (Handled_Statement_Sequence (S)))
4256 ("cannot inline& (exception handler)?",
4257 First (Exception_Handlers (Handled_Statement_Sequence (S))),
4267 end Has_Excluded_Statement;
4269 --------------------------
4270 -- Has_Initialized_Type --
4271 --------------------------
4273 function Has_Initialized_Type (E : Entity_Id) return Boolean is
4274 E_Body : constant Node_Id := Subprogram_Body (E);
4278 if No (E_Body) then -- imported subprogram
4282 Decl := First (Declarations (E_Body));
4283 while Present (Decl) loop
4284 if Nkind (Decl) = N_Full_Type_Declaration
4285 and then Present (Init_Proc (Defining_Identifier (Decl)))
4295 end Has_Initialized_Type;
4297 -----------------------
4298 -- Has_Single_Return --
4299 -----------------------
4301 function Has_Single_Return (N : Node_Id) return Boolean is
4302 Return_Statement : Node_Id := Empty;
4304 function Check_Return (N : Node_Id) return Traverse_Result;
4310 function Check_Return (N : Node_Id) return Traverse_Result is
4312 if Nkind (N) = N_Simple_Return_Statement then
4313 if Present (Expression (N))
4314 and then Is_Entity_Name (Expression (N))
4316 pragma Assert (Present (Entity (Expression (N))));
4318 if No (Return_Statement) then
4319 Return_Statement := N;
4324 (Present (Entity (Expression (Return_Statement))));
4326 if Entity (Expression (N)) =
4327 Entity (Expression (Return_Statement))
4335 -- A return statement within an extended return is a noop after
4338 elsif No (Expression (N))
4339 and then Nkind (Parent (Parent (N))) =
4340 N_Extended_Return_Statement
4345 -- Expression has wrong form
4350 -- We can only inline a build-in-place function if it has a single
4353 elsif Nkind (N) = N_Extended_Return_Statement then
4354 if No (Return_Statement) then
4355 Return_Statement := N;
4367 function Check_All_Returns is new Traverse_Func (Check_Return);
4369 -- Start of processing for Has_Single_Return
4372 if Check_All_Returns (N) /= OK then
4375 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
4380 Present (Declarations (N))
4381 and then Present (First (Declarations (N)))
4382 and then Entity (Expression (Return_Statement)) =
4383 Defining_Identifier (First (Declarations (N)));
4385 end Has_Single_Return;
4387 -----------------------------
4388 -- In_Main_Unit_Or_Subunit --
4389 -----------------------------
4391 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is
4392 Comp : Node_Id := Cunit (Get_Code_Unit (E));
4395 -- Check whether the subprogram or package to inline is within the main
4396 -- unit or its spec or within a subunit. In either case there are no
4397 -- additional bodies to process. If the subprogram appears in a parent
4398 -- of the current unit, the check on whether inlining is possible is
4399 -- done in Analyze_Inlined_Bodies.
4401 while Nkind (Unit (Comp)) = N_Subunit loop
4402 Comp := Library_Unit (Comp);
4405 return Comp = Cunit (Main_Unit)
4406 or else Comp = Library_Unit (Cunit (Main_Unit));
4407 end In_Main_Unit_Or_Subunit;
4413 procedure Initialize is
4415 Pending_Instantiations.Init;
4416 Called_Pending_Instantiations.Init;
4417 Inlined_Bodies.Init;
4421 for J in Hash_Headers'Range loop
4422 Hash_Headers (J) := No_Subp;
4425 Inlined_Calls := No_Elist;
4426 Backend_Calls := No_Elist;
4427 Backend_Instances := No_Elist;
4428 Backend_Inlined_Subps := No_Elist;
4429 Backend_Not_Inlined_Subps := No_Elist;
4432 ------------------------
4433 -- Instantiate_Bodies --
4434 ------------------------
4436 -- Generic bodies contain all the non-local references, so an
4437 -- instantiation does not need any more context than Standard
4438 -- itself, even if the instantiation appears in an inner scope.
4439 -- Generic associations have verified that the contract model is
4440 -- satisfied, so that any error that may occur in the analysis of
4441 -- the body is an internal error.
4443 procedure Instantiate_Bodies is
4445 procedure Instantiate_Body (Info : Pending_Body_Info);
4446 -- Instantiate a pending body
4448 ------------------------
4449 -- Instantiate_Body --
4450 ------------------------
4452 procedure Instantiate_Body (Info : Pending_Body_Info) is
4454 -- If the instantiation node is absent, it has been removed as part
4455 -- of unreachable code.
4457 if No (Info.Inst_Node) then
4460 -- If the instantiation node is a package body, this means that the
4461 -- instance is a compilation unit and the instantiation has already
4462 -- been performed by Build_Instance_Compilation_Unit_Nodes.
4464 elsif Nkind (Info.Inst_Node) = N_Package_Body then
4467 elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
4468 Instantiate_Package_Body (Info);
4469 Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
4472 Instantiate_Subprogram_Body (Info);
4474 end Instantiate_Body;
4477 Info : Pending_Body_Info;
4479 -- Start of processing for Instantiate_Bodies
4482 if Serious_Errors_Detected = 0 then
4483 Expander_Active := (Operating_Mode = Opt.Generate_Code);
4484 Push_Scope (Standard_Standard);
4485 To_Clean := New_Elmt_List;
4487 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
4491 -- A body instantiation may generate additional instantiations, so
4492 -- the following loop must scan to the end of a possibly expanding
4493 -- set (that's why we cannot simply use a FOR loop here). We must
4494 -- also capture the element lest the set be entirely reallocated.
4497 if Back_End_Inlining then
4498 while J <= Called_Pending_Instantiations.Last
4499 and then Serious_Errors_Detected = 0
4501 K := Called_Pending_Instantiations.Table (J);
4502 Info := Pending_Instantiations.Table (K);
4503 Instantiate_Body (Info);
4509 while J <= Pending_Instantiations.Last
4510 and then Serious_Errors_Detected = 0
4512 Info := Pending_Instantiations.Table (J);
4513 Instantiate_Body (Info);
4519 -- Reset the table of instantiations. Additional instantiations
4520 -- may be added through inlining, when additional bodies are
4523 if Back_End_Inlining then
4524 Called_Pending_Instantiations.Init;
4526 Pending_Instantiations.Init;
4529 -- We can now complete the cleanup actions of scopes that contain
4530 -- pending instantiations (skipped for generic units, since we
4531 -- never need any cleanups in generic units).
4534 and then not Is_Generic_Unit (Main_Unit_Entity)
4537 elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
4543 end Instantiate_Bodies;
4549 function Is_Nested (E : Entity_Id) return Boolean is
4554 while Scop /= Standard_Standard loop
4555 if Is_Subprogram (Scop) then
4558 elsif Ekind (Scop) = E_Task_Type
4559 or else Ekind (Scop) = E_Entry
4560 or else Ekind (Scop) = E_Entry_Family
4565 Scop := Scope (Scop);
4571 ------------------------
4572 -- List_Inlining_Info --
4573 ------------------------
4575 procedure List_Inlining_Info is
4581 if not Debug_Flag_Dot_J then
4585 -- Generate listing of calls inlined by the frontend
4587 if Present (Inlined_Calls) then
4589 Elmt := First_Elmt (Inlined_Calls);
4590 while Present (Elmt) loop
4593 if not In_Internal_Unit (Nod) then
4597 Write_Str ("List of calls inlined by the frontend");
4604 Write_Location (Sloc (Nod));
4613 -- Generate listing of calls passed to the backend
4615 if Present (Backend_Calls) then
4618 Elmt := First_Elmt (Backend_Calls);
4619 while Present (Elmt) loop
4622 if not In_Internal_Unit (Nod) then
4626 Write_Str ("List of inlined calls passed to the backend");
4633 Write_Location (Sloc (Nod));
4641 -- Generate listing of instances inlined for the backend
4643 if Present (Backend_Instances) then
4646 Elmt := First_Elmt (Backend_Instances);
4647 while Present (Elmt) loop
4650 if not In_Internal_Unit (Nod) then
4654 Write_Str ("List of instances inlined for the backend");
4661 Write_Location (Sloc (Nod));
4669 -- Generate listing of subprograms passed to the backend
4671 if Present (Backend_Inlined_Subps) and then Back_End_Inlining then
4674 Elmt := First_Elmt (Backend_Inlined_Subps);
4675 while Present (Elmt) loop
4678 if not In_Internal_Unit (Nod) then
4683 ("List of inlined subprograms passed to the backend");
4690 Write_Name (Chars (Nod));
4692 Write_Location (Sloc (Nod));
4701 -- Generate listing of subprograms that cannot be inlined by the backend
4703 if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining then
4706 Elmt := First_Elmt (Backend_Not_Inlined_Subps);
4707 while Present (Elmt) loop
4710 if not In_Internal_Unit (Nod) then
4715 ("List of subprograms that cannot be inlined by backend");
4722 Write_Name (Chars (Nod));
4724 Write_Location (Sloc (Nod));
4732 end List_Inlining_Info;
4740 Pending_Instantiations.Release;
4741 Pending_Instantiations.Locked := True;
4742 Called_Pending_Instantiations.Release;
4743 Called_Pending_Instantiations.Locked := True;
4744 Inlined_Bodies.Release;
4745 Inlined_Bodies.Locked := True;
4747 Successors.Locked := True;
4749 Inlined.Locked := True;
4752 --------------------------------
4753 -- Remove_Aspects_And_Pragmas --
4754 --------------------------------
4756 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id) is
4757 procedure Remove_Items (List : List_Id);
4758 -- Remove all useless aspects/pragmas from a particular list
4764 procedure Remove_Items (List : List_Id) is
4767 Next_Item : Node_Id;
4770 -- Traverse the list looking for an aspect specification or a pragma
4772 Item := First (List);
4773 while Present (Item) loop
4774 Next_Item := Next (Item);
4776 if Nkind (Item) = N_Aspect_Specification then
4777 Item_Id := Identifier (Item);
4778 elsif Nkind (Item) = N_Pragma then
4779 Item_Id := Pragma_Identifier (Item);
4784 if Present (Item_Id)
4785 and then Nam_In (Chars (Item_Id), Name_Contract_Cases,
4790 Name_Refined_Global,
4791 Name_Refined_Depends,
4805 -- Start of processing for Remove_Aspects_And_Pragmas
4808 Remove_Items (Aspect_Specifications (Body_Decl));
4809 Remove_Items (Declarations (Body_Decl));
4811 -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear
4812 -- in the body of the subprogram.
4814 Remove_Items (Statements (Handled_Statement_Sequence (Body_Decl)));
4815 end Remove_Aspects_And_Pragmas;
4817 --------------------------
4818 -- Remove_Dead_Instance --
4819 --------------------------
4821 procedure Remove_Dead_Instance (N : Node_Id) is
4826 while J <= Pending_Instantiations.Last loop
4827 if Pending_Instantiations.Table (J).Inst_Node = N then
4828 Pending_Instantiations.Table (J).Inst_Node := Empty;
4834 end Remove_Dead_Instance;