1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Einfo
; use Einfo
;
28 with Elists
; use Elists
;
29 with Errout
; use Errout
;
30 with Exp_Ch7
; use Exp_Ch7
;
31 with Exp_Tss
; use Exp_Tss
;
32 with Fname
; use Fname
;
33 with Fname
.UF
; use Fname
.UF
;
35 with Namet
; use Namet
;
36 with Nlists
; use Nlists
;
37 with Sem_Aux
; use Sem_Aux
;
38 with Sem_Ch8
; use Sem_Ch8
;
39 with Sem_Ch10
; use Sem_Ch10
;
40 with Sem_Ch12
; use Sem_Ch12
;
41 with Sem_Util
; use Sem_Util
;
42 with Sinfo
; use Sinfo
;
43 with Snames
; use Snames
;
44 with Stand
; use Stand
;
45 with Uname
; use Uname
;
47 package body Inline
is
53 -- Inlined functions are actually placed in line by the backend if the
54 -- corresponding bodies are available (i.e. compiled). Whenever we find
55 -- a call to an inlined subprogram, we add the name of the enclosing
56 -- compilation unit to a worklist. After all compilation, and after
57 -- expansion of generic bodies, we traverse the list of pending bodies
58 -- and compile them as well.
60 package Inlined_Bodies
is new Table
.Table
(
61 Table_Component_Type
=> Entity_Id
,
62 Table_Index_Type
=> Int
,
64 Table_Initial
=> Alloc
.Inlined_Bodies_Initial
,
65 Table_Increment
=> Alloc
.Inlined_Bodies_Increment
,
66 Table_Name
=> "Inlined_Bodies");
68 -----------------------
69 -- Inline Processing --
70 -----------------------
72 -- For each call to an inlined subprogram, we make entries in a table
73 -- that stores caller and callee, and indicates a prerequisite from
74 -- one to the other. We also record the compilation unit that contains
75 -- the callee. After analyzing the bodies of all such compilation units,
76 -- we produce a list of subprograms in topological order, for use by the
77 -- back-end. If P2 is a prerequisite of P1, then P1 calls P2, and for
78 -- proper inlining the back-end must analyze the body of P2 before that of
79 -- P1. The code below guarantees that the transitive closure of inlined
80 -- subprograms called from the main compilation unit is made available to
81 -- the code generator.
83 Last_Inlined
: Entity_Id
:= Empty
;
85 -- For each entry in the table we keep a list of successors in topological
86 -- order, i.e. callers of the current subprogram.
88 type Subp_Index
is new Nat
;
89 No_Subp
: constant Subp_Index
:= 0;
91 -- The subprogram entities are hashed into the Inlined table
93 Num_Hash_Headers
: constant := 512;
95 Hash_Headers
: array (Subp_Index
range 0 .. Num_Hash_Headers
- 1)
98 type Succ_Index
is new Nat
;
99 No_Succ
: constant Succ_Index
:= 0;
101 type Succ_Info
is record
106 -- The following table stores list elements for the successor lists.
107 -- These lists cannot be chained directly through entries in the Inlined
108 -- table, because a given subprogram can appear in several such lists.
110 package Successors
is new Table
.Table
(
111 Table_Component_Type
=> Succ_Info
,
112 Table_Index_Type
=> Succ_Index
,
113 Table_Low_Bound
=> 1,
114 Table_Initial
=> Alloc
.Successors_Initial
,
115 Table_Increment
=> Alloc
.Successors_Increment
,
116 Table_Name
=> "Successors");
118 type Subp_Info
is record
119 Name
: Entity_Id
:= Empty
;
120 First_Succ
: Succ_Index
:= No_Succ
;
121 Count
: Integer := 0;
122 Listed
: Boolean := False;
123 Main_Call
: Boolean := False;
124 Next
: Subp_Index
:= No_Subp
;
125 Next_Nopred
: Subp_Index
:= No_Subp
;
128 package Inlined
is new Table
.Table
(
129 Table_Component_Type
=> Subp_Info
,
130 Table_Index_Type
=> Subp_Index
,
131 Table_Low_Bound
=> 1,
132 Table_Initial
=> Alloc
.Inlined_Initial
,
133 Table_Increment
=> Alloc
.Inlined_Increment
,
134 Table_Name
=> "Inlined");
136 -----------------------
137 -- Local Subprograms --
138 -----------------------
140 function Scope_In_Main_Unit
(Scop
: Entity_Id
) return Boolean;
141 -- Return True if Scop is in the main unit or its spec
143 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
);
144 -- Make two entries in Inlined table, for an inlined subprogram being
145 -- called, and for the inlined subprogram that contains the call. If
146 -- the call is in the main compilation unit, Caller is Empty.
148 function Add_Subp
(E
: Entity_Id
) return Subp_Index
;
149 -- Make entry in Inlined table for subprogram E, or return table index
150 -- that already holds E.
152 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean;
153 -- If a candidate for inlining contains type declarations for types with
154 -- non-trivial initialization procedures, they are not worth inlining.
156 function Is_Nested
(E
: Entity_Id
) return Boolean;
157 -- If the function is nested inside some other function, it will
158 -- always be compiled if that function is, so don't add it to the
159 -- inline list. We cannot compile a nested function outside the
160 -- scope of the containing function anyway. This is also the case if
161 -- the function is defined in a task body or within an entry (for
162 -- example, an initialization procedure).
164 procedure Add_Inlined_Subprogram
(Index
: Subp_Index
);
165 -- Add subprogram to Inlined List once all of its predecessors have been
166 -- placed on the list. Decrement the count of all its successors, and
167 -- add them to list (recursively) if count drops to zero.
169 ------------------------------
170 -- Deferred Cleanup Actions --
171 ------------------------------
173 -- The cleanup actions for scopes that contain instantiations is delayed
174 -- until after expansion of those instantiations, because they may
175 -- contain finalizable objects or tasks that affect the cleanup code.
176 -- A scope that contains instantiations only needs to be finalized once,
177 -- even if it contains more than one instance. We keep a list of scopes
178 -- that must still be finalized, and call cleanup_actions after all the
179 -- instantiations have been completed.
183 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
);
184 -- Build set of scopes on which cleanup actions must be performed
186 procedure Cleanup_Scopes
;
187 -- Complete cleanup actions on scopes that need it
193 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
) is
194 P1
: constant Subp_Index
:= Add_Subp
(Called
);
199 if Present
(Caller
) then
200 P2
:= Add_Subp
(Caller
);
202 -- Add P2 to the list of successors of P1, if not already there.
203 -- Note that P2 may contain more than one call to P1, and only
204 -- one needs to be recorded.
206 J
:= Inlined
.Table
(P1
).First_Succ
;
207 while J
/= No_Succ
loop
208 if Successors
.Table
(J
).Subp
= P2
then
212 J
:= Successors
.Table
(J
).Next
;
215 -- On exit, make a successor entry for P2
217 Successors
.Increment_Last
;
218 Successors
.Table
(Successors
.Last
).Subp
:= P2
;
219 Successors
.Table
(Successors
.Last
).Next
:=
220 Inlined
.Table
(P1
).First_Succ
;
221 Inlined
.Table
(P1
).First_Succ
:= Successors
.Last
;
223 Inlined
.Table
(P2
).Count
:= Inlined
.Table
(P2
).Count
+ 1;
226 Inlined
.Table
(P1
).Main_Call
:= True;
230 ----------------------
231 -- Add_Inlined_Body --
232 ----------------------
234 procedure Add_Inlined_Body
(E
: Entity_Id
) is
237 function Must_Inline
return Boolean;
238 -- Inlining is only done if the call statement N is in the main unit,
239 -- or within the body of another inlined subprogram.
245 function Must_Inline
return Boolean is
250 -- Check if call is in main unit
252 Scop
:= Current_Scope
;
254 -- Do not try to inline if scope is standard. This could happen, for
255 -- example, for a call to Add_Global_Declaration, and it causes
256 -- trouble to try to inline at this level.
258 if Scop
= Standard_Standard
then
262 -- Otherwise lookup scope stack to outer scope
264 while Scope
(Scop
) /= Standard_Standard
265 and then not Is_Child_Unit
(Scop
)
267 Scop
:= Scope
(Scop
);
270 Comp
:= Parent
(Scop
);
271 while Nkind
(Comp
) /= N_Compilation_Unit
loop
272 Comp
:= Parent
(Comp
);
275 if Comp
= Cunit
(Main_Unit
)
276 or else Comp
= Library_Unit
(Cunit
(Main_Unit
))
282 -- Call is not in main unit. See if it's in some inlined subprogram
284 Scop
:= Current_Scope
;
285 while Scope
(Scop
) /= Standard_Standard
286 and then not Is_Child_Unit
(Scop
)
288 if Is_Overloadable
(Scop
)
289 and then Is_Inlined
(Scop
)
295 Scop
:= Scope
(Scop
);
301 -- Start of processing for Add_Inlined_Body
304 -- Find unit containing E, and add to list of inlined bodies if needed.
305 -- If the body is already present, no need to load any other unit. This
306 -- is the case for an initialization procedure, which appears in the
307 -- package declaration that contains the type. It is also the case if
308 -- the body has already been analyzed. Finally, if the unit enclosing
309 -- E is an instance, the instance body will be analyzed in any case,
310 -- and there is no need to add the enclosing unit (whose body might not
313 -- Library-level functions must be handled specially, because there is
314 -- no enclosing package to retrieve. In this case, it is the body of
315 -- the function that will have to be loaded.
317 if not Is_Abstract_Subprogram
(E
) and then not Is_Nested
(E
)
318 and then Convention
(E
) /= Convention_Protected
323 and then Ekind
(Pack
) = E_Package
327 if Pack
= Standard_Standard
then
329 -- Library-level inlined function. Add function itself to
330 -- list of needed units.
332 Inlined_Bodies
.Increment_Last
;
333 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
335 elsif Is_Generic_Instance
(Pack
) then
338 elsif not Is_Inlined
(Pack
)
339 and then not Has_Completion
(E
)
341 Set_Is_Inlined
(Pack
);
342 Inlined_Bodies
.Increment_Last
;
343 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
347 end Add_Inlined_Body
;
349 ----------------------------
350 -- Add_Inlined_Subprogram --
351 ----------------------------
353 procedure Add_Inlined_Subprogram
(Index
: Subp_Index
) is
354 E
: constant Entity_Id
:= Inlined
.Table
(Index
).Name
;
355 Pack
: constant Entity_Id
:= Cunit_Entity
(Get_Code_Unit
(E
));
359 function Back_End_Cannot_Inline
(Subp
: Entity_Id
) return Boolean;
360 -- There are various conditions under which back-end inlining cannot
363 -- a) If a body has handlers, it must not be inlined, because this
364 -- may violate program semantics, and because in zero-cost exception
365 -- mode it will lead to undefined symbols at link time.
367 -- b) If a body contains inlined function instances, it cannot be
368 -- inlined under ZCX because the numeric suffix generated by gigi
369 -- will be different in the body and the place of the inlined call.
371 -- If the body to be inlined contains calls to subprograms declared
372 -- in the same body that have no previous spec, the back-end cannot
373 -- inline either because the bodies to be inlined are processed before
374 -- the rest of the enclosing package body, and gigi will then find
375 -- references to entities that have not been elaborated yet.
377 -- This procedure must be carefully coordinated with the back end.
379 ----------------------------
380 -- Back_End_Cannot_Inline --
381 ----------------------------
383 function Back_End_Cannot_Inline
(Subp
: Entity_Id
) return Boolean is
384 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
385 Body_Ent
: Entity_Id
;
389 function Process
(N
: Node_Id
) return Traverse_Result
;
390 -- Look for calls to subprograms with no previous spec, declared
391 -- in the same enclosing package body.
397 function Process
(N
: Node_Id
) return Traverse_Result
is
399 if Nkind
(N
) = N_Procedure_Call_Statement
400 or else Nkind
(N
) = N_Function_Call
402 if Is_Entity_Name
(Name
(N
))
403 and then Comes_From_Source
(Entity
(Name
(N
)))
405 Nkind
(Unit_Declaration_Node
(Entity
(Name
(N
))))
407 and then In_Same_Extended_Unit
(Subp
, Entity
(Name
(N
)))
419 function Has_Exposed_Call
is new Traverse_Func
(Process
);
421 -- Start of processing for Back_End_Cannot_Inline
424 if Nkind
(Decl
) = N_Subprogram_Declaration
425 and then Present
(Corresponding_Body
(Decl
))
427 Body_Ent
:= Corresponding_Body
(Decl
);
432 -- If subprogram is marked Inline_Always, inlining is mandatory
434 if Has_Pragma_Inline_Always
(Subp
) then
440 (Handled_Statement_Sequence
441 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)))))
446 Ent
:= First_Entity
(Body_Ent
);
447 while Present
(Ent
) loop
448 if Is_Subprogram
(Ent
)
449 and then Is_Generic_Instance
(Ent
)
458 (Unit_Declaration_Node
(Corresponding_Body
(Decl
))) = Abandon
460 if Ineffective_Inline_Warnings
then
462 ("?call to subprogram with no separate spec"
463 & " prevents inlining!!", Bad_Call
);
470 end Back_End_Cannot_Inline
;
472 -- Start of processing for Add_Inlined_Subprogram
475 -- Insert the current subprogram in the list of inlined subprograms, if
476 -- it can actually be inlined by the back-end, and if its unit is known
477 -- to be inlined, or is an instance whose body will be analyzed anyway.
479 if (Is_Inlined
(Pack
) or else Is_Generic_Instance
(Pack
))
480 and then not Scope_In_Main_Unit
(E
)
481 and then Is_Inlined
(E
)
482 and then not Is_Nested
(E
)
483 and then not Has_Initialized_Type
(E
)
485 if Back_End_Cannot_Inline
(E
) then
486 Set_Is_Inlined
(E
, False);
489 if No
(Last_Inlined
) then
490 Set_First_Inlined_Subprogram
(Cunit
(Main_Unit
), E
);
492 Set_Next_Inlined_Subprogram
(Last_Inlined
, E
);
499 Inlined
.Table
(Index
).Listed
:= True;
501 -- Now add to the list those callers of the current subprogram that
502 -- are themselves called. They may appear on the graph as callers
503 -- of the current one, even if they are themselves not called, and
504 -- there is no point in including them in the list for the backend.
505 -- Furthermore, they might not even be public, in which case the
506 -- back-end cannot handle them at all.
508 Succ
:= Inlined
.Table
(Index
).First_Succ
;
509 while Succ
/= No_Succ
loop
510 Subp
:= Successors
.Table
(Succ
).Subp
;
511 Inlined
.Table
(Subp
).Count
:= Inlined
.Table
(Subp
).Count
- 1;
513 if Inlined
.Table
(Subp
).Count
= 0
514 and then Is_Called
(Inlined
.Table
(Subp
).Name
)
516 Add_Inlined_Subprogram
(Subp
);
519 Succ
:= Successors
.Table
(Succ
).Next
;
521 end Add_Inlined_Subprogram
;
523 ------------------------
524 -- Add_Scope_To_Clean --
525 ------------------------
527 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
) is
528 Scop
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(Inst
);
532 -- If the instance appears in a library-level package declaration,
533 -- all finalization is global, and nothing needs doing here.
535 if Scop
= Standard_Standard
then
539 -- If the instance appears within a generic subprogram there is nothing
540 -- to finalize either.
547 while Present
(S
) and then S
/= Standard_Standard
loop
548 if Is_Generic_Subprogram
(S
) then
556 Elmt
:= First_Elmt
(To_Clean
);
557 while Present
(Elmt
) loop
558 if Node
(Elmt
) = Scop
then
562 Elmt
:= Next_Elmt
(Elmt
);
565 Append_Elmt
(Scop
, To_Clean
);
566 end Add_Scope_To_Clean
;
572 function Add_Subp
(E
: Entity_Id
) return Subp_Index
is
573 Index
: Subp_Index
:= Subp_Index
(E
) mod Num_Hash_Headers
;
577 -- Initialize entry in Inlined table
579 procedure New_Entry
is
581 Inlined
.Increment_Last
;
582 Inlined
.Table
(Inlined
.Last
).Name
:= E
;
583 Inlined
.Table
(Inlined
.Last
).First_Succ
:= No_Succ
;
584 Inlined
.Table
(Inlined
.Last
).Count
:= 0;
585 Inlined
.Table
(Inlined
.Last
).Listed
:= False;
586 Inlined
.Table
(Inlined
.Last
).Main_Call
:= False;
587 Inlined
.Table
(Inlined
.Last
).Next
:= No_Subp
;
588 Inlined
.Table
(Inlined
.Last
).Next_Nopred
:= No_Subp
;
591 -- Start of processing for Add_Subp
594 if Hash_Headers
(Index
) = No_Subp
then
596 Hash_Headers
(Index
) := Inlined
.Last
;
600 J
:= Hash_Headers
(Index
);
601 while J
/= No_Subp
loop
602 if Inlined
.Table
(J
).Name
= E
then
606 J
:= Inlined
.Table
(J
).Next
;
610 -- On exit, subprogram was not found. Enter in table. Index is
611 -- the current last entry on the hash chain.
614 Inlined
.Table
(Index
).Next
:= Inlined
.Last
;
619 ----------------------------
620 -- Analyze_Inlined_Bodies --
621 ----------------------------
623 procedure Analyze_Inlined_Bodies
is
629 function Is_Ancestor_Of_Main
631 Nam
: Node_Id
) return Boolean;
632 -- Determine whether the unit whose body is loaded is an ancestor of
633 -- the main unit, and has a with_clause on it. The body is not
634 -- analyzed yet, so the check is purely lexical: the name of the with
635 -- clause is a selected component, and names of ancestors must match.
637 -------------------------
638 -- Is_Ancestor_Of_Main --
639 -------------------------
641 function Is_Ancestor_Of_Main
643 Nam
: Node_Id
) return Boolean
648 if Nkind
(Nam
) /= N_Selected_Component
then
652 if Chars
(Selector_Name
(Nam
)) /=
653 Chars
(Cunit_Entity
(Main_Unit
))
658 Pref
:= Prefix
(Nam
);
659 if Nkind
(Pref
) = N_Identifier
then
661 -- Par is an ancestor of Par.Child.
663 return Chars
(Pref
) = Chars
(U_Name
);
665 elsif Nkind
(Pref
) = N_Selected_Component
666 and then Chars
(Selector_Name
(Pref
)) = Chars
(U_Name
)
668 -- Par.Child is an ancestor of Par.Child.Grand.
670 return True; -- should check that ancestor match
673 -- A is an ancestor of A.B.C if it is an ancestor of A.B
675 return Is_Ancestor_Of_Main
(U_Name
, Pref
);
678 end Is_Ancestor_Of_Main
;
680 -- Start of processing for Analyze_Inlined_Bodies
683 Analyzing_Inlined_Bodies
:= False;
685 if Serious_Errors_Detected
= 0 then
686 Push_Scope
(Standard_Standard
);
689 while J
<= Inlined_Bodies
.Last
690 and then Serious_Errors_Detected
= 0
692 Pack
:= Inlined_Bodies
.Table
(J
);
694 and then Scope
(Pack
) /= Standard_Standard
695 and then not Is_Child_Unit
(Pack
)
697 Pack
:= Scope
(Pack
);
700 Comp_Unit
:= Parent
(Pack
);
701 while Present
(Comp_Unit
)
702 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
704 Comp_Unit
:= Parent
(Comp_Unit
);
707 -- Load the body, unless it the main unit, or is an instance whose
708 -- body has already been analyzed.
710 if Present
(Comp_Unit
)
711 and then Comp_Unit
/= Cunit
(Main_Unit
)
712 and then Body_Required
(Comp_Unit
)
713 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
714 or else No
(Corresponding_Body
(Unit
(Comp_Unit
))))
717 Bname
: constant Unit_Name_Type
:=
718 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
723 if not Is_Loaded
(Bname
) then
724 Style_Check
:= False;
725 Load_Needed_Body
(Comp_Unit
, OK
, Do_Analyze
=> False);
729 -- Warn that a body was not available for inlining
732 Error_Msg_Unit_1
:= Bname
;
734 ("one or more inlined subprograms accessed in $!?",
737 Get_File_Name
(Bname
, Subunit
=> False);
738 Error_Msg_N
("\but file{ was not found!?", Comp_Unit
);
741 -- If the package to be inlined is an ancestor unit of
742 -- the main unit, and it has a semantic dependence on
743 -- it, the inlining cannot take place to prevent an
744 -- elaboration circularity. The desired body is not
745 -- analyzed yet, to prevent the completion of Taft
746 -- amendment types that would lead to elaboration
747 -- circularities in gigi.
750 U_Id
: constant Entity_Id
:=
751 Defining_Entity
(Unit
(Comp_Unit
));
752 Body_Unit
: constant Node_Id
:=
753 Library_Unit
(Comp_Unit
);
757 Item
:= First
(Context_Items
(Body_Unit
));
758 while Present
(Item
) loop
759 if Nkind
(Item
) = N_With_Clause
761 Is_Ancestor_Of_Main
(U_Id
, Name
(Item
))
763 Set_Is_Inlined
(U_Id
, False);
770 -- If no suspicious with_clauses, analyze the body.
772 if Is_Inlined
(U_Id
) then
773 Semantics
(Body_Unit
);
784 -- The analysis of required bodies may have produced additional
785 -- generic instantiations. To obtain further inlining, we perform
786 -- another round of generic body instantiations. Establishing a
787 -- fully recursive loop between inlining and generic instantiations
788 -- is unlikely to yield more than this one additional pass.
792 -- The list of inlined subprograms is an overestimate, because it
793 -- includes inlined functions called from functions that are compiled
794 -- as part of an inlined package, but are not themselves called. An
795 -- accurate computation of just those subprograms that are needed
796 -- requires that we perform a transitive closure over the call graph,
797 -- starting from calls in the main program. Here we do one step of
798 -- the inverse transitive closure, and reset the Is_Called flag on
799 -- subprograms all of whose callers are not.
801 for Index
in Inlined
.First
.. Inlined
.Last
loop
802 S
:= Inlined
.Table
(Index
).First_Succ
;
805 and then not Inlined
.Table
(Index
).Main_Call
807 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
809 while S
/= No_Succ
loop
811 (Inlined
.Table
(Successors
.Table
(S
).Subp
).Name
)
812 or else Inlined
.Table
(Successors
.Table
(S
).Subp
).Main_Call
814 Set_Is_Called
(Inlined
.Table
(Index
).Name
);
818 S
:= Successors
.Table
(S
).Next
;
823 -- Now that the units are compiled, chain the subprograms within
824 -- that are called and inlined. Produce list of inlined subprograms
825 -- sorted in topological order. Start with all subprograms that
826 -- have no prerequisites, i.e. inlined subprograms that do not call
827 -- other inlined subprograms.
829 for Index
in Inlined
.First
.. Inlined
.Last
loop
831 if Is_Called
(Inlined
.Table
(Index
).Name
)
832 and then Inlined
.Table
(Index
).Count
= 0
833 and then not Inlined
.Table
(Index
).Listed
835 Add_Inlined_Subprogram
(Index
);
839 -- Because Add_Inlined_Subprogram treats recursively nodes that have
840 -- no prerequisites left, at the end of the loop all subprograms
841 -- must have been listed. If there are any unlisted subprograms
842 -- left, there must be some recursive chains that cannot be inlined.
844 for Index
in Inlined
.First
.. Inlined
.Last
loop
845 if Is_Called
(Inlined
.Table
(Index
).Name
)
846 and then Inlined
.Table
(Index
).Count
/= 0
847 and then not Is_Predefined_File_Name
849 (Get_Source_Unit
(Inlined
.Table
(Index
).Name
)))
852 ("& cannot be inlined?", Inlined
.Table
(Index
).Name
);
854 -- A warning on the first one might be sufficient ???
860 end Analyze_Inlined_Bodies
;
862 -----------------------------
863 -- Check_Body_For_Inlining --
864 -----------------------------
866 procedure Check_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
867 Bname
: Unit_Name_Type
;
872 if Is_Compilation_Unit
(P
)
873 and then not Is_Generic_Instance
(P
)
875 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
877 E
:= First_Entity
(P
);
878 while Present
(E
) loop
879 if Has_Pragma_Inline_Always
(E
)
880 or else (Front_End_Inlining
and then Has_Pragma_Inline
(E
))
882 if not Is_Loaded
(Bname
) then
883 Load_Needed_Body
(N
, OK
);
887 -- Check we are not trying to inline a parent whose body
888 -- depends on a child, when we are compiling the body of
889 -- the child. Otherwise we have a potential elaboration
890 -- circularity with inlined subprograms and with
891 -- Taft-Amendment types.
894 Comp
: Node_Id
; -- Body just compiled
895 Child_Spec
: Entity_Id
; -- Spec of main unit
896 Ent
: Entity_Id
; -- For iteration
897 With_Clause
: Node_Id
; -- Context of body.
900 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
901 and then Present
(Body_Entity
(P
))
905 ((Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
908 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
910 -- Check whether the context of the body just
911 -- compiled includes a child of itself, and that
912 -- child is the spec of the main compilation.
914 With_Clause
:= First
(Context_Items
(Comp
));
915 while Present
(With_Clause
) loop
916 if Nkind
(With_Clause
) = N_With_Clause
918 Scope
(Entity
(Name
(With_Clause
))) = P
920 Entity
(Name
(With_Clause
)) = Child_Spec
922 Error_Msg_Node_2
:= Child_Spec
;
924 ("body of & depends on child unit&?",
927 ("\subprograms in body cannot be inlined?",
930 -- Disable further inlining from this unit,
931 -- and keep Taft-amendment types incomplete.
933 Ent
:= First_Entity
(P
);
934 while Present
(Ent
) loop
936 and then Has_Completion_In_Body
(Ent
)
938 Set_Full_View
(Ent
, Empty
);
940 elsif Is_Subprogram
(Ent
) then
941 Set_Is_Inlined
(Ent
, False);
955 elsif Ineffective_Inline_Warnings
then
956 Error_Msg_Unit_1
:= Bname
;
958 ("unable to inline subprograms defined in $?", P
);
959 Error_Msg_N
("\body not found?", P
);
970 end Check_Body_For_Inlining
;
976 procedure Cleanup_Scopes
is
982 Elmt
:= First_Elmt
(To_Clean
);
983 while Present
(Elmt
) loop
986 if Ekind
(Scop
) = E_Entry
then
987 Scop
:= Protected_Body_Subprogram
(Scop
);
989 elsif Is_Subprogram
(Scop
)
990 and then Is_Protected_Type
(Scope
(Scop
))
991 and then Present
(Protected_Body_Subprogram
(Scop
))
993 -- If a protected operation contains an instance, its
994 -- cleanup operations have been delayed, and the subprogram
995 -- has been rewritten in the expansion of the enclosing
996 -- protected body. It is the corresponding subprogram that
997 -- may require the cleanup operations, so propagate the
998 -- information that triggers cleanup activity.
1001 (Protected_Body_Subprogram
(Scop
),
1002 Uses_Sec_Stack
(Scop
));
1003 Set_Finalization_Chain_Entity
1004 (Protected_Body_Subprogram
(Scop
),
1005 Finalization_Chain_Entity
(Scop
));
1006 Scop
:= Protected_Body_Subprogram
(Scop
);
1009 if Ekind
(Scop
) = E_Block
then
1010 Decl
:= Parent
(Block_Node
(Scop
));
1013 Decl
:= Unit_Declaration_Node
(Scop
);
1015 if Nkind
(Decl
) = N_Subprogram_Declaration
1016 or else Nkind
(Decl
) = N_Task_Type_Declaration
1017 or else Nkind
(Decl
) = N_Subprogram_Body_Stub
1019 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
1024 Expand_Cleanup_Actions
(Decl
);
1027 Elmt
:= Next_Elmt
(Elmt
);
1031 --------------------------
1032 -- Has_Initialized_Type --
1033 --------------------------
1035 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
1036 E_Body
: constant Node_Id
:= Get_Subprogram_Body
(E
);
1040 if No
(E_Body
) then -- imported subprogram
1044 Decl
:= First
(Declarations
(E_Body
));
1045 while Present
(Decl
) loop
1047 if Nkind
(Decl
) = N_Full_Type_Declaration
1048 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
1058 end Has_Initialized_Type
;
1064 procedure Initialize
is
1066 Analyzing_Inlined_Bodies
:= False;
1067 Pending_Descriptor
.Init
;
1068 Pending_Instantiations
.Init
;
1069 Inlined_Bodies
.Init
;
1073 for J
in Hash_Headers
'Range loop
1074 Hash_Headers
(J
) := No_Subp
;
1078 ------------------------
1079 -- Instantiate_Bodies --
1080 ------------------------
1082 -- Generic bodies contain all the non-local references, so an
1083 -- instantiation does not need any more context than Standard
1084 -- itself, even if the instantiation appears in an inner scope.
1085 -- Generic associations have verified that the contract model is
1086 -- satisfied, so that any error that may occur in the analysis of
1087 -- the body is an internal error.
1089 procedure Instantiate_Bodies
is
1091 Info
: Pending_Body_Info
;
1094 if Serious_Errors_Detected
= 0 then
1096 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
1097 Push_Scope
(Standard_Standard
);
1098 To_Clean
:= New_Elmt_List
;
1100 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
1104 -- A body instantiation may generate additional instantiations, so
1105 -- the following loop must scan to the end of a possibly expanding
1106 -- set (that's why we can't simply use a FOR loop here).
1109 while J
<= Pending_Instantiations
.Last
1110 and then Serious_Errors_Detected
= 0
1112 Info
:= Pending_Instantiations
.Table
(J
);
1114 -- If the instantiation node is absent, it has been removed
1115 -- as part of unreachable code.
1117 if No
(Info
.Inst_Node
) then
1120 elsif Nkind
(Info
.Act_Decl
) = N_Package_Declaration
then
1121 Instantiate_Package_Body
(Info
);
1122 Add_Scope_To_Clean
(Defining_Entity
(Info
.Act_Decl
));
1125 Instantiate_Subprogram_Body
(Info
);
1131 -- Reset the table of instantiations. Additional instantiations
1132 -- may be added through inlining, when additional bodies are
1135 Pending_Instantiations
.Init
;
1137 -- We can now complete the cleanup actions of scopes that contain
1138 -- pending instantiations (skipped for generic units, since we
1139 -- never need any cleanups in generic units).
1140 -- pending instantiations.
1143 and then not Is_Generic_Unit
(Main_Unit_Entity
)
1146 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
1152 end Instantiate_Bodies
;
1158 function Is_Nested
(E
: Entity_Id
) return Boolean is
1163 while Scop
/= Standard_Standard
loop
1164 if Ekind
(Scop
) in Subprogram_Kind
then
1167 elsif Ekind
(Scop
) = E_Task_Type
1168 or else Ekind
(Scop
) = E_Entry
1169 or else Ekind
(Scop
) = E_Entry_Family
then
1173 Scop
:= Scope
(Scop
);
1185 Pending_Instantiations
.Locked
:= True;
1186 Inlined_Bodies
.Locked
:= True;
1187 Successors
.Locked
:= True;
1188 Inlined
.Locked
:= True;
1189 Pending_Instantiations
.Release
;
1190 Inlined_Bodies
.Release
;
1195 --------------------------
1196 -- Remove_Dead_Instance --
1197 --------------------------
1199 procedure Remove_Dead_Instance
(N
: Node_Id
) is
1204 while J
<= Pending_Instantiations
.Last
loop
1205 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
1206 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
1212 end Remove_Dead_Instance
;
1214 ------------------------
1215 -- Scope_In_Main_Unit --
1216 ------------------------
1218 function Scope_In_Main_Unit
(Scop
: Entity_Id
) return Boolean is
1219 Comp
: constant Node_Id
:= Cunit
(Get_Code_Unit
(Scop
));
1222 -- Check whether the scope of the subprogram to inline is within the
1223 -- main unit or within its spec. In either case there are no additional
1224 -- bodies to process. If the subprogram appears in a parent of the
1225 -- current unit, the check on whether inlining is possible is done in
1226 -- Analyze_Inlined_Bodies.
1229 Comp
= Cunit
(Main_Unit
)
1230 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
1231 end Scope_In_Main_Unit
;