1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Exp_Ch7
; use Exp_Ch7
;
32 with Exp_Tss
; use Exp_Tss
;
33 with Fname
; use Fname
;
34 with Fname
.UF
; use Fname
.UF
;
36 with Nlists
; use Nlists
;
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
;
209 while J
/= No_Succ
loop
211 if Successors
.Table
(J
).Subp
= P2
then
215 J
:= Successors
.Table
(J
).Next
;
218 -- On exit, make a successor entry for P2
220 Successors
.Increment_Last
;
221 Successors
.Table
(Successors
.Last
).Subp
:= P2
;
222 Successors
.Table
(Successors
.Last
).Next
:=
223 Inlined
.Table
(P1
).First_Succ
;
224 Inlined
.Table
(P1
).First_Succ
:= Successors
.Last
;
226 Inlined
.Table
(P2
).Count
:= Inlined
.Table
(P2
).Count
+ 1;
229 Inlined
.Table
(P1
).Main_Call
:= True;
233 ----------------------
234 -- Add_Inlined_Body --
235 ----------------------
237 procedure Add_Inlined_Body
(E
: Entity_Id
) is
240 function Must_Inline
return Boolean;
241 -- Inlining is only done if the call statement N is in the main unit,
242 -- or within the body of another inlined subprogram.
248 function Must_Inline
return Boolean is
249 Scop
: Entity_Id
:= Current_Scope
;
253 -- Check if call is in main unit
255 while Scope
(Scop
) /= Standard_Standard
256 and then not Is_Child_Unit
(Scop
)
258 Scop
:= Scope
(Scop
);
261 Comp
:= Parent
(Scop
);
263 while Nkind
(Comp
) /= N_Compilation_Unit
loop
264 Comp
:= Parent
(Comp
);
267 if Comp
= Cunit
(Main_Unit
)
268 or else Comp
= Library_Unit
(Cunit
(Main_Unit
))
274 -- Call is not in main unit. See if it's in some inlined
277 Scop
:= Current_Scope
;
278 while Scope
(Scop
) /= Standard_Standard
279 and then not Is_Child_Unit
(Scop
)
281 if Is_Overloadable
(Scop
)
282 and then Is_Inlined
(Scop
)
288 Scop
:= Scope
(Scop
);
295 -- Start of processing for Add_Inlined_Body
298 -- Find unit containing E, and add to list of inlined bodies if needed.
299 -- If the body is already present, no need to load any other unit. This
300 -- is the case for an initialization procedure, which appears in the
301 -- package declaration that contains the type. It is also the case if
302 -- the body has already been analyzed. Finally, if the unit enclosing
303 -- E is an instance, the instance body will be analyzed in any case,
304 -- and there is no need to add the enclosing unit (whose body might not
307 -- Library-level functions must be handled specially, because there is
308 -- no enclosing package to retrieve. In this case, it is the body of
309 -- the function that will have to be loaded.
311 if not Is_Abstract
(E
) and then not Is_Nested
(E
)
312 and then Convention
(E
) /= Convention_Protected
317 and then Ekind
(Pack
) = E_Package
321 if Pack
= Standard_Standard
then
323 -- Library-level inlined function. Add function iself to
324 -- list of needed units.
326 Inlined_Bodies
.Increment_Last
;
327 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
329 elsif Is_Generic_Instance
(Pack
) then
332 elsif not Is_Inlined
(Pack
)
333 and then not Has_Completion
(E
)
334 and then not Scope_In_Main_Unit
(Pack
)
336 Set_Is_Inlined
(Pack
);
337 Inlined_Bodies
.Increment_Last
;
338 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
342 end Add_Inlined_Body
;
344 ----------------------------
345 -- Add_Inlined_Subprogram --
346 ----------------------------
348 procedure Add_Inlined_Subprogram
(Index
: Subp_Index
) is
349 E
: constant Entity_Id
:= Inlined
.Table
(Index
).Name
;
353 function Back_End_Cannot_Inline
(Subp
: Entity_Id
) return Boolean;
354 -- There are various conditions under which back-end inlining cannot
357 -- a) If a body has handlers, it must not be inlined, because this
358 -- may violate program semantics, and because in zero-cost exception
359 -- mode it will lead to undefined symbols at link time.
361 -- b) If a body contains inlined function instances, it cannot be
362 -- inlined under ZCX because the numerix suffix generated by gigi
363 -- will be different in the body and the place of the inlined call.
365 -- This procedure must be carefully coordinated with the back end
367 ----------------------------
368 -- Back_End_Cannot_Inline --
369 ----------------------------
371 function Back_End_Cannot_Inline
(Subp
: Entity_Id
) return Boolean is
372 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
373 Body_Ent
: Entity_Id
;
377 if Nkind
(Decl
) = N_Subprogram_Declaration
378 and then Present
(Corresponding_Body
(Decl
))
380 Body_Ent
:= Corresponding_Body
(Decl
);
385 -- If subprogram is marked Inline_Always, inlining is mandatory
387 if Is_Always_Inlined
(Subp
) then
393 (Handled_Statement_Sequence
394 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)))))
399 Ent
:= First_Entity
(Body_Ent
);
401 while Present
(Ent
) loop
402 if Is_Subprogram
(Ent
)
403 and then Is_Generic_Instance
(Ent
)
411 end Back_End_Cannot_Inline
;
413 -- Start of processing for Add_Inlined_Subprogram
416 -- Insert the current subprogram in the list of inlined subprograms,
417 -- if it can actually be inlined by the back-end.
419 if not Scope_In_Main_Unit
(E
)
420 and then Is_Inlined
(E
)
421 and then not Is_Nested
(E
)
422 and then not Has_Initialized_Type
(E
)
424 if Back_End_Cannot_Inline
(E
) then
425 Set_Is_Inlined
(E
, False);
428 if No
(Last_Inlined
) then
429 Set_First_Inlined_Subprogram
(Cunit
(Main_Unit
), E
);
431 Set_Next_Inlined_Subprogram
(Last_Inlined
, E
);
438 Inlined
.Table
(Index
).Listed
:= True;
439 Succ
:= Inlined
.Table
(Index
).First_Succ
;
441 while Succ
/= No_Succ
loop
442 Subp
:= Successors
.Table
(Succ
).Subp
;
443 Inlined
.Table
(Subp
).Count
:= Inlined
.Table
(Subp
).Count
- 1;
445 if Inlined
.Table
(Subp
).Count
= 0 then
446 Add_Inlined_Subprogram
(Subp
);
449 Succ
:= Successors
.Table
(Succ
).Next
;
451 end Add_Inlined_Subprogram
;
453 ------------------------
454 -- Add_Scope_To_Clean --
455 ------------------------
457 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
) is
458 Scop
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(Inst
);
462 -- If the instance appears in a library-level package declaration,
463 -- all finalization is global, and nothing needs doing here.
465 if Scop
= Standard_Standard
then
469 -- If the instance appears within a generic subprogram there is nothing
470 -- to finalize either.
476 while Present
(S
) and then S
/= Standard_Standard
loop
477 if Is_Generic_Subprogram
(S
) then
485 Elmt
:= First_Elmt
(To_Clean
);
487 while Present
(Elmt
) loop
489 if Node
(Elmt
) = Scop
then
493 Elmt
:= Next_Elmt
(Elmt
);
496 Append_Elmt
(Scop
, To_Clean
);
497 end Add_Scope_To_Clean
;
503 function Add_Subp
(E
: Entity_Id
) return Subp_Index
is
504 Index
: Subp_Index
:= Subp_Index
(E
) mod Num_Hash_Headers
;
508 -- Initialize entry in Inlined table
510 procedure New_Entry
is
512 Inlined
.Increment_Last
;
513 Inlined
.Table
(Inlined
.Last
).Name
:= E
;
514 Inlined
.Table
(Inlined
.Last
).First_Succ
:= No_Succ
;
515 Inlined
.Table
(Inlined
.Last
).Count
:= 0;
516 Inlined
.Table
(Inlined
.Last
).Listed
:= False;
517 Inlined
.Table
(Inlined
.Last
).Main_Call
:= False;
518 Inlined
.Table
(Inlined
.Last
).Next
:= No_Subp
;
519 Inlined
.Table
(Inlined
.Last
).Next_Nopred
:= No_Subp
;
522 -- Start of processing for Add_Subp
525 if Hash_Headers
(Index
) = No_Subp
then
527 Hash_Headers
(Index
) := Inlined
.Last
;
531 J
:= Hash_Headers
(Index
);
533 while J
/= No_Subp
loop
535 if Inlined
.Table
(J
).Name
= E
then
539 J
:= Inlined
.Table
(J
).Next
;
543 -- On exit, subprogram was not found. Enter in table. Index is
544 -- the current last entry on the hash chain.
547 Inlined
.Table
(Index
).Next
:= Inlined
.Last
;
552 ----------------------------
553 -- Analyze_Inlined_Bodies --
554 ----------------------------
556 procedure Analyze_Inlined_Bodies
is
563 Analyzing_Inlined_Bodies
:= False;
565 if Serious_Errors_Detected
= 0 then
566 New_Scope
(Standard_Standard
);
569 while J
<= Inlined_Bodies
.Last
570 and then Serious_Errors_Detected
= 0
572 Pack
:= Inlined_Bodies
.Table
(J
);
575 and then Scope
(Pack
) /= Standard_Standard
576 and then not Is_Child_Unit
(Pack
)
578 Pack
:= Scope
(Pack
);
581 Comp_Unit
:= Parent
(Pack
);
583 while Present
(Comp_Unit
)
584 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
586 Comp_Unit
:= Parent
(Comp_Unit
);
589 -- Load the body, unless it the main unit, or is an instance
590 -- whose body has already been analyzed.
592 if Present
(Comp_Unit
)
593 and then Comp_Unit
/= Cunit
(Main_Unit
)
594 and then Body_Required
(Comp_Unit
)
595 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
596 or else No
(Corresponding_Body
(Unit
(Comp_Unit
))))
599 Bname
: constant Unit_Name_Type
:=
600 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
605 if not Is_Loaded
(Bname
) then
606 Load_Needed_Body
(Comp_Unit
, OK
);
609 Error_Msg_Unit_1
:= Bname
;
611 ("one or more inlined subprograms accessed in $!",
614 Get_File_Name
(Bname
, Subunit
=> False);
615 Error_Msg_N
("\but file{ was not found!", Comp_Unit
);
616 raise Unrecoverable_Error
;
625 -- The analysis of required bodies may have produced additional
626 -- generic instantiations. To obtain further inlining, we perform
627 -- another round of generic body instantiations. Establishing a
628 -- fully recursive loop between inlining and generic instantiations
629 -- is unlikely to yield more than this one additional pass.
633 -- The list of inlined subprograms is an overestimate, because
634 -- it includes inlined functions called from functions that are
635 -- compiled as part of an inlined package, but are not themselves
636 -- called. An accurate computation of just those subprograms that
637 -- are needed requires that we perform a transitive closure over
638 -- the call graph, starting from calls in the main program. Here
639 -- we do one step of the inverse transitive closure, and reset
640 -- the Is_Called flag on subprograms all of whose callers are not.
642 for Index
in Inlined
.First
.. Inlined
.Last
loop
643 S
:= Inlined
.Table
(Index
).First_Succ
;
646 and then not Inlined
.Table
(Index
).Main_Call
648 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
650 while S
/= No_Succ
loop
653 (Inlined
.Table
(Successors
.Table
(S
).Subp
).Name
)
654 or else Inlined
.Table
(Successors
.Table
(S
).Subp
).Main_Call
656 Set_Is_Called
(Inlined
.Table
(Index
).Name
);
660 S
:= Successors
.Table
(S
).Next
;
665 -- Now that the units are compiled, chain the subprograms within
666 -- that are called and inlined. Produce list of inlined subprograms
667 -- sorted in topological order. Start with all subprograms that
668 -- have no prerequisites, i.e. inlined subprograms that do not call
669 -- other inlined subprograms.
671 for Index
in Inlined
.First
.. Inlined
.Last
loop
673 if Is_Called
(Inlined
.Table
(Index
).Name
)
674 and then Inlined
.Table
(Index
).Count
= 0
675 and then not Inlined
.Table
(Index
).Listed
677 Add_Inlined_Subprogram
(Index
);
681 -- Because Add_Inlined_Subprogram treats recursively nodes that have
682 -- no prerequisites left, at the end of the loop all subprograms
683 -- must have been listed. If there are any unlisted subprograms
684 -- left, there must be some recursive chains that cannot be inlined.
686 for Index
in Inlined
.First
.. Inlined
.Last
loop
687 if Is_Called
(Inlined
.Table
(Index
).Name
)
688 and then Inlined
.Table
(Index
).Count
/= 0
689 and then not Is_Predefined_File_Name
691 (Get_Source_Unit
(Inlined
.Table
(Index
).Name
)))
694 ("& cannot be inlined?", Inlined
.Table
(Index
).Name
);
696 -- A warning on the first one might be sufficient ???
702 end Analyze_Inlined_Bodies
;
704 -----------------------------
705 -- Check_Body_For_Inlining --
706 -----------------------------
708 procedure Check_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
709 Bname
: Unit_Name_Type
;
714 if Is_Compilation_Unit
(P
)
715 and then not Is_Generic_Instance
(P
)
717 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
718 E
:= First_Entity
(P
);
720 while Present
(E
) loop
721 if Is_Always_Inlined
(E
)
722 or else (Front_End_Inlining
and then Has_Pragma_Inline
(E
))
724 if not Is_Loaded
(Bname
) then
725 Load_Needed_Body
(N
, OK
);
729 -- Check that we are not trying to inline a parent
730 -- whose body depends on a child, when we are compiling
731 -- the body of the child. Otherwise we have a potential
732 -- elaboration circularity with inlined subprograms and
733 -- with Taft-Amendment types.
736 Comp
: Node_Id
; -- Body just compiled
737 Child_Spec
: Entity_Id
; -- Spec of main unit
738 Ent
: Entity_Id
; -- For iteration
739 With_Clause
: Node_Id
; -- Context of body.
742 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
743 and then Present
(Body_Entity
(P
))
747 (Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
750 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
752 With_Clause
:= First
(Context_Items
(Comp
));
754 -- Check whether the context of the body just
755 -- compiled includes a child of itself, and that
756 -- child is the spec of the main compilation.
758 while Present
(With_Clause
) loop
759 if Nkind
(With_Clause
) = N_With_Clause
761 Scope
(Entity
(Name
(With_Clause
))) = P
763 Entity
(Name
(With_Clause
)) = Child_Spec
765 Error_Msg_Node_2
:= Child_Spec
;
767 ("body of & depends on child unit&?",
770 ("\subprograms in body cannot be inlined?",
773 -- Disable further inlining from this unit,
774 -- and keep Taft-amendment types incomplete.
776 Ent
:= First_Entity
(P
);
778 while Present
(Ent
) loop
780 and then Has_Completion_In_Body
(Ent
)
782 Set_Full_View
(Ent
, Empty
);
784 elsif Is_Subprogram
(Ent
) then
785 Set_Is_Inlined
(Ent
, False);
799 elsif Ineffective_Inline_Warnings
then
800 Error_Msg_Unit_1
:= Bname
;
802 ("unable to inline subprograms defined in $?", P
);
803 Error_Msg_N
("\body not found?", P
);
814 end Check_Body_For_Inlining
;
820 procedure Cleanup_Scopes
is
826 Elmt
:= First_Elmt
(To_Clean
);
828 while Present
(Elmt
) loop
831 if Ekind
(Scop
) = E_Entry
then
832 Scop
:= Protected_Body_Subprogram
(Scop
);
834 elsif Is_Subprogram
(Scop
)
835 and then Is_Protected_Type
(Scope
(Scop
))
836 and then Present
(Protected_Body_Subprogram
(Scop
))
838 -- If a protected operation contains an instance, its
839 -- cleanup operations have been delayed, and the subprogram
840 -- has been rewritten in the expansion of the enclosing
841 -- protected body. It is the corresponding subprogram that
842 -- may require the cleanup operations.
845 (Protected_Body_Subprogram
(Scop
),
846 Uses_Sec_Stack
(Scop
));
847 Scop
:= Protected_Body_Subprogram
(Scop
);
850 if Ekind
(Scop
) = E_Block
then
851 Decl
:= Parent
(Block_Node
(Scop
));
854 Decl
:= Unit_Declaration_Node
(Scop
);
856 if Nkind
(Decl
) = N_Subprogram_Declaration
857 or else Nkind
(Decl
) = N_Task_Type_Declaration
858 or else Nkind
(Decl
) = N_Subprogram_Body_Stub
860 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
865 Expand_Cleanup_Actions
(Decl
);
868 Elmt
:= Next_Elmt
(Elmt
);
872 --------------------------
873 -- Has_Initialized_Type --
874 --------------------------
876 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
877 E_Body
: constant Node_Id
:= Get_Subprogram_Body
(E
);
881 if No
(E_Body
) then -- imported subprogram
885 Decl
:= First
(Declarations
(E_Body
));
887 while Present
(Decl
) loop
889 if Nkind
(Decl
) = N_Full_Type_Declaration
890 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
900 end Has_Initialized_Type
;
906 procedure Initialize
is
908 Analyzing_Inlined_Bodies
:= False;
909 Pending_Descriptor
.Init
;
910 Pending_Instantiations
.Init
;
915 for J
in Hash_Headers
'Range loop
916 Hash_Headers
(J
) := No_Subp
;
920 ------------------------
921 -- Instantiate_Bodies --
922 ------------------------
924 -- Generic bodies contain all the non-local references, so an
925 -- instantiation does not need any more context than Standard
926 -- itself, even if the instantiation appears in an inner scope.
927 -- Generic associations have verified that the contract model is
928 -- satisfied, so that any error that may occur in the analysis of
929 -- the body is an internal error.
931 procedure Instantiate_Bodies
is
933 Info
: Pending_Body_Info
;
936 if Serious_Errors_Detected
= 0 then
938 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
939 New_Scope
(Standard_Standard
);
940 To_Clean
:= New_Elmt_List
;
942 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
946 -- A body instantiation may generate additional instantiations, so
947 -- the following loop must scan to the end of a possibly expanding
948 -- set (that's why we can't simply use a FOR loop here).
952 while J
<= Pending_Instantiations
.Last
953 and then Serious_Errors_Detected
= 0
955 Info
:= Pending_Instantiations
.Table
(J
);
957 -- If the instantiation node is absent, it has been removed
958 -- as part of unreachable code.
960 if No
(Info
.Inst_Node
) then
963 elsif Nkind
(Info
.Act_Decl
) = N_Package_Declaration
then
964 Instantiate_Package_Body
(Info
);
965 Add_Scope_To_Clean
(Defining_Entity
(Info
.Act_Decl
));
968 Instantiate_Subprogram_Body
(Info
);
974 -- Reset the table of instantiations. Additional instantiations
975 -- may be added through inlining, when additional bodies are
978 Pending_Instantiations
.Init
;
980 -- We can now complete the cleanup actions of scopes that contain
981 -- pending instantiations (skipped for generic units, since we
982 -- never need any cleanups in generic units).
983 -- pending instantiations.
986 and then not Is_Generic_Unit
(Main_Unit_Entity
)
989 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
995 end Instantiate_Bodies
;
1001 function Is_Nested
(E
: Entity_Id
) return Boolean is
1002 Scop
: Entity_Id
:= Scope
(E
);
1005 while Scop
/= Standard_Standard
loop
1006 if Ekind
(Scop
) in Subprogram_Kind
then
1009 elsif Ekind
(Scop
) = E_Task_Type
1010 or else Ekind
(Scop
) = E_Entry
1011 or else Ekind
(Scop
) = E_Entry_Family
then
1015 Scop
:= Scope
(Scop
);
1027 Pending_Instantiations
.Locked
:= True;
1028 Inlined_Bodies
.Locked
:= True;
1029 Successors
.Locked
:= True;
1030 Inlined
.Locked
:= True;
1031 Pending_Instantiations
.Release
;
1032 Inlined_Bodies
.Release
;
1037 --------------------------
1038 -- Remove_Dead_Instance --
1039 --------------------------
1041 procedure Remove_Dead_Instance
(N
: Node_Id
) is
1047 while J
<= Pending_Instantiations
.Last
loop
1049 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
1050 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
1056 end Remove_Dead_Instance
;
1058 ------------------------
1059 -- Scope_In_Main_Unit --
1060 ------------------------
1062 function Scope_In_Main_Unit
(Scop
: Entity_Id
) return Boolean is
1064 S
: Entity_Id
:= Scop
;
1065 Ent
: Entity_Id
:= Cunit_Entity
(Main_Unit
);
1068 -- The scope may be within the main unit, or it may be an ancestor
1069 -- of the main unit, if the main unit is a child unit. In both cases
1070 -- it makes no sense to process the body before the main unit. In
1071 -- the second case, this may lead to circularities if a parent body
1072 -- depends on a child spec, and we are analyzing the child.
1074 while Scope
(S
) /= Standard_Standard
1075 and then not Is_Child_Unit
(S
)
1082 while Present
(Comp
)
1083 and then Nkind
(Comp
) /= N_Compilation_Unit
1085 Comp
:= Parent
(Comp
);
1088 if Is_Child_Unit
(Ent
) then
1091 and then Is_Child_Unit
(Ent
)
1093 if Scope
(Ent
) = S
then
1102 Comp
= Cunit
(Main_Unit
)
1103 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
1104 end Scope_In_Main_Unit
;