1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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
;
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
253 -- Check if call is in main unit
255 Scop
:= Current_Scope
;
257 -- Do not try to inline if scope is standard. This could happen, for
258 -- example, for a call to Add_Global_Declaration, and it causes
259 -- trouble to try to inline at this level.
261 if Scop
= Standard_Standard
then
265 -- Otherwise lookup scope stack to outer scope
267 while Scope
(Scop
) /= Standard_Standard
268 and then not Is_Child_Unit
(Scop
)
270 Scop
:= Scope
(Scop
);
273 Comp
:= Parent
(Scop
);
274 while Nkind
(Comp
) /= N_Compilation_Unit
loop
275 Comp
:= Parent
(Comp
);
278 if Comp
= Cunit
(Main_Unit
)
279 or else Comp
= Library_Unit
(Cunit
(Main_Unit
))
285 -- Call is not in main unit. See if it's in some inlined subprogram
287 Scop
:= Current_Scope
;
288 while Scope
(Scop
) /= Standard_Standard
289 and then not Is_Child_Unit
(Scop
)
291 if Is_Overloadable
(Scop
)
292 and then Is_Inlined
(Scop
)
298 Scop
:= Scope
(Scop
);
304 -- Start of processing for Add_Inlined_Body
307 -- Find unit containing E, and add to list of inlined bodies if needed.
308 -- If the body is already present, no need to load any other unit. This
309 -- is the case for an initialization procedure, which appears in the
310 -- package declaration that contains the type. It is also the case if
311 -- the body has already been analyzed. Finally, if the unit enclosing
312 -- E is an instance, the instance body will be analyzed in any case,
313 -- and there is no need to add the enclosing unit (whose body might not
316 -- Library-level functions must be handled specially, because there is
317 -- no enclosing package to retrieve. In this case, it is the body of
318 -- the function that will have to be loaded.
320 if not Is_Abstract_Subprogram
(E
) and then not Is_Nested
(E
)
321 and then Convention
(E
) /= Convention_Protected
326 and then Ekind
(Pack
) = E_Package
330 if Pack
= Standard_Standard
then
332 -- Library-level inlined function. Add function iself to
333 -- list of needed units.
335 Inlined_Bodies
.Increment_Last
;
336 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
338 elsif Is_Generic_Instance
(Pack
) then
341 elsif not Is_Inlined
(Pack
)
342 and then not Has_Completion
(E
)
343 and then not Scope_In_Main_Unit
(Pack
)
345 Set_Is_Inlined
(Pack
);
346 Inlined_Bodies
.Increment_Last
;
347 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
351 end Add_Inlined_Body
;
353 ----------------------------
354 -- Add_Inlined_Subprogram --
355 ----------------------------
357 procedure Add_Inlined_Subprogram
(Index
: Subp_Index
) is
358 E
: constant Entity_Id
:= Inlined
.Table
(Index
).Name
;
362 function Back_End_Cannot_Inline
(Subp
: Entity_Id
) return Boolean;
363 -- There are various conditions under which back-end inlining cannot
366 -- a) If a body has handlers, it must not be inlined, because this
367 -- may violate program semantics, and because in zero-cost exception
368 -- mode it will lead to undefined symbols at link time.
370 -- b) If a body contains inlined function instances, it cannot be
371 -- inlined under ZCX because the numerix suffix generated by gigi
372 -- will be different in the body and the place of the inlined call.
374 -- This procedure must be carefully coordinated with the back end
376 ----------------------------
377 -- Back_End_Cannot_Inline --
378 ----------------------------
380 function Back_End_Cannot_Inline
(Subp
: Entity_Id
) return Boolean is
381 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
382 Body_Ent
: Entity_Id
;
386 if Nkind
(Decl
) = N_Subprogram_Declaration
387 and then Present
(Corresponding_Body
(Decl
))
389 Body_Ent
:= Corresponding_Body
(Decl
);
394 -- If subprogram is marked Inline_Always, inlining is mandatory
396 if Has_Pragma_Inline_Always
(Subp
) then
402 (Handled_Statement_Sequence
403 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)))))
408 Ent
:= First_Entity
(Body_Ent
);
410 while Present
(Ent
) loop
411 if Is_Subprogram
(Ent
)
412 and then Is_Generic_Instance
(Ent
)
420 end Back_End_Cannot_Inline
;
422 -- Start of processing for Add_Inlined_Subprogram
425 -- Insert the current subprogram in the list of inlined subprograms,
426 -- if it can actually be inlined by the back-end.
428 if not Scope_In_Main_Unit
(E
)
429 and then Is_Inlined
(E
)
430 and then not Is_Nested
(E
)
431 and then not Has_Initialized_Type
(E
)
433 if Back_End_Cannot_Inline
(E
) then
434 Set_Is_Inlined
(E
, False);
437 if No
(Last_Inlined
) then
438 Set_First_Inlined_Subprogram
(Cunit
(Main_Unit
), E
);
440 Set_Next_Inlined_Subprogram
(Last_Inlined
, E
);
447 Inlined
.Table
(Index
).Listed
:= True;
448 Succ
:= Inlined
.Table
(Index
).First_Succ
;
450 while Succ
/= No_Succ
loop
451 Subp
:= Successors
.Table
(Succ
).Subp
;
452 Inlined
.Table
(Subp
).Count
:= Inlined
.Table
(Subp
).Count
- 1;
454 if Inlined
.Table
(Subp
).Count
= 0 then
455 Add_Inlined_Subprogram
(Subp
);
458 Succ
:= Successors
.Table
(Succ
).Next
;
460 end Add_Inlined_Subprogram
;
462 ------------------------
463 -- Add_Scope_To_Clean --
464 ------------------------
466 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
) is
467 Scop
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(Inst
);
471 -- If the instance appears in a library-level package declaration,
472 -- all finalization is global, and nothing needs doing here.
474 if Scop
= Standard_Standard
then
478 -- If the instance appears within a generic subprogram there is nothing
479 -- to finalize either.
485 while Present
(S
) and then S
/= Standard_Standard
loop
486 if Is_Generic_Subprogram
(S
) then
494 Elmt
:= First_Elmt
(To_Clean
);
496 while Present
(Elmt
) loop
498 if Node
(Elmt
) = Scop
then
502 Elmt
:= Next_Elmt
(Elmt
);
505 Append_Elmt
(Scop
, To_Clean
);
506 end Add_Scope_To_Clean
;
512 function Add_Subp
(E
: Entity_Id
) return Subp_Index
is
513 Index
: Subp_Index
:= Subp_Index
(E
) mod Num_Hash_Headers
;
517 -- Initialize entry in Inlined table
519 procedure New_Entry
is
521 Inlined
.Increment_Last
;
522 Inlined
.Table
(Inlined
.Last
).Name
:= E
;
523 Inlined
.Table
(Inlined
.Last
).First_Succ
:= No_Succ
;
524 Inlined
.Table
(Inlined
.Last
).Count
:= 0;
525 Inlined
.Table
(Inlined
.Last
).Listed
:= False;
526 Inlined
.Table
(Inlined
.Last
).Main_Call
:= False;
527 Inlined
.Table
(Inlined
.Last
).Next
:= No_Subp
;
528 Inlined
.Table
(Inlined
.Last
).Next_Nopred
:= No_Subp
;
531 -- Start of processing for Add_Subp
534 if Hash_Headers
(Index
) = No_Subp
then
536 Hash_Headers
(Index
) := Inlined
.Last
;
540 J
:= Hash_Headers
(Index
);
542 while J
/= No_Subp
loop
544 if Inlined
.Table
(J
).Name
= E
then
548 J
:= Inlined
.Table
(J
).Next
;
552 -- On exit, subprogram was not found. Enter in table. Index is
553 -- the current last entry on the hash chain.
556 Inlined
.Table
(Index
).Next
:= Inlined
.Last
;
561 ----------------------------
562 -- Analyze_Inlined_Bodies --
563 ----------------------------
565 procedure Analyze_Inlined_Bodies
is
572 Analyzing_Inlined_Bodies
:= False;
574 if Serious_Errors_Detected
= 0 then
575 Push_Scope
(Standard_Standard
);
578 while J
<= Inlined_Bodies
.Last
579 and then Serious_Errors_Detected
= 0
581 Pack
:= Inlined_Bodies
.Table
(J
);
584 and then Scope
(Pack
) /= Standard_Standard
585 and then not Is_Child_Unit
(Pack
)
587 Pack
:= Scope
(Pack
);
590 Comp_Unit
:= Parent
(Pack
);
591 while Present
(Comp_Unit
)
592 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
594 Comp_Unit
:= Parent
(Comp_Unit
);
597 -- Load the body, unless it the main unit, or is an instance
598 -- whose body has already been analyzed.
600 if Present
(Comp_Unit
)
601 and then Comp_Unit
/= Cunit
(Main_Unit
)
602 and then Body_Required
(Comp_Unit
)
603 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
604 or else No
(Corresponding_Body
(Unit
(Comp_Unit
))))
607 Bname
: constant Unit_Name_Type
:=
608 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
613 if not Is_Loaded
(Bname
) then
614 Load_Needed_Body
(Comp_Unit
, OK
);
617 Error_Msg_Unit_1
:= Bname
;
619 ("one or more inlined subprograms accessed in $!",
622 Get_File_Name
(Bname
, Subunit
=> False);
623 Error_Msg_N
("\but file{ was not found!", Comp_Unit
);
624 raise Unrecoverable_Error
;
633 -- The analysis of required bodies may have produced additional
634 -- generic instantiations. To obtain further inlining, we perform
635 -- another round of generic body instantiations. Establishing a
636 -- fully recursive loop between inlining and generic instantiations
637 -- is unlikely to yield more than this one additional pass.
641 -- The list of inlined subprograms is an overestimate, because
642 -- it includes inlined functions called from functions that are
643 -- compiled as part of an inlined package, but are not themselves
644 -- called. An accurate computation of just those subprograms that
645 -- are needed requires that we perform a transitive closure over
646 -- the call graph, starting from calls in the main program. Here
647 -- we do one step of the inverse transitive closure, and reset
648 -- the Is_Called flag on subprograms all of whose callers are not.
650 for Index
in Inlined
.First
.. Inlined
.Last
loop
651 S
:= Inlined
.Table
(Index
).First_Succ
;
654 and then not Inlined
.Table
(Index
).Main_Call
656 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
658 while S
/= No_Succ
loop
661 (Inlined
.Table
(Successors
.Table
(S
).Subp
).Name
)
662 or else Inlined
.Table
(Successors
.Table
(S
).Subp
).Main_Call
664 Set_Is_Called
(Inlined
.Table
(Index
).Name
);
668 S
:= Successors
.Table
(S
).Next
;
673 -- Now that the units are compiled, chain the subprograms within
674 -- that are called and inlined. Produce list of inlined subprograms
675 -- sorted in topological order. Start with all subprograms that
676 -- have no prerequisites, i.e. inlined subprograms that do not call
677 -- other inlined subprograms.
679 for Index
in Inlined
.First
.. Inlined
.Last
loop
681 if Is_Called
(Inlined
.Table
(Index
).Name
)
682 and then Inlined
.Table
(Index
).Count
= 0
683 and then not Inlined
.Table
(Index
).Listed
685 Add_Inlined_Subprogram
(Index
);
689 -- Because Add_Inlined_Subprogram treats recursively nodes that have
690 -- no prerequisites left, at the end of the loop all subprograms
691 -- must have been listed. If there are any unlisted subprograms
692 -- left, there must be some recursive chains that cannot be inlined.
694 for Index
in Inlined
.First
.. Inlined
.Last
loop
695 if Is_Called
(Inlined
.Table
(Index
).Name
)
696 and then Inlined
.Table
(Index
).Count
/= 0
697 and then not Is_Predefined_File_Name
699 (Get_Source_Unit
(Inlined
.Table
(Index
).Name
)))
702 ("& cannot be inlined?", Inlined
.Table
(Index
).Name
);
704 -- A warning on the first one might be sufficient ???
710 end Analyze_Inlined_Bodies
;
712 -----------------------------
713 -- Check_Body_For_Inlining --
714 -----------------------------
716 procedure Check_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
717 Bname
: Unit_Name_Type
;
722 if Is_Compilation_Unit
(P
)
723 and then not Is_Generic_Instance
(P
)
725 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
726 E
:= First_Entity
(P
);
728 while Present
(E
) loop
729 if Has_Pragma_Inline_Always
(E
)
730 or else (Front_End_Inlining
and then Has_Pragma_Inline
(E
))
732 if not Is_Loaded
(Bname
) then
733 Load_Needed_Body
(N
, OK
);
737 -- Check that we are not trying to inline a parent
738 -- whose body depends on a child, when we are compiling
739 -- the body of the child. Otherwise we have a potential
740 -- elaboration circularity with inlined subprograms and
741 -- with Taft-Amendment types.
744 Comp
: Node_Id
; -- Body just compiled
745 Child_Spec
: Entity_Id
; -- Spec of main unit
746 Ent
: Entity_Id
; -- For iteration
747 With_Clause
: Node_Id
; -- Context of body.
750 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
751 and then Present
(Body_Entity
(P
))
755 (Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
758 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
760 With_Clause
:= First
(Context_Items
(Comp
));
762 -- Check whether the context of the body just
763 -- compiled includes a child of itself, and that
764 -- child is the spec of the main compilation.
766 while Present
(With_Clause
) loop
767 if Nkind
(With_Clause
) = N_With_Clause
769 Scope
(Entity
(Name
(With_Clause
))) = P
771 Entity
(Name
(With_Clause
)) = Child_Spec
773 Error_Msg_Node_2
:= Child_Spec
;
775 ("body of & depends on child unit&?",
778 ("\subprograms in body cannot be inlined?",
781 -- Disable further inlining from this unit,
782 -- and keep Taft-amendment types incomplete.
784 Ent
:= First_Entity
(P
);
786 while Present
(Ent
) loop
788 and then Has_Completion_In_Body
(Ent
)
790 Set_Full_View
(Ent
, Empty
);
792 elsif Is_Subprogram
(Ent
) then
793 Set_Is_Inlined
(Ent
, False);
807 elsif Ineffective_Inline_Warnings
then
808 Error_Msg_Unit_1
:= Bname
;
810 ("unable to inline subprograms defined in $?", P
);
811 Error_Msg_N
("\body not found?", P
);
822 end Check_Body_For_Inlining
;
828 procedure Cleanup_Scopes
is
834 Elmt
:= First_Elmt
(To_Clean
);
836 while Present
(Elmt
) loop
839 if Ekind
(Scop
) = E_Entry
then
840 Scop
:= Protected_Body_Subprogram
(Scop
);
842 elsif Is_Subprogram
(Scop
)
843 and then Is_Protected_Type
(Scope
(Scop
))
844 and then Present
(Protected_Body_Subprogram
(Scop
))
846 -- If a protected operation contains an instance, its
847 -- cleanup operations have been delayed, and the subprogram
848 -- has been rewritten in the expansion of the enclosing
849 -- protected body. It is the corresponding subprogram that
850 -- may require the cleanup operations.
853 (Protected_Body_Subprogram
(Scop
),
854 Uses_Sec_Stack
(Scop
));
855 Scop
:= Protected_Body_Subprogram
(Scop
);
858 if Ekind
(Scop
) = E_Block
then
859 Decl
:= Parent
(Block_Node
(Scop
));
862 Decl
:= Unit_Declaration_Node
(Scop
);
864 if Nkind
(Decl
) = N_Subprogram_Declaration
865 or else Nkind
(Decl
) = N_Task_Type_Declaration
866 or else Nkind
(Decl
) = N_Subprogram_Body_Stub
868 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
873 Expand_Cleanup_Actions
(Decl
);
876 Elmt
:= Next_Elmt
(Elmt
);
880 --------------------------
881 -- Has_Initialized_Type --
882 --------------------------
884 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
885 E_Body
: constant Node_Id
:= Get_Subprogram_Body
(E
);
889 if No
(E_Body
) then -- imported subprogram
893 Decl
:= First
(Declarations
(E_Body
));
895 while Present
(Decl
) loop
897 if Nkind
(Decl
) = N_Full_Type_Declaration
898 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
908 end Has_Initialized_Type
;
914 procedure Initialize
is
916 Analyzing_Inlined_Bodies
:= False;
917 Pending_Descriptor
.Init
;
918 Pending_Instantiations
.Init
;
923 for J
in Hash_Headers
'Range loop
924 Hash_Headers
(J
) := No_Subp
;
928 ------------------------
929 -- Instantiate_Bodies --
930 ------------------------
932 -- Generic bodies contain all the non-local references, so an
933 -- instantiation does not need any more context than Standard
934 -- itself, even if the instantiation appears in an inner scope.
935 -- Generic associations have verified that the contract model is
936 -- satisfied, so that any error that may occur in the analysis of
937 -- the body is an internal error.
939 procedure Instantiate_Bodies
is
941 Info
: Pending_Body_Info
;
944 if Serious_Errors_Detected
= 0 then
946 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
947 Push_Scope
(Standard_Standard
);
948 To_Clean
:= New_Elmt_List
;
950 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
954 -- A body instantiation may generate additional instantiations, so
955 -- the following loop must scan to the end of a possibly expanding
956 -- set (that's why we can't simply use a FOR loop here).
959 while J
<= Pending_Instantiations
.Last
960 and then Serious_Errors_Detected
= 0
962 Info
:= Pending_Instantiations
.Table
(J
);
964 -- If the instantiation node is absent, it has been removed
965 -- as part of unreachable code.
967 if No
(Info
.Inst_Node
) then
970 elsif Nkind
(Info
.Act_Decl
) = N_Package_Declaration
then
971 Instantiate_Package_Body
(Info
);
972 Add_Scope_To_Clean
(Defining_Entity
(Info
.Act_Decl
));
975 Instantiate_Subprogram_Body
(Info
);
981 -- Reset the table of instantiations. Additional instantiations
982 -- may be added through inlining, when additional bodies are
985 Pending_Instantiations
.Init
;
987 -- We can now complete the cleanup actions of scopes that contain
988 -- pending instantiations (skipped for generic units, since we
989 -- never need any cleanups in generic units).
990 -- pending instantiations.
993 and then not Is_Generic_Unit
(Main_Unit_Entity
)
996 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
1002 end Instantiate_Bodies
;
1008 function Is_Nested
(E
: Entity_Id
) return Boolean is
1009 Scop
: Entity_Id
:= Scope
(E
);
1012 while Scop
/= Standard_Standard
loop
1013 if Ekind
(Scop
) in Subprogram_Kind
then
1016 elsif Ekind
(Scop
) = E_Task_Type
1017 or else Ekind
(Scop
) = E_Entry
1018 or else Ekind
(Scop
) = E_Entry_Family
then
1022 Scop
:= Scope
(Scop
);
1034 Pending_Instantiations
.Locked
:= True;
1035 Inlined_Bodies
.Locked
:= True;
1036 Successors
.Locked
:= True;
1037 Inlined
.Locked
:= True;
1038 Pending_Instantiations
.Release
;
1039 Inlined_Bodies
.Release
;
1044 --------------------------
1045 -- Remove_Dead_Instance --
1046 --------------------------
1048 procedure Remove_Dead_Instance
(N
: Node_Id
) is
1054 while J
<= Pending_Instantiations
.Last
loop
1056 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
1057 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
1063 end Remove_Dead_Instance
;
1065 ------------------------
1066 -- Scope_In_Main_Unit --
1067 ------------------------
1069 function Scope_In_Main_Unit
(Scop
: Entity_Id
) return Boolean is
1071 S
: Entity_Id
:= Scop
;
1072 Ent
: Entity_Id
:= Cunit_Entity
(Main_Unit
);
1075 -- The scope may be within the main unit, or it may be an ancestor
1076 -- of the main unit, if the main unit is a child unit. In both cases
1077 -- it makes no sense to process the body before the main unit. In
1078 -- the second case, this may lead to circularities if a parent body
1079 -- depends on a child spec, and we are analyzing the child.
1081 while Scope
(S
) /= Standard_Standard
1082 and then not Is_Child_Unit
(S
)
1089 while Present
(Comp
)
1090 and then Nkind
(Comp
) /= N_Compilation_Unit
1092 Comp
:= Parent
(Comp
);
1095 if Is_Child_Unit
(Ent
) then
1098 and then Is_Child_Unit
(Ent
)
1100 if Scope
(Ent
) = S
then
1109 Comp
= Cunit
(Main_Unit
)
1110 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
1111 end Scope_In_Main_Unit
;