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, or in a
142 -- parent of the main unit if it is a child unit.
144 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
);
145 -- Make two entries in Inlined table, for an inlined subprogram being
146 -- called, and for the inlined subprogram that contains the call. If
147 -- the call is in the main compilation unit, Caller is Empty.
149 function Add_Subp
(E
: Entity_Id
) return Subp_Index
;
150 -- Make entry in Inlined table for subprogram E, or return table index
151 -- that already holds E.
153 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean;
154 -- If a candidate for inlining contains type declarations for types with
155 -- non-trivial initialization procedures, they are not worth inlining.
157 function Is_Nested
(E
: Entity_Id
) return Boolean;
158 -- If the function is nested inside some other function, it will
159 -- always be compiled if that function is, so don't add it to the
160 -- inline list. We cannot compile a nested function outside the
161 -- scope of the containing function anyway. This is also the case if
162 -- the function is defined in a task body or within an entry (for
163 -- example, an initialization procedure).
165 procedure Add_Inlined_Subprogram
(Index
: Subp_Index
);
166 -- Add subprogram to Inlined List once all of its predecessors have been
167 -- placed on the list. Decrement the count of all its successors, and
168 -- add them to list (recursively) if count drops to zero.
170 ------------------------------
171 -- Deferred Cleanup Actions --
172 ------------------------------
174 -- The cleanup actions for scopes that contain instantiations is delayed
175 -- until after expansion of those instantiations, because they may
176 -- contain finalizable objects or tasks that affect the cleanup code.
177 -- A scope that contains instantiations only needs to be finalized once,
178 -- even if it contains more than one instance. We keep a list of scopes
179 -- that must still be finalized, and call cleanup_actions after all the
180 -- instantiations have been completed.
184 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
);
185 -- Build set of scopes on which cleanup actions must be performed
187 procedure Cleanup_Scopes
;
188 -- Complete cleanup actions on scopes that need it
194 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
) is
195 P1
: constant Subp_Index
:= Add_Subp
(Called
);
200 if Present
(Caller
) then
201 P2
:= Add_Subp
(Caller
);
203 -- Add P2 to the list of successors of P1, if not already there.
204 -- Note that P2 may contain more than one call to P1, and only
205 -- one needs to be recorded.
207 J
:= Inlined
.Table
(P1
).First_Succ
;
208 while J
/= No_Succ
loop
209 if Successors
.Table
(J
).Subp
= P2
then
213 J
:= Successors
.Table
(J
).Next
;
216 -- On exit, make a successor entry for P2
218 Successors
.Increment_Last
;
219 Successors
.Table
(Successors
.Last
).Subp
:= P2
;
220 Successors
.Table
(Successors
.Last
).Next
:=
221 Inlined
.Table
(P1
).First_Succ
;
222 Inlined
.Table
(P1
).First_Succ
:= Successors
.Last
;
224 Inlined
.Table
(P2
).Count
:= Inlined
.Table
(P2
).Count
+ 1;
227 Inlined
.Table
(P1
).Main_Call
:= True;
231 ----------------------
232 -- Add_Inlined_Body --
233 ----------------------
235 procedure Add_Inlined_Body
(E
: Entity_Id
) is
238 function Must_Inline
return Boolean;
239 -- Inlining is only done if the call statement N is in the main unit,
240 -- or within the body of another inlined subprogram.
246 function Must_Inline
return Boolean is
251 -- Check if call is in main unit
253 Scop
:= Current_Scope
;
255 -- Do not try to inline if scope is standard. This could happen, for
256 -- example, for a call to Add_Global_Declaration, and it causes
257 -- trouble to try to inline at this level.
259 if Scop
= Standard_Standard
then
263 -- Otherwise lookup scope stack to outer scope
265 while Scope
(Scop
) /= Standard_Standard
266 and then not Is_Child_Unit
(Scop
)
268 Scop
:= Scope
(Scop
);
271 Comp
:= Parent
(Scop
);
272 while Nkind
(Comp
) /= N_Compilation_Unit
loop
273 Comp
:= Parent
(Comp
);
276 if Comp
= Cunit
(Main_Unit
)
277 or else Comp
= Library_Unit
(Cunit
(Main_Unit
))
283 -- Call is not in main unit. See if it's in some inlined subprogram
285 Scop
:= Current_Scope
;
286 while Scope
(Scop
) /= Standard_Standard
287 and then not Is_Child_Unit
(Scop
)
289 if Is_Overloadable
(Scop
)
290 and then Is_Inlined
(Scop
)
296 Scop
:= Scope
(Scop
);
302 -- Start of processing for Add_Inlined_Body
305 -- Find unit containing E, and add to list of inlined bodies if needed.
306 -- If the body is already present, no need to load any other unit. This
307 -- is the case for an initialization procedure, which appears in the
308 -- package declaration that contains the type. It is also the case if
309 -- the body has already been analyzed. Finally, if the unit enclosing
310 -- E is an instance, the instance body will be analyzed in any case,
311 -- and there is no need to add the enclosing unit (whose body might not
314 -- Library-level functions must be handled specially, because there is
315 -- no enclosing package to retrieve. In this case, it is the body of
316 -- the function that will have to be loaded.
318 if not Is_Abstract_Subprogram
(E
) and then not Is_Nested
(E
)
319 and then Convention
(E
) /= Convention_Protected
324 and then Ekind
(Pack
) = E_Package
328 if Pack
= Standard_Standard
then
330 -- Library-level inlined function. Add function itself to
331 -- list of needed units.
333 Inlined_Bodies
.Increment_Last
;
334 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
336 elsif Is_Generic_Instance
(Pack
) then
339 elsif not Is_Inlined
(Pack
)
340 and then not Has_Completion
(E
)
341 and then not Scope_In_Main_Unit
(Pack
)
343 Set_Is_Inlined
(Pack
);
344 Inlined_Bodies
.Increment_Last
;
345 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
349 end Add_Inlined_Body
;
351 ----------------------------
352 -- Add_Inlined_Subprogram --
353 ----------------------------
355 procedure Add_Inlined_Subprogram
(Index
: Subp_Index
) is
356 E
: constant Entity_Id
:= Inlined
.Table
(Index
).Name
;
360 function Back_End_Cannot_Inline
(Subp
: Entity_Id
) return Boolean;
361 -- There are various conditions under which back-end inlining cannot
364 -- a) If a body has handlers, it must not be inlined, because this
365 -- may violate program semantics, and because in zero-cost exception
366 -- mode it will lead to undefined symbols at link time.
368 -- b) If a body contains inlined function instances, it cannot be
369 -- inlined under ZCX because the numeric suffix generated by gigi
370 -- will be different in the body and the place of the inlined call.
372 -- If the body to be inlined contains calls to subprograms declared
373 -- in the same body that have no previous spec, the back-end cannot
374 -- inline either because the bodies to be inlined are processed before
375 -- the rest of the enclosing package body, and gigi will then find
376 -- references to entities that have not been elaborated yet.
378 -- This procedure must be carefully coordinated with the back end.
380 ----------------------------
381 -- Back_End_Cannot_Inline --
382 ----------------------------
384 function Back_End_Cannot_Inline
(Subp
: Entity_Id
) return Boolean is
385 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
386 Body_Ent
: Entity_Id
;
390 function Process
(N
: Node_Id
) return Traverse_Result
;
391 -- Look for calls to subprograms with no previous spec, declared
392 -- in the same enclosiong package body.
398 function Process
(N
: Node_Id
) return Traverse_Result
is
400 if Nkind
(N
) = N_Procedure_Call_Statement
401 or else Nkind
(N
) = N_Function_Call
403 if Is_Entity_Name
(Name
(N
))
404 and then Comes_From_Source
(Entity
(Name
(N
)))
406 Nkind
(Unit_Declaration_Node
(Entity
(Name
(N
))))
408 and then In_Same_Extended_Unit
(Subp
, Entity
(Name
(N
)))
420 function Has_Exposed_Call
is new Traverse_Func
(Process
);
422 -- Start of processing for Back_End_Cannot_Inline
425 if Nkind
(Decl
) = N_Subprogram_Declaration
426 and then Present
(Corresponding_Body
(Decl
))
428 Body_Ent
:= Corresponding_Body
(Decl
);
433 -- If subprogram is marked Inline_Always, inlining is mandatory
435 if Has_Pragma_Inline_Always
(Subp
) then
441 (Handled_Statement_Sequence
442 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)))))
447 Ent
:= First_Entity
(Body_Ent
);
448 while Present
(Ent
) loop
449 if Is_Subprogram
(Ent
)
450 and then Is_Generic_Instance
(Ent
)
459 (Unit_Declaration_Node
(Corresponding_Body
(Decl
))) = Abandon
461 if Ineffective_Inline_Warnings
then
463 ("?call to subprogram with no separate spec"
464 & " prevents inlining!!", Bad_Call
);
471 end Back_End_Cannot_Inline
;
473 -- Start of processing for Add_Inlined_Subprogram
476 -- Insert the current subprogram in the list of inlined subprograms,
477 -- if it can actually be inlined by the back-end.
479 if not Scope_In_Main_Unit
(E
)
480 and then Is_Inlined
(E
)
481 and then not Is_Nested
(E
)
482 and then not Has_Initialized_Type
(E
)
484 if Back_End_Cannot_Inline
(E
) then
485 Set_Is_Inlined
(E
, False);
488 if No
(Last_Inlined
) then
489 Set_First_Inlined_Subprogram
(Cunit
(Main_Unit
), E
);
491 Set_Next_Inlined_Subprogram
(Last_Inlined
, E
);
498 Inlined
.Table
(Index
).Listed
:= True;
500 -- Now add to the list those callers of the current subprogram that
501 -- are themselves called. They may appear on the graph as callers
502 -- of the current one, even if they are themselves not called, and
503 -- there is no point in including them in the list for the backend.
504 -- Furthermore, they might not even be public, in which case the
505 -- back-end cannot handle them at all.
507 Succ
:= Inlined
.Table
(Index
).First_Succ
;
508 while Succ
/= No_Succ
loop
509 Subp
:= Successors
.Table
(Succ
).Subp
;
510 Inlined
.Table
(Subp
).Count
:= Inlined
.Table
(Subp
).Count
- 1;
512 if Inlined
.Table
(Subp
).Count
= 0
513 and then Is_Called
(Inlined
.Table
(Subp
).Name
)
515 Add_Inlined_Subprogram
(Subp
);
518 Succ
:= Successors
.Table
(Succ
).Next
;
520 end Add_Inlined_Subprogram
;
522 ------------------------
523 -- Add_Scope_To_Clean --
524 ------------------------
526 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
) is
527 Scop
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(Inst
);
531 -- If the instance appears in a library-level package declaration,
532 -- all finalization is global, and nothing needs doing here.
534 if Scop
= Standard_Standard
then
538 -- If the instance appears within a generic subprogram there is nothing
539 -- to finalize either.
546 while Present
(S
) and then S
/= Standard_Standard
loop
547 if Is_Generic_Subprogram
(S
) then
555 Elmt
:= First_Elmt
(To_Clean
);
556 while Present
(Elmt
) loop
557 if Node
(Elmt
) = Scop
then
561 Elmt
:= Next_Elmt
(Elmt
);
564 Append_Elmt
(Scop
, To_Clean
);
565 end Add_Scope_To_Clean
;
571 function Add_Subp
(E
: Entity_Id
) return Subp_Index
is
572 Index
: Subp_Index
:= Subp_Index
(E
) mod Num_Hash_Headers
;
576 -- Initialize entry in Inlined table
578 procedure New_Entry
is
580 Inlined
.Increment_Last
;
581 Inlined
.Table
(Inlined
.Last
).Name
:= E
;
582 Inlined
.Table
(Inlined
.Last
).First_Succ
:= No_Succ
;
583 Inlined
.Table
(Inlined
.Last
).Count
:= 0;
584 Inlined
.Table
(Inlined
.Last
).Listed
:= False;
585 Inlined
.Table
(Inlined
.Last
).Main_Call
:= False;
586 Inlined
.Table
(Inlined
.Last
).Next
:= No_Subp
;
587 Inlined
.Table
(Inlined
.Last
).Next_Nopred
:= No_Subp
;
590 -- Start of processing for Add_Subp
593 if Hash_Headers
(Index
) = No_Subp
then
595 Hash_Headers
(Index
) := Inlined
.Last
;
599 J
:= Hash_Headers
(Index
);
600 while J
/= No_Subp
loop
601 if Inlined
.Table
(J
).Name
= E
then
605 J
:= Inlined
.Table
(J
).Next
;
609 -- On exit, subprogram was not found. Enter in table. Index is
610 -- the current last entry on the hash chain.
613 Inlined
.Table
(Index
).Next
:= Inlined
.Last
;
618 ----------------------------
619 -- Analyze_Inlined_Bodies --
620 ----------------------------
622 procedure Analyze_Inlined_Bodies
is
629 Analyzing_Inlined_Bodies
:= False;
631 if Serious_Errors_Detected
= 0 then
632 Push_Scope
(Standard_Standard
);
635 while J
<= Inlined_Bodies
.Last
636 and then Serious_Errors_Detected
= 0
638 Pack
:= Inlined_Bodies
.Table
(J
);
640 and then Scope
(Pack
) /= Standard_Standard
641 and then not Is_Child_Unit
(Pack
)
643 Pack
:= Scope
(Pack
);
646 Comp_Unit
:= Parent
(Pack
);
647 while Present
(Comp_Unit
)
648 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
650 Comp_Unit
:= Parent
(Comp_Unit
);
653 -- Load the body, unless it the main unit, or is an instance
654 -- whose body has already been analyzed.
656 if Present
(Comp_Unit
)
657 and then Comp_Unit
/= Cunit
(Main_Unit
)
658 and then Body_Required
(Comp_Unit
)
659 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
660 or else No
(Corresponding_Body
(Unit
(Comp_Unit
))))
663 Bname
: constant Unit_Name_Type
:=
664 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
669 if not Is_Loaded
(Bname
) then
670 Load_Needed_Body
(Comp_Unit
, OK
);
674 -- Warn that a body was not available for inlining
677 Error_Msg_Unit_1
:= Bname
;
679 ("one or more inlined subprograms accessed in $!?",
682 Get_File_Name
(Bname
, Subunit
=> False);
683 Error_Msg_N
("\but file{ was not found!?", Comp_Unit
);
692 -- The analysis of required bodies may have produced additional
693 -- generic instantiations. To obtain further inlining, we perform
694 -- another round of generic body instantiations. Establishing a
695 -- fully recursive loop between inlining and generic instantiations
696 -- is unlikely to yield more than this one additional pass.
700 -- The list of inlined subprograms is an overestimate, because
701 -- it includes inlined functions called from functions that are
702 -- compiled as part of an inlined package, but are not themselves
703 -- called. An accurate computation of just those subprograms that
704 -- are needed requires that we perform a transitive closure over
705 -- the call graph, starting from calls in the main program. Here
706 -- we do one step of the inverse transitive closure, and reset
707 -- the Is_Called flag on subprograms all of whose callers are not.
709 for Index
in Inlined
.First
.. Inlined
.Last
loop
710 S
:= Inlined
.Table
(Index
).First_Succ
;
713 and then not Inlined
.Table
(Index
).Main_Call
715 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
717 while S
/= No_Succ
loop
719 (Inlined
.Table
(Successors
.Table
(S
).Subp
).Name
)
720 or else Inlined
.Table
(Successors
.Table
(S
).Subp
).Main_Call
722 Set_Is_Called
(Inlined
.Table
(Index
).Name
);
726 S
:= Successors
.Table
(S
).Next
;
731 -- Now that the units are compiled, chain the subprograms within
732 -- that are called and inlined. Produce list of inlined subprograms
733 -- sorted in topological order. Start with all subprograms that
734 -- have no prerequisites, i.e. inlined subprograms that do not call
735 -- other inlined subprograms.
737 for Index
in Inlined
.First
.. Inlined
.Last
loop
739 if Is_Called
(Inlined
.Table
(Index
).Name
)
740 and then Inlined
.Table
(Index
).Count
= 0
741 and then not Inlined
.Table
(Index
).Listed
743 Add_Inlined_Subprogram
(Index
);
747 -- Because Add_Inlined_Subprogram treats recursively nodes that have
748 -- no prerequisites left, at the end of the loop all subprograms
749 -- must have been listed. If there are any unlisted subprograms
750 -- left, there must be some recursive chains that cannot be inlined.
752 for Index
in Inlined
.First
.. Inlined
.Last
loop
753 if Is_Called
(Inlined
.Table
(Index
).Name
)
754 and then Inlined
.Table
(Index
).Count
/= 0
755 and then not Is_Predefined_File_Name
757 (Get_Source_Unit
(Inlined
.Table
(Index
).Name
)))
760 ("& cannot be inlined?", Inlined
.Table
(Index
).Name
);
762 -- A warning on the first one might be sufficient ???
768 end Analyze_Inlined_Bodies
;
770 -----------------------------
771 -- Check_Body_For_Inlining --
772 -----------------------------
774 procedure Check_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
775 Bname
: Unit_Name_Type
;
780 if Is_Compilation_Unit
(P
)
781 and then not Is_Generic_Instance
(P
)
783 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
785 E
:= First_Entity
(P
);
786 while Present
(E
) loop
787 if Has_Pragma_Inline_Always
(E
)
788 or else (Front_End_Inlining
and then Has_Pragma_Inline
(E
))
790 if not Is_Loaded
(Bname
) then
791 Load_Needed_Body
(N
, OK
);
795 -- Check we are not trying to inline a parent whose body
796 -- depends on a child, when we are compiling the body of
797 -- the child. Otherwise we have a potential elaboration
798 -- circularity with inlined subprograms and with
799 -- Taft-Amendment types.
802 Comp
: Node_Id
; -- Body just compiled
803 Child_Spec
: Entity_Id
; -- Spec of main unit
804 Ent
: Entity_Id
; -- For iteration
805 With_Clause
: Node_Id
; -- Context of body.
808 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
809 and then Present
(Body_Entity
(P
))
813 ((Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
816 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
818 -- Check whether the context of the body just
819 -- compiled includes a child of itself, and that
820 -- child is the spec of the main compilation.
822 With_Clause
:= First
(Context_Items
(Comp
));
823 while Present
(With_Clause
) loop
824 if Nkind
(With_Clause
) = N_With_Clause
826 Scope
(Entity
(Name
(With_Clause
))) = P
828 Entity
(Name
(With_Clause
)) = Child_Spec
830 Error_Msg_Node_2
:= Child_Spec
;
832 ("body of & depends on child unit&?",
835 ("\subprograms in body cannot be inlined?",
838 -- Disable further inlining from this unit,
839 -- and keep Taft-amendment types incomplete.
841 Ent
:= First_Entity
(P
);
842 while Present
(Ent
) loop
844 and then Has_Completion_In_Body
(Ent
)
846 Set_Full_View
(Ent
, Empty
);
848 elsif Is_Subprogram
(Ent
) then
849 Set_Is_Inlined
(Ent
, False);
863 elsif Ineffective_Inline_Warnings
then
864 Error_Msg_Unit_1
:= Bname
;
866 ("unable to inline subprograms defined in $?", P
);
867 Error_Msg_N
("\body not found?", P
);
878 end Check_Body_For_Inlining
;
884 procedure Cleanup_Scopes
is
890 Elmt
:= First_Elmt
(To_Clean
);
891 while Present
(Elmt
) loop
894 if Ekind
(Scop
) = E_Entry
then
895 Scop
:= Protected_Body_Subprogram
(Scop
);
897 elsif Is_Subprogram
(Scop
)
898 and then Is_Protected_Type
(Scope
(Scop
))
899 and then Present
(Protected_Body_Subprogram
(Scop
))
901 -- If a protected operation contains an instance, its
902 -- cleanup operations have been delayed, and the subprogram
903 -- has been rewritten in the expansion of the enclosing
904 -- protected body. It is the corresponding subprogram that
905 -- may require the cleanup operations, so propagate the
906 -- information that triggers cleanup activity.
909 (Protected_Body_Subprogram
(Scop
),
910 Uses_Sec_Stack
(Scop
));
911 Set_Finalization_Chain_Entity
912 (Protected_Body_Subprogram
(Scop
),
913 Finalization_Chain_Entity
(Scop
));
914 Scop
:= Protected_Body_Subprogram
(Scop
);
917 if Ekind
(Scop
) = E_Block
then
918 Decl
:= Parent
(Block_Node
(Scop
));
921 Decl
:= Unit_Declaration_Node
(Scop
);
923 if Nkind
(Decl
) = N_Subprogram_Declaration
924 or else Nkind
(Decl
) = N_Task_Type_Declaration
925 or else Nkind
(Decl
) = N_Subprogram_Body_Stub
927 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
932 Expand_Cleanup_Actions
(Decl
);
935 Elmt
:= Next_Elmt
(Elmt
);
939 --------------------------
940 -- Has_Initialized_Type --
941 --------------------------
943 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
944 E_Body
: constant Node_Id
:= Get_Subprogram_Body
(E
);
948 if No
(E_Body
) then -- imported subprogram
952 Decl
:= First
(Declarations
(E_Body
));
953 while Present
(Decl
) loop
955 if Nkind
(Decl
) = N_Full_Type_Declaration
956 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
966 end Has_Initialized_Type
;
972 procedure Initialize
is
974 Analyzing_Inlined_Bodies
:= False;
975 Pending_Descriptor
.Init
;
976 Pending_Instantiations
.Init
;
981 for J
in Hash_Headers
'Range loop
982 Hash_Headers
(J
) := No_Subp
;
986 ------------------------
987 -- Instantiate_Bodies --
988 ------------------------
990 -- Generic bodies contain all the non-local references, so an
991 -- instantiation does not need any more context than Standard
992 -- itself, even if the instantiation appears in an inner scope.
993 -- Generic associations have verified that the contract model is
994 -- satisfied, so that any error that may occur in the analysis of
995 -- the body is an internal error.
997 procedure Instantiate_Bodies
is
999 Info
: Pending_Body_Info
;
1002 if Serious_Errors_Detected
= 0 then
1004 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
1005 Push_Scope
(Standard_Standard
);
1006 To_Clean
:= New_Elmt_List
;
1008 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
1012 -- A body instantiation may generate additional instantiations, so
1013 -- the following loop must scan to the end of a possibly expanding
1014 -- set (that's why we can't simply use a FOR loop here).
1017 while J
<= Pending_Instantiations
.Last
1018 and then Serious_Errors_Detected
= 0
1020 Info
:= Pending_Instantiations
.Table
(J
);
1022 -- If the instantiation node is absent, it has been removed
1023 -- as part of unreachable code.
1025 if No
(Info
.Inst_Node
) then
1028 elsif Nkind
(Info
.Act_Decl
) = N_Package_Declaration
then
1029 Instantiate_Package_Body
(Info
);
1030 Add_Scope_To_Clean
(Defining_Entity
(Info
.Act_Decl
));
1033 Instantiate_Subprogram_Body
(Info
);
1039 -- Reset the table of instantiations. Additional instantiations
1040 -- may be added through inlining, when additional bodies are
1043 Pending_Instantiations
.Init
;
1045 -- We can now complete the cleanup actions of scopes that contain
1046 -- pending instantiations (skipped for generic units, since we
1047 -- never need any cleanups in generic units).
1048 -- pending instantiations.
1051 and then not Is_Generic_Unit
(Main_Unit_Entity
)
1054 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
1060 end Instantiate_Bodies
;
1066 function Is_Nested
(E
: Entity_Id
) return Boolean is
1071 while Scop
/= Standard_Standard
loop
1072 if Ekind
(Scop
) in Subprogram_Kind
then
1075 elsif Ekind
(Scop
) = E_Task_Type
1076 or else Ekind
(Scop
) = E_Entry
1077 or else Ekind
(Scop
) = E_Entry_Family
then
1081 Scop
:= Scope
(Scop
);
1093 Pending_Instantiations
.Locked
:= True;
1094 Inlined_Bodies
.Locked
:= True;
1095 Successors
.Locked
:= True;
1096 Inlined
.Locked
:= True;
1097 Pending_Instantiations
.Release
;
1098 Inlined_Bodies
.Release
;
1103 --------------------------
1104 -- Remove_Dead_Instance --
1105 --------------------------
1107 procedure Remove_Dead_Instance
(N
: Node_Id
) is
1112 while J
<= Pending_Instantiations
.Last
loop
1113 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
1114 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
1120 end Remove_Dead_Instance
;
1122 ------------------------
1123 -- Scope_In_Main_Unit --
1124 ------------------------
1126 function Scope_In_Main_Unit
(Scop
: Entity_Id
) return Boolean is
1129 Ent
: Entity_Id
:= Cunit_Entity
(Main_Unit
);
1132 -- The scope may be within the main unit, or it may be an ancestor
1133 -- of the main unit, if the main unit is a child unit. In both cases
1134 -- it makes no sense to process the body before the main unit. In
1135 -- the second case, this may lead to circularities if a parent body
1136 -- depends on a child spec, and we are analyzing the child.
1139 while Scope
(S
) /= Standard_Standard
1140 and then not Is_Child_Unit
(S
)
1146 while Present
(Comp
)
1147 and then Nkind
(Comp
) /= N_Compilation_Unit
1149 Comp
:= Parent
(Comp
);
1152 if Is_Child_Unit
(Ent
) then
1154 and then Is_Child_Unit
(Ent
)
1156 if Scope
(Ent
) = S
then
1165 Comp
= Cunit
(Main_Unit
)
1166 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
1167 end Scope_In_Main_Unit
;